diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2009-2018 Simon Hengel +Copyright (c) 2020 Henning Thielemann + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/doctest-lib.cabal b/doctest-lib.cabal new file mode 100644 --- /dev/null +++ b/doctest-lib.cabal @@ -0,0 +1,36 @@ +Cabal-Version: 2.2 +Name: doctest-lib +Version: 0.1 +License: MIT +License-File: LICENSE +Author: Henning Thielemann , Simon Hengel +Maintainer: Henning Thielemann +Homepage: https://hub.darcs.net/thielema/doctest-lib/ +Category: Testing +Synopsis: Parts of doctest exposed as library +Description: + Parts of doctest exposed as library. + For use with the doctest-extract utility. +Tested-With: GHC==7.4.2, GHC==8.6.5 +Build-Type: Simple + +Source-Repository this + Tag: 0.1 + Type: darcs + Location: https://hub.darcs.net/thielema/doctest-lib/ + +Source-Repository head + Type: darcs + Location: https://hub.darcs.net/thielema/doctest-lib/ + +Library + Build-Depends: + base >=4.3 && <5 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Default-Language: Haskell98 + Exposed-Modules: + Test.DocTest.Parse + Test.DocTest.Location + Test.DocTest.Base diff --git a/src/Test/DocTest/Base.hs b/src/Test/DocTest/Base.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Base.hs @@ -0,0 +1,165 @@ +module Test.DocTest.Base ( + checkResult, + ExpectedResult, + Result(..), + ExpectedLine(..), + LineChunk(..), + ) where + +import Data.List (isPrefixOf) +import Data.Char (isSpace, isPrint) + + +stripEnd :: String -> String +stripEnd = reverse . dropWhile isSpace . reverse + + +data LineChunk = LineChunk String | WildCardChunk + deriving (Show, Eq) + +data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine + deriving (Show, Eq) + +type ExpectedResult = [ExpectedLine] + + +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) + +checkResult :: ExpectedResult -> [String] -> Result +checkResult expected_ actual_ = + case expected `matches` actual of + Full -> Equal + Partial partial -> NotEqual (formatNotEqual expected actual partial) + where + -- 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 = + if x `isPrefixOf` ys + then fmap (prependText x) $ (xs `chunksMatch` drop (length x) ys) + else Partial $ matchingPrefix x ys + chunksMatch zs@(WildCardChunk : xs) (_:ys) = + -- 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 "" "") + + 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 "") + +-- 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_ + + formatLines :: String -> [String] -> [String] + 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/src/Test/DocTest/Location.hs b/src/Test/DocTest/Location.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Location.hs @@ -0,0 +1,23 @@ +module Test.DocTest.Location where + +import Data.Traversable (Traversable, traverse) +import Data.Foldable (Foldable, foldMap) + + +-- | A thing with a location attached. +data Located pos a = Located pos a + deriving (Eq, Show) + +instance Functor (Located pos) where + fmap f (Located loc a) = Located loc $ f a + +instance Foldable (Located pos) where + foldMap f (Located _loc a) = f a + +instance Traversable (Located pos) where + traverse f (Located loc a) = fmap (Located loc) $ f a + + +-- | Discard location information. +unLoc :: Located pos a -> a +unLoc (Located _ a) = a diff --git a/src/Test/DocTest/Parse.hs b/src/Test/DocTest/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest/Parse.hs @@ -0,0 +1,128 @@ +module Test.DocTest.Parse ( + DocTest(..), + Expression, + Interaction, + parseComment, + ) where + +import Test.DocTest.Location (Located(Located), unLoc) +import Test.DocTest.Base + +import Data.List (stripPrefix, isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Char (isSpace) + + + +data DocTest = Example Expression ExpectedResult | Property Expression + deriving (Eq, Show) + +type Expression = String + +type Interaction = (Expression, ExpectedResult) + +parseComment :: [Located pos String] -> [Located pos DocTest] +parseComment nLines = properties ++ examples + where + examples = map (fmap $ uncurry Example) (parseInteractions nLines) + properties = map (fmap Property) (parseProperties nLines) + +-- | Extract all properties from given Haddock comment. +parseProperties :: [Located pos String] -> [Located pos Expression] +parseProperties = go + where + isPrompt :: Located pos String -> Bool + isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc + + go xs = case dropWhile (not . isPrompt) xs of + prop:rest -> stripPrompt `fmap` prop : go rest + [] -> [] + + stripPrompt = strip . drop 5 . dropWhile isSpace + +-- | Extract all interactions from given Haddock comment. +parseInteractions :: [Located pos String] -> [Located pos Interaction] +parseInteractions = go + where + isPrompt :: Located pos String -> Bool + isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc + + isBlankLine :: Located pos String -> Bool + isBlankLine = null . dropWhile isSpace . unLoc + + isEndOfInteraction :: Located pos String -> Bool + isEndOfInteraction x = isPrompt x || isBlankLine x + + + go :: [Located pos String] -> [Located pos Interaction] + go xs = case dropWhile (not . isPrompt) xs of + prompt:rest -> + case (words (drop 3 (dropWhile isSpace (unLoc prompt))), + break isBlankLine rest) of + (":{" : _, (ys,zs)) -> toInteraction prompt ys : go zs + _ -> + let (ys,zs) = break isEndOfInteraction rest + in toInteraction prompt ys : go zs + [] -> [] + +-- | Create an `Interaction`, strip superfluous whitespace as appropriate. +-- +-- also merge lines between :{ and :}, preserving whitespace inside +-- the block (since this is useful for avoiding {;}). +toInteraction :: Located pos String -> [Located pos String] -> Located pos Interaction +toInteraction (Located loc x) xs = Located loc $ + ( + (strip cleanedE) -- we do not care about leading and trailing + -- whitespace in expressions, so drop them + , map mkExpectedLine result_ + ) + where + -- 1. drop trailing whitespace from the prompt, remember the prefix + (prefix, e) = span isSpace x + (ePrompt, eRest) = splitAt 3 e + + -- 2. drop, if possible, the exact same sequence of whitespace + -- characters from each result line + unindent pre = map (tryStripPrefix pre . unLoc) + + cleanBody line = fromMaybe (unLoc line) + (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) + + (cleanedE, result_) = + case break ( (==) [":}"] . take 1 . words . cleanBody) xs of + (body , endLine : rest) -> + (unlines (eRest : map cleanBody body ++ + [dropWhile isSpace (cleanBody endLine)]), + unindent (takeWhile isSpace (unLoc endLine)) rest) + _ -> (eRest, unindent prefix xs) + + +tryStripPrefix :: String -> String -> String +tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys + +mkExpectedLine :: String -> ExpectedLine +mkExpectedLine x = case x of + "" -> ExpectedLine [LineChunk ""] + "..." -> 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