{-# LANGUAGE CPP #-}
module Options (
  Result(..)
, Run(..)
, Config(..)
, defaultConfig
, parseOptions
#ifdef TEST
, defaultRun
, usage
, info
, versionInfo
, nonInteractiveGhcOptions
#endif
) where

import           Imports

import           Control.Monad.Trans.RWS (RWS, execRWS)
import qualified Control.Monad.Trans.RWS as RWS

import           Data.List (stripPrefix)

import           GHC.Paths (ghc)

import           Info

usage :: String
usage :: String
usage = [String] -> String
unlines [
    String
"Usage:"
  , String
"  doctest [ --fast | --preserve-it | --no-magic | --verbose | GHC OPTION | MODULE ]..."
  , String
"  doctest --help"
  , String
"  doctest --version"
  , String
"  doctest --info"
  , String
""
  , String
"Options:"
  , String
"  --fast         disable :reload between example groups"
  , String
"  --preserve-it  preserve the `it` variable between examples"
  , String
"  --verbose      print each test as it is run"
  , String
"  --help         display this help and exit"
  , String
"  --version      output version information and exit"
  , String
"  --info         output machine-readable version information and exit"
  ]

data Result a = ProxyToGhc [String] | Output String | Result a
  deriving (Result a -> Result a -> Bool
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 -> ShowS
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show, 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
<$ :: forall a b. a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: forall a b. (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor)

type Warning = String

data Run = Run {
  Run -> [String]
runWarnings :: [Warning]
, Run -> Bool
runMagicMode :: Bool
, Run -> Config
runConfig :: Config
} deriving (Run -> Run -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Run -> Run -> Bool
$c/= :: Run -> Run -> Bool
== :: Run -> Run -> Bool
$c== :: Run -> Run -> Bool
Eq, Int -> Run -> ShowS
[Run] -> ShowS
Run -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Run] -> ShowS
$cshowList :: [Run] -> ShowS
show :: Run -> String
$cshow :: Run -> String
showsPrec :: Int -> Run -> ShowS
$cshowsPrec :: Int -> Run -> ShowS
Show)

data Config = Config {
  Config -> [String]
ghcOptions :: [String]
, Config -> Bool
fastMode :: Bool
, Config -> Bool
preserveIt :: Bool
, Config -> Bool
verbose :: Bool
, Config -> (String, [String])
repl :: (String, [String])
} deriving (Config -> Config -> Bool
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, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config {
  ghcOptions :: [String]
ghcOptions = []
, fastMode :: Bool
fastMode = Bool
False
, preserveIt :: Bool
preserveIt = Bool
False
, verbose :: Bool
verbose = Bool
False
, repl :: (String, [String])
repl = (String
ghc, [String
"--interactive"])
}

nonInteractiveGhcOptions :: [String]
nonInteractiveGhcOptions :: [String]
nonInteractiveGhcOptions = [
    String
"--numeric-version"
  , String
"--supported-languages"
  , String
"--info"
  , String
"--print-global-package-db"
  , String
"--print-libdir"
  , String
"-c"
  , String
"-o"
  , String
"--make"
  , String
"--abi-hash"
  ]

defaultRun :: Run
defaultRun :: Run
defaultRun = Run {
  runWarnings :: [String]
runWarnings = []
, runMagicMode :: Bool
runMagicMode = Bool
False
, runConfig :: Config
runConfig = Config
defaultConfig
}

modifyWarnings :: ([String] -> [String]) -> Run -> Run
modifyWarnings :: ([String] -> [String]) -> Run -> Run
modifyWarnings [String] -> [String]
f Run
run = Run
run { runWarnings :: [String]
runWarnings = [String] -> [String]
f (Run -> [String]
runWarnings Run
run) }

setOptions :: [String] -> Run -> Run
setOptions :: [String] -> Run -> Run
setOptions [String]
ghcOptions run :: Run
run@Run{Bool
[String]
Config
runConfig :: Config
runMagicMode :: Bool
runWarnings :: [String]
runConfig :: Run -> Config
runMagicMode :: Run -> Bool
runWarnings :: Run -> [String]
..} = Run
run { runConfig :: Config
runConfig = Config
runConfig { [String]
ghcOptions :: [String]
ghcOptions :: [String]
ghcOptions } }

setMagicMode :: Bool -> Run -> Run
setMagicMode :: Bool -> Run -> Run
setMagicMode Bool
magic Run
run = Run
run { runMagicMode :: Bool
runMagicMode = Bool
magic }

setFastMode :: Bool -> Run -> Run
setFastMode :: Bool -> Run -> Run
setFastMode Bool
fastMode run :: Run
run@Run{Bool
[String]
Config
runConfig :: Config
runMagicMode :: Bool
runWarnings :: [String]
runConfig :: Run -> Config
runMagicMode :: Run -> Bool
runWarnings :: Run -> [String]
..} = Run
run { runConfig :: Config
runConfig = Config
runConfig { Bool
fastMode :: Bool
fastMode :: Bool
fastMode } }

setPreserveIt :: Bool -> Run -> Run
setPreserveIt :: Bool -> Run -> Run
setPreserveIt Bool
preserveIt run :: Run
run@Run{Bool
[String]
Config
runConfig :: Config
runMagicMode :: Bool
runWarnings :: [String]
runConfig :: Run -> Config
runMagicMode :: Run -> Bool
runWarnings :: Run -> [String]
..} = Run
run { runConfig :: Config
runConfig = Config
runConfig { Bool
preserveIt :: Bool
preserveIt :: Bool
preserveIt } }

setVerbose :: Bool -> Run -> Run
setVerbose :: Bool -> Run -> Run
setVerbose Bool
verbose run :: Run
run@Run{Bool
[String]
Config
runConfig :: Config
runMagicMode :: Bool
runWarnings :: [String]
runConfig :: Run -> Config
runMagicMode :: Run -> Bool
runWarnings :: Run -> [String]
..} = Run
run { runConfig :: Config
runConfig = Config
runConfig { Bool
verbose :: Bool
verbose :: Bool
verbose } }

parseOptions :: [String] -> Result Run
parseOptions :: [String] -> Result Run
parseOptions [String]
args
  | String -> Bool
on String
"--info" = forall a. String -> Result a
Output String
info
  | String -> Bool
on String
"--interactive" = [String] -> Run -> RunOptionsParser -> Result Run
runRunOptionsParser (String -> [String] -> [String]
discard String
"--interactive" [String]
args) Run
defaultRun forall a b. (a -> b) -> a -> b
$ do
      RunOptionsParser
commonRunOptions
  | String -> Bool
on forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String]
nonInteractiveGhcOptions = forall a. [String] -> Result a
ProxyToGhc [String]
args
  | String -> Bool
on String
"--help" = forall a. String -> Result a
Output String
usage
  | String -> Bool
on String
"--version" = forall a. String -> Result a
Output String
versionInfo
  | Bool
otherwise = [String] -> Run -> RunOptionsParser -> Result Run
runRunOptionsParser [String]
args Run
defaultRun {runMagicMode :: Bool
runMagicMode = Bool
True} forall a b. (a -> b) -> a -> b
$ do
      RunOptionsParser
commonRunOptions
      String -> (Run -> Run) -> RunOptionsParser
parseFlag String
"--no-magic" (Bool -> Run -> Run
setMagicMode Bool
False)
      RunOptionsParser
parseOptGhc
  where
    on :: String -> Bool
on String
option = String
option forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args

type RunOptionsParser = RWS () (Endo Run) [String] ()

runRunOptionsParser :: [String] -> Run -> RunOptionsParser -> Result Run
runRunOptionsParser :: [String] -> Run -> RunOptionsParser -> Result Run
runRunOptionsParser [String]
args Run
def RunOptionsParser
parse = case forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS RunOptionsParser
parse () [String]
args of
  ([String]
xs, Endo Run -> Run
setter) ->
    forall a. a -> Result a
Result ([String] -> Run -> Run
setOptions [String]
xs forall a b. (a -> b) -> a -> b
$ Run -> Run
setter Run
def)

commonRunOptions :: RunOptionsParser
commonRunOptions :: RunOptionsParser
commonRunOptions = do
  String -> (Run -> Run) -> RunOptionsParser
parseFlag String
"--fast" (Bool -> Run -> Run
setFastMode Bool
True)
  String -> (Run -> Run) -> RunOptionsParser
parseFlag String
"--preserve-it" (Bool -> Run -> Run
setPreserveIt Bool
True)
  String -> (Run -> Run) -> RunOptionsParser
parseFlag String
"--verbose" (Bool -> Run -> Run
setVerbose Bool
True)

parseFlag :: String -> (Run -> Run) -> RunOptionsParser
parseFlag :: String -> (Run -> Run) -> RunOptionsParser
parseFlag String
flag Run -> Run
setter = do
  [String]
args <- forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
flag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.tell (forall a. (a -> a) -> Endo a
Endo Run -> Run
setter)
  forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.put (String -> [String] -> [String]
discard String
flag [String]
args)

parseOptGhc :: RunOptionsParser
parseOptGhc :: RunOptionsParser
parseOptGhc = do
  Bool
issueWarning <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> (a, s)) -> RWST r w s m a
RWS.state [String] -> (Bool, [String])
go
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
issueWarning forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.tell forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ ([String] -> [String]) -> Run -> Run
modifyWarnings (forall a. [a] -> [a] -> [a]
++ [String
warning])
  where
    go :: [String] -> (Bool, [String])
go [String]
args = case [String]
args of
      [] -> (Bool
False, [])
      String
"--optghc" : String
opt : [String]
rest -> (Bool
True, String
opt forall a. a -> [a] -> [a]
: forall a b. (a, b) -> b
snd ([String] -> (Bool, [String])
go [String]
rest))
      String
opt : [String]
rest -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
opt forall a. a -> [a] -> [a]
:)) (\String
x (Bool
_, [String]
xs) -> (Bool
True, String
x forall a. a -> [a] -> [a]
: [String]
xs)) (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"--optghc=" String
opt) ([String] -> (Bool, [String])
go [String]
rest)

    warning :: String
warning = String
"WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."

discard :: String -> [String] -> [String]
discard :: String -> [String] -> [String]
discard String
flag = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
flag)