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
martijnbastiaan · Jan 5, 2022 · e72af01 · e72af01
1 parent 87ecf4f
commit e72af01
Show file tree

Hide file tree

Showing 19 changed files with 500 additions and 171 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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 ]... [<module>]...
+  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
@@ -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
@@ -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,50 +219,109 @@ 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
   `extQ` fromLDocDecl
   `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,15 +337,15 @@ extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl
       _ -> (extractDocStrings decl, True)
 
 
-    fromLDocDecl :: Selector
+    fromLDocDecl :: DocSelector
 #if __GLASGOW_HASKELL__ >= 901
                              (LDocDecl GhcPs)
 #else
                              LDocDecl
 #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)