doctest-parallel 0.2.1 → 0.2.2

raw patch · 20 files changed

+512/−173 lines, 20 filesdep +extraPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: extra

API changes (from Hackage documentation)

Files

• CHANGES.markdown +6/−0
• README.markdown +24/−2
• doctest-parallel.cabal +8/−1
• src/Test/DocTest.hs +7/−16
• src/Test/DocTest/Helpers.hs +16/−3
• src/Test/DocTest/Internal/Extract.hs +120/−35
• src/Test/DocTest/Internal/Options.hs +79/−23
• src/Test/DocTest/Internal/Parse.hs +10/−8
• src/Test/DocTest/Internal/Runner.hs +103/−58
• test/ExtractSpec.hs +44/−21
• test/MainSpec.hs +10/−2
• test/OptionsSpec.hs +25/−2
• test/ParseSpec.hs +2/−2
• test/extract/module-options/Binders.hs +5/−0
• test/extract/module-options/Mono.hs +8/−0
• test/extract/module-options/NoOptions.hs +5/−0
• test/extract/module-options/Poly.hs +5/−0
• test/integration/ModuleOptions/Foo.hs +22/−0
• test/integration/NonExposedModule/Exposed.hs +3/−0
• test/integration/NonExposedModule/NoImplicitImport.hs +10/−0

@@ -1,3 +1,9 @@+# 0.2.2+  * Command line arguments (such as `--randomize-order`) can now be overridden on a per-module basis ([#25](https://github.com/martijnbastiaan/doctest-parallel/pull/25))+  * Implicit pre-test module imports can now be disabled using `--no-implicit-module-import`. This can help to test functions from non-exposed modules ([#26](https://github.com/martijnbastiaan/doctest-parallel/pull/26))+  * `runModule` does not swallow import errors anymore ([#28](https://github.com/martijnbastiaan/doctest-parallel/issues/28))+  * `autogen-modules` are not searched for tests anymore ([#30](https://github.com/martijnbastiaan/doctest-parallel/issues/30))+ # 0.2.1   * C include directories (Cabal field: `include-dirs`) are now passed to GHC when parsing source files ([#7](https://github.com/martijnbastiaan/doctest-parallel/issues/7))   * A migration guide has been added ([#11](https://github.com/martijnbastiaan/doctest-parallel/issues/11))

@@ -289,6 +289,29 @@ -- >>> :m -Prelude ``` +## Per module options+You can override command line flags per module by using a module annotation. For example, if you know a specific module does not support test order randomization, you can disable it with:++```haskell+{-# ANN module "doctest-parallel: --no-randomize-order" #-}+```++## Test non-exposed modules+Generally, `doctest-parallel` cannot test binders that are part of non-exposed modules, unless they are re-exported from exposed modules. By default `doctest-parallel` will fail to do so (and report an error message), because it doesn't track whether functions are re-exported in such a way. To test a re-exported function, add the following to the _non-exposed_ module:++```haskell+{-# ANN module "doctest-parallel: --no-implicit-module-import" #-}+```++This makes `doctest-parallel` omit the usual module import at the start of a test.++Then, before a test -or in `$setup`- add:++```haskell+>>> import Exposed.Module (someFunction)+```++ # Relation to [`doctest`](https://github.com/sol/doctest) This is a fork of [sol/doctest](https://github.com/sol/doctest) that allows running tests in parallel and aims to provide a more robust project integration method. It is not backwards compatible and expects to be setup differently. At the time of writing it has a few advantages over the base project: @@ -299,9 +322,8 @@  * A minor change: it does not count lines in setup blocks as test cases  * A minor change: the testsuite has been ported to v2 commands - There are two downsides to using this project:+AFAIK there's only one downside to using this project: - * Examples in non-exposed modules cannot be tested (but will nonetheless be detected and consequently fail)  * Use of conditionals in a cabal file as well as CPP flags will be ignored (TODO?)  All in all, you can expect `doctest-parallel` to run about 1 or 2 orders of magnitude faster than `doctest` for large projects.

@@ -1,7 +1,7 @@ cabal-version: 2.0  name:           doctest-parallel-version:        0.2.1+version:        0.2.2 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>).@@ -22,6 +22,7 @@   , GHC == 8.8.4   , GHC == 8.10.7   , GHC == 9.0.1+  , GHC == 9.2.1 extra-source-files:     example/example.cabal     example/src/Example.hs@@ -40,6 +41,7 @@     test/extract/export-list/*.hs     test/extract/imported-module/*.hs     test/extract/module-header/*.hs+    test/extract/module-options/*.hs     test/extract/named-chunks/*.hs     test/extract/regression/*.hs     test/extract/setup/*.hs@@ -93,6 +95,7 @@     , deepseq     , directory     , exceptions+    , extra     , filepath     , ghc >=8.4 && <9.3     , ghc-paths >=0.1.0.9@@ -139,6 +142,8 @@     LocalStderrBinding.A     ModuleIsolation.TestA     ModuleIsolation.TestB+    ModuleOptions.Foo+    NonExposedModule.Exposed     Multiline.Multiline     PropertyBool.Foo     PropertyBoolWithTypeSignature.Foo@@ -162,6 +167,8 @@     TrailingWhitespace.Foo     WithCbits.Bar     WithCInclude.Bar+  other-modules:+    NonExposedModule.NoImplicitImport  test-suite spectests   main-is: Spec.hs

@@ -12,7 +12,7 @@   -- * Internal   , filterModules   , isSuccess-  , getSeed+  , setSeed   , run   ) where @@ -115,23 +115,14 @@   nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1)   isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1 -getSeed-  :: Bool-  -- ^ Whether quiet mode is enabled-  -> Bool-  -- ^ Enable order randomization. If 'False', this function always returns 'Nothing'-  -> Maybe Int-  -- ^ User supplied seed. If 'Nothing', a fresh seed will be generated.-  -> IO (Maybe Int)-  -- ^ Maybe seed to use for order randomization.-getSeed _quiet False _ = pure Nothing-getSeed _quiet True (Just seed) = pure (Just seed)-getSeed quiet True Nothing = do+setSeed :: Bool -> ModuleConfig -> IO ModuleConfig+setSeed quiet cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do   -- Using an abslute number to prevent copy+paste errors   seed <- abs <$> randomIO   unless quiet $     putStrLn ("Using freshly generated seed to randomize test order: " <> show seed)-  pure (Just seed)+  pure cfg{cfgSeed=Just seed}+setSeed _quiet cfg = pure cfg  -- | Run doctest for given library and config. Produce a summary of all tests. run :: Library -> Config -> IO Summary@@ -141,10 +132,10 @@     (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib     evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"] -  seed <- getSeed cfgQuiet cfgRandomizeOrder cfgSeed+  modConfig <- setSeed cfgQuiet cfgModuleConfig    -- get examples from Haddock comments   allModules <- getDocTests (includeArgs ++ moduleArgs ++ otherGhciArgs)   runModules-    cfgThreads cfgPreserveIt cfgVerbose seed implicitPrelude evalGhciArgs+    modConfig cfgThreads cfgVerbose implicitPrelude evalGhciArgs     cfgQuiet (filterModules cfgModules allModules)

@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}  module Test.DocTest.Helpers where @@ -16,6 +17,8 @@ import Data.Monoid ((<>)) #endif +import qualified Data.Set as Set+ -- Cabal import Distribution.ModuleName (ModuleName) import Distribution.Simple@@ -24,7 +27,8 @@ import Distribution.PackageDescription   ( CondTree(CondNode, condTreeData), GenericPackageDescription (condLibrary)   , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package-  , packageDescription, condSubLibraries, includeDirs )+  , packageDescription, condSubLibraries, includeDirs, autogenModules )+ import Distribution.Pretty (prettyShow) import Distribution.Verbosity (silent) @@ -35,6 +39,15 @@ -- cabal-install-parsers import Distribution.PackageDescription.Parsec (readGenericPackageDescription) +-- | Efficient implementation of set like deletion on lists+--+-- >>> "abcd" `rmList` "ad"+-- "bc"+-- >>> "aaabcccd" `rmList` "ad"+-- "bccc"+rmList :: Ord a => [a] -> [a] -> [a]+rmList xs (Set.fromList -> ys) = filter (not . (`Set.member` ys)) xs+ data Library = Library   { libSourceDirectories :: [FilePath]     -- ^ Haskell source directories@@ -155,7 +168,7 @@       pure Library         { libSourceDirectories = map ((root </>) . compatPrettyShow) sourceDirs         , libCSourceDirectories = map (root </>) cSourceDirs-        , libModules = exposedModules lib+        , libModules = exposedModules lib `rmList` autogenModules buildInfo         , libDefaultExtensions = defaultExtensions buildInfo         } 

@@ -1,21 +1,33 @@-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}-module Test.DocTest.Internal.Extract (Module(..), extract) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} +module Test.DocTest.Internal.Extract (Module(..), extract, eraseConfigLocation) where+ import           Prelude hiding (mod, concat) import           Control.Monad import           Control.Exception-import           Data.List (partition)+import           Data.List (partition, isPrefixOf)+import           Data.List.Extra (trim) import           Data.Maybe -import           Control.DeepSeq (deepseq, NFData(rnf))-import           Data.Generics+import           Control.DeepSeq (NFData, deepseq)+import           Data.Generics (Data, Typeable, extQ, mkQ, everythingBut) +import qualified GHC+ #if __GLASGOW_HASKELL__ < 900-import           GHC hiding (Module, Located)+import           GHC hiding (Module, Located, moduleName) import           DynFlags import           MonadUtils (liftIO) #else-import           GHC hiding (Module, Located)+import           GHC hiding (Module, Located, moduleName) import           GHC.Driver.Session import           GHC.Utils.Monad (liftIO) #endif@@ -32,8 +44,15 @@ import           System.Directory import           System.FilePath -#if __GLASGOW_HASKELL__ < 805+#if __GLASGOW_HASKELL__ < 900+import           BasicTypes (SourceText(SourceText)) import           FastString (unpackFS)+#elif __GLASGOW_HASKELL__ < 902+import           GHC.Data.FastString (unpackFS)+import           GHC.Types.Basic (SourceText(SourceText))+#else+import           GHC.Data.FastString (unpackFS)+import           GHC.Types.SourceText (SourceText(SourceText)) #endif  import           System.Posix.Internals (c_getpid)@@ -54,6 +73,9 @@ import           GHC.Unit.Module.Graph #endif +import           GHC.Generics (Generic)++ -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException   deriving Typeable@@ -81,10 +103,14 @@   moduleName    :: String , moduleSetup   :: Maybe a , moduleContent :: [a]-} deriving (Eq, Functor, Show)+, moduleConfig  :: [Located String]+} deriving (Eq, Functor, Show, Generic, NFData) -instance NFData a => NFData (Module a) where-  rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` ()+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@@ -193,42 +219,101 @@  -- | Extract all docstrings from given module and attach the modules name. extractFromModule :: ParsedModule -> Module (Located String)-extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs)-  where-    isSetup = (== Just "setup") . fst-    (setup, docs) = partition isSetup (docStringsFromModule m)-    name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m+extractFromModule m = Module+  { moduleName = name+  , moduleSetup = listToMaybe (map snd setup)+  , moduleContent = map snd docs+  , moduleConfig = moduleAnnsFromModule m+  }+ 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 mod =+  [fmap stripOptionString ann | ann <- anns, isOption ann]+ where+  optionPrefix = "doctest-parallel:"+  isOption (Located _ s) = optionPrefix `isPrefixOf` s+  stripOptionString s = trim (drop (length optionPrefix) s)+  anns = extractModuleAnns source+  source = (unLoc . pm_parsed_source) mod+ -- | Extract all docstrings from given module. docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]-docStringsFromModule mod = map (fmap (toLocated . fmap unpackHDS)) docs-  where-    source   = (unLoc . pm_parsed_source) mod+docStringsFromModule mod =+  map (fmap (toLocated . fmap unpackHDS)) docs+ where+  source   = (unLoc . pm_parsed_source) mod -    -- we use dlist-style concatenation here-    docs     = header ++ exports ++ decls+  -- we use dlist-style concatenation here+  docs     = header ++ exports ++ decls -    -- We process header, exports and declarations separately instead of-    -- traversing the whole source in a generic way, to ensure that we get-    -- everything in source order.-    header  = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]-    exports = [ (Nothing, L (locA loc) doc)+  -- We process header, exports and declarations separately instead of+  -- traversing the whole source in a generic way, to ensure that we get+  -- everything in source order.+  header  = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]+  exports = [ (Nothing, L (locA loc) doc) #if __GLASGOW_HASKELL__ < 710-              | L loc (IEDoc doc) <- concat (hsmodExports source)+            | L loc (IEDoc doc) <- concat (hsmodExports source) #elif __GLASGOW_HASKELL__ < 805-              | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)+            | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source) #else-              | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source)+            | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) #endif-              ]-    decls   = extractDocStrings (hsmodDecls source)+            ]+  decls   = extractDocStrings (hsmodDecls source) -type Selector a = a -> ([(Maybe String, LHsDocString)], Bool)+type Selector b a = a -> ([b], Bool) +type DocSelector a = Selector (Maybe String, LHsDocString) a+type AnnSelector a = Selector (Located String) a+ -- | Collect given value and descend into subtree. select :: a -> ([a], Bool) select x = ([x], False) +-- | Extract module annotations from given value.+extractModuleAnns :: Data a => a -> [Located String]+extractModuleAnns = everythingBut (++) (([], False) `mkQ` fromLHsDecl)+ where+  fromLHsDecl :: AnnSelector (LHsDecl GhcPs)+  fromLHsDecl (L (locA -> loc) decl) = case decl of+#if __GLASGOW_HASKELL__ < 805+    AnnD (HsAnnotation (SourceText _) ModuleAnnProvenance (L _loc expr))+#else+    AnnD _ (HsAnnotation _ (SourceText _) ModuleAnnProvenance (L _loc expr))+#endif+     | Just s <- extractLit loc expr+     -> select s+    _ ->+      -- XXX: Shouldn't this be handled by 'everythingBut'?+      (extractModuleAnns decl, True)++-- | Extract string literals. Looks through type annotations and parentheses.+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+  HsPar _ (L l e) -> extractLit (locA l) e+#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 :: Data a => a -> [(Maybe String, LHsDocString)] extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl@@ -236,7 +321,7 @@   `extQ` fromLHsDocString   )   where-    fromLHsDecl :: Selector (LHsDecl GhcPs)+    fromLHsDecl :: DocSelector (LHsDecl GhcPs)     fromLHsDecl (L loc decl) = case decl of        -- Top-level documentation has to be treated separately, because it has@@ -252,7 +337,7 @@       _ -> (extractDocStrings decl, True)  -    fromLDocDecl :: Selector+    fromLDocDecl :: DocSelector #if __GLASGOW_HASKELL__ >= 901                              (LDocDecl GhcPs) #else@@ -260,7 +345,7 @@ #endif     fromLDocDecl (L loc x) = select (fromDocDecl (locA loc) x) -    fromLHsDocString :: Selector LHsDocString+    fromLHsDocString :: DocSelector LHsDocString     fromLHsDocString x = select (Nothing, x)      fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)

@@ -1,13 +1,16 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}  module Test.DocTest.Internal.Options where  import           Prelude () import           Prelude.Compat +import           Control.DeepSeq (NFData) import           Data.List.Compat+import           GHC.Generics (Generic)  import qualified Paths_doctest_parallel import           Data.Version (showVersion)@@ -18,6 +21,7 @@ import           GHC.Settings.Config as GHC #endif +import           Test.DocTest.Internal.Location (Located (Located), Location) import           Test.DocTest.Internal.Interpreter (ghc) import           Text.Read (readMaybe) @@ -30,15 +34,27 @@   , "  doctest --info"   , ""   , "Options:"-  , "  -jN                      number of threads to use"-  , "  --randomize-order        randomize order in which tests are run"-  , "  --seed                   use a specific seed to randomize test order"-  , "  --preserve-it            preserve the `it` variable between examples"-  , "  --verbose                print each test as it is run"-  , "  --quiet                  only print errors"-  , "  --help                   display this help and exit"-  , "  --version                output version information and exit"-  , "  --info                   output machine-readable version information and exit"+  , "   -jN                      number of threads to use"+  , "†  --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"+  , "   --verbose                print each test as it is run"+  , "   --quiet                  only print errors"+  , "   --help                   display this help and exit"+  , "   --version                output version information and exit"+  , "   --info                   output machine-readable version information and exit"+  , ""+  , "Supported inverted options:"+  , "†  --no-implicit-module-import"+  , "†  --no-randomize-order (default)"+  , "†  --no-preserve-it (default)"+  , ""+  , "Options marked with a dagger (†) can also be used to set module level options, using"+  , "an ANN pragma like this:"+  , ""+  , "  {-# ANN module \"doctest-parallel: --no-randomize-order\" #-} "+  , ""   ]  version :: String@@ -71,36 +87,75 @@ type ModuleName = String  data Config = Config-  { cfgPreserveIt :: Bool-  -- ^ Preserve the @it@ variable between examples (default: @False@)-  , cfgVerbose :: Bool+  { cfgVerbose :: Bool   -- ^ Verbose output (default: @False@)   , 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+  } deriving (Show, Eq, Generic, NFData)++data ModuleConfig = ModuleConfig+  { cfgPreserveIt :: Bool+  -- ^ Preserve the @it@ variable between examples (default: @False@)   , cfgRandomizeOrder :: Bool   -- ^ Randomize the order in which test cases in a module are run (default: @False@)   , cfgSeed :: Maybe Int   -- ^ Initialize random number generator used to randomize test cases when   -- 'cfgRandomizeOrder' is set. If set to 'Nothing', a random seed is picked   -- from a system RNG source on startup.-  , cfgQuiet :: Bool-  -- ^ Only print error messages, no status or progress messages (default: @False@)-  } deriving (Show, Eq)+  , cfgImplicitModuleImport :: Bool+  -- ^ Import a module before testing it. Can be disabled to enabled to test+  -- non-exposed modules.+  } deriving (Show, Eq, Generic, NFData) +defaultModuleConfig :: ModuleConfig+defaultModuleConfig = ModuleConfig+  { cfgPreserveIt = False+  , cfgRandomizeOrder = False+  , cfgSeed = Nothing+  , cfgImplicitModuleImport = True+  }+ defaultConfig :: Config defaultConfig = Config-  { cfgPreserveIt = False-  , cfgVerbose = False+  { cfgVerbose = False   , cfgModules = []   , cfgThreads = Nothing-  , cfgRandomizeOrder = False-  , cfgSeed = Nothing   , cfgQuiet = False+  , cfgModuleConfig = defaultModuleConfig   } +parseLocatedModuleOptions ::+  ModuleName ->+  ModuleConfig ->+  [Located String] ->+  Either (Location, String) ModuleConfig+parseLocatedModuleOptions _modName modConfig [] = Right modConfig+parseLocatedModuleOptions modName modConfig0 (Located loc o:os) =+  case parseModuleOption modConfig0 o of+    Nothing ->+      Left (loc, o)+    Just modConfig1 ->+      parseLocatedModuleOptions modName modConfig1 os++parseModuleOption :: ModuleConfig -> String -> Maybe ModuleConfig+parseModuleOption config arg =+  case arg of+    "--randomize-order" -> Just config{cfgRandomizeOrder=True}+    "--no-randomize-order" -> Just config{cfgRandomizeOrder=False}+    "--preserve-it" -> Just config{cfgPreserveIt=True}+    "--no-preserve-it" -> Just config{cfgPreserveIt=False}+    "--implicit-module-import" -> Just config{cfgImplicitModuleImport=True}+    "--no-implicit-module-import" -> Just config{cfgImplicitModuleImport=False}+    ('-':_) | Just n <- parseSeed arg -> Just config{cfgSeed=Just n}+    _ -> Nothing+ parseOptions :: [String] -> Result Config parseOptions = go defaultConfig  where@@ -110,12 +165,13 @@       "--help" -> ResultStdout usage       "--info" -> ResultStdout info       "--version" -> ResultStdout versionInfo-      "--randomize-order" -> go config{cfgRandomizeOrder=True} args-      "--preserve-it" -> go config{cfgPreserveIt=True} args       "--verbose" -> go config{cfgVerbose=True} args       "--quiet" -> go config{cfgQuiet=True} args-      ('-':_) | Just n <- parseSeed arg -> go config{cfgSeed=Just n} args       ('-':_) | Just n <- parseThreads arg -> go config{cfgThreads=Just n} args+      ('-':_)+        -- Module specific configuration options+        | Just modCfg <- parseModuleOption (cfgModuleConfig config) arg+       -> go config{cfgModuleConfig=modCfg} args       ('-':_) -> ResultStderr ("Unknown command line argument: " <> arg)       mod_ -> go config{cfgModules=mod_ : cfgModules config} args 

@@ -56,17 +56,19 @@  parseModules :: [Module (Located String)] -> [Module [Located DocTest]] parseModules = filter (not . isEmpty) . map parseModule-  where-    isEmpty (Module _ setup tests) = null tests && isNothing setup+ where+  isEmpty (Module _ setup tests _) = null tests && isNothing setup  -- | Convert documentation to `Example`s. parseModule :: Module (Located String) -> Module [Located DocTest]-parseModule m = case parseComment <$> m of-  Module name setup tests -> Module name setup_ (filter (not . null) tests)-    where-      setup_ = case setup of-        Just [] -> Nothing-        _       -> setup+parseModule m =+  case parseComment <$> m of+    Module name setup tests cfg ->+      Module name setup_ (filter (not . null) tests) cfg+      where+        setup_ = case setup of+          Just [] -> Nothing+          _       -> setup  parseComment :: Located String -> [Located DocTest] parseComment c = properties ++ examples

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NamedFieldPuns #-} @@ -13,7 +12,7 @@ import           Data.Foldable (forM_) import           Data.Function (on) import           Data.List (sortBy)-import           Data.Maybe (fromMaybe)+import           Data.Maybe (fromMaybe, maybeToList) import           GHC.Conc (numCapabilities) import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) import           System.Random (randoms, mkStdGen)@@ -25,9 +24,12 @@ import           Test.DocTest.Internal.Interpreter (Interpreter) import qualified Test.DocTest.Internal.Interpreter as Interpreter import           Test.DocTest.Internal.Parse-import           Test.DocTest.Internal.Options (ModuleName)+import           Test.DocTest.Internal.Options+  ( ModuleName, ModuleConfig (cfgPreserveIt), cfgSeed, cfgPreserveIt+  , cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions) import           Test.DocTest.Internal.Location-import           Test.DocTest.Internal.Property+import Test.DocTest.Internal.Property+    ( runProperty, PropertyResult(Failure, Success, Error) ) import           Test.DocTest.Internal.Runner.Example  import           System.IO.CodePage (withCP65001)@@ -69,14 +71,12 @@  -- | Run all examples from a list of modules. runModules-  :: Maybe Int+  :: ModuleConfig+  -- ^ Configuration options specific to module+  -> Maybe Int   -- ^ Number of threads to use. Defaults to 'numCapabilities'.   -> Bool-  -- ^ Preserve it-  -> Bool   -- ^ Verbose-  -> Maybe Int-  -- ^ If 'Just', use seed to randomize test order   -> Bool   -- ^ Implicit Prelude   -> [String]@@ -86,14 +86,14 @@   -> [Module [Located DocTest]]   -- ^ Modules under test   -> IO Summary-runModules nThreads preserveIt verbose seed implicitPrelude args quiet modules = do+runModules modConfig nThreads verbose implicitPrelude args quiet modules = do   isInteractive <- hIsTerminalDevice stderr    -- Start a thread pool. It sends status updates to this thread through 'output'.   (input, output) <-     makeThreadPool       (fromMaybe numCapabilities nThreads)-      (runModule preserveIt seed implicitPrelude args)+      (runModule modConfig implicitPrelude args)    -- Send instructions to threads   liftIO (mapM_ (writeChan input) modules)@@ -122,17 +122,18 @@     consumeUpdates output =<<       case update of         UpdateInternalError fs loc e -> reportInternalError fs loc e >> pure (modsLeft - 1)-        UpdateImportError modName -> reportImportError modName >> pure (modsLeft - 1)+        UpdateImportError modName result -> reportImportError modName result >> pure (modsLeft - 1)         UpdateSuccess fs loc -> reportSuccess fs loc >> 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)  -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int-count (Module _ _ tests) = sum (map length tests)+count (Module _ _ tests _) = sum (map length tests)  -- | A monad for generating test reports. type Report = StateT ReportState IO@@ -182,60 +183,83 @@  -- | Run all examples from given module. runModule-  :: Bool-  -> Maybe Int+  :: ModuleConfig   -> Bool   -> [String]   -> Chan ReportUpdate   -> Module [Located DocTest]   -> IO ()-runModule preserveIt (Just seed) implicitPrelude ghciArgs output (Module module_ setup examples) = do-  runModule-    preserveIt Nothing implicitPrelude ghciArgs output-    (Module module_ setup (shuffle seed examples))-runModule preserveIt Nothing implicitPrelude ghciArgs output (Module module_ setup examples) = do-  Interpreter.withInterpreter ghciArgs $ \repl -> withCP65001 $ do-    -- Try to import this module, if it fails, something is off-    importResult <- Interpreter.safeEval repl importModule-    case importResult of-      Right "" -> do-        -- Run setup group-        successes <- mapM (runTestGroup FromSetup preserveIt repl (reload repl) output) setup+runModule modConfig0 implicitPrelude ghciArgs output mod_ = do+  case modConfig2 of+    Left (loc, flag) ->+      writeChan output (UpdateOptionError loc flag) -        -- only run tests, if setup does not produce any errors/failures-        when-          (and successes)-          (mapM_ (runTestGroup NotFromSetup preserveIt repl (setup_ repl) output) examples)-      _ ->-        writeChan output (UpdateImportError module_)+    Right modConfig3 -> do+      let+        examples1+          | cfgRandomizeOrder modConfig3 = shuffle seed examples0+          | otherwise = examples0 -    -- Signal main thread a module has been tested-    writeChan output UpdateModuleDone+        importModule+          | cfgImplicitModuleImport modConfig3 = Just (":m +" ++ module_)+          | otherwise = Nothing -    pure ()+        preserveIt = cfgPreserveIt modConfig3+        seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already -  where-    importModule = ":m +" ++ module_+        reload repl = do+          void $ Interpreter.safeEval repl ":reload"+          mapM_ (Interpreter.safeEval repl) $+            if implicitPrelude+            then ":m Prelude" : maybeToList importModule+            else maybeToList importModule -    reload repl = do-      void $ Interpreter.safeEval repl ":reload"-      mapM_ (Interpreter.safeEval repl) $-        if implicitPrelude-        then [":m Prelude", importModule]-        else [":m +" ++ module_]+          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 $ "()" -      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 $ "()"+        setup_ repl = do+          reload repl+          forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of+            Property _  -> return ()+            Example e _ -> void $ safeEvalWith preserveIt repl e -    setup_ repl = do-      reload repl-      forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of-        Property _  -> return ()-        Example e _ -> void $ safeEvalWith preserveIt repl e +      Interpreter.withInterpreter 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++        case importResult of+          Right "" -> do+            -- Run setup group+            successes <-+              mapM+                (runTestGroup FromSetup preserveIt repl (reload repl) output)+                setup++            -- only run tests, if setup does not produce any errors/failures+            when+              (and successes)+              (mapM_+                (runTestGroup NotFromSetup preserveIt repl (setup_ repl) output)+                examples1)+          _ ->+            writeChan output (UpdateImportError module_ importResult)++  -- Signal main thread a module has been tested+  writeChan output UpdateModuleDone++  pure ()++ where+  Module module_ setup examples0 modArgs = mod_+  modConfig2 = parseLocatedModuleOptions module_ modConfig0 modArgs+ data ReportUpdate   = UpdateSuccess FromSetup Location   -- ^ Test succeeded@@ -251,8 +275,10 @@   -- ^ Indicate test has started executing (verbose output)   | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException   -- ^ Exception caught while executing internal code-  | UpdateImportError ModuleName+  | UpdateImportError ModuleName (Either String String)   -- ^ Could not import module+  | UpdateOptionError Location String+  -- ^ Unrecognized flag in module specific option  makeThreadPool ::   Int ->@@ -290,6 +316,12 @@   report ""   updateSummary fromSetup (Summary 0 1 1 0) +reportOptionError :: Location -> String -> Report ()+reportOptionError loc opt = do+  report (printf "%s: unrecognized option: %s. Try --help to see all options." (show loc) opt)+  report ""+  updateSummary FromSetup (Summary 0 1 1 0)+ reportInternalError :: FromSetup -> Module a -> SomeException -> Report () reportInternalError fs mod_ err = do   report (printf "Internal error when executing tests in %s" (moduleName mod_))@@ -297,11 +329,13 @@   report ""   updateSummary fs emptySummary{sErrors=1} -reportImportError :: ModuleName -> Report ()-reportImportError modName = do+reportImportError :: 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'."+  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'"@@ -315,6 +349,17 @@   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 ""+  case importResult of+    Left out -> do+      report "Unexpected output:"+      report out+    Right err -> do+      report "Error:"+      report err+   updateSummary FromSetup emptySummary{sErrors=1}  reportSuccess :: FromSetup -> Location -> Report ()

@@ -22,73 +22,96 @@ shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion (d, m) `shouldGive` expected = do   r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir </> m]-  r `shouldBe` expected-  where dir = "test/extract" </> d+  map eraseConfigLocation r `shouldBe` map eraseConfigLocation expected+ where+  dir = "test/extract" </> d  main :: IO () main = hspec spec  spec :: Spec spec = do+  let mod_ nm content = Module nm Nothing content []    describe "extract" $ do     it "extracts documentation for a top-level declaration" $ do-      ("declaration", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]]+      ("declaration", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]]      it "extracts documentation from argument list" $ do-      ("argument-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" doc for arg1", " doc for arg2"]]+      ("argument-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" doc for arg1", " doc for arg2"]]      it "extracts documentation for a type class function" $ do-      ("type-class", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Convert given value to a string."]]+      ("type-class", "Foo.hs") `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` [Module "Foo" Nothing [" foo", " bar"]]+      ("type-class-args", "Foo.hs") `shouldGive` [mod_ "Foo" [" foo", " bar"]]      it "extracts documentation from the module header" $ do-      ("module-header", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" Some documentation"]]+      ("module-header", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]]      it "extracts documentation from imported modules" $ do-      ("imported-module", "Bar.hs") `shouldGive` [Module "Bar" Nothing [" documentation for bar"], Module "Baz" Nothing [" documentation for baz"]]+      ("imported-module", "Bar.hs") `shouldGive` [mod_ "Bar" [" documentation for bar"], mod_ "Baz" [" documentation for baz"]]      it "extracts documentation from export list" $ do-      ("export-list", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" documentation from export list"]]+      ("export-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" documentation from export list"]]      it "extracts documentation from named chunks" $ do-      ("named-chunks", "Foo.hs") `shouldGive` [Module "Foo" Nothing [" named chunk foo", "\n named chunk bar"]]+      ("named-chunks", "Foo.hs") `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` [Module "Foo" Nothing [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]]+      ("comment-order", "Foo.hs") `shouldGive` [mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]]      it "extracts $setup code" $ do-      ("setup", "Foo.hs") `shouldGive` [Module "Foo" (Just "\n some setup code") [" foo", " bar", " baz"]]+      ("setup", "Foo.hs") `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)    describe "extract (regression tests)" $ do     it "works with infix operators" $ do-      ("regression", "Fixity.hs") `shouldGive` [Module "Fixity" Nothing []]+      ("regression", "Fixity.hs") `shouldGive` [mod_ "Fixity" []]      it "works with parallel list comprehensions" $ do-      ("regression", "ParallelListComp.hs") `shouldGive` [Module "ParallelListComp" Nothing []]+      ("regression", "ParallelListComp.hs") `shouldGive` [mod_ "ParallelListComp" []]      it "works with list comprehensions in instance definitions" $ do-      ("regression", "ParallelListCompClass.hs") `shouldGive` [Module "ParallelListCompClass" Nothing []]+      ("regression", "ParallelListCompClass.hs") `shouldGive` [mod_ "ParallelListCompClass" []]      it "works with foreign imports" $ do-      ("regression", "ForeignImport.hs") `shouldGive` [Module "ForeignImport" Nothing []]+      ("regression", "ForeignImport.hs") `shouldGive` [mod_ "ForeignImport" []]      it "works for rewrite rules" $ do-      ("regression", "RewriteRules.hs") `shouldGive` [Module "RewriteRules" Nothing [" doc for foo"]]+      ("regression", "RewriteRules.hs") `shouldGive` [mod_ "RewriteRules" [" doc for foo"]]      it "works for rewrite rules with type signatures" $ do-      ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [Module "RewriteRulesWithSigs" Nothing [" doc for foo"]]+      ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [mod_ "RewriteRulesWithSigs" [" doc for foo"]]      it "strips CR from dos line endings" $ do-      ("dos-line-endings", "Foo.hs") `shouldGive` [Module "Foo" Nothing ["\n foo\n bar\n baz"]]+      ("dos-line-endings", "Foo.hs") `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` [Module "Foo" Nothing [" some documentation"], Module "Bar" Nothing []]+      ("th", "Foo.hs") `shouldGive` [mod_ "Foo" [" some documentation"], mod_ "Bar" []]      it "works for type families and GHC 7.6.1" $ do-      ("type-families", "Foo.hs") `shouldGive` [Module "Foo" Nothing []]+      ("type-families", "Foo.hs") `shouldGive` [mod_ "Foo" []]++    it "ignores binder annotations" $ do+      ("module-options", "Binders.hs") `shouldGive` [mod_ "Binders" []]++    it "ignores module annotations that don't start with 'doctest-parallel:'" $ do+      ("module-options", "NoOptions.hs") `shouldGive` [mod_ "NoOptions" []]++    it "detects monomorphic module settings" $ do+      ("module-options", "Mono.hs") `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=+        [ noLocation "--no-randomize-error"+        ]}]

@@ -53,11 +53,11 @@         (cases 1)      it "it-variable" $ do-      doctestWithOpts (defaultConfig{cfgPreserveIt=True}) ["It.Foo"]+      doctestWithOpts (defaultConfig{cfgModuleConfig=defaultModuleConfig{cfgPreserveIt=True}}) ["It.Foo"]         (cases 5)      it "it-variable in $setup" $ do-      doctestWithOpts (defaultConfig{cfgPreserveIt=True}) ["It.Setup"]+      doctestWithOpts (defaultConfig{cfgModuleConfig=defaultModuleConfig{cfgPreserveIt=True}}) ["It.Setup"]         (cases 2)      it "failing" $ do@@ -176,3 +176,11 @@     it "correctly handles C import directories" $ do       doctest ["WithCInclude.Bar"]         (cases 1)++    it "sets module level options" $ do+      doctest ["ModuleOptions.Foo"]+        (cases 5)++    it "succeeds for non-exposed modules if --no-implicit-module-import is set" $ do+      doctest ["NonExposedModule.NoImplicitImport"]+        (cases 2)

@@ -13,11 +13,34 @@     describe "--preserve-it" $ do       context "without --preserve-it" $ do         it "does not preserve the `it` variable" $ do-          cfgPreserveIt <$> parseOptions [] `shouldBe` Result False+          cfgPreserveIt . cfgModuleConfig <$>+            parseOptions [] `shouldBe` Result False        context "with --preserve-it" $ do         it "preserves the `it` variable" $ do-          cfgPreserveIt <$> parseOptions ["--preserve-it"] `shouldBe` Result True+          cfgPreserveIt . cfgModuleConfig <$>+            parseOptions ["--preserve-it"] `shouldBe` Result True++      context "with --no-preserve-it" $ do+        it "preserves the `it` variable" $ do+          cfgPreserveIt . cfgModuleConfig <$>+            parseOptions ["--no-preserve-it"] `shouldBe` Result False++    describe "--randomize-order" $ do+      context "without --randomize-order" $ do+        it "does not set randomize order" $ do+          cfgRandomizeOrder . cfgModuleConfig <$>+            parseOptions [] `shouldBe` Result False++      context "with --randomize-order" $ do+        it "sets randomize order" $ do+          cfgRandomizeOrder . cfgModuleConfig <$>+            parseOptions ["--randomize-order"] `shouldBe` Result True++      context "with --no-randomize-order" $ do+        it "unsets randomize order" $ do+          cfgRandomizeOrder . cfgModuleConfig <$>+            parseOptions ["--no-randomize-order"] `shouldBe` Result False      context "with --help" $ do       it "outputs usage information" $ do

@@ -22,7 +22,7 @@ prop_ e = tell [Property e]  module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] ()-module_ name gs = tell [Module name Nothing $ execWriter gs]+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@@ -82,7 +82,7 @@      it "keeps modules that only contain setup code" $ do       getDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do-        tell [Module "Foo" (Just [Example "foo" ["23"]]) []]+        tell [Module "Foo" (Just [Example "foo" ["23"]]) [] []]    describe "parseInteractions (an internal function)" $ do 

@@ -0,0 +1,5 @@+module Binders where++{-# ANN f "doctest-parallel: --no-randomize-error" #-}+f :: a -> a+f = id

@@ -0,0 +1,8 @@+module Mono where++{-# ANN module "doctest-parallel: --no-randomize-error1" #-}+{-# ANN module ("doctest-parallel: --no-randomize-error2") #-}+{-# ANN module ("doctest-parallel: --no-randomize-error3"  ) #-}+{-# ANN module ("doctest-parallel:   --no-randomize-error4"  ) #-}+{-# ANN module ("doctest-parallel:   --no-randomize-error5   "  ) #-}+{-# ANN module ("doctest-parallel: --no-randomize-error6" :: String) #-}

@@ -0,0 +1,5 @@+module NoOptions where++{-# ANN module "doctest-parallel" #-}+{-# ANN module "abc" #-}+{-# ANN module "" #-}

@@ -0,0 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}++module Poly where++{-# ANN module ("doctest-parallel: --no-randomize-error" :: String) #-}

@@ -0,0 +1,22 @@+module ModuleOptions.Foo where++{-# ANN module "doctest-parallel: --preserve-it" #-}++-- |+--+-- >>> :t 'a'+-- 'a' :: Char+--+-- >>> "foo"+-- "foo"+--+-- >>> length it+-- 3+--+-- >>> it * it+-- 9+--+-- >>> :t it+-- it :: Int+--+foo = undefined

@@ -0,0 +1,3 @@+module NonExposedModule.Exposed (foo) where++import NonExposedModule.NoImplicitImport (foo)

@@ -0,0 +1,10 @@+module NonExposedModule.NoImplicitImport where++{-# ANN module "doctest-parallel: --no-implicit-module-import" #-}++-- |+-- >>> import NonExposedModule.Exposed (foo)+-- >>> foo 7+-- 14+foo :: Int -> Int+foo a = a + a