diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,8 @@ +Changes in 0.16.3 + - Add a cursor to highlight the differing portion between the + expected and actual output. (#249) + - GHC 8.10 compatibility. (#247, #257) + Changes in 0.16.2 - Add doctest's necessary-for-operation options to GHC's command line at the end, so that they over-ride anything provided by the diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -66,6 +66,12 @@ haddock -h Fib.hs -o doc/ +`doctest` will fail on comments that `haddock` also doesn't like. +Sometimes (e.g., (https://github.com/sol/doctest/issues/251)[#251]), this means that `doctest` will fail on input that GHC accepts. + +`doctest` likes UTF-8. If you are running it with, e.g., `LC_ALL=C`, +you may need to invoke `doctest` with `LC_ALL=C.UTF-8`. + ### Example groups Examples from a single Haddock comment are grouped together and share the same diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 5cc030c2d812828564b9725382af262e688b5005f8fff23c961b5ac94d7d22e1 +-- hash: 4cde762c2c650b42498854666c00b2d44f751e196c9b0dd779fcb055b388414f name: doctest -version: 0.16.2 +version: 0.16.3 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python (). @@ -20,7 +20,7 @@ license-file: LICENSE copyright: (c) 2009-2018 Simon Hengel author: Simon Hengel -maintainer: Simon Hengel +maintainer: quasicomputational build-type: Simple extra-source-files: example/example.cabal @@ -137,7 +137,7 @@ , deepseq , directory , filepath - , ghc >=7.0 && <8.9 + , ghc >=7.0 && <8.11 , ghc-paths >=0.1.0.9 , process , syb >=0.3 @@ -159,7 +159,7 @@ , directory , doctest , filepath - , ghc >=7.0 && <8.9 + , ghc >=7.0 && <8.11 , ghc-paths >=0.1.0.9 , process , syb >=0.3 @@ -180,7 +180,7 @@ , directory , doctest , filepath - , ghc >=7.0 && <8.9 + , ghc >=7.0 && <8.11 , ghc-paths >=0.1.0.9 , process , syb >=0.3 @@ -238,9 +238,10 @@ , deepseq , directory , filepath - , ghc >=7.0 && <8.9 + , ghc >=7.0 && <8.11 , ghc-paths >=0.1.0.9 , hspec >=2.3.0 + , hspec-core >=2.3.0 , mockery , process , setenv diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -118,9 +118,11 @@ enableCompilation modGraph = do #if __GLASGOW_HASKELL__ < 707 let enableComp d = d { hscTarget = defaultObjectTarget } -#else +#elif __GLASGOW_HASKELL__ < 809 let enableComp d = let platform = targetPlatform d in d { hscTarget = defaultObjectTarget platform } +#else + let enableComp d = d { hscTarget = defaultObjectTarget d } #endif modifySessionDynFlags enableComp -- We need to update the DynFlags of the ModSummaries as well. diff --git a/src/Runner/Example.hs b/src/Runner/Example.hs --- a/src/Runner/Example.hs +++ b/src/Runner/Example.hs @@ -9,56 +9,143 @@ import Parse +maxBy :: (Ord a) => (b -> a) -> b -> b -> b +maxBy f x y = case compare (f x) (f y) of + LT -> y + EQ -> x + GT -> x + data Result = Equal | NotEqual [String] deriving (Eq, Show) mkResult :: ExpectedResult -> [String] -> Result -mkResult expected actual - | expected `matches` actual = Equal - | otherwise = NotEqual (formatNotEqual expected actual) +mkResult expected_ actual_ = + case expected `matches` actual of + Full -> Equal + Partial partial -> NotEqual (formatNotEqual expected actual partial) where - chunksMatch :: [LineChunk] -> String -> Bool - chunksMatch [] "" = True - chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys + -- use show to escape special characters in output lines if any output line + -- contains any unsafe character + escapeOutput + | any (not . isSafe) $ concat (expectedAsString ++ actual_) = init . tail . show . stripEnd + | otherwise = id + + actual :: [String] + actual = fmap escapeOutput actual_ + + expected :: ExpectedResult + expected = fmap (transformExcpectedLine escapeOutput) expected_ + + expectedAsString :: [String] + expectedAsString = map (\x -> case x of + ExpectedLine str -> concatMap lineChunkToString str + WildCardLine -> "..." ) expected_ + + isSafe :: Char -> Bool + isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) + + chunksMatch :: [LineChunk] -> String -> Match ChunksDivergence + chunksMatch [] "" = Full + chunksMatch [LineChunk xs] ys = + if stripEnd xs == stripEnd ys + then Full + else Partial $ matchingPrefix xs ys chunksMatch (LineChunk x : xs) ys = - x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys + if x `isPrefixOf` ys + then fmap (prependText x) $ (xs `chunksMatch` drop (length x) ys) + else Partial $ matchingPrefix x ys chunksMatch zs@(WildCardChunk : xs) (_:ys) = - xs `chunksMatch` ys || zs `chunksMatch` ys - chunksMatch _ _ = False + -- Prefer longer matches. + fmap prependWildcard $ maxBy + (fmap $ length . matchText) + (chunksMatch xs ys) + (chunksMatch zs ys) + chunksMatch [WildCardChunk] [] = Full + chunksMatch (WildCardChunk:_) [] = Partial (ChunksDivergence "" "") + chunksMatch [] (_:_) = Partial (ChunksDivergence "" "") - matches :: ExpectedResult -> [String] -> Bool - matches (ExpectedLine x : xs) (y : ys) = x `chunksMatch` y && xs `matches` ys - matches (WildCardLine : xs) ys | xs `matches` ys = True - matches zs@(WildCardLine : _) (_ : ys) = zs `matches` ys - matches [] [] = True - matches [] _ = False - matches _ [] = False + matchingPrefix xs ys = + let common = fmap fst (takeWhile (\(x, y) -> x == y) (xs `zip` ys)) in + ChunksDivergence common common + matches :: ExpectedResult -> [String] -> Match LinesDivergence + matches (ExpectedLine x : xs) (y : ys) = + case x `chunksMatch` y of + Full -> fmap incLineNo $ xs `matches` ys + Partial partial -> Partial (LinesDivergence 1 (expandedWildcards partial)) + matches zs@(WildCardLine : xs) us@(_ : ys) = + -- Prefer longer matches, and later ones of equal length. + let matchWithoutWC = xs `matches` us in + let matchWithWC = fmap incLineNo (zs `matches` ys) in + let key (LinesDivergence lineNo line) = (length line, lineNo) in + maxBy (fmap key) matchWithoutWC matchWithWC + matches [WildCardLine] [] = Full + matches [] [] = Full + matches [] _ = Partial (LinesDivergence 1 "") + matches _ [] = Partial (LinesDivergence 1 "") -formatNotEqual :: ExpectedResult -> [String] -> [String] -formatNotEqual expected_ actual = formatLines "expected: " expected ++ formatLines " but got: " actual +-- Note: order of constructors matters, so that full matches sort as +-- greater than partial. +data Match a = Partial a | Full + deriving (Eq, Ord, Show) + +instance Functor Match where + fmap f (Partial a) = Partial (f a) + fmap _ Full = Full + +data ChunksDivergence = ChunksDivergence { matchText :: String, expandedWildcards :: String } + deriving (Show) + +prependText :: String -> ChunksDivergence -> ChunksDivergence +prependText s (ChunksDivergence mt wct) = ChunksDivergence (s++mt) (s++wct) + +prependWildcard :: ChunksDivergence -> ChunksDivergence +prependWildcard (ChunksDivergence mt wct) = ChunksDivergence mt ('.':wct) + +data LinesDivergence = LinesDivergence { _mismatchLineNo :: Int, _partialLine :: String } + deriving (Show) + +incLineNo :: LinesDivergence -> LinesDivergence +incLineNo (LinesDivergence lineNo partialLineMatch) = LinesDivergence (lineNo + 1) partialLineMatch + +formatNotEqual :: ExpectedResult -> [String] -> LinesDivergence -> [String] +formatNotEqual expected_ actual partial = formatLines "expected: " expected ++ formatLines " but got: " (lineMarker wildcard partial actual) where expected :: [String] expected = map (\x -> case x of ExpectedLine str -> concatMap lineChunkToString str WildCardLine -> "..." ) expected_ - -- use show to escape special characters in output lines if any output line - -- contains any unsafe character - escapeOutput - | any (not . isSafe) (concat $ expected ++ actual) = map show - | otherwise = id - - isSafe :: Char -> Bool - isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) - formatLines :: String -> [String] -> [String] - formatLines message xs = case escapeOutput xs of + formatLines message xs = case xs of y:ys -> (message ++ y) : map (padding ++) ys [] -> [message] where padding = replicate (length message) ' ' + wildcard :: Bool + wildcard = any (\x -> case x of + ExpectedLine xs -> any (\y -> case y of { WildCardChunk -> True; _ -> False }) xs + WildCardLine -> True ) expected_ + lineChunkToString :: LineChunk -> String lineChunkToString WildCardChunk = "..." lineChunkToString (LineChunk str) = str + +transformExcpectedLine :: (String -> String) -> ExpectedLine -> ExpectedLine +transformExcpectedLine f (ExpectedLine xs) = + ExpectedLine $ fmap (\el -> case el of + LineChunk s -> LineChunk $ f s + WildCardChunk -> WildCardChunk + ) xs +transformExcpectedLine _ WildCardLine = WildCardLine + +lineMarker :: Bool -> LinesDivergence -> [String] -> [String] +lineMarker wildcard (LinesDivergence row expanded) actual = + let (pre, post) = splitAt row actual in + pre ++ + [(if wildcard && length expanded > 30 + -- show expanded pattern if match is long, to help understanding what matched what + then expanded + else replicate (length expanded) ' ') ++ "^"] ++ + post diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -131,6 +131,7 @@ , "test/integration/failing/Foo.hs:5: failure in expression `23'" , "expected: 42" , " but got: 23" + , " ^" , "" , "# Final summary:" , "Examples: 1 Tried: 1 Errors: 0 Failures: 1" diff --git a/test/Runner/ExampleSpec.hs b/test/Runner/ExampleSpec.hs --- a/test/Runner/ExampleSpec.hs +++ b/test/Runner/ExampleSpec.hs @@ -6,6 +6,7 @@ import Data.String import Test.Hspec +import Test.Hspec.Core.QuickCheck (modifyMaxSize) import Test.QuickCheck import Parse @@ -47,24 +48,55 @@ mkResult ["foo", WildCardLine, "bar"] ["foo", "bar"] `shouldBe` Equal + it "matches first zero line" $ do + mkResult [WildCardLine, "foo", "bar"] ["foo", "bar"] + `shouldBe` Equal + + it "matches final zero line" $ do + mkResult ["foo", "bar", WildCardLine] ["foo", "bar"] + `shouldBe` Equal + it "matches an arbitrary number of lines" $ do mkResult ["foo", WildCardLine, "bar"] ["foo", "baz", "bazoom", "bar"] `shouldBe` Equal - it "matches an arbitrary number of lines (quickcheck)" $ do - property $ \xs -> mkResult (lineToExpected xs) (lineToActual xs) - `shouldBe` Equal + -- See https://github.com/sol/doctest/issues/259 + modifyMaxSize (const 8) $ + it "matches an arbitrary number of lines (quickcheck)" $ do + property $ \xs -> mkResult (lineToExpected xs) (lineToActual xs) + `shouldBe` Equal context "with WildCardChunk" $ do it "matches an arbitrary line chunk" $ do mkResult [ExpectedLine ["foo", WildCardChunk, "bar"]] ["foo baz bar"] `shouldBe` Equal + it "matches an arbitrary line chunk at end" $ do + mkResult [ExpectedLine ["foo", WildCardChunk]] ["foo baz bar"] + `shouldBe` Equal + + it "does not match at end" $ do + mkResult [ExpectedLine [WildCardChunk, "baz"]] ["foo baz bar"] + `shouldBe` NotEqual [ + "expected: ...baz" + , " but got: foo baz bar" + , " ^" + ] + + it "does not match at start" $ do + mkResult [ExpectedLine ["fuu", WildCardChunk]] ["foo baz bar"] + `shouldBe` NotEqual [ + "expected: fuu..." + , " but got: foo baz bar" + , " ^" + ] + context "when output does not match" $ do it "constructs failure message" $ do mkResult ["foo"] ["bar"] `shouldBe` NotEqual [ "expected: foo" , " but got: bar" + , " ^" ] it "constructs failure message for multi-line output" $ do @@ -73,11 +105,59 @@ , " bar" , " but got: foo" , " baz" + , " ^" ] context "when any output line contains \"unsafe\" characters" $ do it "uses show to format output lines" $ do mkResult ["foo\160bar"] ["foo bar"] `shouldBe` NotEqual [ - "expected: \"foo\\160bar\"" - , " but got: \"foo bar\"" + "expected: foo\\160bar" + , " but got: foo bar" + , " ^" ] + + it "insert caret after last matching character on different lengths" $ do + mkResult ["foo"] ["fo"] `shouldBe` NotEqual [ + "expected: foo" + , " but got: fo" + , " ^" + ] + + it "insert caret after mismatching line for multi-line output" $ do + mkResult ["foo", "bar", "bat"] ["foo", "baz", "bax"] `shouldBe` NotEqual [ + "expected: foo" + , " bar" + , " bat" + , " but got: foo" + , " baz" + , " ^" + , " bax" + ] + + it "insert caret after mismatching line with the longest match for multi-line wildcard pattern" $ do + mkResult ["foo", WildCardLine, "bar", "bat"] ["foo", "xxx", "yyy", "baz", "bxx"] `shouldBe` NotEqual [ + "expected: foo" + , " ..." + , " bar" + , " bat" + , " but got: foo" + , " xxx" + , " yyy" + , " baz" + , " ^" + , " bxx" + ] + + it "insert caret after longest match for wildcard" $ do + mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo xxx yyy baz bxx"] `shouldBe` NotEqual [ + "expected: foo ... bar bat" + , " but got: foo xxx yyy baz bxx" + , " ^" + ] + + it "show expanded pattern for long matches" $ do + mkResult [ExpectedLine ["foo ", WildCardChunk, " bar bat"]] ["foo 123456789 123456789 xxx yyy baz bxx"] `shouldBe` NotEqual [ + "expected: foo ... bar bat" + , " but got: foo 123456789 123456789 xxx yyy baz bxx" + , " foo ........................... ba^" + ]