Permalink
Browse files

Output less clutter on failing examples (fixes #17)

  • Loading branch information...
1 parent be9130a commit 81b4836d2af22c260aa9b582ec88280b49d355b4 @sol committed Apr 11, 2012
Showing with 78 additions and 9 deletions.
  1. +1 −1 .ghci
  2. +2 −0 doctest.cabal
  3. +29 −2 src/Report.hs
  4. +46 −6 test/ReportSpec.hs
View
@@ -1 +1 @@
-:set -isrc -itest -idist/build/autogen -packageghc
+:set -DTEST -isrc -itest -idist/build/autogen -packageghc
View
@@ -81,6 +81,8 @@ test-suite spec
Spec.hs
ghc-options:
-Wall -Werror -threaded
+ cpp-options:
+ -DTEST
hs-source-dirs:
src, test
build-depends:
View
@@ -7,6 +7,7 @@ module Report (
, ReportState (..)
, report
, report_
+, reportFailure
) where
import Prelude hiding (putStr, putStrLn, error)
@@ -16,6 +17,7 @@ import Control.Applicative
import Control.Exception
import Text.Printf (printf)
import System.IO (hPutStrLn, hPutStr, stderr)
+import Data.Char
import Control.Monad.Trans.State
import Control.Monad.IO.Class
@@ -107,8 +109,7 @@ runModule repl (Module name examples) = do
error
Failure (Located loc (Interaction expression expected)) actual -> do
report (printf "### Failure in %s: expression `%s'" (show loc) expression)
- report ("expected: " ++ show expected)
- report (" but got: " ++ show actual)
+ reportFailure expected actual
failure
where
success = updateSummary (Summary 0 1 0 0)
@@ -119,6 +120,32 @@ runModule repl (Module name examples) = do
ReportState n s <- get
put (ReportState n $ s `mappend` summary)
+reportFailure :: [String] -> [String] -> Report ()
+reportFailure expected actual = do
+ outputLines "expected: " expected
+ outputLines " but got: " actual
+ where
+
+ -- print quotes if any line ends with trailing whitespace
+ printQuotes = any isSpace (map last . filter (not . null) $ expected ++ actual)
+
+ -- use show to escape special characters in output lines if any output line
+ -- contains any unsafe character
+ escapeOutput = any (not . isSafe) (concat $ expected ++ actual)
+
+ isSafe :: Char -> Bool
+ isSafe c = c == ' ' || (isPrint c && (not . isSpace) c)
+
+ outputLines message l_ = case l of
+ x:xs -> do
+ report (message ++ x)
+ let padding = replicate (length message) ' '
+ forM_ xs $ \y -> report (padding ++ y)
+ [] ->
+ report message
+ where
+ l | printQuotes || escapeOutput = map show l_
+ | otherwise = l_
-- | The result of evaluating an interaction.
data InteractionResult =
View
@@ -1,6 +1,10 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module ReportSpec (main, spec) where
import Test.Hspec.ShouldBe
+import Data.String.Builder
+import Test.HUnit
import Data.Monoid
import System.IO
@@ -14,41 +18,77 @@ main = hspecX spec
capture :: Report a -> IO String
capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 mempty)
+shouldGive :: IO String -> Builder -> Assertion
+action `shouldGive` expected = action `shouldReturn` build expected
+
spec :: Specs
spec = do
describe "report" $ do
it "writes to stderr" $ do
capture $ do
report "foobar"
- >>= (`shouldBe` "foobar\n")
+ `shouldReturn` "foobar\n"
it "overwrites any intermediate output" $ do
capture $ do
report_ "foo"
report "bar"
- >>= (`shouldBe` "foo\rbar\n")
+ `shouldReturn` "foo\rbar\n"
it "blank out intermediate output if necessary" $ do
capture $ do
report_ "foobar"
report "baz"
- >>= (`shouldBe` "foobar\rbaz \n")
+ `shouldReturn` "foobar\rbaz \n"
describe "report_" $ do
it "writes intermediate output to stderr" $ do
capture $ do
report_ "foobar"
- >>= (`shouldBe` "foobar")
+ `shouldReturn` "foobar"
it "overwrites any intermediate output" $ do
capture $ do
report_ "foo"
report_ "bar"
- >>= (`shouldBe` "foo\rbar")
+ `shouldReturn` "foo\rbar"
it "blank out intermediate output if necessary" $ do
capture $ do
report_ "foobar"
report_ "baz"
- >>= (`shouldBe` "foobar\rbaz ")
+ `shouldReturn` "foobar\rbaz "
+
+ describe "reportFailure" $ do
+ it "works for one-line test output" $ do
+ capture $ do
+ reportFailure ["foo"] ["bar"]
+ `shouldGive` do
+ "expected: foo"
+ " but got: bar"
+
+ it "works for multi-line test output" $ do
+ capture $ do
+ reportFailure ["foo", "bar"] ["foo", "baz"]
+ `shouldGive` do
+ "expected: foo"
+ " bar"
+ " but got: foo"
+ " baz"
+
+ it "quotes output if any output line ends with trailing whitespace" $ do
+ capture $ do
+ reportFailure ["foo", "bar "] ["foo", "baz"]
+ `shouldGive` do
+ "expected: \"foo\""
+ " \"bar \""
+ " but got: \"foo\""
+ " \"baz\""
+
+ it "uses show to format output lines if any output line contains \"unsafe\" characters" $ do
+ capture $ do
+ reportFailure ["foo\160bar"] ["foo bar"]
+ `shouldGive` do
+ "expected: \"foo\\160bar\""
+ " but got: \"foo bar\""

0 comments on commit 81b4836

Please sign in to comment.