{-# 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           Text.Read (readMaybe)

import qualified Paths_doctest_parallel
import           Data.Version (showVersion)

#if __GLASGOW_HASKELL__ < 900
import           Config as GHC
#else
import           GHC.Settings.Config as GHC
#endif

import           Test.DocTest.Internal.Location (Located (Located), Location)
import           Test.DocTest.Internal.Interpreter (ghc)
import           Test.DocTest.Internal.Logging (LogLevel(..))
import qualified Test.DocTest.Internal.Logging as Logging

usage :: String
usage :: String
usage = [String] -> String
unlines [
    String
"Usage:"
  , String
"  doctest [ options ]... [<module>]..."
  , String
"  doctest --help"
  , String
"  doctest --version"
  , String
"  doctest --info"
  , String
""
  , String
"Options:"
  , String
"   -jN                      number of threads to use"
  , String
"   --log-level=LEVEL        one of: debug, verbose, info, warning, error. Default: info."
  , String
"†  --implicit-module-import import module before testing it (default)"
  , String
"†  --randomize-order        randomize order in which tests are run"
  , String
"†  --seed=N                 use a specific seed to randomize test order"
  , String
"†  --preserve-it            preserve the `it` variable between examples"
  , String
"   --nix                    account for Nix build environments (default)"
  , String
"   --quiet                  set log level to `Error`, shorthand for `--log-level=error`"
  , String
"   --verbose                set log level to `Verbose`, shorthand for `--log-level=verbose`"
  , String
"   --debug                  set log level to `Debug`, shorthand for `--log-level=debug`"
  , String
"   --help                   display this help and exit"
  , String
"   --version                output version information and exit"
  , String
"   --info                   output machine-readable version information and exit"
  , String
""
  , String
"Supported inverted options:"
  , String
"   --no-nix"
  , String
"†  --no-implicit-module-import"
  , String
"†  --no-randomize-order (default)"
  , String
"†  --no-preserve-it (default)"
  , String
""
  , String
"Options marked with a dagger (†) can also be used to set module level options, using"
  , String
"an ANN pragma like this:"
  , String
""
  , String
"  {-# ANN module \"doctest-parallel: --no-randomize-order\" #-} "
  , String
""
  ]

version :: String
version :: String
version = Version -> String
showVersion Version
Paths_doctest_parallel.version

ghcVersion :: String
ghcVersion :: String
ghcVersion = String
GHC.cProjectVersion

versionInfo :: String
versionInfo :: String
versionInfo = [String] -> String
unlines [
    String
"doctest version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
version
  , String
"using version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ghcVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of the GHC API"
  , String
"using " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ghc
  ]

info :: String
info :: String
info = String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n, " ([String] -> String)
-> ([(String, String)] -> [String]) -> [(String, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a. Show a => a -> String
show ([(String, String)] -> String) -> [(String, String)] -> String
forall a b. (a -> b) -> a -> b
$ [
    (String
"version", String
version)
  , (String
"ghc_version", String
ghcVersion)
  , (String
"ghc", String
ghc)
  ]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n]\n"

data Result a
  = ResultStderr String
  | ResultStdout String
  | Result a
  deriving (Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq, Int -> Result a -> String -> String
[Result a] -> String -> String
Result a -> String
(Int -> Result a -> String -> String)
-> (Result a -> String)
-> ([Result a] -> String -> String)
-> Show (Result a)
forall a. Show a => Int -> Result a -> String -> String
forall a. Show a => [Result a] -> String -> String
forall a. Show a => Result a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Result a] -> String -> String
$cshowList :: forall a. Show a => [Result a] -> String -> String
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Result a -> String -> String
Show, a -> Result b -> Result a
(a -> b) -> Result a -> Result b
(forall a b. (a -> b) -> Result a -> Result b)
-> (forall a b. a -> Result b -> Result a) -> Functor Result
forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor)

type Warning = String
type ModuleName = String

data Config = Config
  { Config -> LogLevel
cfgLogLevel :: LogLevel
  -- ^ Verbosity level.
  , Config -> [String]
cfgModules :: [ModuleName]
  -- ^ Module names to test. An empty list means "test all modules".
  , Config -> Maybe Int
cfgThreads :: Maybe Int
  -- ^ Number of threads to use. Defaults to autodetection based on the number
  -- of cores.
  , Config -> ModuleConfig
cfgModuleConfig :: ModuleConfig
  -- ^ Options specific to modules
  , Config -> Bool
cfgNix :: Bool
  -- ^ Detect Nix build environment and try to make GHC aware of the local package
  -- being tested.
  } deriving (Int -> Config -> String -> String
[Config] -> String -> String
Config -> String
(Int -> Config -> String -> String)
-> (Config -> String)
-> ([Config] -> String -> String)
-> Show Config
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Config] -> String -> String
$cshowList :: [Config] -> String -> String
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> String -> String
$cshowsPrec :: Int -> Config -> String -> String
Show, Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, (forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generic, Config -> ()
(Config -> ()) -> NFData Config
forall a. (a -> ()) -> NFData a
rnf :: Config -> ()
$crnf :: Config -> ()
NFData)

data ModuleConfig = ModuleConfig
  { ModuleConfig -> Bool
cfgPreserveIt :: Bool
  -- ^ Preserve the @it@ variable between examples (default: @False@)
  , ModuleConfig -> Bool
cfgRandomizeOrder :: Bool
  -- ^ Randomize the order in which test cases in a module are run (default: @False@)
  , ModuleConfig -> Maybe Int
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.
  , ModuleConfig -> Bool
cfgImplicitModuleImport :: Bool
  -- ^ Import a module before testing it. Can be disabled to enabled to test
  -- non-exposed modules.
  } deriving (Int -> ModuleConfig -> String -> String
[ModuleConfig] -> String -> String
ModuleConfig -> String
(Int -> ModuleConfig -> String -> String)
-> (ModuleConfig -> String)
-> ([ModuleConfig] -> String -> String)
-> Show ModuleConfig
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ModuleConfig] -> String -> String
$cshowList :: [ModuleConfig] -> String -> String
show :: ModuleConfig -> String
$cshow :: ModuleConfig -> String
showsPrec :: Int -> ModuleConfig -> String -> String
$cshowsPrec :: Int -> ModuleConfig -> String -> String
Show, ModuleConfig -> ModuleConfig -> Bool
(ModuleConfig -> ModuleConfig -> Bool)
-> (ModuleConfig -> ModuleConfig -> Bool) -> Eq ModuleConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleConfig -> ModuleConfig -> Bool
$c/= :: ModuleConfig -> ModuleConfig -> Bool
== :: ModuleConfig -> ModuleConfig -> Bool
$c== :: ModuleConfig -> ModuleConfig -> Bool
Eq, (forall x. ModuleConfig -> Rep ModuleConfig x)
-> (forall x. Rep ModuleConfig x -> ModuleConfig)
-> Generic ModuleConfig
forall x. Rep ModuleConfig x -> ModuleConfig
forall x. ModuleConfig -> Rep ModuleConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ModuleConfig x -> ModuleConfig
$cfrom :: forall x. ModuleConfig -> Rep ModuleConfig x
Generic, ModuleConfig -> ()
(ModuleConfig -> ()) -> NFData ModuleConfig
forall a. (a -> ()) -> NFData a
rnf :: ModuleConfig -> ()
$crnf :: ModuleConfig -> ()
NFData)

defaultModuleConfig :: ModuleConfig
defaultModuleConfig :: ModuleConfig
defaultModuleConfig = ModuleConfig :: Bool -> Bool -> Maybe Int -> Bool -> ModuleConfig
ModuleConfig
  { cfgPreserveIt :: Bool
cfgPreserveIt = Bool
False
  , cfgRandomizeOrder :: Bool
cfgRandomizeOrder = Bool
False
  , cfgSeed :: Maybe Int
cfgSeed = Maybe Int
forall a. Maybe a
Nothing
  , cfgImplicitModuleImport :: Bool
cfgImplicitModuleImport = Bool
True
  }

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config :: LogLevel -> [String] -> Maybe Int -> ModuleConfig -> Bool -> Config
Config
  { cfgModules :: [String]
cfgModules = []
  , cfgThreads :: Maybe Int
cfgThreads = Maybe Int
forall a. Maybe a
Nothing
  , cfgLogLevel :: LogLevel
cfgLogLevel = LogLevel
Info
  , cfgModuleConfig :: ModuleConfig
cfgModuleConfig = ModuleConfig
defaultModuleConfig
  , cfgNix :: Bool
cfgNix = Bool
True
  }

parseLocatedModuleOptions ::
  ModuleName ->
  ModuleConfig ->
  [Located String] ->
  Either (Location, String) ModuleConfig
parseLocatedModuleOptions :: String
-> ModuleConfig
-> [Located String]
-> Either (Location, String) ModuleConfig
parseLocatedModuleOptions String
_modName ModuleConfig
modConfig [] = ModuleConfig -> Either (Location, String) ModuleConfig
forall a b. b -> Either a b
Right ModuleConfig
modConfig
parseLocatedModuleOptions String
modName ModuleConfig
modConfig0 (Located Location
loc String
o:[Located String]
os) =
  case ModuleConfig -> String -> Maybe ModuleConfig
parseModuleOption ModuleConfig
modConfig0 String
o of
    Maybe ModuleConfig
Nothing ->
      (Location, String) -> Either (Location, String) ModuleConfig
forall a b. a -> Either a b
Left (Location
loc, String
o)
    Just ModuleConfig
modConfig1 ->
      String
-> ModuleConfig
-> [Located String]
-> Either (Location, String) ModuleConfig
parseLocatedModuleOptions String
modName ModuleConfig
modConfig1 [Located String]
os

parseModuleOption :: ModuleConfig -> String -> Maybe ModuleConfig
parseModuleOption :: ModuleConfig -> String -> Maybe ModuleConfig
parseModuleOption ModuleConfig
config String
arg =
  case String
arg of
    String
"--randomize-order" -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgRandomizeOrder :: Bool
cfgRandomizeOrder=Bool
True}
    String
"--no-randomize-order" -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgRandomizeOrder :: Bool
cfgRandomizeOrder=Bool
False}
    String
"--preserve-it" -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgPreserveIt :: Bool
cfgPreserveIt=Bool
True}
    String
"--no-preserve-it" -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgPreserveIt :: Bool
cfgPreserveIt=Bool
False}
    String
"--implicit-module-import" -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgImplicitModuleImport :: Bool
cfgImplicitModuleImport=Bool
True}
    String
"--no-implicit-module-import" -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgImplicitModuleImport :: Bool
cfgImplicitModuleImport=Bool
False}
    (Char
'-':String
_) | Just Int
n <- String -> Maybe Int
parseSeed String
arg -> ModuleConfig -> Maybe ModuleConfig
forall a. a -> Maybe a
Just ModuleConfig
config{cfgSeed :: Maybe Int
cfgSeed=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n}
    String
_ -> Maybe ModuleConfig
forall a. Maybe a
Nothing

parseOptions :: [String] -> Result Config
parseOptions :: [String] -> Result Config
parseOptions = Config -> [String] -> Result Config
go Config
defaultConfig
 where
  go :: Config -> [String] -> Result Config
go Config
config [] = Config -> Result Config
forall a. a -> Result a
Result Config
config
  go Config
config (String
arg:[String]
args) =
    case String
arg of
      String
"--help" -> String -> Result Config
forall a. String -> Result a
ResultStdout String
usage
      String
"--info" -> String -> Result Config
forall a. String -> Result a
ResultStdout String
info
      String
"--version" -> String -> Result Config
forall a. String -> Result a
ResultStdout String
versionInfo
      String
"--quiet" -> Config -> [String] -> Result Config
go Config
config{cfgLogLevel :: LogLevel
cfgLogLevel=LogLevel
Error} [String]
args
      String
"--verbose" -> Config -> [String] -> Result Config
go Config
config{cfgLogLevel :: LogLevel
cfgLogLevel=LogLevel
Verbose} [String]
args
      String
"--debug" -> Config -> [String] -> Result Config
go Config
config{cfgLogLevel :: LogLevel
cfgLogLevel=LogLevel
Debug} [String]
args
      String
"--nix" -> Config -> [String] -> Result Config
go Config
config{cfgNix :: Bool
cfgNix=Bool
True} [String]
args
      String
"--no-nix" -> Config -> [String] -> Result Config
go Config
config{cfgNix :: Bool
cfgNix=Bool
False} [String]
args
      (Char
'-':String
_) | Just Int
n <- String -> Maybe Int
parseThreads String
arg -> Config -> [String] -> Result Config
go Config
config{cfgThreads :: Maybe Int
cfgThreads=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n} [String]
args
      (Char
'-':String
_) | Just LogLevel
l <- String -> Maybe LogLevel
parseLogLevel String
arg -> Config -> [String] -> Result Config
go Config
config{cfgLogLevel :: LogLevel
cfgLogLevel=LogLevel
l} [String]
args
      (Char
'-':String
_)
        -- Module specific configuration options
        | Just ModuleConfig
modCfg <- ModuleConfig -> String -> Maybe ModuleConfig
parseModuleOption (Config -> ModuleConfig
cfgModuleConfig Config
config) String
arg
       -> Config -> [String] -> Result Config
go Config
config{cfgModuleConfig :: ModuleConfig
cfgModuleConfig=ModuleConfig
modCfg} [String]
args
      (Char
'-':String
_) -> String -> Result Config
forall a. String -> Result a
ResultStderr (String
"Unknown command line argument: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
arg)
      String
mod_ -> Config -> [String] -> Result Config
go Config
config{cfgModules :: [String]
cfgModules=String
mod_ String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Config -> [String]
cfgModules Config
config} [String]
args

-- | Parse seed argument
--
-- >>> parseSeed "--seed=6"
-- Just 6
-- >>> parseSeed "--seeeed=6"
-- Nothing
--
parseSeed :: String -> Maybe Int
parseSeed :: String -> Maybe Int
parseSeed String
arg = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> Maybe String
parseSpecificFlag String
arg String
"seed"

-- | Parse seed argument
--
-- >>> parseLogLevel "--log-level=Debug"
-- Just Debug
-- >>> parseLogLevel "--log-level=debug"
-- Just Debug
-- >>> parseSeed "---log-level=debug"
-- Nothing
parseLogLevel  :: String -> Maybe LogLevel
parseLogLevel :: String -> Maybe LogLevel
parseLogLevel String
arg = String -> Maybe LogLevel
Logging.parseLogLevel (String -> Maybe LogLevel) -> Maybe String -> Maybe LogLevel
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> Maybe String
parseSpecificFlag String
arg String
"log-level"

-- | Parse number of threads argument
--
-- >>> parseThreads "-j6"
-- Just 6
-- >>> parseThreads "-j-2"
-- Nothing
-- >>> parseThreads "-jA"
-- Nothing
--
parseThreads :: String -> Maybe Int
parseThreads :: String -> Maybe Int
parseThreads (Char
'-':Char
'j':String
n0) = do
  Int
n1 <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
n0
  if Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n1 else Maybe Int
forall a. Maybe a
Nothing
parseThreads String
_ = Maybe Int
forall a. Maybe a
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 :: String -> String -> Maybe String
parseSpecificFlag String
arg String
flag = do
  case String -> (String, Maybe String)
parseFlag String
arg of
    (Char
'-':Char
'-':String
f, Maybe String
value) | String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
flag -> Maybe String
value
    (String, Maybe String)
_ -> Maybe String
forall a. Maybe a
Nothing

-- | Parse a flag into its flag and argument component.
--
-- Example:
--
-- >>> parseFlag "--optghc=foo"
-- ("--optghc",Just "foo")
-- >>> parseFlag "--optghc="
-- ("--optghc",Nothing)
-- >>> parseFlag "--fast"
-- ("--fast",Nothing)
parseFlag :: String -> (String, Maybe String)
parseFlag :: String -> (String, Maybe String)
parseFlag String
arg =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') String
arg of
    (String
flag, [Char
'=']) -> (String
flag, Maybe String
forall a. Maybe a
Nothing)
    (String
flag, Char
'=':String
opt) -> (String
flag, String -> Maybe String
forall a. a -> Maybe a
Just String
opt)
    (String
flag, String
_) -> (String
flag, Maybe String
forall a. Maybe a
Nothing)