Add --randomize-order (#12)

CHANGES.markdown

@@ -1,6 +1,7 @@
 # 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 under [#11](https://github.com/martijnbastiaan/doctest-parallel/issues/11)
+  * Test order can be randomized using `--randomize-order`. Test order can be made deterministic by adding an optional `--seed=N` argument. Implemented in [#12](https://github.com/martijnbastiaan/doctest-parallel/pull/12)
 
 # 0.2
 Changes:

doctest-parallel.cabal

@@ -97,6 +97,7 @@ library
     , ghc-paths >=0.1.0.9
     , pretty
     , process
+    , random >= 1.2
     , syb >=0.3
     , transformers
     , unordered-containers

src/Test/DocTest.hs

@@ -12,6 +12,7 @@ module Test.DocTest
   -- * Internal
   , filterModules
   , isSuccess
+  , getSeed
   , run
   ) where
 
@@ -23,6 +24,7 @@ import qualified Data.Set as Set
 import           Control.Monad (unless)
 import           System.Exit (exitFailure)
 import           System.IO
+import           System.Random (randomIO)
 
 import qualified Control.Exception as E
 
@@ -113,6 +115,15 @@ filterModules wantedMods0 allMods0
   nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1)
   isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1
 
+getSeed :: Bool -> Maybe Int -> IO (Maybe Int)
+getSeed False _ = pure Nothing
+getSeed True (Just seed) = pure (Just seed)
+getSeed True Nothing = do
+  -- Using an abslute number to prevent copy+paste errors
+  seed <- abs <$> randomIO
+  putStrLn ("Using freshly generated seed to randomize test order: " <> show seed)
+  pure (Just seed)
+
 -- | Run doctest for given library and config. Produce a summary of all tests.
 run :: Library -> Config -> IO Summary
 run lib Config{..} = do
@@ -121,7 +132,10 @@ run lib Config{..} = do
     (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib
     evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"]
 
+  seed <- getSeed cfgRandomizeOrder cfgSeed
+
   -- get examples from Haddock comments
   allModules <- getDocTests (includeArgs ++ moduleArgs ++ otherGhciArgs)
-  let modules = filterModules cfgModules allModules
-  runModules cfgThreads cfgPreserveIt cfgVerbose implicitPrelude evalGhciArgs modules
+  runModules
+    cfgThreads cfgPreserveIt cfgVerbose seed implicitPrelude evalGhciArgs
+    (filterModules cfgModules allModules)

src/Test/DocTest/Internal/Options.hs

@@ -24,13 +24,15 @@ import           Text.Read (readMaybe)
 usage :: String
 usage = unlines [
     "Usage:"
-  , "  doctest [ --fast | --preserve-it | --verbose | -jN ]... [<module>]..."
+  , "  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                   use a specific seed to randomize test order"
   , "  --preserve-it            preserve the `it` variable between examples"
   , "  --verbose                print each test as it is run"
   , "  --help                   display this help and exit"
@@ -77,6 +79,12 @@ data Config = Config
   , cfgThreads :: Maybe Int
   -- ^ Number of threads to use. Defaults to autodetection based on the number
   -- of cores.
+  , 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.
   } deriving (Show, Eq)
 
 defaultConfig :: Config
@@ -85,6 +93,8 @@ defaultConfig = Config
   , cfgVerbose = False
   , cfgModules = []
   , cfgThreads = Nothing
+  , cfgRandomizeOrder = False
+  , cfgSeed = Nothing
   }
 
 parseOptions :: [String] -> Result Config
@@ -96,16 +106,55 @@ 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
-      ('-':'j':n0) | Just n1 <- parseThreads n0 -> go config{cfgThreads=Just n1} args
+      ('-':_) | Just n <- parseSeed arg -> go config{cfgSeed=Just n} args
+      ('-':_) | Just n <- parseThreads arg -> go config{cfgThreads=Just n} args
       ('-':_) -> ResultStderr ("Unknown command line argument: " <> arg)
       mod_ -> go config{cfgModules=mod_ : cfgModules config} args
 
+-- | Parse seed argument
+--
+-- >>> parseSeed "--seed=6"
+-- Just 6
+-- >>> parseSeed "--seeeed=6"
+-- Nothing
+--
+parseSeed :: String -> Maybe Int
+parseSeed arg = readMaybe =<< parseSpecificFlag arg "seed"
+
+
+-- | Parse number of threads argument
+--
+-- >>> parseThreads "-j6"
+-- Just 6
+-- >>> parseThreads "-j-2"
+-- Nothing
+-- >>> parseThreads "-jA"
+-- Nothing
+--
 parseThreads :: String -> Maybe Int
-parseThreads n0 = do
+parseThreads ('-':'j':n0) = do
   n1 <- readMaybe n0
   if n1 > 0 then Just n1 else Nothing
+parseThreads _ = Nothing
+
+-- | Parse a specific flag with a value, or return 'Nothing'
+--
+-- >>> parseSpecificFlag "--foo" "foo"
+-- Nothing
+-- >>> parseSpecificFlag "--foo=" "foo"
+-- Nothing
+-- >>> parseSpecificFlag "--foo=5" "foo"
+-- Just "5"
+-- >>> parseSpecificFlag "--foo=5" "bar"
+-- Nothing
+parseSpecificFlag :: String -> String -> Maybe String
+parseSpecificFlag arg flag = do
+  case parseFlag arg of
+    ('-':'-':f, value) | f == flag -> value
+    _ -> Nothing
 
 -- | Parse a flag into its flag and argument component.
 --
@@ -121,5 +170,5 @@ parseFlag :: String -> (String, Maybe String)
 parseFlag arg =
   case break (== '=') arg of
     (flag, ['=']) -> (flag, Nothing)
-    (flag, ('=':opt)) -> (flag, Just opt)
+    (flag, '=':opt) -> (flag, Just opt)
     (flag, _) -> (flag, Nothing)

src/Test/DocTest/Internal/Runner.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.DocTest.Internal.Runner where
 
@@ -8,11 +9,14 @@ import           Prelude hiding (putStr, putStrLn, error)
 import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO)
 import           Control.Exception (SomeException, catch)
 import           Control.Monad hiding (forM_)
-import           Data.Maybe (fromMaybe)
-import           Text.Printf (printf)
-import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
 import           Data.Foldable (forM_)
+import           Data.Function (on)
+import           Data.List (sortBy)
+import           Data.Maybe (fromMaybe)
 import           GHC.Conc (numCapabilities)
+import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
+import           System.Random (randoms, mkStdGen)
+import           Text.Printf (printf)
 
 import           Control.Monad.Trans.State
 import           Control.Monad.IO.Class
@@ -70,21 +74,23 @@ runModules
   -- ^ Preserve it
   -> Bool
   -- ^ Verbose
+  -> Maybe Int
+  -- ^ If 'Just', use seed to randomize test order
   -> Bool
   -- ^ Implicit Prelude
   -> [String]
   -- ^ Arguments passed to the GHCi process.
   -> [Module [Located DocTest]]
   -- ^ Modules under test
   -> IO Summary
-runModules nThreads preserveIt verbose implicitPrelude args modules = do
+runModules nThreads preserveIt verbose seed implicitPrelude args 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 implicitPrelude args)
+      (runModule preserveIt seed implicitPrelude args)
 
   -- Send instructions to threads
   liftIO (mapM_ (writeChan input) modules)
@@ -156,15 +162,27 @@ overwrite msg = do
           | otherwise = msg
   liftIO (hPutStr stderr str)
 
+-- | Shuffle a list given a seed for an RNG
+shuffle :: Int -> [a] -> [a]
+shuffle seed xs =
+    map snd
+  $ sortBy (compare `on` fst)
+  $ zip (randoms @Int (mkStdGen seed)) xs
+
 -- | Run all examples from given module.
 runModule
   :: Bool
+  -> Maybe Int
   -> Bool
   -> [String]
   -> Chan ReportUpdate
   -> Module [Located DocTest]
   -> IO ()
-runModule preserveIt implicitPrelude ghciArgs output (Module module_ setup examples) = do
+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

test/doctests.hs

@@ -4,4 +4,6 @@ import Test.DocTest (mainFromCabal)
 import System.Environment (getArgs)
 
 main :: IO ()
-main = mainFromCabal "doctest-parallel" =<< getArgs
+main = do
+  args <- getArgs
+  mainFromCabal "doctest-parallel" ("--randomize-order":args)