diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -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 diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -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 diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -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 diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -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 diff --git a/src/Property.hs b/src/Property.hs --- a/src/Property.hs +++ b/src/Property.hs @@ -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 ++ ")" diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -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 () diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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 diff --git a/src/Type.hs b/src/Type.hs deleted file mode 100644 --- a/src/Type.hs +++ /dev/null @@ -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)