doctest 0.6.1 → 0.7.0

raw patch · 18 files changed

+606/−241 lines, 18 filesdep +doctestdep +hspec-discoverdep +silentlydep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, hspec-discover, silently

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• doctest.cabal +33/−25
• driver/Main.hs +6/−0
• src/DocTest.hs +0/−44
• src/Extract.hs +18/−13
• src/GhcUtil.hs +11/−10
• src/Interpreter.hs +26/−11
• src/Location.hs +67/−0
• src/Main.hs +0/−41
• src/Options.hs +11/−13
• src/Parse.hs +59/−36
• src/Property.hs +65/−0
• src/Report.hs +192/−0
• src/Run.hs +63/−0
• src/Test/DocTest.hs +3/−33
• src/Type.hs +12/−0
• src/Util.hs +26/−0
• test/Spec.hs +1/−15
• test/doctests.hs +13/−0

@@ -1,5 +1,5 @@ name:             doctest-version:          0.6.1+version:          0.7.0 synopsis:         Test interactive Haskell examples description:      The doctest program checks examples in source code comments.                   It is modeled after doctest for Python@@ -30,13 +30,18 @@   hs-source-dirs:       src   other-modules:-      Interpreter+      Extract+    , GhcUtil+    , Interpreter+    , Location     , Options-    , DocTest     , Parse-    , Extract-    , GhcUtil     , Paths_doctest+    , Property+    , Report+    , Run+    , Type+    , Util   build-depends:       base        >= 4.0  && < 4.6     , ghc         >= 6.12 && < 7.6@@ -45,7 +50,7 @@     , directory     , process     , ghc-paths   == 0.1.*-    , HUnit       == 1.2.*+    , transformers  executable doctest   main-is:@@ -53,32 +58,20 @@   ghc-options:       -Wall -threaded   hs-source-dirs:-      src-  other-modules:-      Interpreter-    , Options-    , DocTest-    , Parse-    , Extract-    , GhcUtil-    , Paths_doctest+      driver   build-depends:       base        >= 4.0  && < 4.6-    , ghc         >= 6.12 && < 7.6-    , syb-    , deepseq-    , directory-    , process-    , ghc-paths   == 0.1.*-    , HUnit       == 1.2.*+    , doctest  test-suite spec-  type:-      exitcode-stdio-1.0   main-is:       Spec.hs+  type:+      exitcode-stdio-1.0   ghc-options:       -Wall -Werror -threaded+  cpp-options:+      -DTEST   hs-source-dirs:       src, test   build-depends:@@ -89,8 +82,23 @@     , directory     , process     , ghc-paths   == 0.1.*+    , transformers     , HUnit       == 1.2.*+    , hspec-discover     , hspec-shouldbe-    , transformers     , stringbuilder+    , silently     , filepath++test-suite doctests+  main-is:+      doctests.hs+  type:+      exitcode-stdio-1.0+  ghc-options:+      -Wall -Werror -threaded+  hs-source-dirs:+      test+  build-depends:+      base+    , doctest

@@ -0,0 +1,6 @@+module Main (main) where+import           Test.DocTest+import           System.Environment (getArgs)++main :: IO ()+main = getArgs >>= doctest

@@ -1,44 +0,0 @@-module DocTest (-    getDocTests-  , DocTest(..)-  , Interaction(..)-  , toTestCase-  , toAssertion-  ) where--import Test.HUnit (Test(..), assertEqual, Assertion)-import qualified Interpreter-import Parse---toTestCase :: Interpreter.Interpreter -> DocTest -> Test-toTestCase repl test = TestLabel sourceFile $ TestCase $ toAssertion repl test-  where-    -- FIXME: use source location here-    sourceFile = moduleName test---- |--- Execute all expressions from given 'DocTest' in given--- 'Interpreter.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.Interpreter' for several calls to `toAssertion`.-toAssertion :: Interpreter.Interpreter -> DocTest -> Assertion-toAssertion repl test = do-  _ <- Interpreter.eval repl $ ":reload"-  _ <- Interpreter.eval repl $ ":m *" ++ moduleName test-  mapM_ interactionToAssertion $ interactions test-  where-    interactionToAssertion x = do-      result' <- Interpreter.eval repl exampleExpression-      assertEqual ("expression `" ++ exampleExpression ++ "'")-        exampleResult $ lines result'-      where-        exampleExpression = expression x-        exampleResult     = map subBlankLines $ result x--        -- interpret lines that only contain the string "<BLANKLINE>" as an-        -- empty line-        subBlankLines "<BLANKLINE>" = ""-        subBlankLines line          = line

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, DeriveFunctor #-} module Extract (Module(..), extract) where  import           Prelude hiding (mod, catch)@@ -9,14 +9,17 @@ import           Control.DeepSeq (deepseq, NFData(rnf)) import           Data.Generics -import           GHC hiding (flags, Module)+import           GHC hiding (flags, Module, Located) import           NameSet (NameSet) import           Coercion (Coercion) import           FastString (unpackFS) import           Digraph (flattenSCCs)  import           GhcUtil (withGhc)+import           Location hiding (unLoc) +import           Util (convertDosLineEndings)+ -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException   deriving Typeable@@ -40,12 +43,14 @@ instance Exception ExtractError  -- | Documentation for a module grouped together with the modules name.-data Module = Module {-  moduleName          :: String-, moduleDocumentation :: [String]-} deriving (Eq, Show)+data Module a = Module {+  moduleName    :: String+, moduleContent :: [a]+} deriving (Eq, Functor) -instance NFData Module where+deriving instance Show a => Show (Module a)++instance NFData a => NFData (Module a) where   rnf (Module name docs) = name `deepseq` docs `deepseq` ()  -- | Parse a list of modules.@@ -53,7 +58,7 @@       -> [String] -- ^ files/modules       -> IO [TypecheckedModule] parse flags modules = withGhc flags $ do-  mapM (flip guessTarget Nothing) modules >>= setTargets+  mapM (`guessTarget` Nothing) modules >>= setTargets   mods <- depanal [] False   let sortedMods = flattenSCCs (topSortModuleGraph False mods Nothing)   reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods@@ -64,10 +69,10 @@ -- those modules (possibly indirect). extract :: [String] -- ^ flags         -> [String] -- ^ files/modules-        -> IO [Module]+        -> IO [Module (Located String)] extract flags modules = do   mods <- parse flags modules-  let docs = map extractFromModule (map tm_parsed_module mods)+  let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods    (docs `deepseq` return docs) `catches` [       -- Re-throw AsyncException, otherwise execution will not terminate on@@ -79,15 +84,15 @@     ]  -- | Extract all docstrings from given module and attach the modules name.-extractFromModule :: ParsedModule -> Module+extractFromModule :: ParsedModule -> Module (Located String) extractFromModule m = Module name docs   where-    docs = map unLoc (docStringsFromModule m)+    docs = 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 (fmap unpackDocString) docs+docStringsFromModule mod = map (toLocated . fmap unpackDocString) docs   where     source   = (unLoc . pm_parsed_source) mod 

@@ -1,20 +1,21 @@ {-# LANGUAGE CPP #-} module GhcUtil (withGhc) where -import            Control.Exception+import           Control.Exception+import           Control.Monad (void) -import            GHC.Paths (libdir)-import            GHC hiding (flags)-import            DynFlags (dopt_set)+import           GHC.Paths (libdir)+import           GHC hiding (flags)+import           DynFlags (dopt_set) -import            MonadUtils (liftIO)-import            System.Exit (exitFailure)+import           MonadUtils (liftIO)+import           System.Exit (exitFailure)  #if __GLASGOW_HASKELL__ < 702-import            StaticFlags (v_opt_C_ready)-import            Data.IORef (writeIORef)+import           StaticFlags (v_opt_C_ready)+import           Data.IORef (writeIORef) #else-import            StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)+import           StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) #endif  @@ -55,7 +56,7 @@   (dynflags, rest, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags   case rest of     x : _ -> error ("Unrecognized GHC option: " ++ unLoc x)-    _     -> setSessionDynFlags dynflags >> return ()+    _     -> void (setSessionDynFlags dynflags)  setHaddockMode :: DynFlags -> DynFlags setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) {

@@ -1,19 +1,20 @@ module Interpreter (   Interpreter , eval+, safeEval , withInterpreter ) where -import System.IO-import System.Process-import System.Exit-import System.Directory (getPermissions, executable)-import Control.Monad(when)-import Control.Exception (bracket)-import Data.Char-import Data.List+import           System.IO+import           System.Process+import           System.Exit+import           System.Directory (getPermissions, executable)+import           Control.Monad (when, unless)+import           Control.Exception hiding (handle)+import           Data.Char+import           Data.List -import GHC.Paths (ghc)+import           GHC.Paths (ghc)  -- | Truly random marker, used to separate expressions. --@@ -35,7 +36,7 @@   -- in a perfect world this permission check should never fail, but I know of   -- at least one case where it did..   x <- getPermissions ghc-  when (not $ executable x) $ do+  unless (executable x) $ do     fail $ ghc ++ " is not executable!"    (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stdout}@@ -128,7 +129,7 @@ getResult :: Interpreter -> IO String getResult repl = do   line <- hGetLine stdout_-  if isSuffixOf marker line+  if marker `isSuffixOf` line     then       return $ stripMarker line     else do@@ -146,3 +147,17 @@ eval repl expr = do   putExpression repl expr   getResult repl++-- | Evaluate an expression; return a Left value on executions.+--+-- Exceptions 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+  -- SIGINT (ctrl-c).  All AsyncExceptions are re-thrown (not just+  -- UserInterrupt) because all of them indicate severe conditions and+  -- should not occur during normal test runs.+  Handler $ \e -> throw (e :: AsyncException),++  Handler $ \e -> (return . Left . show) (e :: SomeException)+  ]

@@ -0,0 +1,67 @@+{-# LANGUAGE CPP, DeriveFunctor #-}+module Location where++import           Control.DeepSeq (deepseq, NFData(rnf))+import           SrcLoc hiding (Located)+import qualified SrcLoc as GHC+import           FastString (unpackFS)++#if __GLASGOW_HASKELL__ < 702+import           Outputable (showPpr)+#endif++-- | A thing with a location attached.+data Located a = Located Location a+  deriving (Eq, Show, Functor)++instance NFData a => NFData (Located a) where+  rnf (Located loc a) = loc `deepseq` a `deepseq` ()++-- | Convert a GHC located thing to a located thing.+toLocated :: GHC.Located a -> Located a+toLocated (L loc a) = Located (toLocation loc) a++-- | Discard location information.+unLoc :: Located a -> a+unLoc (Located _ a) = a++-- | Add dummy location information.+noLocation :: a -> Located a+noLocation = Located (UnhelpfulLocation "<no location info>")++-- | A line number.+type Line = Int++-- | A combination of file name and line number.+data Location = UnhelpfulLocation String | Location FilePath Line+  deriving Eq++instance Show Location where+  show (UnhelpfulLocation s) = s+  show (Location file line)  = file ++ ":" ++ show line++instance NFData Location where+  rnf (UnhelpfulLocation str) = str `deepseq` ()+  rnf (Location file line)    = file `deepseq` line `deepseq` ()++-- |+-- Create a list from a location, by repeatedly increasing the line number by+-- one.+enumerate :: Location -> [Location]+enumerate loc = case loc of+  UnhelpfulLocation _ -> repeat loc+  Location file line  -> map (Location file) [line ..]++-- | Convert a GHC source span to a location.+toLocation :: SrcSpan -> Location+#if __GLASGOW_HASKELL__ < 702+toLocation loc+  | isGoodSrcLoc start = Location (unpackFS $ srcLocFile start) (srcLocLine start)+  | otherwise          = (UnhelpfulLocation . showPpr) start+  where+    start = srcSpanStart loc+#else+toLocation loc = case loc of+  UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str)+  RealSrcSpan sp    -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp)+#endif

@@ -1,41 +0,0 @@-module Main where--import Test.HUnit (runTestTT, Test(..), Counts(..))-import System.Exit (exitSuccess, exitFailure)-import System.IO--import Parse-import Options-import DocTest--import qualified Interpreter--main :: IO ()-main = do-  (options, files) <- getOptions-  let ghciArgs = ghcOptions options ++ files--  -- get examples from Haddock comments-  docTests <- getDocTests (ghcOptions options) files--  let (tCount, iCount) = (length docTests, length (concatMap interactions docTests))-  hPutStrLn stderr (formatTestAndInteractionCount tCount iCount)--  if DumpOnly `elem` options-    then do-      -- dump to stdout-      print docTests-    else do-      -- map to unit tests-      Interpreter.withInterpreter ghciArgs $ \repl -> do-        let tests = TestList $ map (toTestCase repl) docTests-        Counts _ _ errCount failCount <- runTestTT tests-        if errCount == 0 && failCount == 0-          then exitSuccess-          else exitFailure---formatTestAndInteractionCount :: Int -> Int -> String-formatTestAndInteractionCount 1 1           = "There is one test, with one single interaction."-formatTestAndInteractionCount 1 iCount      = "There is one test, with " ++ show iCount ++ " interactions."-formatTestAndInteractionCount tCount iCount = "There are " ++ show tCount ++ " tests, with " ++ show iCount ++ " total interactions."

@@ -1,19 +1,18 @@ module Options (   Option(..)-, getOptions+, parseOptions , ghcOptions ) where -import Control.Monad (when)-import System.Environment (getArgs)-import System.Exit (exitSuccess, exitFailure)-import System.IO (hPutStr, stderr)+import           Control.Monad (when, unless)+import           System.Exit (exitSuccess, exitFailure)+import           System.IO (hPutStr, stderr) -import System.Console.GetOpt+import           System.Console.GetOpt -import Paths_doctest (version)-import Data.Version (showVersion)-import Config as GHC+import           Paths_doctest (version)+import           Data.Version (showVersion)+import           Config as GHC  data Option = Help             | Version@@ -37,9 +36,8 @@   ]  -getOptions :: IO ([Option], [String])-getOptions = do-  args  <- getArgs+parseOptions :: [String] -> IO ([Option], [String])+parseOptions args = do   let (options, modules, errors) = getOpt Permute (documentedOptions ++ undocumentedOptions) args    when (Help `elem` options) $ do@@ -51,7 +49,7 @@     putStrLn ("using version " ++ GHC.cProjectVersion ++ " of the GHC API")     exitSuccess -  when ((not . null) errors) $ do+  unless (null errors) $ do     tryHelp $ head errors    when (null modules) $ do

@@ -1,10 +1,14 @@ module Parse (-  DocTest(..)-, Interaction(..)+  Module (..)+, DocTest (..)+, Interaction (..)+, Expression+, ExpectedResult , getDocTests  -- * exported for testing-, parse+, parseInteractions+, parseProperties ) where  import           Data.Char (isSpace)@@ -12,54 +16,73 @@ import           Data.Maybe (fromMaybe)  import           Extract--data DocTest = DocExample {-  moduleName    :: String-, interactions  :: [Interaction]-} deriving (Eq, Show)+import           Location +data DocTest = Example [Located Interaction] | Property (Located Expression)+  deriving (Eq, Show) -data Interaction = Interaction {-  expression :: String    -- ^ example expression-, result     :: [String]  -- ^ expected result-} deriving (Eq, Show)+type Expression = String+type ExpectedResult = [String] +data Interaction = Interaction Expression ExpectedResult+  deriving (Eq, Show)  -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules.-getDocTests :: [String]     -- ^ List of GHC flags-            -> [String]     -- ^ File or module names-            -> IO [DocTest] -- ^ Extracted 'DocTest's+getDocTests+  :: [String]             -- ^ List of GHC flags+  -> [String]             -- ^ File or module names+  -> IO [Module DocTest]  -- ^ Extracted 'DocTest's getDocTests flags modules = do   mods <- extract flags modules-  return (concatMap moduleToDocTest mods)+  return (filter (not . null . moduleContent) $ map parseModule mods) --- | Convert a `Module` to a list of `DocTest`s.-moduleToDocTest :: Module -> [DocTest]-moduleToDocTest (Module name docs) = (map (DocExample name) . filter (not . null) . map parse) docs+-- | Convert documentation to `Example`s.+parseModule :: Module (Located String) -> Module DocTest+parseModule (Module name docs) = Module name (properties ++ examples)+  where+    examples = (map Example . filter (not . null) . map parseInteractions) docs+    properties = [] -- (map Property . concatMap parseProperties) docs --- | Extract all interactions from given Haddock documentation.-parse :: String -> [Interaction]-parse input = go (map (reverse . dropWhile ((==) '\r') . reverse) $ lines input)+-- | Extract all properties from given Haddock comment.+parseProperties :: Located String -> [Located Expression]+parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input)   where-    isPrompt = isPrefixOf ">>>" . dropWhile isSpace-    isBlankLine  = null . dropWhile isSpace+    isPrompt :: Located 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 String -> [Located Interaction]+parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input)+  where+    isPrompt :: Located String -> Bool+    isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc++    isBlankLine :: Located String -> Bool+    isBlankLine  = null . dropWhile isSpace . unLoc++    isEndOfInteraction :: Located String -> Bool     isEndOfInteraction x = isPrompt x || isBlankLine x -    go :: [String] -> [Interaction]-    go xs =-      case dropWhile (not . isPrompt) xs of-        prompt:rest ->-          let -            (ys,zs) = break isEndOfInteraction rest-          in-            toInteraction prompt ys : go zs-        _ -> []+    go :: [Located String] -> [Located Interaction]+    go xs = case dropWhile (not . isPrompt) xs of+      prompt:rest ->+        let+          (ys,zs) = break isEndOfInteraction rest+        in+          toInteraction prompt ys : go zs+      [] -> []  -- | Create an `Interaction`, strip superfluous whitespace as appropriate.-toInteraction :: String -> [String] -> Interaction-toInteraction x xs =+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@@ -73,7 +96,7 @@     --     -- 3. interpret lines that only contain the string "<BLANKLINE>" as an     -- empty line-    result_ = map (substituteBlankLine . tryStripPrefix prefix) xs+    result_ = map (substituteBlankLine . tryStripPrefix prefix . unLoc) xs       where         tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys 

@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+module Property (+  runProperty+#ifdef TEST+, freeVariables+, parseNotInScope+#endif+) where++import           Data.List++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+  _ <- Interpreter.eval repl "import Test.QuickCheck (quickCheck, (==>))"+  r <- closeTerm expression >>= (Interpreter.safeEval repl . quickCheck)+  case r of+    Left err -> do+      return (Error p err)+    Right res+      | "OK, passed" `isInfixOf` res -> return Success+      | otherwise -> do+          let msg =  stripEnd (takeWhileEnd (/= '\b') res)+          return (PropertyFailure p msg)+  where+    quickCheck term = "quickCheck (" ++ term ++ ")"++    -- | Find all free variables in given term, and close it by abstrating over+    -- them.+    closeTerm :: String -> IO String+    closeTerm term = do+      r <- freeVariables repl (quickCheck term)+      case r of+        []   -> return term+        vars -> return ("\\" ++ unwords vars ++ "-> (" ++ term ++ ")")++-- | Find all free variables in given term.+--+-- GHCi is used to detect free variables.+freeVariables :: Interpreter -> String -> IO [String]+freeVariables repl term = do+  r <- Interpreter.safeEval repl (":type " ++ term)+  return (either (const []) (nub . parseNotInScope) r)++-- | Parse and return all variables that are not in scope from a ghc error+-- message.+--+-- >>> parseNotInScope "<interactive>:4:1: Not in scope: `foo'"+-- ["foo"]+parseNotInScope :: String -> [String]+parseNotInScope = nub . map extractVariable . filter ("Not in scope: " `isInfixOf`) . lines+  where+    -- | Extract variable name from a "Not in scope"-error.+    extractVariable :: String -> String+    extractVariable = unquote . takeWhileEnd (/= ' ')++    -- | Remove quotes from given name, if any.+    unquote ('`':xs) = init xs+    unquote xs       = xs

@@ -0,0 +1,192 @@+{-# LANGUAGE CPP #-}+module Report (+  runModules+, Summary(..)++#ifdef TEST+, Report+, ReportState (..)+, report+, report_+, reportFailure+, runProperty+, DocTestResult (..)+#endif+) where++import           Prelude hiding (putStr, putStrLn, error)+import           Data.Monoid+import           Control.Monad+import           Text.Printf (printf)+import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)+import           Data.Char++import           Control.Monad.Trans.State+import           Control.Monad.IO.Class++import           Interpreter (Interpreter)+import qualified Interpreter+import           Parse+import           Location+import           Type+import           Property++-- | Summary of a test run.+data Summary = Summary {+  sExamples :: Int+, sTried    :: Int+, sErrors   :: Int+, sFailures :: Int+}++-- | Format a summary.+instance Show Summary where+  show (Summary examples tried errors failures) =+    printf "Examples: %d  Tried: %d  Errors: %d  Failures: %d" examples tried errors failures++-- | Sum up summaries.+instance Monoid Summary where+  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 Bool+runModules exampleCount repl modules = do+  isInteractive <- hIsTerminalDevice stderr+  ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = exampleCount}) $ do+    forM_ modules $ runModule repl++    -- report final summary+    gets (show . reportStateSummary) >>= report++  return (sErrors s /= 0 || sFailures s /= 0)++-- | A monad for generating test reports.+type Report = StateT ReportState IO++data ReportState = ReportState {+  reportStateCount        :: Int     -- ^ characters on the current line+, reportStateInteractive  :: Bool    -- ^ should intermediate results be printed?+, reportStateSummary      :: Summary -- ^ test summary+}++-- | Add output to the report.+report :: String -> Report ()+report msg = do+  overwrite msg++  -- add a newline, this makes the output permanent+  liftIO $ hPutStrLn stderr ""+  modify (\st -> st {reportStateCount = 0})++-- | Add intermediate output to the report.+--+-- This will be overwritten by subsequent calls to `report`/`report_`.+-- Intermediate out may not contain any newlines.+report_ :: String -> Report ()+report_ msg = do+  f <- gets reportStateInteractive+  when f $ do+    overwrite msg+    modify (\st -> st {reportStateCount = length msg})++-- | Add output to the report, overwrite any intermediate out.+overwrite :: String -> Report ()+overwrite msg = do+  n <- gets reportStateCount+  let str | 0 < n     = "\r" ++ msg ++ replicate (n - length msg) ' '+          | otherwise = msg+  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++    -- report intermediate summary+    gets (show . reportStateSummary) >>= report_++    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+  where+    success = updateSummary (Summary 0 1 0 0)+    failure = updateSummary (Summary 0 1 0 1)+    error   = updateSummary (Summary 0 1 1 0)++    updateSummary summary = do+      ReportState n f s <- get+      put (ReportState n f $ s `mappend` summary)++reportFailure :: [String] -> [String] -> Report ()+reportFailure expected actual = do+  outputLines "expected: " expected+  outputLines " but got: " actual+  where++    -- print quotes if any line ends with trailing whitespace+    printQuotes = any isSpace (map last . filter (not . null) $ expected ++ actual)++    -- use show to escape special characters in output lines if any output line+    -- contains any unsafe character+    escapeOutput = any (not . isSafe) (concat $ expected ++ actual)++    isSafe :: Char -> Bool+    isSafe c = c == ' ' || (isPrint c && (not . isSpace) c)++    outputLines message l_ = case l of+      x:xs -> do+        report (message ++ x)+        let padding = replicate (length message) ' '+        forM_ xs $ \y -> report (padding ++ y)+      []   ->+        report message+      where+        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++-- |+-- 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+  where+    go (i@(Located loc (Interaction expression expected)) : xs) = do+      r <- fmap lines `fmap` Interpreter.safeEval repl expression+      case r of+        Left err -> do+          return (Error (Located loc expression) err)+        Right actual -> do+          if expected /= actual+            then+              return (InteractionFailure i actual)+            else+              go xs+    go [] = return Success

@@ -0,0 +1,63 @@+module Run (doctest) where+import           Data.Monoid+import           Control.Monad (when)+import           System.Exit (exitFailure)+import           System.IO++import           Parse+import           Options+import           Report+import qualified Interpreter++doctest :: [String] -> IO ()+-- | Run doctest with given list of arguments.+--+-- Example:+--+-- >>> doctest ["--optghc=-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 args = do+  (options, files) <- parseOptions args+  let ghciArgs = ghcOptions options ++ files++  -- get examples from Haddock comments+  modules <- getDocTests (ghcOptions options) files++  let c = (mconcat . map count) modules+  hPrint stderr c++  if DumpOnly `elem` options+    then do+      -- dump to stdout+      print modules+    else do+      -- run tests+      Interpreter.withInterpreter ghciArgs $ \repl -> do+        r <- runModules (exampleCount c) repl modules+        when r exitFailure+  where+    exampleCount (Count n _) = n++-- | 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

@@ -1,35 +1,5 @@--- |--- An experimental API for extracting and executing `DocTest`s.------ Use 'getDocTests' to extract 'DocTest' examples from Haddock comments.  To--- verify that the examples work turn them into 'Test.HUnit.Assertion's, using--- 'withInterpreter' and 'toAssertion'.  After this just wrap the newly minted--- assertions into something suitable for your favorite test framework. module Test.DocTest (-    DocTest-  , getDocTests-  , sourcePath-  , firstExpression-  , toAssertion-  , Interpreter-  , withInterpreter-  ) where--import           DocTest-import           Interpreter (Interpreter)-import qualified Interpreter---- | Instead of what the name suggests, this returns the module name, not the--- file name.-sourcePath :: DocTest -> FilePath-sourcePath = moduleName-{-# DEPRECATED sourcePath "this function will vanish in a future release" #-}--firstExpression :: DocTest -> String-firstExpression test = expression $ head $ interactions test+  doctest+) where -withInterpreter-  :: [String]               -- ^ List of flags, passed to GHC-  -> (Interpreter -> IO a)  -- ^ Action to run-  -> IO a                   -- ^ Result of action-withInterpreter = Interpreter.withInterpreter+import           Run

@@ -0,0 +1,12 @@+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)

@@ -0,0 +1,26 @@+module Util where+import           Data.Char++convertDosLineEndings :: String -> String+convertDosLineEndings = go+  where+    go input = case input of+      '\r':'\n':xs -> '\n' : go xs++      -- Haddock comments from source files with dos line endings end with a+      -- CR, so we strip that, too.+      "\r"         -> ""++      x:xs         -> x : go xs+      ""           -> ""++-- | Return the longest suffix of elements that satisfy a given predicate.+takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd p = reverse . takeWhile p . reverse++-- | Remove trailing white space from a string.+--+-- >>> stripEnd "foo   "+-- "foo"+stripEnd :: String -> String+stripEnd = reverse . dropWhile isSpace . reverse

@@ -1,15 +1,1 @@-module Main (main) where--import           Test.Hspec.ShouldBe--import qualified ExtractSpec-import qualified ParseSpec-import qualified InterpreterSpec-import qualified MainSpec--main :: IO ()-main = hspecX $ do-  describe "ExtractSpec"      ExtractSpec.spec-  describe "ParseSpec"        ParseSpec.spec-  describe "InterpreterSpec"  InterpreterSpec.spec-  describe "MainSpec"         MainSpec.spec+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,13 @@+module Main where++import           Test.DocTest++main :: IO ()+main = doctest [+    "--optghc=-packageghc"+  , "--optghc=-isrc"+  , "--optghc=-idist/build/autogen/"+  , "--optghc=-optP-include"+  , "--optghc=-optPdist/build/autogen/cabal_macros.h"+  , "src/Run.hs"+  ]