packages feed

doctest-lib (empty) → 0.1

raw patch · 6 files changed

+375/−0 lines, 6 filesdep +basesetup-changed

Dependencies added: base

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2009-2018 Simon Hengel <sol@typeful.net>+Copyright (c) 2020 Henning Thielemann <haskell@henning-thielemann.de>++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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ doctest-lib.cabal view
@@ -0,0 +1,36 @@+Cabal-Version:  2.2+Name:           doctest-lib+Version:        0.1+License:        MIT+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>, Simon Hengel <sol@typeful.net>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+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
+ src/Test/DocTest/Base.hs view
@@ -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
+ src/Test/DocTest/Location.hs view
@@ -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
+ src/Test/DocTest/Parse.hs view
@@ -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+    "<BLANKLINE>" -> 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