packages feed

doctest 0.8.0.1 → 0.9.0

raw patch · 8 files changed

+176/−155 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

doctest.cabal view
@@ -1,5 +1,5 @@ name:             doctest-version:          0.8.0.1+version:          0.9.0 synopsis:         Test interactive Haskell examples description:      The doctest program checks examples in source code comments.                   It is modeled after doctest for Python@@ -40,7 +40,6 @@     , Property     , Report     , Run-    , Type     , Util   build-depends:       base        >= 4.0  && < 4.7
src/Extract.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, DeriveFunctor #-} module Extract (Module(..), extract) where -import           Prelude hiding (mod)+import           Prelude hiding (mod, concat) import           Control.Monad import           Control.Applicative import           Control.Exception+import           Data.List (partition)+import           Data.Maybe+import           Data.Foldable (concat)  import           Control.DeepSeq (deepseq, NFData(rnf)) import           Data.Generics@@ -51,13 +54,14 @@ -- | Documentation for a module grouped together with the modules name. data Module a = Module {   moduleName    :: String+, moduleSetup   :: Maybe a , moduleContent :: [a] } deriving (Eq, Functor)  deriving instance Show a => Show (Module a)  instance NFData a => NFData (Module a) where-  rnf (Module name docs) = name `deepseq` docs `deepseq` ()+  rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` ()  -- | Parse a list of modules. parse :: [String] -> IO [TypecheckedModule]@@ -80,7 +84,7 @@       let modGraph' = map upd modGraph       return modGraph' -    -- copied Haddock/GhcUtils.hs+    -- copied from Haddock/GhcUtils.hs     modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()     modifySessionDynFlags f = do       dflags <- getSessionDynFlags@@ -130,31 +134,29 @@  -- | Extract all docstrings from given module and attach the modules name. extractFromModule :: ParsedModule -> Module (Located String)-extractFromModule m = Module name docs+extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs)   where-    docs = docStringsFromModule m+    isSetup = (== Just "setup") . fst+    (setup, docs) = partition isSetup (docStringsFromModule m)     name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m  -- | Extract all docstrings from given module.-docStringsFromModule :: ParsedModule -> [Located String]-docStringsFromModule mod = map (toLocated . fmap unpackDocString) docs+docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]+docStringsFromModule mod = map (fmap (toLocated . fmap unpackDocString)) docs   where     source   = (unLoc . pm_parsed_source) mod      -- we use dlist-style concatenation here-    docs     = (maybe id (:) mHeader . maybe id (++) mExports) decls+    docs     = header ++ exports ++ decls      -- We process header, exports and declarations separately instead of     -- traversing the whole source in a generic way, to ensure that we get     -- everything in source order.-    mHeader  = hsmodHaddockModHeader source-    mExports = f `fmap` hsmodExports source-      where-        f xs = [L loc doc | L loc (IEDoc doc) <- xs]-    decls    = extractDocStrings (hsmodDecls source)-+    header  = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]+    exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- concat (hsmodExports source)]+    decls   = extractDocStrings (hsmodDecls source) -type Selector a = a -> ([LHsDocString], Bool)+type Selector a = a -> ([(Maybe String, LHsDocString)], Bool)  -- | Ignore a subtree. ignore :: Selector a@@ -165,7 +167,7 @@ select x = ([x], False)  -- | Extract all docstrings from given value.-extractDocStrings :: Data a => a -> [LHsDocString]+extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)] extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl   `extQ` fromLDocDecl   `extQ` fromLHsDocString@@ -191,15 +193,20 @@       -- Top-level documentation has to be treated separately, because it has       -- no location information attached.  The location information is       -- attached to HsDecl instead.-      DocD x -> (select . L loc . docDeclDoc) x+      DocD x -> select (fromDocDecl loc x)        _ -> (extractDocStrings decl, True)      fromLDocDecl :: Selector LDocDecl-    fromLDocDecl = select . fmap docDeclDoc+    fromLDocDecl (L loc x) = select (fromDocDecl loc x)      fromLHsDocString :: Selector LHsDocString-    fromLHsDocString = select+    fromLHsDocString x = select (Nothing, x)++    fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)+    fromDocDecl loc x = case x of+      DocCommentNamed name doc -> (Just name, L loc doc)+      _                        -> (Nothing, L loc $ docDeclDoc x)  -- | Convert a docstring to a plain string. unpackDocString :: HsDocString -> String
src/Interpreter.hs view
@@ -152,9 +152,9 @@   putExpression repl expr   getResult repl --- | Evaluate an expression; return a Left value on executions.+-- | Evaluate an expression; return a Left value on exceptions. ----- Exceptions may e.g. be caused on unterminated multiline expressions.+-- An exception may e.g. be caused on unterminated multiline expressions. safeEval :: Interpreter -> String -> IO (Either String String) safeEval repl expression = (Right `fmap` Interpreter.eval repl expression) `catches` [   -- Re-throw AsyncException, otherwise execution will not terminate on
src/Parse.hs view
@@ -1,7 +1,7 @@ module Parse (   Module (..) , DocTest (..)-, Interaction (..)+, Interaction , Expression , ExpectedResult , getDocTests@@ -13,34 +13,43 @@  import           Data.Char (isSpace) import           Data.List-import           Data.Maybe (fromMaybe)+import           Data.Maybe+import           Control.Applicative  import           Extract import           Location -data DocTest = Example [Located Interaction] | Property (Located Expression)+data DocTest = Example Expression ExpectedResult | Property Expression   deriving (Eq, Show)  type Expression = String type ExpectedResult = [String] -data Interaction = Interaction Expression ExpectedResult-  deriving (Eq, Show)+type Interaction = (Expression, ExpectedResult)  -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules.-getDocTests :: [String] -> IO [Module DocTest]  -- ^ Extracted 'DocTest's+getDocTests :: [String] -> IO [Module [Located DocTest]]  -- ^ Extracted 'DocTest's getDocTests args = do-  mods <- extract args-  return (filter (not . null . moduleContent) $ map parseModule mods)+  filter (not . isEmpty) . map parseModule <$> extract args+  where+    isEmpty (Module _ setup tests) = null tests && isNothing setup  -- | Convert documentation to `Example`s.-parseModule :: Module (Located String) -> Module DocTest-parseModule (Module name docs) = Module name (properties ++ examples)+parseModule :: Module (Located String) -> Module [Located DocTest]+parseModule m = case parseComment <$> m of+  Module name setup tests -> Module name setup_ (filter (not . null) tests)+    where+      setup_ = case setup of+        Just [] -> Nothing+        _       -> setup++parseComment :: Located String -> [Located DocTest]+parseComment c = properties ++ examples   where-    examples = (map Example . filter (not . null) . map parseInteractions) docs-    properties = [] -- (map Property . concatMap parseProperties) docs+    examples   = map (fmap $ uncurry Example) (parseInteractions c)+    properties = [] -- map (fmap          Property) (parseProperties   c)  -- | Extract all properties from given Haddock comment. parseProperties :: Located String -> [Located Expression]@@ -80,10 +89,11 @@ -- | Create an `Interaction`, strip superfluous whitespace as appropriate. toInteraction :: Located String -> [Located String] -> Located Interaction toInteraction (Located loc x) xs = Located loc $-  Interaction+  (     (strip $ drop 3 e)  -- we do not care about leading and trailing                         -- whitespace in expressions, so drop them-    result_+  , result_+  )   where     -- 1. drop trailing whitespace from the prompt, remember the prefix     (prefix, e) = span isSpace x
src/Property.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module Property (   runProperty+, PropertyResult (..) #ifdef TEST , freeVariables , parseNotInScope@@ -12,22 +13,27 @@ import           Util import           Interpreter (Interpreter) import qualified Interpreter-import           Type-import           Location import           Parse -runProperty :: Interpreter -> Located Expression -> IO DocTestResult-runProperty repl p@(Located _ expression) = do+-- | The result of evaluating an interaction.+data PropertyResult =+    Success+  | Failure String+  | Error String+  deriving (Eq, Show)++runProperty :: Interpreter -> Expression -> IO PropertyResult+runProperty repl expression = do   _ <- Interpreter.eval repl "import Test.QuickCheck (quickCheck, (==>))"   r <- closeTerm expression >>= (Interpreter.safeEval repl . quickCheck)   case r of     Left err -> do-      return (Error p err)+      return (Error err)     Right res       | "OK, passed" `isInfixOf` res -> return Success       | otherwise -> do           let msg =  stripEnd (takeWhileEnd (/= '\b') res)-          return (PropertyFailure p msg)+          return (Failure msg)   where     quickCheck term = "quickCheck (" ++ term ++ ")"
src/Report.hs view
@@ -8,18 +8,18 @@ , ReportState (..) , report , report_-, reportFailure-, runProperty-, DocTestResult (..)+, reportNotEqual #endif ) where  import           Prelude hiding (putStr, putStrLn, error) import           Data.Monoid-import           Control.Monad+import           Control.Applicative+import           Control.Monad hiding (forM_) import           Text.Printf (printf) import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) import           Data.Char+import           Data.Foldable (forM_)  import           Control.Monad.Trans.State import           Control.Monad.IO.Class@@ -28,7 +28,6 @@ import qualified Interpreter import           Parse import           Location-import           Type import           Property  -- | Summary of a test run.@@ -49,20 +48,24 @@   mempty = Summary 0 0 0 0   (Summary x1 x2 x3 x4) `mappend` (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) --- |--- Run all examples from given modules, return true if there were--- errors/failures.-runModules :: Int -> Interpreter -> [Module DocTest] -> IO Summary-runModules exampleCount repl modules = do+-- | Run all examples from a list of modules.+runModules :: Interpreter -> [Module [Located DocTest]] -> IO Summary+runModules repl modules = do   isInteractive <- hIsTerminalDevice stderr-  ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = exampleCount}) $ do+  ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = c}) $ do     forM_ modules $ runModule repl      -- report final summary     gets (show . reportStateSummary) >>= report    return s+  where+    c = (sum . map count) modules +-- | Count number of expressions in given module.+count :: Module [Located DocTest] -> Int+count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup+ -- | A monad for generating test reports. type Report = StateT ReportState IO @@ -101,40 +104,57 @@   liftIO (hPutStr stderr str)  -- | Run all examples from given module.-runModule :: Interpreter -> Module DocTest -> Report ()-runModule repl (Module name examples) = do-  forM_ examples $ \e -> do+runModule :: Interpreter -> Module [Located DocTest] -> Report ()+runModule repl (Module module_ setup examples) = do -    -- report intermediate summary-    gets (show . reportStateSummary) >>= report_+  Summary _ _ e0 f0 <- gets reportStateSummary -    r <- liftIO $ runDocTest repl name e-    case r of-      Success ->-        success-      Error (Located loc expression) err -> do-        report (printf "### Error in %s: expression `%s'" (show loc) expression)-        report err-        error-      InteractionFailure (Located loc (Interaction expression expected)) actual -> do-        report (printf "### Failure in %s: expression `%s'" (show loc) expression)-        reportFailure expected actual-        failure-      PropertyFailure (Located loc expression) msg -> do-        report (printf "### Failure in %s: expression `%s'" (show loc) expression)-        report msg-        failure+  forM_ setup $+    runTestGroup repl reload++  Summary _ _ e1 f1 <- gets reportStateSummary++  -- only run tests, if seutp does not produce any errors/failures+  when (e0 == e1 && f0 == f1) $+    forM_ examples $+      runTestGroup repl setup_   where-    success = updateSummary (Summary 0 1 0 0)-    failure = updateSummary (Summary 0 1 0 1)-    error   = updateSummary (Summary 0 1 1 0)+    reload :: IO ()+    reload = do+      -- NOTE: It is important do the :reload first!  There was some odd bug+      -- with a previous version of GHC (7.4.1?).+      void $ Interpreter.eval repl   ":reload"+      void $ Interpreter.eval repl $ ":m *" ++ module_ -    updateSummary summary = do-      ReportState n f s <- get-      put (ReportState n f $ s `mappend` summary)+    setup_ :: IO ()+    setup_ = do+      reload+      forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of+        Property _  -> return ()+        Example e _ -> void $ Interpreter.eval repl e -reportFailure :: [String] -> [String] -> Report ()-reportFailure expected actual = do+reportFailure :: Location -> Expression -> Report ()+reportFailure loc expression = do+  report (printf "### Failure in %s: expression `%s'" (show loc) expression)+  updateSummary (Summary 0 1 0 1)++reportError :: Location -> Expression -> String -> Report ()+reportError loc expression err = do+  report (printf "### Error in %s: expression `%s'" (show loc) expression)+  report err+  updateSummary (Summary 0 1 1 0)++reportSuccess :: Report ()+reportSuccess =+  updateSummary (Summary 0 1 0 0)++updateSummary :: Summary -> Report ()+updateSummary summary = do+  ReportState n f s <- get+  put (ReportState n f $ s `mappend` summary)++reportNotEqual :: [String] -> [String] -> Report ()+reportNotEqual expected actual = do   outputLines "expected: " expected   outputLines " but got: " actual   where@@ -160,33 +180,54 @@         l | printQuotes || escapeOutput = map show l_           | otherwise                   = l_ -runDocTest :: Interpreter -> String -> DocTest -> IO DocTestResult-runDocTest repl module_ docTest = do-  _ <- Interpreter.eval repl   ":reload"-  _ <- Interpreter.eval repl $ ":m *" ++ module_-  case docTest of-    Example xs -> runExample repl xs-    Property p -> runProperty repl p+-- | Run given test group.+--+-- The interpreter state is zeroed with @:reload@ first.  This means that you+-- can reuse the same 'Interpreter' for several test groups.+runTestGroup :: Interpreter -> IO () -> [Located DocTest] -> Report ()+runTestGroup repl setup tests = do +  -- report intermediate summary+  gets (show . reportStateSummary) >>= report_++  liftIO setup+  runExampleGroup repl examples++  forM_ properties $ \(loc, expression) -> do+    r <- liftIO $ do+      setup+      runProperty repl expression+    case r of+      Success ->+        reportSuccess+      Error err -> do+        reportError loc expression err+      Failure msg -> do+        reportFailure loc expression+        report msg+  where+    properties = [(loc, p) | Located loc (Property p) <- tests]++    examples :: [Located Interaction]+    examples = [Located loc (e, r) | Located loc (Example e r) <- tests]+ -- |--- Execute all expressions from given example in given--- 'Interpreter' and verify the output.------ The interpreter state is zeroed with @:reload@ before executing the--- expressions.  This means that you can reuse the same--- 'Interpreter' for several calls to `runExample`.-runExample :: Interpreter -> [Located Interaction] -> IO DocTestResult-runExample repl = go+-- Execute all expressions from given example in given 'Interpreter' and verify+-- the output.+runExampleGroup :: Interpreter -> [Located Interaction] -> Report ()+runExampleGroup repl = go   where-    go (i@(Located loc (Interaction expression expected)) : xs) = do-      r <- fmap lines `fmap` Interpreter.safeEval repl expression+    go ((Located loc (expression, expected)) : xs) = do+      r <- fmap lines <$> liftIO (Interpreter.safeEval repl expression)       case r of         Left err -> do-          return (Error (Located loc expression) err)+          reportError loc expression err         Right actual -> do           if expected /= actual-            then-              return (InteractionFailure i actual)-            else+            then do+              reportFailure loc expression+              reportNotEqual expected actual+            else do+              reportSuccess               go xs-    go [] = return Success+    go [] = return ()
src/Run.hs view
@@ -8,7 +8,6 @@ #endif ) where -import           Data.Monoid import           Data.List import           Control.Monad (when) import           System.Exit (exitFailure)@@ -27,19 +26,15 @@ -- Example: -- -- >>> doctest ["-iexample/src", "example/src/Example.hs"]--- There are 2 tests, with 2 total interactions. -- Examples: 2  Tried: 2  Errors: 0  Failures: 0 -- -- This can be used to create a Cabal test suite that runs doctest for your -- project. doctest :: [String] -> IO ()-doctest args = do-  case args of-    ["--help"] -> do-      putStr usage-    ["--version"] ->-      printVersion-    _ -> do+doctest args+  | "--help"    `elem` args = putStr usage+  | "--version" `elem` args = printVersion+  | otherwise = do       let (f, args_) = stripOptGhc args       when f $ do         hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."@@ -53,6 +48,9 @@           _ -> E.throw e       when (not $ isSuccess r) exitFailure +isSuccess :: Summary -> Bool+isSuccess s = sErrors s == 0 && sFailures s == 0+ -- | -- Strip --optghc from GHC options.  This is for backward compatibility with -- previous versions of doctest.@@ -73,33 +71,5 @@   -- get examples from Haddock comments   modules <- getDocTests args -  let c = (mconcat . map count) modules-  hPrint stderr c-   Interpreter.withInterpreter args $ \repl -> do-    runModules (exampleCount c) repl modules-  where-    exampleCount (Count n _) = n--isSuccess :: Summary -> Bool-isSuccess s = sErrors s == 0 && sFailures s == 0---- | Number of examples and interactions.-data Count = Count Int {- example count -} Int {- interaction count -}--instance Monoid Count where-  mempty = Count 0 0-  (Count x1 y1) `mappend` (Count x2 y2) = Count (x1 + x2) (y1 + y2)--instance Show Count where-  show (Count 1 1)           = "There is one test, with one single interaction."-  show (Count 1 iCount)      = "There is one test, with " ++ show iCount ++ " interactions."-  show (Count tCount iCount) = "There are " ++ show tCount ++ " tests, with " ++ show iCount ++ " total interactions."---- | Count number of examples and interactions in given module.-count :: Module DocTest -> Count-count (Module _ examples) = (mconcat . map f) examples-  where-    f :: DocTest -> Count-    f (Example x)  = Count 1 (length x)-    f (Property _) = Count 1 1+    runModules repl modules
− src/Type.hs 
@@ -1,12 +0,0 @@-module Type where--import           Location-import           Parse---- | The result of evaluating an interaction.-data DocTestResult =-    Success-  | InteractionFailure (Located Interaction) [String]-  | PropertyFailure (Located Expression) String-  | Error (Located Expression) String-  deriving (Eq, Show)