doctest-parallel 0.2.6 → 0.3.0

raw patch · 19 files changed

+891/−438 lines, 19 filesdep −extradep −hspec-discoverdep −prettysetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies removed: extra, hspec-discover, pretty

API changes (from Hackage documentation)

Files

• CHANGES.markdown +5/−0
• Setup.lhs +0/−3
• doctest-parallel.cabal +8/−10
• ghci-wrapper/src/Language/Haskell/GhciWrapper.hs +0/−156
• src/Control/Monad/Extra.hs +9/−0
• src/Data/List/Extra.hs +21/−0
• src/Test/DocTest.hs +29/−47
• src/Test/DocTest/Internal/GhciWrapper.hs +180/−0
• src/Test/DocTest/Internal/Interpreter.hs +16/−13
• src/Test/DocTest/Internal/Logging.hs +123/−0
• src/Test/DocTest/Internal/Nix.hs +138/−0
• src/Test/DocTest/Internal/Options.hs +25/−12
• src/Test/DocTest/Internal/Runner.hs +129/−140
• test/GhciWrapperSpec.hs +111/−0
• test/InterpreterSpec.hs +3/−2
• test/OptionsSpec.hs +3/−2
• test/PropertySpec.hs +20/−19
• test/RunnerSpec.hs +39/−33
• test/Spec.hs +32/−1

@@ -1,3 +1,8 @@+# 0.3.0+ * Add support for Nix shell environments ([#58](https://github.com/martijnbastiaan/doctest-parallel/pull/58))+ * `Language.Haskell.GhciWrapper` has been moved to `Test.DocTest.Internal.GhciWrapper`. This module was never intended to be part of the public API. ([#61](https://github.com/martijnbastiaan/doctest-parallel/pull/61))+ * Add more elaborate debug options. You can now pass `--log-level=LEVEL` where `level` is one of `debug`, `verbose`, `info`, `warning`, or `error`. ([#14](https://github.com/martijnbastiaan/doctest-parallel/issues/14))+ # 0.2.6   * `getNumProcessors` is now used to detect the (default) number of GHCi subprocesses to spawn. This should more reliably use all of a system's resources. Fixes [#53](https://github.com/martijnbastiaan/doctest-parallel/issues/53).   * Add Nix support. If the environment variable `NIX_BUILD_TOP` is present an extra package database is added to `GHC_PACKAGE_PATH`. This isn't expected to break existing builds, but if it does consider passing `--no-nix`. ([#34](https://github.com/martijnbastiaan/doctest-parallel/issues/34))

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain

@@ -1,7 +1,7 @@ cabal-version: 2.0  name:           doctest-parallel-version:        0.2.6+version:        0.3.0 synopsis:       Test interactive Haskell examples description:    The doctest program checks examples in source code comments.  It is modeled                 after doctest for Python (<https://docs.python.org/3/library/doctest.html>).@@ -66,26 +66,28 @@  library   ghc-options: -Wall-  hs-source-dirs:-      src-      ghci-wrapper/src+  hs-source-dirs: src   exposed-modules:       Test.DocTest       Test.DocTest.Helpers       Test.DocTest.Internal.Extract+      Test.DocTest.Internal.GhciWrapper       Test.DocTest.Internal.GhcUtil       Test.DocTest.Internal.Interpreter       Test.DocTest.Internal.Location+      Test.DocTest.Internal.Logging+      Test.DocTest.Internal.Nix       Test.DocTest.Internal.Options       Test.DocTest.Internal.Parse       Test.DocTest.Internal.Property       Test.DocTest.Internal.Runner       Test.DocTest.Internal.Runner.Example       Test.DocTest.Internal.Util-      Language.Haskell.GhciWrapper   autogen-modules:       Paths_doctest_parallel   other-modules:+      Control.Monad.Extra+      Data.List.Extra       Paths_doctest_parallel   build-depends:       Cabal >= 2.4 && < 3.9@@ -97,11 +99,9 @@     , deepseq     , directory     , exceptions-    , extra     , filepath     , ghc >=8.2 && <9.5     , ghc-paths >=0.1.0.9-    , pretty     , process     , random >= 1.2     , syb >=0.3@@ -176,6 +176,7 @@   main-is: Spec.hs   other-modules:       ExtractSpec+      GhciWrapperSpec       InterpreterSpec       LocationSpec       MainSpec@@ -191,8 +192,6 @@   cpp-options: -DTEST   hs-source-dirs:       test-  build-tool-depends:-    hspec-discover:hspec-discover   build-depends:       HUnit     , QuickCheck >=2.13.1@@ -209,7 +208,6 @@     , ghc-paths >=0.1.0.9     , hspec >=2.3.0     , hspec-core >=2.3.0-    , hspec-discover     , mockery     , process     , setenv

@@ -1,156 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiWayIf #-}--module Language.Haskell.GhciWrapper (-  Interpreter-, Config(..)-, defaultConfig-, new-, close-, eval-, evalIt-, evalEcho-) where--import           System.IO hiding (stdin, stdout, stderr)-import           System.Process-import           System.Exit-import           Control.Monad-import           Control.Exception-import           Data.List-import           Data.Maybe--data Config = Config {-  configGhci :: String-, configVerbose :: Bool-, configIgnoreDotGhci :: Bool-} deriving (Eq, Show)--defaultConfig :: Config-defaultConfig = Config {-  configGhci = "ghci"-, configVerbose = False-, configIgnoreDotGhci = True-}---- | Truly random marker, used to separate expressions.------ IMPORTANT: This module relies upon the fact that this marker is unique.  It--- has been obtained from random.org.  Do not expect this module to work--- properly, if you reuse it for any purpose!-marker :: String-marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"--itMarker :: String-itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a"--data Interpreter = Interpreter {-    hIn  :: Handle-  , hOut :: Handle-  , process :: ProcessHandle-  }--new :: Config -> [String] -> IO Interpreter-new Config{..} args_ = do-  (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}-  setMode stdin_-  setMode stdout_-  let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}-  _ <- eval interpreter "import qualified System.IO"-  _ <- eval interpreter "import qualified GHC.IO.Handle"-  -- The buffering of stdout and stderr is NoBuffering-  _ <- eval interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"-  -- Now the buffering of stderr is BlockBuffering Nothing-  -- In this situation, GHC 7.7 does not flush the buffer even when-  -- error happens.-  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"-  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"--  -- this is required on systems that don't use utf8 as default encoding (e.g.-  -- Windows)-  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout GHC.IO.Handle.utf8"-  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr GHC.IO.Handle.utf8"--  _ <- eval interpreter ":m - System.IO"-  _ <- eval interpreter ":m - GHC.IO.Handle"--  return interpreter-  where-    args = args_ ++ catMaybes [-        if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing-      , if configVerbose then Nothing else Just "-v0"-      ]-    setMode h = do-      hSetBinaryMode h False-      hSetBuffering h LineBuffering-      hSetEncoding h utf8--close :: Interpreter -> IO ()-close repl = do-  hClose $ hIn repl--  -- It is crucial not to close `hOut` before calling `waitForProcess`,-  -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang-  -- around consuming 100% CPU.  This happens when ghci tries to print-  -- something to stdout in its signal handler (e.g. when it is blocked in-  -- threadDelay it writes "Interrupted." on SIGINT).-  e <- waitForProcess $ process repl-  hClose $ hOut repl--  when (e /= ExitSuccess) $ do-    throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")--putExpression :: Interpreter -> Bool -> String -> IO ()-putExpression Interpreter{hIn = stdin} preserveIt e = do-  hPutStrLn stdin e-  when preserveIt $ hPutStrLn stdin $ "let " ++ itMarker ++ " = it"-  hPutStrLn stdin (marker ++ " :: Data.String.String")-  when preserveIt $ hPutStrLn stdin $ "let it = " ++ itMarker-  hFlush stdin--getResult :: Bool -> Interpreter -> IO String-getResult echoMode Interpreter{hOut = stdout} = go-  where-    go = do-      line <- hGetLine stdout--      if-        | marker `isSuffixOf` line -> do-          let xs = stripMarker line-          echo xs-          return xs-#if __GLASGOW_HASKELL__ < 810-        -- For some (happy) reason newer GHCs don't decide to print this-        -- message - or at least we don't see it.-        | "Loaded package environment from " `isPrefixOf` line -> do-          go-#endif-        | otherwise -> do-          echo (line ++ "\n")-          result <- go-          return (line ++ "\n" ++ result)-    stripMarker l = take (length l - length marker) l--    echo :: String -> IO ()-    echo-      | echoMode = putStr-      | otherwise = (const $ return ())---- | Evaluate an expression-eval :: Interpreter -> String -> IO String-eval repl expr = do-  putExpression repl False expr-  getResult False repl---- | Like 'eval', but try to preserve the @it@ variable-evalIt :: Interpreter -> String -> IO String-evalIt repl expr = do-  putExpression repl True expr-  getResult False repl---- | Evaluate an expression-evalEcho :: Interpreter -> String -> IO String-evalEcho repl expr = do-  putExpression repl False expr-  getResult True repl

@@ -0,0 +1,9 @@+module Control.Monad.Extra where++-- | Like @if@, but where the test can be monadic.+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM predicate t f = do b <- predicate; if b then t else f++-- | Like 'when', but where the test can be monadic.+whenM :: Monad m => m Bool -> m () -> m ()+whenM b t = ifM b t (pure ())

@@ -0,0 +1,21 @@+module Data.List.Extra (trim) where++import Data.Char (isSpace)+import Data.List (dropWhileEnd)++-- | Remove spaces from either side of a string. A combination of 'trimEnd' and 'trimStart'.+--+-- > trim      "  hello   " == "hello"+-- > trimStart "  hello   " == "hello   "+-- > trimEnd   "  hello   " == "  hello"+-- > \s -> trim s == trimEnd (trimStart s)+trim :: String -> String+trim = trimEnd . trimStart++-- | Remove spaces from the start of a string, see 'trim'.+trimStart :: String -> String+trimStart = dropWhile isSpace++-- | Remove spaces from the end of a string, see 'trim'.+trimEnd :: String -> String+trimEnd = dropWhileEnd isSpace

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}@@ -21,16 +21,11 @@ import           Prelude.Compat  import qualified Data.Set as Set+import           Data.List (intercalate)  import           Control.Monad (unless)-import           Control.Monad.Compat (when)-import           Control.Monad.Extra (whenM)-import           Data.List (isInfixOf)-import           Data.Maybe (fromMaybe)-import           System.Directory (doesDirectoryExist, makeAbsolute)-import           System.Environment (lookupEnv, setEnv)+import           Control.Monad.Extra (ifM) import           System.Exit (exitFailure)-import           System.FilePath ((</>)) import           System.IO import           System.Random (randomIO) @@ -45,6 +40,7 @@ import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Options import Test.DocTest.Internal.Runner+import Test.DocTest.Internal.Nix (getNixGhciArgs)  -- Cabal import Distribution.Simple@@ -54,7 +50,10 @@ import Test.DocTest.Helpers   ( Library (libDefaultExtensions), extractCabalLibrary, findCabalPackage   , libraryToGhciArgs )+import Test.DocTest.Internal.Logging (LogLevel(..)) +import qualified Test.DocTest.Internal.Logging as Logging+ -- | Run doctest with given list of arguments. -- -- Example:@@ -123,56 +122,39 @@   nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1)   isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1 -setSeed :: Bool -> ModuleConfig -> IO ModuleConfig-setSeed quiet cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do+setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig+setSeed cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do   -- Using an absolute number to prevent copy+paste errors   seed <- abs <$> randomIO-  unless quiet $-    putStrLn ("Using freshly generated seed to randomize test order: " <> show seed)+  Logging.log Info ("Using freshly generated seed to randomize test order: " <> show seed)   pure cfg{cfgSeed=Just seed}-setSeed _quiet cfg = pure cfg---- | @GHC_PACKAGE_PATH@. Here as a variable to prevent typos.-gHC_PACKAGE_PATH :: String-gHC_PACKAGE_PATH = "GHC_PACKAGE_PATH"---- | Add locally built package to @GHC_PACKAGE_PATH@ if a Nix environment is--- detected.-addLocalNixPackageToGhcPath :: IO ()-addLocalNixPackageToGhcPath = do-  lookupEnv "NIX_BUILD_TOP" >>= \case-    Nothing -> pure ()-    Just _ -> do-      pkgDb <- makeAbsolute ("dist" </> "package.conf.inplace")-      ghcPackagePath <- fromMaybe "" <$> lookupEnv gHC_PACKAGE_PATH--      -- Don't add package db if it is already mentioned on path-      unless ((pkgDb ++ ":") `isInfixOf` ghcPackagePath) $-        -- Only add package db if it exists on disk-        whenM (doesDirectoryExist pkgDb) $-          setEnv gHC_PACKAGE_PATH (pkgDb ++ ":" ++ ghcPackagePath)+setSeed cfg = pure cfg  -- | Run doctest for given library and config. Produce a summary of all tests. run :: Library -> Config -> IO Summary run lib Config{..} = do-  when cfgNix addLocalNixPackageToGhcPath+  nixGhciArgs <- ifM (pure cfgNix) getNixGhciArgs (pure [])    let     implicitPrelude = DisableExtension ImplicitPrelude `notElem` libDefaultExtensions lib     (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib-    evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"]+    evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"] ++ nixGhciArgs+    parseGhciArgs = includeArgs ++ moduleArgs ++ otherGhciArgs ++ nixGhciArgs -    -- Nix doesn't always expose the GHC library (_specifically_ the GHC lib) even-    -- if a package lists it as a dependency. This simply always exposes it as a-    -- workaround.-    nixGhciArgs-      | cfgNix = ["-package", "ghc"]-      | otherwise = []+  let+    ?verbosity = cfgLogLevel -  modConfig <- setSeed cfgQuiet cfgModuleConfig+  modConfig <- setSeed cfgModuleConfig -  -- get examples from Haddock comments-  allModules <- getDocTests (includeArgs ++ moduleArgs ++ otherGhciArgs ++ nixGhciArgs)-  runModules-    modConfig cfgThreads cfgVerbose implicitPrelude evalGhciArgs-    cfgQuiet (filterModules cfgModules allModules)+  -- Get examples from Haddock comments+  Logging.log Verbose "Parsing comments.."+  Logging.log Debug ("Calling GHC API with: " <> unwords parseGhciArgs)+  allModules <- getDocTests parseGhciArgs++  -- Run tests+  Logging.log Verbose "Running examples.."+  let+    filteredModules = filterModules cfgModules allModules+    filteredModulesMsg = intercalate ", " (map moduleName filteredModules)+  Logging.log Debug ("Running examples in modules: " <> filteredModulesMsg)+  runModules modConfig cfgThreads implicitPrelude evalGhciArgs filteredModules

@@ -0,0 +1,180 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}++module Test.DocTest.Internal.GhciWrapper (+  Interpreter+, Config(..)+, defaultConfig+, new+, close+, eval+, evalIt+, evalEcho+) where++import System.IO hiding (stdin, stdout, stderr)+import System.Process+import System.Exit+import Control.Monad+import Control.Exception+import Data.List+import Data.Maybe++import Test.DocTest.Internal.Logging (DebugLogger)++data Config = Config {+  configGhci :: String+, configVerbose :: Bool+, configIgnoreDotGhci :: Bool+} deriving (Eq, Show)++defaultConfig :: Config+defaultConfig = Config {+  configGhci = "ghci"+, configVerbose = False+, configIgnoreDotGhci = True+}++-- | Truly random marker, used to separate expressions.+--+-- IMPORTANT: This module relies upon the fact that this marker is unique.  It+-- has been obtained from random.org.  Do not expect this module to work+-- properly, if you reuse it for any purpose!+marker :: String+marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1"++itMarker :: String+itMarker = "d42472243a0e6fc481e7514cbc9eb08812ed48daa29ca815844d86010b1d113a"++data Interpreter = Interpreter {+    hIn  :: Handle+  , hOut :: Handle+  , process :: ProcessHandle+  , logger :: DebugLogger+  }++new :: DebugLogger -> Config -> [String] -> IO Interpreter+new logger Config{..} args_ = do+  logger ("Calling: " ++ unwords (configGhci:args))+  (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}+  setMode stdin_+  setMode stdout_+  let+    interpreter = Interpreter+      { hIn = stdin_+      , hOut = stdout_+      , process = processHandle+      , logger=logger+      }+  _ <- eval interpreter "import qualified System.IO"+  _ <- eval interpreter "import qualified GHC.IO.Handle"+  -- The buffering of stdout and stderr is NoBuffering+  _ <- eval interpreter "GHC.IO.Handle.hDuplicateTo System.IO.stdout System.IO.stderr"+  -- Now the buffering of stderr is BlockBuffering Nothing+  -- In this situation, GHC 7.7 does not flush the buffer even when+  -- error happens.+  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stdout GHC.IO.Handle.LineBuffering"+  _ <- eval interpreter "GHC.IO.Handle.hSetBuffering System.IO.stderr GHC.IO.Handle.LineBuffering"++  -- this is required on systems that don't use utf8 as default encoding (e.g.+  -- Windows)+  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stdout System.IO.utf8"+  _ <- eval interpreter "GHC.IO.Handle.hSetEncoding System.IO.stderr System.IO.utf8"++  _ <- eval interpreter ":m - System.IO"+  _ <- eval interpreter ":m - GHC.IO.Handle"++  return interpreter+  where+    args = args_ ++ catMaybes [+        if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing+      , if configVerbose then Nothing else Just "-v0"+      ]+    setMode h = do+      hSetBinaryMode h False+      hSetBuffering h LineBuffering+      hSetEncoding h utf8++close :: Interpreter -> IO ()+close repl = do+  hClose $ hIn repl++  -- It is crucial not to close `hOut` before calling `waitForProcess`,+  -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang+  -- around consuming 100% CPU.  This happens when ghci tries to print+  -- something to stdout in its signal handler (e.g. when it is blocked in+  -- threadDelay it writes "Interrupted." on SIGINT).+  e <- waitForProcess $ process repl+  hClose $ hOut repl++  when (e /= ExitSuccess) $ do+    throwIO (userError $ "Test.DocTest.Internal.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")")++putExpression :: Interpreter -> Bool -> String -> IO ()+putExpression Interpreter{logger = logger, hIn = stdin} preserveIt e = do+  logger (">>> " ++ e)+  hPutStrLn stdin e++  when preserveIt $ do+    let e1 = "let " ++ itMarker ++ " = it"+    logger (">>> " ++ e1)+    hPutStrLn stdin e1++  hPutStrLn stdin (marker ++ " :: Data.String.String")++  when preserveIt $ do+    let e3 = "let it = " ++ itMarker+    logger (">>> " ++ e3)+    hPutStrLn stdin e3++  hFlush stdin++getResult :: Bool -> Interpreter -> IO String+getResult echoMode Interpreter{logger = logger, hOut = stdout} = do+  result <- go+  unless (result == mempty) $ logger result+  pure result+  where+    go = do+      line <- hGetLine stdout++      if+        | marker `isSuffixOf` line -> do+          let xs = stripMarker line+          echo xs+          return xs+#if __GLASGOW_HASKELL__ < 810+        -- For some (happy) reason newer GHCs don't decide to print this+        -- message - or at least we don't see it.+        | "Loaded package environment from " `isPrefixOf` line -> do+          go+#endif+        | otherwise -> do+          echo (line ++ "\n")+          result <- go+          return (line ++ "\n" ++ result)+    stripMarker l = take (length l - length marker) l++    echo :: String -> IO ()+    echo+      | echoMode = putStr+      | otherwise = (const $ return ())++-- | Evaluate an expression+eval :: Interpreter -> String -> IO String+eval repl expr = do+  putExpression repl False expr+  getResult False repl++-- | Like 'eval', but try to preserve the @it@ variable+evalIt :: Interpreter -> String -> IO String+evalIt repl expr = do+  putExpression repl True expr+  getResult False repl++-- | Evaluate an expression+evalEcho :: Interpreter -> String -> IO String+evalEcho repl expr = do+  putExpression repl False expr+  getResult True repl

@@ -8,22 +8,24 @@ , ghc , interpreterSupported --- exported for testing+-- * exported for testing , ghcInfo , haveInterpreterKey ) where -import           System.Process-import           System.Directory (getPermissions, executable)-import           Control.Monad-import           Control.Exception hiding (handle)-import           Data.Char-import           GHC.Paths (ghc)+import System.Process+import System.Directory (getPermissions, executable)+import Control.Monad+import Control.Exception hiding (handle)+import Data.Char+import GHC.Paths (ghc) -import           Language.Haskell.GhciWrapper+import Test.DocTest.Internal.GhciWrapper+import Test.DocTest.Internal.Logging (DebugLogger)  -- $setup--- >>> import Language.Haskell.GhciWrapper (eval)+-- >>> import Test.DocTest.Internal.GhciWrapper (eval)+-- >>> import Test.DocTest.Internal.Logging (noLogger)  haveInterpreterKey :: String haveInterpreterKey = "Have interpreter"@@ -45,13 +47,14 @@ -- -- Example: ----- >>> withInterpreter [] $ \i -> eval i "23 + 42"+-- >>> withInterpreter noLogger [] $ \i -> eval i "23 + 42" -- "65\n" withInterpreter-  :: [String]               -- ^ List of flags, passed to GHC+  :: DebugLogger            -- ^ Debug logger+  -> [String]               -- ^ List of flags, passed to GHC   -> (Interpreter -> IO a)  -- ^ Action to run   -> IO a                   -- ^ Result of action-withInterpreter flags action = do+withInterpreter logger flags action = do   let     args = flags ++ [         "--interactive"@@ -60,7 +63,7 @@       , "-fno-diagnostics-show-caret" #endif       ]-  bracket (new defaultConfig{configGhci = ghc} args) close action+  bracket (new logger defaultConfig{configGhci = ghc} args) close action  -- | Evaluate an expression; return a Left value on exceptions. --

@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ViewPatterns #-}++module Test.DocTest.Internal.Logging where++import Control.Applicative (Alternative((<|>)))+import Control.Concurrent (ThreadId, myThreadId)+import Control.DeepSeq (NFData)+import Data.Char (toLower, toUpper)+import Data.List (intercalate)+import GHC.Generics (Generic)+import System.IO (hPutStrLn, stderr)+import Text.Printf (printf)++-- | Convenience type alias - not used in this module, but sprinkled across the+-- project.+type DebugLogger = String -> IO ()++-- | Discards any log message+noLogger :: DebugLogger+noLogger = const (pure ())++data LogLevel+  = Debug+  -- ^ Intended for debug runs+  | Verbose+  -- ^ Intended for debug runs, but without flooding the user with internal messages+  | Info+  -- ^ Default log level - print messages user is likely wanting to see+  | Warning+  -- ^ Only print warnings+  | Error+  -- ^ Only print errors+  deriving (Show, Eq, Enum, Generic, NFData, Ord, Bounded)++-- | Case insensitive+--+-- >>> parseLogLevel "Info"+-- Just Info+-- >>> parseLogLevel "info"+-- Just Info+-- >>> parseLogLevel "errox"+-- Nothing+--+parseLogLevel :: String -> Maybe LogLevel+parseLogLevel (map toLower -> level) =+  foldl (<|>) Nothing (map go [minBound..])+ where+  go :: LogLevel -> Maybe LogLevel+  go l+    | map toLower (show l) == level = Just l+    | otherwise = Nothing++-- | Pretty print a 'LogLevel' in a justified manner, i.e., all outputs take the+-- same amount of characters to display.+--+-- >>> showJustifiedLogLevel Debug+-- "Debug  "+-- >>> showJustifiedLogLevel Verbose+-- "Verbose"+-- >>> showJustifiedLogLevel Info+-- "Info   "+-- >>> showJustifiedLogLevel Warning+-- "Warning"+-- >>> showJustifiedLogLevel Error+-- "Error  "+--+showJustifiedLogLevel :: LogLevel -> String+showJustifiedLogLevel = justifyLeft maxSizeLogLevel ' ' . show+ where+  maxSizeLogLevel :: Int+  maxSizeLogLevel = maximum (map (length . show) [(minBound :: LogLevel)..])++-- | Justify a list with a custom fill symbol+--+-- >>> justifyLeft 10 'x' "foo"+-- "fooxxxxxxx"+-- >>> justifyLeft 3 'x' "foo"+-- "foo"+-- >>> justifyLeft 2 'x' "foo"+-- "foo"+--+justifyLeft :: Int -> a -> [a] -> [a]+justifyLeft n c s = s ++ replicate (n - length s) c++-- | /Prettily/ format a log message+--+-- > threadId <- myThreadId+-- > formatLog Debug threadId "some debug message"+-- "[DEBUG  ] [ThreadId 1277462] some debug message"+--+formatLog :: ThreadId -> LogLevel -> String -> String+formatLog threadId lvl msg = do+  intercalate "\n" (map go (lines msg))+ where+  go line =+    printf+      "[%s] [%s] %s"+      (map toUpper (showJustifiedLogLevel lvl))+      (show threadId)+      line++-- | Like 'formatLog', but instantiates the /thread/ argument with the current 'ThreadId'+--+-- > formatLogHere Debug "some debug message"+-- "[DEBUG  ] [ThreadId 1440849] some debug message"+--+formatLogHere :: LogLevel -> String -> IO String+formatLogHere lvl msg = do+  threadId <- myThreadId+  pure (formatLog threadId lvl msg)++-- | Should a message be printed? For a given verbosity level and message log level.+shouldLog :: (?verbosity :: LogLevel) => LogLevel -> Bool+shouldLog lvl = ?verbosity <= lvl++-- | Basic logging function. Uses 'formatLogHere'. Is not thread-safe.+log :: (?verbosity :: LogLevel) => LogLevel -> String -> IO ()+log lvl msg+  | shouldLog lvl = hPutStrLn stderr =<< formatLogHere lvl msg+  | otherwise = pure ()

@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Test.DocTest.Internal.Nix where++import Control.Monad (msum)+import Control.Monad.Extra (ifM)+import Control.Monad.Trans.Maybe+import Data.Bool (bool)+import Data.List (intercalate, isSuffixOf)+import Data.Maybe (isJust)+import Data.Version+import GHC.Base (mzero)+import System.Directory+import System.Environment (lookupEnv)+import System.FilePath ((</>), isDrive, takeDirectory)+import System.Process (readProcess)++#if __GLASGOW_HASKELL__ >= 900+import GHC.Data.Maybe (liftMaybeT)+import System.Info (fullCompilerVersion)+#else+import Maybes (liftMaybeT)+import System.Info (compilerVersion)++fullCompilerVersion :: Version+fullCompilerVersion =+  case compilerVersion of+    Version majorMinor tags ->+      Version (majorMinor ++ [lvl1]) tags+ where+  lvl1 :: Int+  lvl1 = __GLASGOW_HASKELL_PATCHLEVEL1__+#endif++-- | E.g. @9.0.2@+compilerVersionStr :: String+compilerVersionStr = intercalate "." (map show (versionBranch fullCompilerVersion))++-- | Traverse upwards until one of the following conditions is met:+--+--   * Current working directory is either root or a home directory+--   * The predicate function returns 'Just'+--+findDirectoryUp :: (FilePath -> IO (Maybe a)) -> MaybeT IO a+findDirectoryUp f = do+  home <- liftMaybeT getHomeDirectory+  MaybeT (go home =<< getCurrentDirectory)+ where+  go home cwd+    | isDrive cwd = pure Nothing+    | cwd == home = pure Nothing+    | otherwise =+      f cwd >>= \case+        Just a -> pure (Just a)+        Nothing -> go home (takeDirectory cwd)++-- | Like 'findDirectoryUp', but takes a predicate function instead. If the predicate+-- yields 'True', the filepath is returned.+findDirectoryUpPredicate :: (FilePath -> IO Bool) -> MaybeT IO FilePath+findDirectoryUpPredicate f = findDirectoryUp (\fp -> bool Nothing (Just fp) <$> f fp)++-- | Find the root of the Cabal project relative to the current directory.+findCabalProjectRoot :: MaybeT IO FilePath+findCabalProjectRoot =+  msum+    [ findDirectoryUpPredicate containsCabalProject+    , findDirectoryUpPredicate containsCabalPackage+    ]+ where+  containsCabalPackage :: FilePath -> IO Bool+  containsCabalPackage fp = elem "cabal.project" <$> getDirectoryContents fp++  containsCabalProject :: FilePath -> IO Bool+  containsCabalProject fp = any (".cabal" `isSuffixOf`) <$> getDirectoryContents fp++-- | Find the local package database in @dist-newstyle@.+findLocalPackageDb :: MaybeT IO FilePath+findLocalPackageDb = do+  projectRoot <- findCabalProjectRoot+  let+    relDir = "dist-newstyle" </> "packagedb" </> ("ghc-" ++ compilerVersionStr)+    absDir = projectRoot </> relDir+  ifM+    (liftMaybeT (doesDirectoryExist absDir))+    (return absDir)+    mzero++-- | Are we running in a Nix shell?+inNixShell :: IO Bool+inNixShell = isJust <$> lookupEnv "IN_NIX_SHELL"++-- | Are we running in a Nix build environment?+inNixBuild :: IO Bool+inNixBuild = isJust <$> lookupEnv "NIX_BUILD_TOP"++getLocalCabalPackageDbArgs :: IO [String]+getLocalCabalPackageDbArgs = do+  runMaybeT findLocalPackageDb >>= \case+     Nothing -> pure []+     Just s -> pure ["-package-db", s]++getLocalNixPackageDbArgs :: IO [String]+getLocalNixPackageDbArgs = do+  pkgDb <- makeAbsolute ("dist" </> "package.conf.inplace")+  ifM+    (doesDirectoryExist pkgDb)+    (pure ["-package-db", pkgDb])+    (pure [])++-- | Get global package db; used in a NIX_SHELL context+getGlobalPackageDb :: IO String+getGlobalPackageDb = init <$> readProcess "ghc" ["--print-global-package-db"] ""++-- | Get flags to be used when running in a Nix context (either in a build, or a+-- shell).+getNixGhciArgs :: IO [String]+getNixGhciArgs =+  ifM inNixShell goShell (ifM inNixBuild goBuild (pure []))+ where+  goShell = do+    globalPkgDb <- getGlobalPackageDb+    localPkgDbFlag <- getLocalCabalPackageDbArgs+    let globalDbFlag = ["-package-db", globalPkgDb]+    pure (defaultArgs ++ globalDbFlag ++ localPkgDbFlag)++  goBuild = do+    localDbFlag <- getLocalNixPackageDbArgs+    pure (defaultArgs ++ localDbFlag)++  defaultArgs =+    [ "-package-env", "-"++    -- Nix doesn't always expose the GHC library (_specifically_ the GHC lib) even+    -- if a package lists it as a dependency. This simply always exposes it as a+    -- workaround.+    , "-package", "ghc"+    ]

@@ -11,6 +11,7 @@ import           Control.DeepSeq (NFData) import           Data.List.Compat import           GHC.Generics (Generic)+import           Text.Read (readMaybe)  import qualified Paths_doctest_parallel import           Data.Version (showVersion)@@ -23,7 +24,8 @@  import           Test.DocTest.Internal.Location (Located (Located), Location) import           Test.DocTest.Internal.Interpreter (ghc)-import           Text.Read (readMaybe)+import           Test.DocTest.Internal.Logging (LogLevel(..))+import qualified Test.DocTest.Internal.Logging as Logging  usage :: String usage = unlines [@@ -35,13 +37,15 @@   , ""   , "Options:"   , "   -jN                      number of threads to use"+  , "   --log-level=LEVEL        one of: debug, verbose, info, warning, error. Default: info."   , "†  --implicit-module-import import module before testing it (default)"   , "†  --randomize-order        randomize order in which tests are run"   , "†  --seed=N                 use a specific seed to randomize test order"   , "†  --preserve-it            preserve the `it` variable between examples"   , "   --nix                    account for Nix build environments (default)"-  , "   --verbose                print each test as it is run"-  , "   --quiet                  only print errors"+  , "   --quiet                  set log level to `Error`, shorthand for `--log-level=error`"+  , "   --verbose                set log level to `Verbose`, shorthand for `--log-level=verbose`"+  , "   --debug                  set log level to `Debug`, shorthand for `--log-level=debug`"   , "   --help                   display this help and exit"   , "   --version                output version information and exit"   , "   --info                   output machine-readable version information and exit"@@ -89,15 +93,13 @@ type ModuleName = String  data Config = Config-  { cfgVerbose :: Bool-  -- ^ Verbose output (default: @False@)+  { cfgLogLevel :: LogLevel+  -- ^ Verbosity level.   , cfgModules :: [ModuleName]   -- ^ Module names to test. An empty list means "test all modules".   , cfgThreads :: Maybe Int   -- ^ Number of threads to use. Defaults to autodetection based on the number   -- of cores.-  , cfgQuiet :: Bool-  -- ^ Only print error messages, no status or progress messages (default: @False@)   , cfgModuleConfig :: ModuleConfig   -- ^ Options specific to modules   , cfgNix :: Bool@@ -129,10 +131,9 @@  defaultConfig :: Config defaultConfig = Config-  { cfgVerbose = False-  , cfgModules = []+  { cfgModules = []   , cfgThreads = Nothing-  , cfgQuiet = False+  , cfgLogLevel = Info   , cfgModuleConfig = defaultModuleConfig   , cfgNix = True   }@@ -171,11 +172,13 @@       "--help" -> ResultStdout usage       "--info" -> ResultStdout info       "--version" -> ResultStdout versionInfo-      "--verbose" -> go config{cfgVerbose=True} args-      "--quiet" -> go config{cfgQuiet=True} args+      "--quiet" -> go config{cfgLogLevel=Error} args+      "--verbose" -> go config{cfgLogLevel=Verbose} args+      "--debug" -> go config{cfgLogLevel=Debug} args       "--nix" -> go config{cfgNix=True} args       "--no-nix" -> go config{cfgNix=False} args       ('-':_) | Just n <- parseThreads arg -> go config{cfgThreads=Just n} args+      ('-':_) | Just l <- parseLogLevel arg -> go config{cfgLogLevel=l} args       ('-':_)         -- Module specific configuration options         | Just modCfg <- parseModuleOption (cfgModuleConfig config) arg@@ -193,6 +196,16 @@ parseSeed :: String -> Maybe Int parseSeed arg = readMaybe =<< parseSpecificFlag arg "seed" +-- | Parse seed argument+--+-- >>> parseLogLevel "--log-level=Debug"+-- Just Debug+-- >>> parseLogLevel "--log-level=debug"+-- Just Debug+-- >>> parseSeed "---log-level=debug"+-- Nothing+parseLogLevel  :: String -> Maybe LogLevel+parseLogLevel arg = Logging.parseLogLevel =<< parseSpecificFlag arg "log-level"  -- | Parse number of threads argument --

@@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}  module Test.DocTest.Internal.Runner where  import           Prelude hiding (putStr, putStrLn, error) -import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO)+import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId) import           Control.Exception (SomeException, catch) import           Control.Monad hiding (forM_) import           Data.Foldable (forM_)@@ -28,11 +29,12 @@   ( ModuleName, ModuleConfig (cfgPreserveIt), cfgSeed, cfgPreserveIt   , cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions) import           Test.DocTest.Internal.Location-import Test.DocTest.Internal.Property-    ( runProperty, PropertyResult(Failure, Success, Error) )+import qualified Test.DocTest.Internal.Property as Property import           Test.DocTest.Internal.Runner.Example+import           Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog)  import           System.IO.CodePage (withCP65001)+import Control.Monad.Extra (whenM)  #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup@@ -71,22 +73,19 @@  -- | Run all examples from a list of modules. runModules-  :: ModuleConfig+  :: (?verbosity::LogLevel)+  => ModuleConfig   -- ^ Configuration options specific to module   -> Maybe Int   -- ^ Number of threads to use. Defaults to 'getNumProcessors'.   -> Bool-  -- ^ Verbose-  -> Bool   -- ^ Implicit Prelude   -> [String]   -- ^ Arguments passed to the GHCi process.-  -> Bool-  -- ^ Quiet mode activated   -> [Module [Located DocTest]]   -- ^ Modules under test   -> IO Summary-runModules modConfig nThreads verbose implicitPrelude args quiet modules = do+runModules modConfig nThreads implicitPrelude args modules = do   isInteractive <- hIsTerminalDevice stderr    -- Start a thread pool. It sends status updates to this thread through 'output'.@@ -104,33 +103,37 @@     initState = ReportState       { reportStateCount = 0       , reportStateInteractive = isInteractive-      , reportStateVerbose = verbose-      , reportStateQuiet = quiet       , reportStateSummary = mempty{sExamples=nExamples}       } +  threadId <- myThreadId+  let ?threadId = threadId+   ReportState{reportStateSummary} <- (`execStateT` initState) $ do     consumeUpdates output (length modules)-    unless quiet $ do-      verboseReport "# Final summary:"-      gets (show . reportStateSummary) >>= report+    gets (show . reportStateSummary) >>= report Info    return reportStateSummary  where+  consumeUpdates ::+    (?threadId :: ThreadId) =>+    Chan (ThreadId, ReportUpdate) ->+    Int ->+    StateT ReportState IO ()   consumeUpdates _output 0 = pure ()   consumeUpdates output modsLeft = do-    update <- liftIO (readChan output)+    (threadId, update) <- liftIO (readChan output)+    let ?threadId = threadId     consumeUpdates output =<<       case update of         UpdateInternalError fs loc e -> reportInternalError fs loc e >> pure (modsLeft - 1)         UpdateImportError modName result -> reportImportError modName result >> pure (modsLeft - 1)-        UpdateSuccess fs loc -> reportSuccess fs loc >> reportProgress >> pure modsLeft+        UpdateSuccess fs -> reportSuccess fs >> reportProgress >> pure modsLeft         UpdateFailure fs loc expr errs -> reportFailure fs loc expr errs >> pure modsLeft         UpdateError fs loc expr err -> reportError fs loc expr err >> pure modsLeft         UpdateOptionError loc err -> reportOptionError loc err >> pure modsLeft-        UpdateVerbose msg -> verboseReport msg >> pure modsLeft-        UpdateStart loc expr msg -> reportStart loc expr msg >> pure modsLeft         UpdateModuleDone -> pure (modsLeft - 1)+        UpdateLog lvl msg -> report lvl msg >> pure modsLeft  -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int@@ -142,30 +145,36 @@ data ReportState = ReportState {   reportStateCount        :: Int     -- ^ characters on the current line , reportStateInteractive  :: Bool    -- ^ should intermediate results be printed?-, reportStateVerbose      :: Bool-, reportStateQuiet        :: Bool , reportStateSummary      :: Summary -- ^ test summary }  -- | Add output to the report.-report :: String -> Report ()-report msg = do-  overwrite msg+report ::+  ( ?verbosity :: LogLevel+  , ?threadId :: ThreadId+  ) =>+  LogLevel ->+  String ->+  Report ()+report lvl msg0 =+  when (shouldLog lvl) $ do+    let msg1 = formatLog ?threadId lvl msg0+    overwrite msg1 -  -- add a newline, this makes the output permanent-  liftIO $ hPutStrLn stderr ""-  modify (\st -> st {reportStateCount = 0})+    -- 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})+report_ :: (?verbosity :: LogLevel) => LogLevel -> String -> Report ()+report_ lvl msg =+  when (shouldLog lvl) $ do+    whenM (gets reportStateInteractive) $ do+      overwrite msg+      modify (\st -> st {reportStateCount = length msg})  -- | Add output to the report, overwrite any intermediate out. overwrite :: String -> Report ()@@ -187,13 +196,16 @@   :: ModuleConfig   -> Bool   -> [String]-  -> Chan ReportUpdate+  -> Chan (ThreadId, ReportUpdate)   -> Module [Located DocTest]   -> IO () runModule modConfig0 implicitPrelude ghciArgs output mod_ = do+  threadId <- myThreadId+  let update r = writeChan output (threadId, r)+   case modConfig2 of     Left (loc, flag) ->-      writeChan output (UpdateOptionError loc flag)+      update (UpdateOptionError loc flag)      Right modConfig3 -> do       let@@ -228,7 +240,8 @@             Example e _ -> void $ safeEvalWith preserveIt repl e  -      Interpreter.withInterpreter ghciArgs $ \repl -> withCP65001 $ do+      let logger = update . UpdateLog Debug+      Interpreter.withInterpreter logger ghciArgs $ \repl -> withCP65001 $ do         -- Try to import this module, if it fails, something is off         importResult <-           case importModule of@@ -240,20 +253,20 @@             -- Run setup group             successes <-               mapM-                (runTestGroup FromSetup preserveIt repl (reload repl) output)+                (runTestGroup FromSetup preserveIt repl (reload repl) update)                 setup              -- only run tests, if setup does not produce any errors/failures             when               (and successes)               (mapM_-                (runTestGroup NotFromSetup preserveIt repl (setup_ repl) output)+                (runTestGroup NotFromSetup preserveIt repl (setup_ repl) update)                 examples1)           _ ->-            writeChan output (UpdateImportError module_ importResult)+            update (UpdateImportError module_ importResult)    -- Signal main thread a module has been tested-  writeChan output UpdateModuleDone+  update UpdateModuleDone    pure () @@ -262,137 +275,112 @@   modConfig2 = parseLocatedModuleOptions module_ modConfig0 modArgs  data ReportUpdate-  = UpdateSuccess FromSetup Location+  = UpdateSuccess FromSetup   -- ^ Test succeeded   | UpdateFailure FromSetup Location Expression [String]   -- ^ Test failed with unexpected result   | UpdateError FromSetup Location Expression String   -- ^ Test failed with an error-  | UpdateVerbose String-  -- ^ Message to send when verbose output is activated   | UpdateModuleDone   -- ^ All examples tested in module-  | UpdateStart Location Expression String-  -- ^ Indicate test has started executing (verbose output)   | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException   -- ^ Exception caught while executing internal code   | UpdateImportError ModuleName (Either String String)   -- ^ Could not import module   | UpdateOptionError Location String   -- ^ Unrecognized flag in module specific option+  | UpdateLog LogLevel String+  -- ^ Unstructured message  makeThreadPool ::   Int ->-  (Chan ReportUpdate -> Module [Located DocTest] -> IO ()) ->-  IO (Chan (Module [Located DocTest]), Chan ReportUpdate)+  (Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()) ->+  IO (Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate)) makeThreadPool nThreads mutator = do   input <- newChan   output <- newChan   forM_ [1..nThreads] $ \_ ->     forkIO $ forever $ do       i <- readChan input+      threadId <- myThreadId       catch         (mutator output i)-        (\e -> writeChan output (UpdateInternalError NotFromSetup i e))+        (\e -> writeChan output (threadId, UpdateInternalError NotFromSetup i e))   return (input, output) -reportStart :: Location -> Expression -> String -> Report ()-reportStart loc expression testType = do-  quiet <- gets reportStateQuiet-  unless quiet $-    verboseReport-      (printf "### Started execution at %s.\n### %s:\n%s" (show loc) testType expression)--reportFailure :: FromSetup -> Location -> Expression -> [String] -> Report ()+reportFailure :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> [String] -> Report () reportFailure fromSetup loc expression err = do-  report (printf "%s: failure in expression `%s'" (show loc) expression)-  mapM_ report err-  report ""+  report Error (printf "%s: failure in expression `%s'" (show loc) expression)+  mapM_ (report Error) err+  report Error ""   updateSummary fromSetup (Summary 0 1 0 1) -reportError :: FromSetup -> Location -> Expression -> String -> Report ()+reportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> String -> Report () reportError fromSetup loc expression err = do-  report (printf "%s: error in expression `%s'" (show loc) expression)-  report err-  report ""+  report Error (printf "%s: error in expression `%s'" (show loc) expression)+  report Error err+  report Error ""   updateSummary fromSetup (Summary 0 1 1 0) -reportOptionError :: Location -> String -> Report ()+reportOptionError :: (?verbosity::LogLevel, ?threadId::ThreadId) => Location -> String -> Report () reportOptionError loc opt = do-  report (printf "%s: unrecognized option: %s. Try --help to see all options." (show loc) opt)-  report ""+  report Error (printf "%s: unrecognized option: %s. Try --help to see all options." (show loc) opt)+  report Error ""   updateSummary FromSetup (Summary 0 1 1 0) -reportInternalError :: FromSetup -> Module a -> SomeException -> Report ()+reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Module a -> SomeException -> Report () reportInternalError fs mod_ err = do-  report (printf "Internal error when executing tests in %s" (moduleName mod_))-  report (show err)-  report ""+  report Error (printf "Internal error when executing tests in %s" (moduleName mod_))+  report Error (show err)+  report Error ""   updateSummary fs emptySummary{sErrors=1} -reportImportError :: ModuleName -> Either String String -> Report ()+reportImportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Either String String -> Report () reportImportError modName importResult = do-  report ("Could not import module: " <> modName <> ". This can be caused by a number of issues: ")-  report ""-  report " 1. A module found by GHC contained tests, but was not in 'exposed-modules'. If you want"-  report "    to test non-exposed modules follow the instructions here:"-  report "    https://github.com/martijnbastiaan/doctest-parallel#test-non-exposed-modules"-  report ""-  report " 2. For Cabal users: Cabal did not generate a GHC environment file. Either:"-  report "   * Run with '--write-ghc-environment-files=always'"-  report "   * Add 'write-ghc-environment-files: always' to your cabal.project"-  report ""-  report " 3. For Cabal users: Cabal did not generate a GHC environment file in time. This"-  report "    can happen if you use 'cabal test' instead of 'cabal run doctests'. See"-  report "    https://github.com/martijnbastiaan/doctest-parallel/issues/22."-  report ""-  report " 4. The testsuite executable does not have a dependency on your project library. Please"-  report "    add it to the 'build-depends' section of the testsuite executable."-  report ""-  report "See the example project at https://github.com/martijnbastiaan/doctest-parallel/blob/main/example/README.md for more information."-  report ""-  report "The original reason given by GHCi was:"-  report ""+  report Error ("Could not import module: " <> modName <> ". This can be caused by a number of issues: ")+  report Error ""+  report Error " 1. A module found by GHC contained tests, but was not in 'exposed-modules'. If you want"+  report Error "    to test non-exposed modules follow the instructions here:"+  report Error "    https://github.com/martijnbastiaan/doctest-parallel#test-non-exposed-modules"+  report Error ""+  report Error " 2. For Cabal users: Cabal did not generate a GHC environment file. Either:"+  report Error "   * Run with '--write-ghc-environment-files=always'"+  report Error "   * Add 'write-ghc-environment-files: always' to your cabal.project"+  report Error ""+  report Error " 3. For Cabal users: Cabal did not generate a GHC environment file in time. This"+  report Error "    can happen if you use 'cabal test' instead of 'cabal run doctests'. See"+  report Error "    https://github.com/martijnbastiaan/doctest-parallel/issues/22."+  report Error ""+  report Error " 4. The testsuite executable does not have a dependency on your project library. Please"+  report Error "    add it to the 'build-depends' section of the testsuite executable."+  report Error ""+  report Error "See the example project at https://github.com/martijnbastiaan/doctest-parallel/blob/main/example/README.md for more information."+  report Error ""+  report Error "The original reason given by GHCi was:"+  report Error ""   case importResult of     Left out -> do-      report "Unexpected output:"-      report out+      report Error "Unexpected output:"+      report Error out     Right err -> do-      report "Error:"-      report err+      report Error "Error:"+      report Error err    updateSummary FromSetup emptySummary{sErrors=1} -reportSuccess :: FromSetup -> Location -> Report ()-reportSuccess fromSetup loc = do-  quiet <- gets reportStateQuiet-  unless quiet $-    verboseReport (printf "### Successful `%s'!\n" (show loc))-  updateSummary fromSetup (Summary 0 1 0 0)--verboseReport :: String -> Report ()-verboseReport xs = do-  verbose <- gets reportStateVerbose-  quiet <- gets reportStateQuiet-  unless quiet $-    when verbose $-      report xs+reportSuccess :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Report ()+reportSuccess fromSetup = updateSummary fromSetup (Summary 0 1 0 0)  updateSummary :: FromSetup -> Summary -> Report () updateSummary FromSetup summary =   -- Suppress counts, except for errors and unexpected outputs   updateSummary NotFromSetup summary{sExamples=0, sTried=0} updateSummary NotFromSetup summary = do-  ReportState n f v q s <- get-  put (ReportState n f v q $ s `mappend` summary)+  ReportState n f s <- get+  put (ReportState n f $ s `mappend` summary) -reportProgress :: Report ()-reportProgress = do-  verbose <- gets reportStateVerbose-  quiet <- gets reportStateQuiet-  unless quiet $-    unless verbose $-      gets (show . reportStateSummary) >>= report_+reportProgress :: (?verbosity::LogLevel) => Report ()+reportProgress = gets (show . reportStateSummary) >>= report_ Info  -- | Run given test group. --@@ -403,29 +391,28 @@   Bool ->   Interpreter ->   IO () ->-  Chan ReportUpdate ->+  (ReportUpdate -> IO ()) ->   [Located DocTest] ->   IO Bool-runTestGroup fromSetup preserveIt repl setup output tests = do-+runTestGroup fromSetup preserveIt repl setup update tests = do   setup-  successExamples <- runExampleGroup fromSetup preserveIt repl output examples+  successExamples <- runExampleGroup fromSetup preserveIt repl update examples    successesProperties <- forM properties $ \(loc, expression) -> do     r <- do       setup-      writeChan output (UpdateStart loc expression "property")-      runProperty repl expression+      update (UpdateLog Verbose ("Started property at " ++ show loc))+      Property.runProperty repl expression      case r of-      Success -> do-        writeChan output (UpdateSuccess fromSetup loc)+      Property.Success -> do+        update (UpdateSuccess fromSetup)         pure True-      Error err -> do-        writeChan output (UpdateError fromSetup loc expression err)+      Property.Error err -> do+        update (UpdateError fromSetup loc expression err)         pure False-      Failure msg -> do-        writeChan output (UpdateFailure fromSetup loc expression [msg])+      Property.Failure msg -> do+        update (UpdateFailure fromSetup loc expression [msg])         pure False    pure (successExamples && and successesProperties)@@ -442,26 +429,28 @@   FromSetup ->   Bool ->   Interpreter ->-  Chan ReportUpdate ->+  (ReportUpdate -> IO ()) ->   [Located Interaction] ->   IO Bool-runExampleGroup fromSetup preserveIt repl output = go+runExampleGroup fromSetup preserveIt repl update examples = do+  threadId <- myThreadId+  go threadId examples   where-    go ((Located loc (expression, expected)) : xs) = do-      writeChan output (UpdateStart loc expression "example")+    go threadId ((Located loc (expression, expected)) : xs) = do+      update (UpdateLog Verbose ("Started example at " ++ show loc))       r <- fmap lines <$> safeEvalWith preserveIt repl expression       case r of         Left err -> do-          writeChan output (UpdateError fromSetup loc expression err)+          update (UpdateError fromSetup loc expression err)           pure False         Right actual -> case mkResult expected actual of           NotEqual err -> do-            writeChan output (UpdateFailure fromSetup loc expression err)+            update (UpdateFailure fromSetup loc expression err)             pure False           Equal -> do-            writeChan output (UpdateSuccess fromSetup loc)-            go xs-    go [] =+            update (UpdateSuccess fromSetup)+            go threadId xs+    go _ [] =       pure True  safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String)

@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}++module GhciWrapperSpec (main, spec) where++import           Test.Hspec+import           System.IO.Silently++import           Control.Exception+import           Data.List (isInfixOf)++import           Test.DocTest.Internal.GhciWrapper (Interpreter, Config(..), defaultConfig)+import qualified Test.DocTest.Internal.GhciWrapper as Interpreter+import           Test.DocTest.Internal.Logging (noLogger)++main :: IO ()+main = hspec spec++withInterpreterConfig :: Config -> (Interpreter -> IO a) -> IO a+withInterpreterConfig config = bracket (Interpreter.new noLogger config []) Interpreter.close++withInterpreter :: ((String -> IO String) -> IO a) -> IO a+withInterpreter action = withInterpreterConfig defaultConfig $ action . Interpreter.eval++spec :: Spec+spec = do+  describe "evalEcho" $ do+    it "prints result to stdout" $ do+      withInterpreterConfig defaultConfig $ \ghci -> do+        (capture $ Interpreter.evalEcho ghci ("putStr" ++ show "foo\nbar")) `shouldReturn` ("foo\nbar", "foo\nbar")++  describe "evalIt" $ do+    it "preserves it" $ do+      withInterpreterConfig defaultConfig $ \ghci -> do+        Interpreter.evalIt ghci "23" `shouldReturn` "23\n"+        Interpreter.eval ghci "it" `shouldReturn` "23\n"++  describe "eval" $ do+    it "shows literals" $ withInterpreter $ \ghci -> do+      ghci "23" `shouldReturn` "23\n"++    it "shows string literals containing Unicode" $ withInterpreter $ \ghci -> do+      ghci "\"λ\"" `shouldReturn` "\"\\955\"\n"++    it "evaluates simple expressions" $ withInterpreter $ \ghci -> do+      ghci "23 + 42" `shouldReturn` "65\n"++    it "supports let bindings" $ withInterpreter $ \ghci -> do+      ghci "let x = 10" `shouldReturn` ""+      ghci "x" `shouldReturn` "10\n"++    it "allows import statements" $ withInterpreter $ \ghci -> do+      ghci "import Data.Maybe" `shouldReturn` ""+      ghci "fromJust (Just 20)" `shouldReturn` "20\n"++    it "captures stdout" $ withInterpreter $ \ghci -> do+      ghci "putStr \"foo\"" `shouldReturn` "foo"++    it "captures stdout (Unicode)" $ withInterpreter $ \ghci -> do+      ghci "putStrLn \"λ\"" `shouldReturn` "λ\n"++    it "captures stdout (empty line)" $ withInterpreter $ \ghci -> do+      ghci "putStrLn \"\"" `shouldReturn` "\n"++    it "captures stdout (multiple lines)" $ withInterpreter $ \ghci -> do+      ghci "putStrLn \"foo\" >> putStrLn \"bar\" >> putStrLn \"baz\""+        `shouldReturn` "foo\nbar\nbaz\n"++    it "captures stderr" $ withInterpreter $ \ghci -> do+      ghci "import System.IO" `shouldReturn` ""+      ghci "hPutStrLn stderr \"foo\"" `shouldReturn` "foo\n"++    it "captures stderr (Unicode)" $ withInterpreter $ \ghci -> do+      ghci "import System.IO" `shouldReturn` ""+      ghci "hPutStrLn stderr \"λ\"" `shouldReturn` "λ\n"++    it "shows exceptions" $ withInterpreter $ \ghci -> do+      ghci "import Control.Exception" `shouldReturn` ""+      ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n"++    it "shows exceptions (ExitCode)" $ withInterpreter $ \ghci -> do+      ghci "import System.Exit" `shouldReturn` ""+      ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n"++    it "gives an error message for identifiers that are not in scope" $ withInterpreter $ \ghci -> do+#if __GLASGOW_HASKELL__ >= 800+      ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo")+#else+      ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: \8216foo\8217\n")+#endif+    context "when configVerbose is True" $ do+      it "prints prompt" $ do+        withInterpreterConfig defaultConfig{configVerbose = True} $ \ghci -> do+          Interpreter.eval ghci "print 23" >>= (`shouldSatisfy`+            (`elem` [ "Prelude> 23\nPrelude> "+                    ,  "ghci> 23\nghci> "+                    ]))++    context "with -XOverloadedStrings, -Wall and -Werror" $ do+      it "does not fail on marker expression (bug fix)" $ withInterpreter $ \ghci -> do+        ghci ":set -XOverloadedStrings -Wall -Werror" `shouldReturn` ""+        ghci "putStrLn \"foo\"" `shouldReturn` "foo\n"++    context "with NoImplicitPrelude" $ do+      it "works" $ withInterpreter $ \ghci -> do+        ghci ":set -XNoImplicitPrelude" `shouldReturn` ""+        ghci "putStrLn \"foo\"" `shouldReturn` "foo\n"++    context "with a strange String type" $ do+      it "works" $ withInterpreter $ \ghci -> do+        ghci "type String = Int" `shouldReturn` ""+        ghci "putStrLn \"foo\"" `shouldReturn` "foo\n"

@@ -8,6 +8,7 @@ import qualified Test.DocTest.Internal.Interpreter as Interpreter import           Test.DocTest.Internal.Interpreter   (haveInterpreterKey, ghcInfo, withInterpreter)+import           Test.DocTest.Internal.Logging (noLogger)  main :: IO () main = hspec spec@@ -25,8 +26,8 @@         (||) <$> (== Just "YES") <*> (== Just "NO")    describe "safeEval" $ do-    it "evaluates an expression" $ withInterpreter [] $ \ghci -> do+    it "evaluates an expression" $ withInterpreter noLogger [] $ \ghci -> do       Interpreter.safeEval ghci "23 + 42" `shouldReturn` Right "65\n" -    it "returns Left on unterminated multiline command" $ withInterpreter [] $ \ghci -> do+    it "returns Left on unterminated multiline command" $ withInterpreter noLogger [] $ \ghci -> do       Interpreter.safeEval ghci ":{\n23 + 42" `shouldReturn` Left "unterminated multiline command"

@@ -6,6 +6,7 @@ import           Test.Hspec  import           Test.DocTest.Internal.Options+import Test.DocTest.Internal.Logging (LogLevel(..))  spec :: Spec spec = do@@ -57,8 +58,8 @@     describe "--verbose" $ do       context "without --verbose" $ do         it "is not verbose by default" $ do-          cfgVerbose <$> parseOptions [] `shouldBe` Result False+          cfgLogLevel <$> parseOptions [] `shouldBe` Result Info        context "with --verbose" $ do         it "parses verbose option" $ do-          cfgVerbose <$> parseOptions ["--verbose"] `shouldBe` Result True+          cfgLogLevel <$> parseOptions ["--verbose"] `shouldBe` Result Verbose

@@ -1,11 +1,12 @@ {-# LANGUAGE CPP, OverloadedStrings #-} module PropertySpec (main, spec) where -import           Test.Hspec-import           Data.String.Builder+import Test.Hspec+import Data.String.Builder -import           Test.DocTest.Internal.Property-import           Test.DocTest.Internal.Interpreter (withInterpreter)+import Test.DocTest.Internal.Property+import Test.DocTest.Internal.Interpreter (withInterpreter)+import Test.DocTest.Internal.Logging (noLogger)  main :: IO () main = hspec spec@@ -17,54 +18,54 @@ spec :: Spec spec = do   describe "runProperty" $ do-    it "reports a failing property" $ withInterpreter [] $ \repl -> do+    it "reports a failing property" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "False" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):" -    it "runs a Bool property" $ withInterpreter [] $ \repl -> do+    it "runs a Bool property" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "True" `shouldReturn` Success -    it "runs a Bool property with an explicit type signature" $ withInterpreter [] $ \repl -> do+    it "runs a Bool property with an explicit type signature" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "True :: Bool" `shouldReturn` Success -    it "runs an implicitly quantified property" $ withInterpreter [] $ \repl -> do+    it "runs an implicitly quantified property" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "(reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success      it "runs an implicitly quantified property even with GHC 7.4" $       -- ghc will include a suggestion (did you mean `id` instead of `is`) in       -- the error message-      withInterpreter [] $ \repl -> do+      withInterpreter noLogger [] $ \repl -> do         runProperty repl "foldr (+) 0 is == sum (is :: [Int])" `shouldReturn` Success -    it "runs an explicitly quantified property" $ withInterpreter [] $ \repl -> do+    it "runs an explicitly quantified property" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "\\xs -> (reverse . reverse) xs == (xs :: [Int])" `shouldReturn` Success -    it "allows to mix implicit and explicit quantification" $ withInterpreter [] $ \repl -> do+    it "allows to mix implicit and explicit quantification" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "\\x -> x + y == y + x" `shouldReturn` Success -    it "reports the value for which a property fails" $ withInterpreter [] $ \repl -> do+    it "reports the value for which a property fails" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "x == 23" `shouldReturn` Failure "*** Failed! Falsified (after 1 test):\n0" -    it "reports the values for which a property that takes multiple arguments fails" $ withInterpreter [] $ \repl -> do+    it "reports the values for which a property that takes multiple arguments fails" $ withInterpreter noLogger [] $ \repl -> do       let vals x = case x of (Failure r) -> tail (lines r); _ -> error "Property did not fail!"       vals `fmap` runProperty repl "x == True && y == 10 && z == \"foo\"" `shouldReturn` ["False", "0", show ("" :: String)] -    it "defaults ambiguous type variables to Integer" $ withInterpreter [] $ \repl -> do+    it "defaults ambiguous type variables to Integer" $ withInterpreter noLogger [] $ \repl -> do       runProperty repl "reverse xs == xs" >>= (`shouldSatisfy` isFailure)    describe "freeVariables" $ do-    it "finds a free variables in a term" $ withInterpreter [] $ \repl -> do+    it "finds a free variables in a term" $ withInterpreter noLogger [] $ \repl -> do       freeVariables repl "x" `shouldReturn` ["x"] -    it "ignores duplicates" $ withInterpreter [] $ \repl -> do+    it "ignores duplicates" $ withInterpreter noLogger [] $ \repl -> do       freeVariables repl "x == x" `shouldReturn` ["x"] -    it "works for terms with multiple names" $ withInterpreter [] $ \repl -> do+    it "works for terms with multiple names" $ withInterpreter noLogger [] $ \repl -> do       freeVariables repl "\\z -> x + y + z == foo 23" `shouldReturn` ["x", "y", "foo"] -    it "works for names that contain a prime" $ withInterpreter [] $ \repl -> do+    it "works for names that contain a prime" $ withInterpreter noLogger [] $ \repl -> do       freeVariables repl "x' == y''" `shouldReturn` ["x'", "y''"] -    it "works for names that are similar to other names that are in scope" $ withInterpreter [] $ \repl -> do+    it "works for names that are similar to other names that are in scope" $ withInterpreter noLogger [] $ \repl -> do       freeVariables repl "length_" `shouldReturn` ["length_"]    describe "parseNotInScope" $ do

@@ -1,25 +1,31 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams #-} module RunnerSpec (main, spec) where -import           Test.Hspec+import Test.Hspec -import           System.IO-import           System.IO.Silently (hCapture)-import           Control.Monad.Trans.State-import           Test.DocTest.Internal.Runner+import Control.Concurrent+import Control.Monad.Trans.State+import System.IO+import System.IO.Silently (hCapture)+import Test.DocTest.Internal.Logging+import Test.DocTest.Internal.Runner+import Text.Printf (printf)  main :: IO () main = hspec spec  capture :: Report a -> IO String-capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True False False mempty)+capture = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 True mempty)  -- like capture, but with interactivity set to False capture_ :: Report a -> IO String-capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False False False mempty)+capture_ = fmap fst . hCapture [stderr] . (`execStateT` ReportState 0 False mempty)  spec :: Spec spec = do+  threadId <- runIO myThreadId+  let ?threadId = threadId+  let ?verbosity = Info    describe "report" $ do @@ -27,61 +33,61 @@        it "writes to stderr" $ do         capture $ do-          report "foobar"-        `shouldReturn` "foobar\n"+          report Info "foobar"+        `shouldReturn` printf "[INFO   ] [%s] foobar\n" (show threadId)        it "overwrites any intermediate output" $ do         capture $ do-          report_ "foo"-          report  "bar"-        `shouldReturn` "foo\rbar\n"+          report_ Info "foo"+          report Info  "bar"+        `shouldReturn` printf "foo\r[INFO   ] [%s] bar\n" (show threadId)        it "blank out intermediate output if necessary" $ do         capture $ do-          report_ "foobar"-          report  "baz"-        `shouldReturn` "foobar\rbaz   \n"+          report_ Info "foobarrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr"+          report Info  "baz"+        `shouldReturn` printf "foobarrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr\r[INFO   ] [%s] baz             \n" (show threadId)      context "when mode is non-interactive" $ do       it "writes to stderr" $ do         capture_ $ do-          report "foobar"-        `shouldReturn` "foobar\n"+          report Info "foobar"+        `shouldReturn` printf "[INFO   ] [%s] foobar\n" (show threadId) -  describe "report_" $ do+  describe "report_ Info" $ do      context "when mode is interactive" $ do       it "writes intermediate output to stderr" $ do         capture $ do-          report_ "foobar"+          report_ Info "foobar"         `shouldReturn` "foobar"        it "overwrites any intermediate output" $ do         capture $ do-          report_ "foo"-          report_ "bar"+          report_ Info "foo"+          report_ Info "bar"         `shouldReturn` "foo\rbar"        it "blank out intermediate output if necessary" $ do         capture $ do-          report_ "foobar"-          report_  "baz"+          report_ Info "foobar"+          report_ Info  "baz"         `shouldReturn` "foobar\rbaz   "      context "when mode is non-interactive" $ do       it "is ignored" $ do         capture_ $ do-          report_ "foobar"+          report_ Info "foobar"         `shouldReturn` "" -      it "does not influence a subsequent call to `report`" $ do+      it "does not influence a subsequent call to `report Info`" $ do         capture_ $ do-          report_ "foo"-          report  "bar"-        `shouldReturn` "bar\n"+          report_ Info "foo"+          report Info  "bar"+        `shouldReturn` printf "[INFO   ] [%s] bar\n" (show threadId) -      it "does not require `report` to blank out any intermediate output" $ do+      it "does not require `report Info` to blank out any intermediate output" $ do         capture_ $ do-          report_ "foobar"-          report  "baz"-        `shouldReturn` "baz\n"+          report_ Info "foobar"+          report Info  "baz"+        `shouldReturn` printf "[INFO   ] [%s] baz\n" (show threadId)

@@ -1,1 +1,32 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where++import Test.Hspec++import qualified ExtractSpec+import qualified GhciWrapperSpec+import qualified InterpreterSpec+import qualified LocationSpec+import qualified MainSpec+import qualified OptionsSpec+import qualified ParseSpec+import qualified PropertySpec+import qualified RunnerSpec+import qualified RunSpec+import qualified UtilSpec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "ExtractSpec"     ExtractSpec.spec+  describe "GhciWrapperSpec" GhciWrapperSpec.spec+  describe "InterpreterSpec" InterpreterSpec.spec+  describe "LocationSpec"    LocationSpec.spec+  describe "MainSpec"        MainSpec.spec+  describe "OptionsSpec"     OptionsSpec.spec+  describe "ParseSpec"       ParseSpec.spec+  describe "PropertySpec"    PropertySpec.spec+  describe "RunnerSpec"      RunnerSpec.spec+  describe "RunSpec"         RunSpec.spec+  describe "UtilSpec"        UtilSpec.spec