doctest 0.9.12 → 0.9.13
raw patch · 3 files changed
+88/−25 lines, 3 filesdep ~sybnew-uploader
Dependency ranges changed: syb
Files
- doctest.cabal +1/−1
- src/Parse.hs +52/−17
- src/Runner/Example.hs +35/−7
doctest.cabal view
@@ -1,5 +1,5 @@ name: doctest-version: 0.9.12+version: 0.9.13 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python
src/Parse.hs view
@@ -1,20 +1,25 @@ {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-} module Parse ( Module (..) , DocTest (..) , Interaction , Expression , ExpectedResult+, ExpectedLine (..)+, LineChunk (..) , getDocTests -- * exported for testing , parseInteractions , parseProperties+, mkLineChunks ) where import Data.Char (isSpace) import Data.List import Data.Maybe+import Data.String import Control.Applicative import Extract@@ -24,11 +29,24 @@ data DocTest = Example Expression ExpectedResult | Property Expression deriving (Eq, Show) +data LineChunk = LineChunk String | WildCardChunk+ deriving (Show, Eq)++instance IsString LineChunk where+ fromString = LineChunk++data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine+ deriving (Show, Eq)++instance IsString ExpectedLine where+ fromString = ExpectedLine . return . LineChunk+ type Expression = String-type ExpectedResult = [String]+type ExpectedResult = [ExpectedLine] type Interaction = (Expression, ExpectedResult) + -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules.@@ -82,11 +100,11 @@ go :: [Located String] -> [Located Interaction] go xs = case dropWhile (not . isPrompt) xs of- prompt:rest + prompt:rest | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))), (ys,zs) <- break isBlankLine rest -> toInteraction prompt ys : go zs- + | otherwise -> let (ys,zs) = break isEndOfInteraction rest@@ -103,7 +121,7 @@ ( (strip cleanedE) -- we do not care about leading and trailing -- whitespace in expressions, so drop them- , result_+ , map mkExpectedLine result_ ) where -- 1. drop trailing whitespace from the prompt, remember the prefix@@ -112,17 +130,8 @@ -- 2. drop, if possible, the exact same sequence of whitespace -- characters from each result line- --- -- 3. interpret lines that only contain the string "<BLANKLINE>" as an- -- empty line- getResult pfx xs' = map (substituteBlankLine . tryStripPrefix pfx . unLoc) xs'- where- tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys-- substituteBlankLine "<BLANKLINE>" = ""- substituteBlankLine line = line+ unindent pre = map (tryStripPrefix pre . unLoc) - cleanBody line = fromMaybe (unLoc line) (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) @@ -132,10 +141,36 @@ xs = (unlines (eRest : map cleanBody body ++ [dropWhile isSpace (cleanBody endLine)]),- getResult (takeWhile isSpace (unLoc endLine)) rest)- | otherwise = (eRest, getResult prefix xs)+ unindent (takeWhile isSpace (unLoc endLine)) rest)+ | otherwise = (eRest, unindent prefix xs) ++tryStripPrefix :: String -> String -> String+tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys++mkExpectedLine :: String -> ExpectedLine+mkExpectedLine x = case x of+ "<BLANKLINE>" -> ""+ "..." -> WildCardLine+ _ -> ExpectedLine $ mkLineChunks x++mkLineChunks :: String -> [LineChunk]+mkLineChunks = finish . foldr go (0, [], [])+ where+ mkChunk :: String -> [LineChunk]+ mkChunk "" = []+ mkChunk x = [LineChunk x]++ go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk])+ go '.' (count, acc, res) = if count == 2+ then (0, "", WildCardChunk : mkChunk acc ++ res)+ else (count + 1, acc, res)+ go c (count, acc, res) = if count > 0+ then (0, c : replicate count '.' ++ acc, res)+ else (0, c : acc, res)+ finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res++ -- | Remove leading and trailing whitespace. strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse-
src/Runner/Example.hs view
@@ -4,22 +4,46 @@ ) where import Data.Char+import Data.List import Util +import Parse+ data Result = Equal | NotEqual [String] deriving (Eq, Show) -mkResult :: [String] -> [String] -> Result-mkResult expected_ actual_- | expected == actual = Equal+mkResult :: ExpectedResult -> [String] -> Result+mkResult expected actual+ | expected `matches` actual = Equal | otherwise = NotEqual (formatNotEqual expected actual) where- expected = map stripEnd expected_- actual = map stripEnd actual_+ chunksMatch :: [LineChunk] -> String -> Bool+ chunksMatch [] "" = True+ chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys+ chunksMatch (LineChunk x : xs) ys =+ x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys+ chunksMatch zs@(WildCardChunk : xs) (_:ys) =+ xs `chunksMatch` ys || zs `chunksMatch` ys+ chunksMatch _ _ = False -formatNotEqual :: [String] -> [String] -> [String]-formatNotEqual expected actual = formatLines "expected: " expected ++ formatLines " but got: " actual+ matches :: ExpectedResult -> [String] -> Bool+ matches [] [] = True+ matches [] _ = False+ matches _ [] = False+ matches (ExpectedLine x : xs) (y:ys) =+ x `chunksMatch` y && xs `matches` ys+ matches zs@(WildCardLine : xs) (_:ys) =+ xs `matches` ys || zs `matches` ys+++formatNotEqual :: ExpectedResult -> [String] -> [String]+formatNotEqual expected_ actual = formatLines "expected: " expected ++ formatLines " but got: " 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@@ -35,3 +59,7 @@ [] -> [message] where padding = replicate (length message) ' '++lineChunkToString :: LineChunk -> String+lineChunkToString WildCardChunk = "..."+lineChunkToString (LineChunk str) = str