From e72af0119bac4e474605da1c42609393ec104978 Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Wed, 5 Jan 2022 17:01:19 +0000 Subject: [PATCH] Add module level options Command-line options can now be overridden on a per-module basis by using a module annotation: {-# ANN module "doctest-parallel: --no-randomize-order" #-} Closes #19 --- CHANGES.markdown | 3 + README.markdown | 8 ++ doctest-parallel.cabal | 3 + example/README.md | 50 ++++++- src/Test/DocTest.hs | 23 +--- src/Test/DocTest/Internal/Extract.hs | 159 +++++++++++++++++------ src/Test/DocTest/Internal/Options.hs | 94 ++++++++++---- src/Test/DocTest/Internal/Parse.hs | 18 +-- src/Test/DocTest/Internal/Runner.hs | 141 +++++++++++--------- test/ExtractSpec.hs | 65 ++++++--- test/MainSpec.hs | 8 +- test/OptionsSpec.hs | 27 +++- test/ParseSpec.hs | 4 +- test/extract/module-options/Binders.hs | 5 + test/extract/module-options/Mono.hs | 8 ++ test/extract/module-options/NoOptions.hs | 5 + test/extract/module-options/Poly.hs | 5 + test/integration/ModuleOptions/Foo.hs | 22 ++++ test/integration/ModuleOptions/Setup.hs | 23 ++++ 19 files changed, 500 insertions(+), 171 deletions(-) create mode 100644 test/extract/module-options/Binders.hs create mode 100644 test/extract/module-options/Mono.hs create mode 100644 test/extract/module-options/NoOptions.hs create mode 100644 test/extract/module-options/Poly.hs create mode 100644 test/integration/ModuleOptions/Foo.hs create mode 100644 test/integration/ModuleOptions/Setup.hs diff --git a/CHANGES.markdown b/CHANGES.markdown index 928ec31..d65ba0b 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,6 @@ +# dev + * 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)) + # 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)) diff --git a/README.markdown b/README.markdown index 42db580..c848dd1 100644 --- a/README.markdown +++ b/README.markdown @@ -289,6 +289,14 @@ You _hide_ the import of `Prelude` by using: -- >>> :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 disabled it with: + +```haskell +{-# ANN module "--no-randomize-order" #-} +``` + + # 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: diff --git a/doctest-parallel.cabal b/doctest-parallel.cabal index c7c378d..526a1b5 100644 --- a/doctest-parallel.cabal +++ b/doctest-parallel.cabal @@ -40,6 +40,7 @@ extra-source-files: 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 +94,7 @@ library , deepseq , directory , exceptions + , extra , filepath , ghc >=8.4 && <9.3 , ghc-paths >=0.1.0.9 @@ -139,6 +141,7 @@ library spectests-modules LocalStderrBinding.A ModuleIsolation.TestA ModuleIsolation.TestB + ModuleOptions.Foo Multiline.Multiline PropertyBool.Foo PropertyBoolWithTypeSignature.Foo diff --git a/example/README.md b/example/README.md index ed8635e..9f4fa9c 100644 --- a/example/README.md +++ b/example/README.md @@ -43,7 +43,7 @@ main = mainFromCabal "your-project" =<< getArgs Execute: ``` -cabal run doctests -- arg1 arg2 +cabal run doctests ``` **At the moment, using `cabal test` is not reliable. See [#22](https://github.com/martijnbastiaan/doctest-parallel/issues/22).** @@ -52,5 +52,51 @@ cabal run doctests -- arg1 arg2 Stack users can use: ``` -stack test +stack test example:doctestsstack test +``` + +It will also run as part of `stack test`. + +# Help +Run: + +``` +cabal run doctests -- --help +``` + +Or: + +``` +stack test example:doctests --test-arguments --help +``` + +Example output: + +``` +Usage: + doctest [ options ]... []... + doctest --help + doctest --version + doctest --info + +Options: + -jN number of threads to use +† --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-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" #-} + ``` diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs index cac25d2..79555ce 100644 --- a/src/Test/DocTest.hs +++ b/src/Test/DocTest.hs @@ -12,7 +12,7 @@ module Test.DocTest -- * Internal , filterModules , isSuccess - , getSeed + , setSeed , run ) where @@ -115,23 +115,14 @@ filterModules wantedMods0 allMods0 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 @@ run lib Config{..} = do (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) diff --git a/src/Test/DocTest/Internal/Extract.hs b/src/Test/DocTest/Internal/Extract.hs index 00faaae..99dbd0b 100644 --- a/src/Test/DocTest/Internal/Extract.hs +++ b/src/Test/DocTest/Internal/Extract.hs @@ -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 Control.Monad.Catch (generalBracket) 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.Runtime.Loader (initializePlugins) 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 @@ data Module a = Module { 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 args = do -- | 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 - - -- 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) +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 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 @@ extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl `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 = everythingBut (++) (([], False) `mkQ` fromLHsDecl _ -> (extractDocStrings decl, True) - fromLDocDecl :: Selector + fromLDocDecl :: DocSelector #if __GLASGOW_HASKELL__ >= 901 (LDocDecl GhcPs) #else @@ -260,7 +345,7 @@ extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl #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) diff --git a/src/Test/DocTest/Internal/Options.hs b/src/Test/DocTest/Internal/Options.hs index 5cc12ce..462a778 100644 --- a/src/Test/DocTest/Internal/Options.hs +++ b/src/Test/DocTest/Internal/Options.hs @@ -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 Config as GHC 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,25 @@ usage = unlines [ , " 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" + , "† --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-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 +85,69 @@ type Warning = String 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) + } deriving (Show, Eq, Generic, NFData) + +defaultModuleConfig :: ModuleConfig +defaultModuleConfig = ModuleConfig + { cfgPreserveIt = False + , cfgRandomizeOrder = False + , cfgSeed = Nothing + } 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} + ('-':_) | Just n <- parseSeed arg -> Just config{cfgSeed=Just n} + _ -> Nothing + parseOptions :: [String] -> Result Config parseOptions = go defaultConfig where @@ -110,12 +157,13 @@ parseOptions = go defaultConfig "--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 diff --git a/src/Test/DocTest/Internal/Parse.hs b/src/Test/DocTest/Internal/Parse.hs index a7c58e7..fba3b77 100644 --- a/src/Test/DocTest/Internal/Parse.hs +++ b/src/Test/DocTest/Internal/Parse.hs @@ -56,17 +56,19 @@ getDocTests args = parseModules <$> extract args 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 diff --git a/src/Test/DocTest/Internal/Runner.hs b/src/Test/DocTest/Internal/Runner.hs index 0f2d71f..9e90630 100644 --- a/src/Test/DocTest/Internal/Runner.hs +++ b/src/Test/DocTest/Internal/Runner.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NamedFieldPuns #-} @@ -25,9 +24,12 @@ import Control.Monad.IO.Class 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, 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 @@ instance Semigroup Summary where -- | 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 @@ runModules -> [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) @@ -126,13 +126,14 @@ runModules nThreads preserveIt verbose seed implicitPrelude args quiet modules = 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,59 +183,75 @@ shuffle seed xs = -- | 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 - - -- 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_) - - -- Signal main thread a module has been tested - writeChan output UpdateModuleDone - - pure () +runModule modConfig0 implicitPrelude ghciArgs output mod_ = do + case modConfig2 of + Left (loc, flag) -> + writeChan output (UpdateOptionError loc flag) + + Right modConfig3 -> do + let + examples1 + | cfgRandomizeOrder modConfig3 = shuffle seed examples0 + | otherwise = examples0 + + preserveIt = cfgPreserveIt modConfig3 + seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already + + 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 $ "()" + + 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 <- Interpreter.safeEval repl importModule + 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_) + + -- Signal main thread a module has been tested + writeChan output UpdateModuleDone + + pure () - where - importModule = ":m +" ++ module_ - - 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 $ "()" - - setup_ repl = do - reload repl - forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of - Property _ -> return () - Example e _ -> void $ safeEvalWith preserveIt repl e + where + Module module_ setup examples0 modArgs = mod_ + modConfig2 = parseLocatedModuleOptions module_ modConfig0 modArgs + importModule = ":m +" ++ module_ data ReportUpdate = UpdateSuccess FromSetup Location @@ -253,6 +270,8 @@ data ReportUpdate -- ^ Exception caught while executing internal code | UpdateImportError ModuleName -- ^ Could not import module + | UpdateOptionError Location String + -- ^ Unrecognized flag in module specific option makeThreadPool :: Int -> @@ -290,6 +309,12 @@ reportError fromSetup loc expression err = do 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_)) diff --git a/test/ExtractSpec.hs b/test/ExtractSpec.hs index 7954a35..437f284 100644 --- a/test/ExtractSpec.hs +++ b/test/ExtractSpec.hs @@ -22,73 +22,96 @@ import System.FilePath 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" + ]}] diff --git a/test/MainSpec.hs b/test/MainSpec.hs index 9965c35..43a92ec 100644 --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -53,11 +53,11 @@ spec = do (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,7 @@ spec = do it "correctly handles C import directories" $ do doctest ["WithCInclude.Bar"] (cases 1) + + it "sets module level options" $ do + doctest ["ModuleOptions.Foo"] + (cases 5) diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs index b39d3d5..3357a68 100644 --- a/test/OptionsSpec.hs +++ b/test/OptionsSpec.hs @@ -13,11 +13,34 @@ spec = do 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 diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs index 2f501b0..ca6f732 100644 --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -22,7 +22,7 @@ prop_ :: Expression -> Writer [DocTest] () 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 @@ spec = do 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 diff --git a/test/extract/module-options/Binders.hs b/test/extract/module-options/Binders.hs new file mode 100644 index 0000000..9e55609 --- /dev/null +++ b/test/extract/module-options/Binders.hs @@ -0,0 +1,5 @@ +module Binders where + +{-# ANN f "doctest-parallel: --no-randomize-error" #-} +f :: a -> a +f = id diff --git a/test/extract/module-options/Mono.hs b/test/extract/module-options/Mono.hs new file mode 100644 index 0000000..017a5d1 --- /dev/null +++ b/test/extract/module-options/Mono.hs @@ -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) #-} diff --git a/test/extract/module-options/NoOptions.hs b/test/extract/module-options/NoOptions.hs new file mode 100644 index 0000000..d68228d --- /dev/null +++ b/test/extract/module-options/NoOptions.hs @@ -0,0 +1,5 @@ +module NoOptions where + +{-# ANN module "doctest-parallel" #-} +{-# ANN module "abc" #-} +{-# ANN module "" #-} diff --git a/test/extract/module-options/Poly.hs b/test/extract/module-options/Poly.hs new file mode 100644 index 0000000..e52d0b8 --- /dev/null +++ b/test/extract/module-options/Poly.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poly where + +{-# ANN module ("doctest-parallel: --no-randomize-error" :: String) #-} diff --git a/test/integration/ModuleOptions/Foo.hs b/test/integration/ModuleOptions/Foo.hs new file mode 100644 index 0000000..50a5d18 --- /dev/null +++ b/test/integration/ModuleOptions/Foo.hs @@ -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 diff --git a/test/integration/ModuleOptions/Setup.hs b/test/integration/ModuleOptions/Setup.hs new file mode 100644 index 0000000..6028dd4 --- /dev/null +++ b/test/integration/ModuleOptions/Setup.hs @@ -0,0 +1,23 @@ +module It.Setup where + +-- $setup +-- >>> :t 'a' +-- 'a' :: Char +-- +-- >>> 42 :: Int +-- 42 +-- +-- >>> it +-- 42 + +-- | +-- +-- >>> it * it +-- 1764 +foo = undefined + +-- | +-- +-- >>> it * it +-- 1764 +bar = undefined