Skip to content

Commit

Permalink
Add module level options
Browse files Browse the repository at this point in the history
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
  • Loading branch information
martijnbastiaan committed Jan 5, 2022
1 parent 87ecf4f commit e72af01
Show file tree
Hide file tree
Showing 19 changed files with 500 additions and 171 deletions.
3 changes: 3 additions & 0 deletions CHANGES.markdown
Original file line number Diff line number Diff line change
@@ -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))
Expand Down
8 changes: 8 additions & 0 deletions README.markdown
Original file line number Diff line number Diff line change
Expand Up @@ -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:

Expand Down
3 changes: 3 additions & 0 deletions doctest-parallel.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -93,6 +94,7 @@ library
, deepseq
, directory
, exceptions
, extra
, filepath
, ghc >=8.4 && <9.3
, ghc-paths >=0.1.0.9
Expand Down Expand Up @@ -139,6 +141,7 @@ library spectests-modules
LocalStderrBinding.A
ModuleIsolation.TestA
ModuleIsolation.TestB
ModuleOptions.Foo
Multiline.Multiline
PropertyBool.Foo
PropertyBoolWithTypeSignature.Foo
Expand Down
50 changes: 48 additions & 2 deletions example/README.md
Original file line number Diff line number Diff line change
Expand Up @@ -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).**
Expand All @@ -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" #-}
```
23 changes: 7 additions & 16 deletions src/Test/DocTest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@ module Test.DocTest
-- * Internal
, filterModules
, isSuccess
, getSeed
, setSeed
, run
) where

Expand Down Expand Up @@ -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
Expand All @@ -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)
159 changes: 122 additions & 37 deletions src/Test/DocTest/Internal/Extract.hs
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down
Loading

0 comments on commit e72af01

Please sign in to comment.