doctest-parallel 0.3.1.1 → 0.4

raw patch · 25 files changed

+445/−451 lines, 25 filesdep +ghc-exactprintdep ~Cabaldep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-exactprint

Dependency ranges changed: Cabal, ghc

API changes (from Hackage documentation)

Files

• CHANGES.markdown +7/−0
• cabal.project +2/−7
• doctest-parallel.cabal +11/−12
• src/Data/List/Extra.hs +19/−1
• src/Test/DocTest.hs +7/−18
• src/Test/DocTest/Helpers.hs +38/−12
• src/Test/DocTest/Internal/Extract.hs +125/−155
• src/Test/DocTest/Internal/GhcUtil.hs +5/−26
• src/Test/DocTest/Internal/GhciWrapper.hs +0/−7
• src/Test/DocTest/Internal/Interpreter.hs +0/−2
• src/Test/DocTest/Internal/Location.hs +1/−13
• src/Test/DocTest/Internal/Logging.hs +22/−11
• src/Test/DocTest/Internal/Nix.hs +0/−15
• src/Test/DocTest/Internal/Options.hs +0/−5
• src/Test/DocTest/Internal/Parse.hs +9/−11
• src/Test/DocTest/Internal/Property.hs +0/−1
• src/Test/DocTest/Internal/Runner.hs +123/−91
• test/ExtractSpec.hs +30/−36
• test/GhciWrapperSpec.hs +3/−8
• test/LocationSpec.hs +0/−7
• test/MainSpec.hs +1/−2
• test/ParseSpec.hs +11/−10
• test/ProjectsSpec.hs +29/−0
• test/RunSpec.hs +0/−1
• test/Spec.hs +2/−0

@@ -1,4 +1,11 @@+# 0.4+ * Account for `default-language` sections in Cabal files ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/85))+ * Add support for Cabal 3.14 ([#88](https://github.com/martijnbastiaan/doctest-parallel/pull/88))+ * Add parallel parsing on Linux/macOS. The GHC API is now used to call the parser directly, which allows parallel parsing. On Windows, files will be parsed sequentially still due to the GHC API locking files. ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/89))+ * Drop support for GHC < 9+ # 0.3.1.1+ * Add support for GHC 9.12 (loosened bounds in Hackage revision)  * Add support for GHC 9.10  # 0.3.1

@@ -5,10 +5,5 @@  tests: true -source-repository-package-  type: git-  location: https://github.com/haskell-unordered-containers/unordered-containers.git-  tag: d52a0fd10bfa701cbbc9d7ac06bd7eb7664b3972--allow-newer:-  unordered-containers:template-haskell+package doctest-parallel+  ghc-options: +RTS -qn4 -A128M -RTS -j4

@@ -1,7 +1,7 @@ cabal-version: 2.0  name:           doctest-parallel-version:        0.3.1.1+version:        0.4 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>).@@ -17,16 +17,13 @@ maintainer:     Martijn Bastiaan <martijn@hmbastiaan.nl> build-type:     Simple tested-with:-    GHC == 8.4.4-  , GHC == 8.6.5-  , GHC == 8.8.4-  , GHC == 8.10.7-  , GHC == 9.0.2+    GHC == 9.0.2   , GHC == 9.2.8-  , GHC == 9.4.7-  , GHC == 9.6.3-  , GHC == 9.8.1-  , GHC == 9.10.1+  , GHC == 9.4.8+  , GHC == 9.6.7+  , GHC == 9.8.4+  , GHC == 9.10.2+  , GHC == 9.12.2  extra-source-files:     example/example.cabal@@ -93,7 +90,7 @@       Data.List.Extra       Paths_doctest_parallel   build-depends:-      Cabal >= 2.4 && < 3.11+      Cabal >= 2.4 && < 3.15     , Glob     , base >=4.10 && <5     , base-compat >=0.7.0@@ -103,7 +100,8 @@     , directory     , exceptions     , filepath-    , ghc >=8.2 && <9.11+    , ghc >=9.0 && <9.13+    , ghc-exactprint     , ghc-paths >=0.1.0.9     , process     , random >= 1.2@@ -186,6 +184,7 @@       MainSpec       OptionsSpec       ParseSpec+      ProjectsSpec       PropertySpec       Runner.ExampleSpec       RunnerSpec

@@ -1,4 +1,4 @@-module Data.List.Extra (trim) where+module Data.List.Extra (trim, splitOn) where  import Data.Char (isSpace) import Data.List (dropWhileEnd)@@ -19,3 +19,21 @@ -- | Remove spaces from the end of a string, see 'trim'. trimEnd :: String -> String trimEnd = dropWhileEnd isSpace++-- TODO: Use doctests after fixing: https://github.com/martijnbastiaan/doctest-parallel/issues/87++-- | Break a list into pieces separated by the first argument, consuming the delimiter.+--+-- > splitOn '.' "A.B"+-- ["A","B"]+-- > splitOn '.' "A.B.C"+-- ["A","B","C"]+-- > splitOn '.' "."+-- ["",""]+-- > splitOn '.' ""+-- [""]+splitOn :: Eq a => a -> [a] -> [[a]]+splitOn needle haystack =+  case break (== needle) haystack of+    (chunk, []) -> [chunk]+    (chunk, _ : rest) -> chunk : splitOn needle rest

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}@@ -31,13 +30,8 @@  import qualified Control.Exception as E -#if __GLASGOW_HASKELL__ < 900-import Panic-#else import GHC.Utils.Panic-#endif -import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Options import Test.DocTest.Internal.Runner import Test.DocTest.Internal.Nix (getNixGhciArgs)@@ -110,17 +104,17 @@ -- | Filter modules to be tested against a list of modules to be tested (specified -- by the user on the command line). If list is empty, test all modules. Throws -- and error if a non-existing module was specified.-filterModules :: [ModuleName] -> [Module a] -> [Module a]+filterModules :: [ModuleName] -> [ModuleName] -> [ModuleName] filterModules [] mods = mods filterModules wantedMods0 allMods0   | (_:_) <- nonExistingMods = error ("Unknown modules specified: " <> show nonExistingMods)   | otherwise = filter isSpecifiedMod allMods0  where   wantedMods1 = Set.fromList wantedMods0-  allMods1 = Set.fromList (map moduleName allMods0)+  allMods1 = Set.fromList allMods0    nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1)-  isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1+  isSpecifiedMod nm = nm `Set.member` wantedMods1  setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig setSeed cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do@@ -137,24 +131,19 @@    let     implicitPrelude = DisableExtension ImplicitPrelude `notElem` libDefaultExtensions lib-    (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib+    (includeArgs, allModules, otherGhciArgs) = libraryToGhciArgs lib     evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"] ++ nixGhciArgs-    parseGhcArgs = includeArgs ++ moduleArgs ++ otherGhciArgs ++ nixGhciArgs ++ cfgGhcArgs+    parseGhcArgs = includeArgs ++ otherGhciArgs ++ nixGhciArgs ++ cfgGhcArgs    let     ?verbosity = cfgLogLevel    modConfig <- setSeed cfgModuleConfig -  -- Get examples from Haddock comments-  Logging.log Verbose "Parsing comments.."-  Logging.log Debug ("Calling GHC API with: " <> unwords parseGhcArgs)-  allModules <- getDocTests parseGhcArgs-   -- Run tests   Logging.log Verbose "Running examples.."   let     filteredModules = filterModules cfgModules allModules-    filteredModulesMsg = intercalate ", " (map moduleName filteredModules)+    filteredModulesMsg = intercalate ", " filteredModules   Logging.log Debug ("Running examples in modules: " <> filteredModulesMsg)-  runModules modConfig cfgThreads implicitPrelude evalGhciArgs filteredModules+  runModules modConfig cfgThreads implicitPrelude parseGhcArgs evalGhciArgs filteredModules

@@ -9,27 +9,25 @@  import GHC.Stack (HasCallStack) +import Data.Maybe (maybeToList) import System.Directory   ( canonicalizePath, doesFileExist ) import System.FilePath ((</>), isDrive, takeDirectory) import System.FilePath.Glob (glob) import System.Info (compilerVersion) -#if __GLASGOW_HASKELL__ < 804-import Data.Monoid ((<>))-#endif- import qualified Data.Set as Set  -- Cabal import Distribution.ModuleName (ModuleName) import Distribution.Simple-  ( Extension (DisableExtension, EnableExtension, UnknownExtension) )+  ( Extension (DisableExtension, EnableExtension, UnknownExtension), Language (..) ) import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.PackageDescription   ( GenericPackageDescription (condLibrary)   , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package-  , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..) )+  , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..)+  , defaultLanguage, BuildInfo (otherModules) )  import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Pretty (prettyShow)@@ -46,7 +44,9 @@ import Distribution.PackageDescription.Parsec (readGenericPackageDescription) #endif -#if MIN_VERSION_Cabal(3,6,0)+#if MIN_VERSION_Cabal(3,14,0)+import Distribution.Utils.Path (SymbolicPath, makeSymbolicPath)+#elif MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath) #endif @@ -69,27 +69,36 @@     -- ^ Exposed modules   , libDefaultExtensions :: [Extension]     -- ^ Extensions enabled by default+  , libDefaultLanguages :: [Language]+    -- ^ Language version(s) to enable   }   deriving (Show)  -- | Merge multiple libraries into one, by concatenating all their fields. mergeLibraries :: [Library] -> Library mergeLibraries libs = Library+  -- XXX: Why do we merge libraries? Shouldn't we always aim to parse ONE library?   { libSourceDirectories = concatMap libSourceDirectories libs   , libCSourceDirectories = concatMap libCSourceDirectories libs   , libModules = concatMap libModules libs   , libDefaultExtensions = concatMap libDefaultExtensions libs+  , libDefaultLanguages = concatMap libDefaultLanguages libs   }  -- | Convert a "Library" to arguments suitable to be passed to GHCi. libraryToGhciArgs :: Library -> ([String], [String], [String])-libraryToGhciArgs Library{..} = (hsSrcArgs <> cSrcArgs, modArgs, extArgs)+libraryToGhciArgs Library{..} = (hsSrcArgs <> cSrcArgs, modArgs, extArgs <> langArgs)  where   hsSrcArgs = map ("-i" <>) libSourceDirectories   cSrcArgs = map ("-I" <>) libCSourceDirectories   modArgs = map prettyShow libModules   extArgs = map showExt libDefaultExtensions+  langArgs = map showLanguage libDefaultLanguages +  showLanguage = \case+    UnknownLanguage ul -> "-X" <> ul+    l -> "-X" <> show l+   showExt = \case     EnableExtension ext -> "-X" <> show ext     DisableExtension ext -> "-XNo" <> show ext@@ -145,7 +154,10 @@   packageFilename = packageName <> ".cabal"   projectFilename = "cabal.project" -#if MIN_VERSION_Cabal(3,6,0)+#if MIN_VERSION_Cabal(3,14,0)+compatPrettyShow :: SymbolicPath a b -> FilePath+compatPrettyShow = prettyShow+#elif MIN_VERSION_Cabal(3,6,0) compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath compatPrettyShow = prettyShow #else@@ -199,7 +211,15 @@ -- a specific sublibrary. extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library extractSpecificCabalLibrary maybeLibName pkgPath = do-  pkg <- readGenericPackageDescription silent pkgPath+  pkg <-+    readGenericPackageDescription+      silent+#if MIN_VERSION_Cabal(3,14,0)+      Nothing+      (makeSymbolicPath pkgPath)+#else+      pkgPath+#endif   case maybeLibName of     Nothing ->       case condLibrary pkg of@@ -227,11 +247,17 @@    goLib lib = Library     { libSourceDirectories = map ((root </>) . compatPrettyShow) sourceDirs-    , libCSourceDirectories = map (root </>) cSourceDirs-    , libModules = exposedModules lib `rmList` autogenModules buildInfo+    , libCSourceDirectories = map ((root </>))+#if MIN_VERSION_Cabal(3,14,0)+      $ map compatPrettyShow+#endif+      cSourceDirs+    , libModules = modules `rmList` autogenModules buildInfo     , libDefaultExtensions = defaultExtensions buildInfo+    , libDefaultLanguages = maybeToList (defaultLanguage buildInfo)     }    where+    modules = otherModules buildInfo <> exposedModules lib     buildInfo = libBuildInfo lib     sourceDirs = hsSourceDirs buildInfo     cSourceDirs = includeDirs buildInfo

@@ -8,46 +8,36 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -module Test.DocTest.Internal.Extract (Module(..), extract, eraseConfigLocation) where-+module Test.DocTest.Internal.Extract+  ( Module(..)+  , isEmptyModule+  , extract+  , extractIO+  , eraseConfigLocation+  ) where import           Prelude hiding (mod, concat)+import           Control.DeepSeq (NFData, deepseq)+import           Control.Exception (AsyncException, throw, throwIO, fromException) import           Control.Monad-import           Control.Exception+import           Control.Monad.Catch (catches, SomeException, Exception, Handler (Handler))+import           Data.Generics (Data, extQ, mkQ, everythingBut) import           Data.List (partition, isPrefixOf)-import           Data.List.Extra (trim)+import           Data.List.Extra (trim, splitOn) import           Data.Maybe--import           Control.DeepSeq (NFData, deepseq)-import           Data.Generics (Data, Typeable, extQ, mkQ, everythingBut)+import           GHC.Generics (Generic) -import qualified GHC+#if __GLASGOW_HASKELL__ < 912+import           Data.Generics (Typeable)+#endif -#if __GLASGOW_HASKELL__ < 900-import           GHC hiding (Module, Located, moduleName)-import           DynFlags-import           MonadUtils (liftIO)-#else-import           GHC hiding (Module, Located, moduleName)+import           GHC hiding (Module, Located, moduleName, parsedSource) import           GHC.Driver.Session import           GHC.Utils.Monad (liftIO)-#endif -#if __GLASGOW_HASKELL__ < 900-import           Digraph (flattenSCCs)-import           Exception (ExceptionMonad)-#else-import           GHC.Data.Graph.Directed (flattenSCCs)-import           GHC.Utils.Exception (ExceptionMonad)-import           Control.Monad.Catch (generalBracket)-#endif- import           System.Directory import           System.FilePath -#if __GLASGOW_HASKELL__ < 900-import           BasicTypes (SourceText(SourceText))-import           FastString (unpackFS)-#elif __GLASGOW_HASKELL__ < 902+#if __GLASGOW_HASKELL__ < 902 import           GHC.Data.FastString (unpackFS) import           GHC.Types.Basic (SourceText(SourceText)) #elif __GLASGOW_HASKELL__ < 906@@ -57,30 +47,39 @@ import           GHC.Data.FastString (unpackFS) #endif -import           System.Posix.Internals (c_getpid)- import           Test.DocTest.Internal.GhcUtil (withGhc) import           Test.DocTest.Internal.Location hiding (unLoc) import           Test.DocTest.Internal.Util (convertDosLineEndings) -#if __GLASGOW_HASKELL__ >= 806-#if __GLASGOW_HASKELL__ < 900-import           DynamicLoading (initializePlugins)+#if MIN_VERSION_ghc_exactprint(1,3,0)+import           Language.Haskell.GHC.ExactPrint.Parsers (parseModuleEpAnnsWithCppInternal, defaultCppOptions) #else-import           GHC.Runtime.Loader (initializePlugins)-#endif+import           Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCppInternal, defaultCppOptions) #endif -#if __GLASGOW_HASKELL__ >= 901-import           GHC.Unit.Module.Graph+#if __GLASGOW_HASKELL__ < 902+import           GHC.Driver.Types (throwErrors)+import           GHC.Parser.Header (getOptionsFromFile)+#elif __GLASGOW_HASKELL__ < 904+import           GHC.Types.SourceError (throwErrors)+import           GHC.Parser.Header (getOptionsFromFile)+#else+import           GHC.Types.SourceError (throwErrors)+import           GHC.Parser.Header (getOptionsFromFile)+import           GHC.Driver.Config.Parser (initParserOpts) #endif -import           GHC.Generics (Generic)+#if __GLASGOW_HASKELL__ < 904+initParserOpts :: DynFlags -> DynFlags+initParserOpts = id+#endif   -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException+#if __GLASGOW_HASKELL__ < 912   deriving Typeable+#endif  instance Show ExtractError where   show (ExtractError e) =@@ -100,6 +99,24 @@  instance Exception ExtractError +data ModuleNotFoundError = ModuleNotFoundError String [FilePath]+  deriving (+#if __GLASGOW_HASKELL__ < 912+    Typeable,+#endif+    Exception+  )++instance Show ModuleNotFoundError where+  show (ModuleNotFoundError modName incdirs) =+    unlines [+        "Module not found: " ++ modName+      , ""+      , "Tried the following include directories:"+      , ""+      , unlines incdirs+      ]+ -- | Documentation for a module grouped together with the modules name. data Module a = Module {   moduleName    :: String@@ -108,117 +125,100 @@ , moduleConfig  :: [Located String] } deriving (Eq, Functor, Show, Generic, NFData) +isEmptyModule :: Module a -> Bool+isEmptyModule (Module _ setup tests _) = null tests && isNothing setup+ eraseConfigLocation :: Module a -> Module a eraseConfigLocation m@Module{moduleConfig} =   m{moduleConfig=map go moduleConfig}  where   go (Located _ a) = noLocation a -#if __GLASGOW_HASKELL__ < 803-type GhcPs = RdrName-#endif--#if __GLASGOW_HASKELL__ < 805-addQuoteInclude :: [String] -> [String] -> [String]-addQuoteInclude includes new = new ++ includes-#endif+moduleParts :: String -> [String]+moduleParts = splitOn '.' --- | Parse a list of modules.-parse :: [String] -> IO [ParsedModule]-parse args = withGhc args $ \modules -> withTempOutputDir $ do-  setTargets =<< forM modules (\ m -> guessTarget m-#if __GLASGOW_HASKELL__ >= 903-                Nothing-#endif-                Nothing)-  mods <- depanal [] False+findModulePath :: [FilePath] -> String -> IO FilePath+findModulePath importPaths modName = do+  let+    modPath = foldl1 (</>) (moduleParts modName) <.> "hs" -  let sortedMods = flattenSCCs-#if __GLASGOW_HASKELL__ >= 901-                     $ filterToposortToModules-#endif-                     $ topSortModuleGraph False mods Nothing-  reverse <$> mapM (loadModPlugins >=> parseModule) sortedMods+  found <- fmap catMaybes $ forM importPaths $ \importPath -> do+    let fullPath = importPath </> modPath+    exists <- doesFileExist fullPath+    return $ if exists then Just fullPath else Nothing -  where-    -- copied from Haddock/GhcUtils.hs-    modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()-    modifySessionDynFlags f = do-      dflags <- getSessionDynFlags-      let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of-            Just "YES" -> gopt_set dflags Opt_BuildDynamicToo-            _          -> dflags-      _ <- setSessionDynFlags (f dflags')-      return ()+  case found of+    [] -> throwIO (ModuleNotFoundError modName importPaths)+    (p:_) -> pure p -    withTempOutputDir :: Ghc a -> Ghc a-    withTempOutputDir action = do-      tmp <- liftIO getTemporaryDirectory-      x   <- liftIO c_getpid-      let dir = tmp </> ".doctest-" ++ show x-      modifySessionDynFlags (setOutputDir dir)-      gbracket_-        (liftIO $ createDirectory dir)-        (liftIO $ removeDirectoryRecursive dir)-        action+-- | Parse a list of modules. Can throw an `ModuleNotFoundError` if a module's+-- source file cannot be found. Can throw a `SourceError` if an error occurs+-- while parsing.+parse :: String -> Ghc ParsedSource+parse modName = do+  -- Find all specified modules on disk+  importPaths0 <- importPaths <$> getDynFlags+  path <- liftIO $ findModulePath importPaths0 modName -    -- | A variant of 'gbracket' where the return value from the first computation-    -- is not required.-    gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c-#if __GLASGOW_HASKELL__ < 900-    gbracket_ before_ after thing = gbracket before_ (const after) (const thing)+  -- LANGUAGE pragmas can influence how a file is parsed. For example, CPP+  -- means we need to preprocess the file before parsing it. We use GHC's+  -- `getOptionsFromFile` to parse these pragmas and then feed them as options+  -- to the "real" parser.+  dynFlags0 <- getDynFlags+#if __GLASGOW_HASKELL__ < 904+  flagsFromFile <- #else-    gbracket_ before_ after thing = fst <$> generalBracket before_ (\ _ _ -> after) (const thing)+  (_, flagsFromFile) <- #endif--    setOutputDir f d = d {-        objectDir  = Just f-      , hiDir      = Just f-      , stubDir    = Just f-      , includePaths = addQuoteInclude (includePaths d) [f]-      }-+    liftIO $ getOptionsFromFile (initParserOpts dynFlags0) path+  (dynFlags1, _, _) <- parseDynamicFilePragma dynFlags0 flagsFromFile -#if __GLASGOW_HASKELL__ >= 806-    -- Since GHC 8.6, plugins are initialized on a per module basis-    loadModPlugins modsum = do-      _ <- setSessionDynFlags (GHC.ms_hspp_opts modsum)-      hsc_env <- getSession+#if MIN_VERSION_ghc_exactprint(1,3,0)+  result <- parseModuleEpAnnsWithCppInternal defaultCppOptions dynFlags1 path+#else+  result <- parseModuleApiAnnsWithCppInternal defaultCppOptions dynFlags1 path+#endif -# if __GLASGOW_HASKELL__ >= 901-      hsc_env' <- liftIO (initializePlugins hsc_env)-      setSession hsc_env'-      return $ modsum-# else-      dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum))-      return $ modsum { ms_hspp_opts = dynflags' }-# endif+  case result of+    Left errs -> throwErrors errs+#if MIN_VERSION_ghc_exactprint(1,3,0)+    Right (_cppComments, _dynFlags, parsedSource) -> pure parsedSource #else-    loadModPlugins = return+    Right (_apiAnns, _cppComments, _dynFlags, parsedSource) -> pure parsedSource #endif +-- | Like `extract`, but runs in the `IO` monad given GHC parse arguments.+extractIO :: [String] -> String -> IO (Module (Located String))+extractIO parseArgs modName = withGhc parseArgs $ extract modName+ -- | Extract all docstrings from given list of files/modules. -- -- This includes the docstrings of all local modules that are imported from -- those modules (possibly indirect).-extract :: [String] -> IO [Module (Located String)]-extract args = do-  mods <- parse args-  let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule) mods+--+-- Can throw `ExtractError` if an error occurs while extracting the docstrings,+-- or a `SourceError` if an error occurs while parsing the module. Can throw a+-- `ModuleNotFoundError` if a module's source file cannot be found.+extract :: String -> Ghc (Module (Located String))+extract modName = do+  mod <- parse modName+  let+    docs0 = extractFromModule modName mod+    docs1 = fmap convertDosLineEndings <$> docs0 -  (docs `deepseq` return docs) `catches` [+  (docs1 `deepseq` return docs1) `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 operation.       Handler (\e -> throw (e :: AsyncException))-    , Handler (throwIO . ExtractError)+    , Handler (liftIO . throwIO . ExtractError)     ]  -- | Extract all docstrings from given module and attach the modules name.-extractFromModule :: ParsedModule -> Module (Located String)-extractFromModule m = Module-  { moduleName = name+extractFromModule :: String -> ParsedSource -> Module (Located String)+extractFromModule modName m = Module+  { moduleName = modName   , moduleSetup = listToMaybe (map snd setup)   , moduleContent = map snd docs   , moduleConfig = moduleAnnsFromModule m@@ -226,10 +226,9 @@  where   isSetup = (== Just "setup") . fst   (setup, docs) = partition isSetup (docStringsFromModule m)-  name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m  -- | Extract all module annotations from given module.-moduleAnnsFromModule :: ParsedModule -> [Located String]+moduleAnnsFromModule :: ParsedSource -> [Located String] moduleAnnsFromModule mod =   [fmap stripOptionString ann | ann <- anns, isOption ann]  where@@ -237,10 +236,10 @@   isOption (Located _ s) = optionPrefix `isPrefixOf` s   stripOptionString s = trim (drop (length optionPrefix) s)   anns = extractModuleAnns source-  source = (unLoc . pm_parsed_source) mod+  source = unLoc mod  -- | Extract all docstrings from given module.-docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]+docStringsFromModule :: ParsedSource -> [(Maybe String, Located String)] docStringsFromModule mod = #if __GLASGOW_HASKELL__ < 904   map (fmap (toLocated . fmap unpackHDS)) docs@@ -248,7 +247,7 @@   map (fmap (toLocated . fmap renderHsDocString)) docs #endif  where-  source = (unLoc . pm_parsed_source) mod+  source = unLoc mod    -- we use dlist-style concatenation here   docs :: [(Maybe String, LHsDocString)]@@ -268,11 +267,7 @@    exports :: [(Maybe String, LHsDocString)]   exports = [ (Nothing, L (locA loc) doc)-#if __GLASGOW_HASKELL__ < 710-            | L loc (IEDoc doc) <- concat (hsmodExports source)-#elif __GLASGOW_HASKELL__ < 805-            | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)-#elif __GLASGOW_HASKELL__ < 904+#if __GLASGOW_HASKELL__ < 904             | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) #else             | L loc (IEDoc _ (unLoc . fmap hsDocString -> doc)) <- maybe [] unLoc (hsmodExports source)@@ -303,9 +298,7 @@  where   fromLHsDecl :: AnnSelector (LHsDecl GhcPs)   fromLHsDecl (L (locA -> loc) decl) = case decl of-#if __GLASGOW_HASKELL__ < 805-    AnnD (HsAnnotation (SourceText _) ModuleAnnProvenance (L _loc expr))-#elif __GLASGOW_HASKELL__ < 906+#if __GLASGOW_HASKELL__ < 906     AnnD _ (HsAnnotation _ (SourceText _) ModuleAnnProvenance (L _loc expr)) #else     AnnD _ (HsAnnotation _ ModuleAnnProvenance (L _loc expr))@@ -320,13 +313,6 @@ extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String) extractLit loc = \case   -- well this is a holy mess innit-#if __GLASGOW_HASKELL__ < 805-  HsPar (L l e) -> extractLit l e-  ExprWithTySig (L l e) _ -> extractLit l e-  HsOverLit OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s)))-  HsLit (HsString _ s) -> Just (toLocated (L loc (unpackFS s)))-  _ -> Nothing-#else #if __GLASGOW_HASKELL__ < 904   HsPar _ (L l e) -> extractLit (locA l) e #elif __GLASGOW_HASKELL__ < 909@@ -334,15 +320,10 @@ #else   HsPar _ (L l e) -> extractLit (locA l) e #endif-#if __GLASGOW_HASKELL__ < 807-  ExprWithTySig _ (L l e) -> extractLit l e-#else   ExprWithTySig _ (L l e) _ -> extractLit (locA l) e-#endif   HsOverLit _ OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s)))   HsLit _ (HsString _ s) -> Just (toLocated (L loc (unpackFS s)))   _ -> Nothing-#endif  -- | Extract all docstrings from given value. extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs] -> [(Maybe String, LHsDocString)]@@ -364,12 +345,7 @@       -- Top-level documentation has to be treated separately, because it has       -- no location information attached.  The location information is       -- attached to HsDecl instead.-#if __GLASGOW_HASKELL__ < 805-      DocD x-#else-      DocD _ x-#endif-           -> select (fromDocDecl (locA loc) x)+      DocD _ x -> select (fromDocDecl (locA loc) x)        _ -> (extractDocStrings (Left decl), True) @@ -404,12 +380,6 @@ #else       DocCommentNamed name doc -> (Just name, hsDocString <$> doc)       _                        -> (Nothing, L loc $ hsDocString $ unLoc $ docDeclDoc x)-#endif--#if __GLASGOW_HASKELL__ < 805--- | Convert a docstring to a plain string.-unpackHDS :: HsDocString -> String-unpackHDS (HsDocString s) = unpackFS s #endif  #if __GLASGOW_HASKELL__ < 901

@@ -3,44 +3,23 @@  import           GHC.Paths (libdir) import           GHC-#if __GLASGOW_HASKELL__ < 900-import           DynFlags (gopt_set)-#else import           GHC.Driver.Session (gopt_set)-#endif -#if __GLASGOW_HASKELL__ < 900-import           Panic (throwGhcException)-#else import           GHC.Utils.Panic (throwGhcException)-#endif -#if __GLASGOW_HASKELL__ < 900-import           MonadUtils (liftIO)-#else-import           GHC.Utils.Monad (liftIO)-#endif--import           System.Exit (exitFailure)---- Catch GHC source errors, print them and exit.-handleSrcErrors :: Ghc a -> Ghc a-handleSrcErrors action' = flip handleSourceError action' $ \err -> do-  printException err-  liftIO exitFailure- -- | Run a GHC action in Haddock mode-withGhc :: [String] -> ([String] -> Ghc a) -> IO a+withGhc :: [String] -> Ghc a -> IO a withGhc flags action = do   flags_ <- handleStaticFlags flags    runGhc (Just libdir) $ do-    handleDynamicFlags flags_ >>= handleSrcErrors . action+    handleDynamicFlags flags_+    action  handleStaticFlags :: [String] -> IO [Located String] handleStaticFlags flags = return $ map noLoc $ flags -handleDynamicFlags :: GhcMonad m => [Located String] -> m [String]+handleDynamicFlags :: GhcMonad m => [Located String] -> m () handleDynamicFlags flags = do #if __GLASGOW_HASKELL__ >= 901   logger <- getLogger@@ -58,7 +37,7 @@       unknown_opts = [ f | f@('-':_) <- srcs ]   case unknown_opts of     opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'"))-    _       -> return srcs+    _       -> return ()  setHaddockMode :: DynFlags -> DynFlags setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) {

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} @@ -144,12 +143,6 @@           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

@@ -84,10 +84,8 @@   let     args = flags ++ [         "--interactive"-#if __GLASGOW_HASKELL__ >= 802       , "-fdiagnostics-color=never"       , "-fno-diagnostics-show-caret"-#endif       ]   bracket (new logger defaultConfig{configGhci = ghc} args) close action 

@@ -1,17 +1,11 @@-{-# LANGUAGE CPP, DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor #-} module Test.DocTest.Internal.Location where  import           Control.DeepSeq (deepseq, NFData(rnf)) -#if __GLASGOW_HASKELL__ < 900-import           SrcLoc hiding (Located)-import qualified SrcLoc as GHC-import           FastString (unpackFS)-#else import           GHC.Types.SrcLoc hiding (Located) import qualified GHC.Types.SrcLoc as GHC import           GHC.Data.FastString (unpackFS)-#endif  -- | A thing with a location attached. data Located a = Located Location a@@ -57,12 +51,6 @@  -- | Convert a GHC source span to a location. toLocation :: SrcSpan -> Location-#if __GLASGOW_HASKELL__ < 900 toLocation loc = case loc of-  UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str)-  RealSrcSpan sp    -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp)-#else-toLocation loc = case loc of   UnhelpfulSpan str -> UnhelpfulLocation (unpackFS $ unhelpfulSpanFS str)   RealSrcSpan sp _  -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp)-#endif

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ImplicitParams #-}@@ -10,10 +11,20 @@ import Control.DeepSeq (NFData) import Data.Char (toLower, toUpper) import Data.List (intercalate)+import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import System.IO (hPutStrLn, stderr) import Text.Printf (printf) +#if MIN_VERSION_base(4,18,0)+import GHC.Conc.Sync (threadLabel)+#endif++#if !MIN_VERSION_base(4,18,0)+threadLabel :: ThreadId -> IO (Maybe String)+threadLabel _ = pure Nothing+#endif+ -- | Convenience type alias - not used in this module, but sprinkled across the -- project. type DebugLogger = String -> IO ()@@ -85,22 +96,22 @@ justifyLeft :: Int -> a -> [a] -> [a] justifyLeft n c s = s ++ replicate (n - length s) c +-- | Pretty name for a 'ThreadId'. Uses 'threadLabel' if available, otherwise+-- falls back to 'show'.+getThreadName :: ThreadId -> IO String+getThreadName threadId = fromMaybe (show threadId) <$> threadLabel threadId+ -- | /Prettily/ format a log message -- -- > threadId <- myThreadId--- > formatLog Debug threadId "some debug message"+-- > formatLog Debug (show threadId) "some debug message" -- "[DEBUG  ] [ThreadId 1277462] some debug message" ---formatLog :: ThreadId -> LogLevel -> String -> String-formatLog threadId lvl msg = do+formatLog :: String -> LogLevel -> String -> String+formatLog nm lvl msg =   intercalate "\n" (map go (lines msg))  where-  go line =-    printf-      "[%s] [%s] %s"-      (map toUpper (showJustifiedLogLevel lvl))-      (show threadId)-      line+  go = printf "[%s] [%s] %s" (map toUpper (showJustifiedLogLevel lvl)) nm  -- | Like 'formatLog', but instantiates the /thread/ argument with the current 'ThreadId' --@@ -109,8 +120,8 @@ -- formatLogHere :: LogLevel -> String -> IO String formatLogHere lvl msg = do-  threadId <- myThreadId-  pure (formatLog threadId lvl msg)+  threadName <- getThreadName =<< myThreadId+  pure (formatLog threadName lvl msg)  -- | Should a message be printed? For a given verbosity level and message log level. shouldLog :: (?verbosity :: LogLevel) => LogLevel -> Bool

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}  module Test.DocTest.Internal.Nix where@@ -16,22 +15,8 @@ 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

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}@@ -17,11 +16,7 @@ import qualified Paths_doctest_parallel import           Data.Version (showVersion) -#if __GLASGOW_HASKELL__ < 900-import           Config as GHC-#else import           GHC.Settings.Config as GHC-#endif  import           Test.DocTest.Internal.Location (Located (Located), Location) import           Test.DocTest.Internal.Interpreter (ghc)

@@ -1,6 +1,5 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}  module Test.DocTest.Internal.Parse (   Module (..)@@ -11,6 +10,7 @@ , ExpectedLine (..) , LineChunk (..) , getDocTests+, getDocTestsIO  -- * exported for testing , parseInteractions@@ -24,7 +24,9 @@ import           Data.String  import           Test.DocTest.Internal.Extract+import           Test.DocTest.Internal.GhcUtil (withGhc) import           Test.DocTest.Internal.Location+import GHC (Ghc)   data DocTest = Example Expression ExpectedResult | Property Expression@@ -47,17 +49,13 @@  type Interaction = (Expression, ExpectedResult) ---- |--- Extract 'DocTest's from all given modules and all modules included by the--- given modules.-getDocTests :: [String] -> IO [Module [Located DocTest]]  -- ^ Extracted 'DocTest's-getDocTests args = parseModules <$> extract args+-- | Extract 'DocTest's from given module+getDocTestsIO :: [String] -> String -> IO (Module [Located DocTest])+getDocTestsIO parseArgs mod_ = withGhc parseArgs $ parseModule <$> extract mod_ -parseModules :: [Module (Located String)] -> [Module [Located DocTest]]-parseModules = filter (not . isEmpty) . map parseModule- where-  isEmpty (Module _ setup tests _) = null tests && isNothing setup+-- | Extract 'DocTest's from given module+getDocTests :: String -> Ghc (Module [Located DocTest])+getDocTests mod_ = parseModule <$> extract mod_  -- | Convert documentation to `Example`s. parseModule :: Module (Located String) -> Module [Located DocTest]

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-}  module Test.DocTest.Internal.Property where

@@ -7,9 +7,10 @@  import           Prelude hiding (putStr, putStrLn, error) -import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId)-import           Control.Exception (SomeException, catch)+import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId, MVar, newMVar)+import           Control.Exception (SomeException, AsyncException, throw) import           Control.Monad hiding (forM_)+import           Control.Monad.Catch (catches, Handler (Handler)) import           Data.Foldable (forM_) import           Data.Function (on) import           Data.List (sortBy)@@ -30,14 +31,18 @@   , cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions) import           Test.DocTest.Internal.Location import qualified Test.DocTest.Internal.Property as Property+import           Test.DocTest.Internal.Extract (isEmptyModule)+import           Test.DocTest.Internal.GhcUtil (withGhc)+import           Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog, getThreadName) import           Test.DocTest.Internal.Runner.Example-import           Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog)  import           System.IO.CodePage (withCP65001)-import Control.Monad.Extra (whenM)+import           Control.Monad.Extra (whenM)+import GHC (Ghc) -#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup+#ifdef mingw32_HOST_OS+import           Control.Concurrent.MVar (putMVar, takeMVar)+import           Control.Monad.Catch (finally) #endif  -- | Whether an "example" is part of setup block@@ -63,9 +68,6 @@ -- | Sum up summaries. instance Monoid Summary where   mempty = Summary 0 0 0 0-#if __GLASGOW_HASKELL__ < 804-  mappend = (<>)-#endif  instance Semigroup Summary where   (<>) (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) =@@ -81,29 +83,32 @@   -> Bool   -- ^ Implicit Prelude   -> [String]+  -- ^ Arguments passed to the GHC for parsing+  -> [String]   -- ^ Arguments passed to the GHCi process.-  -> [Module [Located DocTest]]+  -> [ModuleName]   -- ^ Modules under test   -> IO Summary-runModules modConfig nThreads implicitPrelude args modules = do+runModules modConfig nThreads implicitPrelude parseArgs evalArgs modules = do   isInteractive <- hIsTerminalDevice stderr+  ghcLock <- newMVar ()    -- Start a thread pool. It sends status updates to this thread through 'output'.   nCores <- getNumProcessors   (input, output) <-     makeThreadPool       (fromMaybe nCores nThreads)-      (runModule modConfig implicitPrelude args)+      parseArgs+      (runModule modConfig implicitPrelude ghcLock evalArgs)    -- Send instructions to threads   liftIO (mapM_ (writeChan input) modules)    let-    nExamples = (sum . map count) modules     initState = ReportState       { reportStateCount = 0       , reportStateInteractive = isInteractive-      , reportStateSummary = mempty{sExamples=nExamples}+      , reportStateSummary = mempty       }    threadId <- myThreadId@@ -126,7 +131,7 @@     let ?threadId = threadId     consumeUpdates output =<<       case update of-        UpdateInternalError fs loc e -> reportInternalError fs loc e >> pure (modsLeft - 1)+        UpdateInternalError modName e -> reportInternalError modName e >> pure (modsLeft - 1)         UpdateImportError modName result -> reportImportError modName result >> pure (modsLeft - 1)         UpdateSuccess fs -> reportSuccess fs >> reportProgress >> pure modsLeft         UpdateFailure fs loc expr errs -> reportFailure fs loc expr errs >> pure modsLeft@@ -134,6 +139,7 @@         UpdateOptionError loc err -> reportOptionError loc err >> pure modsLeft         UpdateModuleDone -> pure (modsLeft - 1)         UpdateLog lvl msg -> report lvl msg >> pure modsLeft+        UpdateModuleParsed modName nExamples -> reportModuleParsed modName nExamples >> pure modsLeft  -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int@@ -158,7 +164,8 @@   Report () report lvl msg0 =   when (shouldLog lvl) $ do-    let msg1 = formatLog ?threadId lvl msg0+    threadName <- liftIO $ getThreadName ?threadId+    let msg1 = formatLog threadName lvl msg0     overwrite msg1      -- add a newline, this makes the output permanent@@ -195,95 +202,107 @@ runModule   :: ModuleConfig   -> Bool+  -> MVar ()+  -- ^ GHC lock   -> [String]+  -- ^ Eval GHCi arguments   -> Chan (ThreadId, ReportUpdate)-  -> Module [Located DocTest]-  -> IO ()-runModule modConfig0 implicitPrelude ghciArgs output mod_ = do-  threadId <- myThreadId+  -> ModuleName+  -> Ghc ()+runModule modConfig0 implicitPrelude ghcLock evalArgs output modName = do+  threadId <- liftIO myThreadId   let update r = writeChan output (threadId, r) -  case modConfig2 of-    Left (loc, flag) ->-      update (UpdateOptionError loc flag)+  mod_@(Module module_ setup examples0 modArgs) <- do+#ifdef mingw32_HOST_OS+    -- XXX: Cannot use multiple GHC APIs at the same time on Windows+    liftIO $ takeMVar ghcLock+    getDocTests modName `finally` liftIO (putMVar ghcLock ())+#else+    ghcLock `seq` getDocTests modName+#endif -    Right modConfig3 -> do-      let-        examples1-          | cfgRandomizeOrder modConfig3 = shuffle seed examples0-          | otherwise = examples0+  liftIO $ update (UpdateModuleParsed modName (count (Module module_ setup examples0 modArgs)))+  let modConfig2 = parseLocatedModuleOptions modName modConfig0 modArgs -        importModule-          | cfgImplicitModuleImport modConfig3 = Just (":m +" ++ module_)-          | otherwise = Nothing+  unless (isEmptyModule mod_) $+    case modConfig2 of+      Left (loc, flag) ->+        liftIO $ update (UpdateOptionError loc flag) -        preserveIt = cfgPreserveIt modConfig3-        seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already+      Right modConfig3 -> do+        let+          examples1+            | cfgRandomizeOrder modConfig3 = shuffle seed examples0+            | otherwise = examples0 -        reload repl = do-          void $ Interpreter.safeEval repl ":reload"-          mapM_ (Interpreter.safeEval repl) $-            if implicitPrelude-            then ":m Prelude" : maybeToList importModule-            else maybeToList importModule+          importModule+            | cfgImplicitModuleImport modConfig3 = Just (":m +" ++ module_)+            | otherwise = Nothing -          when preserveIt $-            -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is-            -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in-            -- a fresh GHCi session.-            void $ Interpreter.safeEval repl $ "()"+          preserveIt = cfgPreserveIt modConfig3+          seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already -        setup_ repl = do-          reload repl-          forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of-            Property _  -> return ()-            Example e _ -> void $ safeEvalWith preserveIt repl e+          reload repl = do+            void $ Interpreter.safeEval repl ":reload"+            mapM_ (Interpreter.safeEval repl) $+              if implicitPrelude+              then ":m Prelude" : maybeToList importModule+              else maybeToList importModule +            when preserveIt $+              -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is+              -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in+              -- a fresh GHCi session.+              void $ Interpreter.safeEval repl $ "()" -      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-            Nothing -> pure (Right "")-            Just i -> Interpreter.safeEval repl i+          setup_ repl = do+            reload repl+            forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of+              Property _  -> return ()+              Example e _ -> void $ safeEvalWith preserveIt repl e -        case importResult of-          Right "" -> do-            -- Run setup group-            successes <--              mapM-                (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) update)-                examples1)-          _ ->-            update (UpdateImportError module_ importResult)+        let logger = update . UpdateLog Debug+        liftIO $ Interpreter.withInterpreter logger evalArgs $ \repl -> withCP65001 $ do+          -- Try to import this module, if it fails, something is off+          importResult <-+            case importModule of+              Nothing -> pure (Right "")+              Just i -> Interpreter.safeEval repl i -  -- Signal main thread a module has been tested-  update UpdateModuleDone+          case importResult of+            Right "" -> do+              -- Run setup group+              successes <-+                mapM+                  (runTestGroup FromSetup preserveIt repl (reload repl) update)+                  setup -  pure ()+              -- only run tests, if setup does not produce any errors/failures+              when+                (and successes)+                (mapM_+                  (runTestGroup NotFromSetup preserveIt repl (setup_ repl) update)+                  examples1)+            _ ->+              update (UpdateImportError module_ importResult) - where-  Module module_ setup examples0 modArgs = mod_-  modConfig2 = parseLocatedModuleOptions module_ modConfig0 modArgs+  -- Signal main thread a module has been tested+  liftIO $ update UpdateModuleDone  data ReportUpdate   = UpdateSuccess FromSetup   -- ^ Test succeeded+  | UpdateModuleParsed ModuleName Int+  -- ^ Parsed module, found /n/ examples   | UpdateFailure FromSetup Location Expression [String]   -- ^ Test failed with unexpected result   | UpdateError FromSetup Location Expression String   -- ^ Test failed with an error   | UpdateModuleDone   -- ^ All examples tested in module-  | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException+  | UpdateInternalError ModuleName SomeException   -- ^ Exception caught while executing internal code   | UpdateImportError ModuleName (Either String String)   -- ^ Could not import module@@ -294,20 +313,33 @@  makeThreadPool ::   Int ->-  (Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()) ->-  IO (Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate))-makeThreadPool nThreads mutator = do+  [String] ->+  (Chan (ThreadId, ReportUpdate) -> ModuleName -> Ghc ()) ->+  IO (Chan ModuleName, Chan (ThreadId, ReportUpdate))+makeThreadPool nThreads parseArgs mutator = do   input <- newChan   output <- newChan   forM_ [1..nThreads] $ \_ ->-    forkIO $ forever $ do-      i <- readChan input-      threadId <- myThreadId-      catch-        (mutator output i)-        (\e -> writeChan output (threadId, UpdateInternalError NotFromSetup i e))+    forkIO $ withGhc parseArgs $ forever $ do+      modName <- liftIO $ readChan input+      threadId <- liftIO myThreadId+      let update e = liftIO $ writeChan output (threadId, UpdateInternalError modName e)+      catches+        (mutator output modName)+        -- 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 operation.+        [ Handler (\e -> throw (e :: AsyncException))+        , Handler (\e -> update (e :: SomeException))+        ]   return (input, output) +reportModuleParsed :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Int -> Report ()+reportModuleParsed modName nExamples = do+  report Debug (printf "Parsed module %s with %d examples" modName nExamples)+  updateSummary NotFromSetup (Summary nExamples 0 0 0)+ reportFailure :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> [String] -> Report () reportFailure fromSetup loc expression err = do   report Error (printf "%s: failure in expression `%s'" (show loc) expression)@@ -328,12 +360,12 @@   report Error ""   updateSummary FromSetup (Summary 0 1 1 0) -reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Module a -> SomeException -> Report ()-reportInternalError fs mod_ err = do-  report Error (printf "Internal error when executing tests in %s" (moduleName mod_))+reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> SomeException -> Report ()+reportInternalError modName err = do+  report Error (printf "Error when executing tests in %s" modName)   report Error (show err)   report Error ""-  updateSummary fs emptySummary{sErrors=1}+  updateSummary NotFromSetup emptySummary{sErrors=1}  reportImportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Either String String -> Report () reportImportError modName importResult = do

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,22 +6,17 @@ import           Test.Hspec import           Test.HUnit --#if __GLASGOW_HASKELL__ < 900-import           Panic (GhcException (..))-#else import           GHC.Utils.Panic (GhcException (..))-#endif  import           Test.DocTest.Internal.Extract import           Test.DocTest.Internal.Location import           System.FilePath  -shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion+shouldGive :: HasCallStack => (String, String) -> Module String -> Assertion (d, m) `shouldGive` expected = do-  r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir </> m]-  map eraseConfigLocation r `shouldBe` map eraseConfigLocation expected+  r <- fmap unLoc `fmap` extractIO ["-i" ++ dir] m+  eraseConfigLocation r `shouldBe` eraseConfigLocation expected  where   dir = "test/extract" </> d @@ -35,83 +29,83 @@    describe "extract" $ do     it "extracts documentation for a top-level declaration" $ do-      ("declaration", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]]+      ("declaration", "Foo") `shouldGive` mod_ "Foo" [" Some documentation"]      it "extracts documentation from argument list" $ do-      ("argument-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" doc for arg1", " doc for arg2"]]+      ("argument-list", "Foo") `shouldGive` mod_ "Foo" [" doc for arg1", " doc for arg2"]      it "extracts documentation for a type class function" $ do-      ("type-class", "Foo.hs") `shouldGive` [mod_ "Foo" [" Convert given value to a string."]]+      ("type-class", "Foo") `shouldGive` mod_ "Foo" [" Convert given value to a string."]      it "extracts documentation from the argument list of a type class function" $ do-      ("type-class-args", "Foo.hs") `shouldGive` [mod_ "Foo" [" foo", " bar"]]+      ("type-class-args", "Foo") `shouldGive` mod_ "Foo" [" foo", " bar"]      it "extracts documentation from the module header" $ do-      ("module-header", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]]+      ("module-header", "Foo") `shouldGive` mod_ "Foo" [" Some documentation"] -    it "extracts documentation from imported modules" $ do-      ("imported-module", "Bar.hs") `shouldGive` [mod_ "Bar" [" documentation for bar"], mod_ "Baz" [" documentation for baz"]]+    it "does not extract documentation from imported modules" $ do+      ("imported-module", "Bar") `shouldGive` mod_ "Bar" [" documentation for bar"]      it "extracts documentation from export list" $ do-      ("export-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" documentation from export list"]]+      ("export-list", "Foo") `shouldGive` mod_ "Foo" [" documentation from export list"]      it "extracts documentation from named chunks" $ do-      ("named-chunks", "Foo.hs") `shouldGive` [mod_ "Foo" [" named chunk foo", "\n named chunk bar"]]+      ("named-chunks", "Foo") `shouldGive` mod_ "Foo" [" named chunk foo", "\n named chunk bar"]      it "returns docstrings in the same order they appear in the source" $ do-      ("comment-order", "Foo.hs") `shouldGive` [mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]]+      ("comment-order", "Foo") `shouldGive` mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]      it "extracts $setup code" $ do-      ("setup", "Foo.hs") `shouldGive` [(mod_ "Foo"  [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"}]+      ("setup", "Foo") `shouldGive` (mod_ "Foo"  [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"}      it "fails on invalid flags" $ do-      extract ["--foobar", "test/Foo.hs"] `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False)+      extractIO ["--foobar"] "test/Foo.hs" `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False)    describe "extract (regression tests)" $ do     it "works with infix operators" $ do-      ("regression", "Fixity.hs") `shouldGive` [mod_ "Fixity" []]+      ("regression", "Fixity") `shouldGive` mod_ "Fixity" []      it "works with parallel list comprehensions" $ do-      ("regression", "ParallelListComp.hs") `shouldGive` [mod_ "ParallelListComp" []]+      ("regression", "ParallelListComp") `shouldGive` mod_ "ParallelListComp" []      it "works with list comprehensions in instance definitions" $ do-      ("regression", "ParallelListCompClass.hs") `shouldGive` [mod_ "ParallelListCompClass" []]+      ("regression", "ParallelListCompClass") `shouldGive` mod_ "ParallelListCompClass" []      it "works with foreign imports" $ do-      ("regression", "ForeignImport.hs") `shouldGive` [mod_ "ForeignImport" []]+      ("regression", "ForeignImport") `shouldGive` mod_ "ForeignImport" []      it "works for rewrite rules" $ do-      ("regression", "RewriteRules.hs") `shouldGive` [mod_ "RewriteRules" [" doc for foo"]]+      ("regression", "RewriteRules") `shouldGive` mod_ "RewriteRules" [" doc for foo"]      it "works for rewrite rules with type signatures" $ do-      ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [mod_ "RewriteRulesWithSigs" [" doc for foo"]]+      ("regression", "RewriteRulesWithSigs") `shouldGive` mod_ "RewriteRulesWithSigs" [" doc for foo"]      it "strips CR from dos line endings" $ do-      ("dos-line-endings", "Foo.hs") `shouldGive` [mod_ "Foo" ["\n foo\n bar\n baz"]]+      ("dos-line-endings", "Foo") `shouldGive` mod_ "Foo" ["\n foo\n bar\n baz"]      it "works with a module that splices in an expression from an other module" $ do-      ("th", "Foo.hs") `shouldGive` [mod_ "Foo" [" some documentation"], mod_ "Bar" []]+      ("th", "Foo") `shouldGive` mod_ "Foo" [" some documentation"]      it "works for type families and GHC 7.6.1" $ do-      ("type-families", "Foo.hs") `shouldGive` [mod_ "Foo" []]+      ("type-families", "Foo") `shouldGive` mod_ "Foo" []      it "ignores binder annotations" $ do-      ("module-options", "Binders.hs") `shouldGive` [mod_ "Binders" []]+      ("module-options", "Binders") `shouldGive` mod_ "Binders" []      it "ignores module annotations that don't start with 'doctest-parallel:'" $ do-      ("module-options", "NoOptions.hs") `shouldGive` [mod_ "NoOptions" []]+      ("module-options", "NoOptions") `shouldGive` mod_ "NoOptions" []      it "detects monomorphic module settings" $ do-      ("module-options", "Mono.hs") `shouldGive` [(mod_ "Mono" []){moduleConfig=+      ("module-options", "Mono") `shouldGive` (mod_ "Mono" []){moduleConfig=         [ noLocation "--no-randomize-error1"         , noLocation "--no-randomize-error2"         , noLocation "--no-randomize-error3"         , noLocation "--no-randomize-error4"         , noLocation "--no-randomize-error5"         , noLocation "--no-randomize-error6"-        ]}]+        ]}      it "detects polypormphic module settings" $ do-      ("module-options", "Poly.hs") `shouldGive` [(mod_ "Poly" []){moduleConfig=+      ("module-options", "Poly") `shouldGive` (mod_ "Poly" []){moduleConfig=         [ noLocation "--no-randomize-error"-        ]}]+        ]}

@@ -1,12 +1,10 @@-{-# LANGUAGE CPP #-}- module GhciWrapperSpec (main, spec) where  import           Test.Hspec import           System.IO.Silently  import           Control.Exception-import           Data.List (isInfixOf)+import           Data.List (isInfixOf, isPrefixOf)  import           Test.DocTest.Internal.GhciWrapper (Interpreter, Config(..), defaultConfig) import qualified Test.DocTest.Internal.GhciWrapper as Interpreter@@ -75,18 +73,15 @@      it "shows exceptions" $ withInterpreter $ \ghci -> do       ghci "import Control.Exception" `shouldReturn` ""-      ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n"+      res <- ghci "throwIO DivideByZero"+      res `shouldSatisfy` isPrefixOf "*** 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

@@ -1,18 +1,11 @@-{-# LANGUAGE CPP #-}- module LocationSpec (main, spec) where  import           Test.Hspec  import           Test.DocTest.Internal.Location -#if __GLASGOW_HASKELL__ < 900-import           SrcLoc-import           FastString (fsLit)-#else import           GHC.Types.SrcLoc import           GHC.Data.FastString (fsLit)-#endif  main :: IO () main = hspec spec

@@ -1,9 +1,8 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} -module MainSpec (main, spec) where+module MainSpec where  import           Test.Hspec import           Test.HUnit (assertEqual, Assertion)

@@ -8,6 +8,7 @@  import           Test.DocTest.Internal.Parse import           Test.DocTest.Internal.Location+import           Test.DocTest.Internal.Extract (isEmptyModule)  main :: IO () main = hspec spec@@ -24,14 +25,14 @@ module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] () module_ name gs = tell [Module name Nothing (execWriter gs) []] -shouldGive :: IO [Module [Located DocTest]] -> Writer [Module [DocTest]] () -> Expectation-shouldGive action expected = map (fmap $ map unLoc) `fmap` action `shouldReturn` execWriter expected+shouldGive :: IO (Module [Located DocTest]) -> Writer [Module [DocTest]] () -> Expectation+shouldGive action expected = map (fmap $ map unLoc) `fmap` fmap pure action `shouldReturn` execWriter expected  spec :: Spec spec = do-  describe "getDocTests" $ do+  describe "getDocTestsIO" $ do     it "extracts properties from a module" $ do-      getDocTests ["test/parse/property/Fib.hs"] `shouldGive` do+      getDocTestsIO ["-itest/parse/property"] "Fib" `shouldGive` do         module_ "Fib" $ do           group $ do             prop_ "foo"@@ -39,7 +40,7 @@             prop_ "baz"      it "extracts examples from a module" $ do-      getDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do+      getDocTestsIO ["-itest/parse/simple"] "Fib" `shouldGive` do         module_ "Fib" $ do           group $ do             ghci "putStrLn \"foo\""@@ -50,7 +51,7 @@               "baz"      it "extracts examples from documentation for non-exported names" $ do-      getDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do+      getDocTestsIO ["-itest/parse/non-exported"] "Fib" `shouldGive` do         module_ "Fib" $ do           group $ do             ghci "putStrLn \"foo\""@@ -61,7 +62,7 @@               "baz"      it "extracts multiple examples from a module" $ do-      getDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do+      getDocTestsIO ["-itest/parse/multiple-examples"] "Foo" `shouldGive` do         module_ "Foo" $ do           group $ do             ghci "foo"@@ -71,17 +72,17 @@               "42"      it "returns an empty list, if documentation contains no examples" $ do-      getDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` [])+      getDocTestsIO ["-itest/parse/no-examples"] "Fib" >>= (`shouldSatisfy` isEmptyModule)      it "sets setup code to Nothing, if it does not contain any tests" $ do-      getDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do+      getDocTestsIO ["-itest/parse/setup-empty"] "Foo" `shouldGive` do         module_ "Foo" $ do           group $ do             ghci "foo"               "23"      it "keeps modules that only contain setup code" $ do-      getDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do+      getDocTestsIO ["-itest/parse/setup-only"] "Foo" `shouldGive` do         tell [Module "Foo" (Just [Example "foo" ["23"]]) [] []]    describe "parseInteractions (an internal function)" $ do

@@ -0,0 +1,29 @@+{-# LANGUAGE MultiWayIf #-}++module ProjectsSpec (main, spec) where++import Test.Hspec+import System.Environment (getEnvironment)+import System.Process (readCreateProcess, proc)++import qualified Data.Map as Map++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  env <- Map.fromList <$> runIO getEnvironment++  let+    -- Only test with cabal+    cDescribe =+      if+        | "STACK_EXE" `Map.member` env -> xdescribe+        | "NIX_BUILD_TOP" `Map.member` env -> xdescribe+        | otherwise -> describe++  cDescribe "T85-default-language" $ do+    it "cabal run doctests" $ do+      _ <- readCreateProcess (proc "cabal" ["run", "-v0", "--", "doctests", "--quiet"]) ""+      pure ()

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module RunSpec (main, spec) where  import           Prelude ()

@@ -9,6 +9,7 @@ import qualified MainSpec import qualified OptionsSpec import qualified ParseSpec+import qualified ProjectsSpec import qualified PropertySpec import qualified RunnerSpec import qualified RunSpec@@ -26,6 +27,7 @@   describe "MainSpec"        MainSpec.spec   describe "OptionsSpec"     OptionsSpec.spec   describe "ParseSpec"       ParseSpec.spec+  describe "ProjectsSpec"    ProjectsSpec.spec   describe "PropertySpec"    PropertySpec.spec   describe "RunnerSpec"      RunnerSpec.spec   describe "RunSpec"         RunSpec.spec