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

type Warning = String

data Run = Run {
  Run -> [String]
runWarnings :: [Warning]
, Run -> Bool
runMagicMode :: Bool
, Run -> Config
runConfig :: Config
} deriving (Run -> Run -> Bool
(Run -> Run -> Bool) -> (Run -> Run -> Bool) -> Eq Run
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Run -> Run -> Bool
== :: Run -> Run -> Bool
$c/= :: Run -> Run -> Bool
/= :: Run -> Run -> Bool
Eq, Int -> Run -> ShowS
[Run] -> ShowS
Run -> String
(Int -> Run -> ShowS)
-> (Run -> String) -> ([Run] -> ShowS) -> Show Run
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Run -> ShowS
showsPrec :: Int -> Run -> ShowS
$cshow :: Run -> String
show :: Run -> String
$cshowList :: [Run] -> ShowS
showList :: [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
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [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
runWarnings :: Run -> [String]
runMagicMode :: Run -> Bool
runConfig :: Run -> Config
runWarnings :: [String]
runMagicMode :: Bool
runConfig :: Config
..} = 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
runWarnings :: Run -> [String]
runMagicMode :: Run -> Bool
runConfig :: Run -> Config
runWarnings :: [String]
runMagicMode :: Bool
runConfig :: Config
..} = 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
runWarnings :: Run -> [String]
runMagicMode :: Run -> Bool
runConfig :: Run -> Config
runWarnings :: [String]
runMagicMode :: Bool
runConfig :: Config
..} = 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
runWarnings :: Run -> [String]
runMagicMode :: Run -> Bool
runConfig :: Run -> Config
runWarnings :: [String]
runMagicMode :: Bool
runConfig :: Config
..} = 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" = String -> Result Run
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 (RunOptionsParser -> Result Run) -> RunOptionsParser -> Result Run
forall a b. (a -> b) -> a -> b
$ do
      RunOptionsParser
commonRunOptions
  | String -> Bool
on (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [String]
nonInteractiveGhcOptions = [String] -> Result Run
forall a. [String] -> Result a
ProxyToGhc [String]
args
  | String -> Bool
on String
"--help" = String -> Result Run
forall a. String -> Result a
Output String
usage
  | String -> Bool
on String
"--version" = String -> Result Run
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} (RunOptionsParser -> Result Run) -> RunOptionsParser -> Result Run
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 String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 RunOptionsParser -> () -> [String] -> ([String], Endo Run)
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) ->
    Run -> Result Run
forall a. a -> Result a
Result ([String] -> Run -> Run
setOptions [String]
xs (Run -> Run) -> Run -> Run
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 <- RWST () (Endo Run) [String] Identity [String]
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
  Bool -> RunOptionsParser -> RunOptionsParser
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
flag String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args) (RunOptionsParser -> RunOptionsParser)
-> RunOptionsParser -> RunOptionsParser
forall a b. (a -> b) -> a -> b
$
    Endo Run -> RunOptionsParser
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.tell ((Run -> Run) -> Endo Run
forall a. (a -> a) -> Endo a
Endo Run -> Run
setter)
  [String] -> RunOptionsParser
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 <- ([String] -> (Bool, [String]))
-> RWST () (Endo Run) [String] Identity Bool
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
  Bool -> RunOptionsParser -> RunOptionsParser
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
issueWarning (RunOptionsParser -> RunOptionsParser)
-> RunOptionsParser -> RunOptionsParser
forall a b. (a -> b) -> a -> b
$
    Endo Run -> RunOptionsParser
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.tell (Endo Run -> RunOptionsParser) -> Endo Run -> RunOptionsParser
forall a b. (a -> b) -> a -> b
$ (Run -> Run) -> Endo Run
forall a. (a -> a) -> Endo a
Endo ((Run -> Run) -> Endo Run) -> (Run -> Run) -> Endo Run
forall a b. (a -> b) -> a -> b
$ ([String] -> [String]) -> Run -> Run
modifyWarnings ([String] -> [String] -> [String]
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 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Bool, [String]) -> [String]
forall a b. (a, b) -> b
snd ([String] -> (Bool, [String])
go [String]
rest))
      String
opt : [String]
rest -> ((Bool, [String]) -> (Bool, [String]))
-> (String -> (Bool, [String]) -> (Bool, [String]))
-> Maybe String
-> (Bool, [String])
-> (Bool, [String])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([String] -> [String]) -> (Bool, [String]) -> (Bool, [String])
forall a b. (a -> b) -> (Bool, a) -> (Bool, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
opt String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) (\String
x (Bool
_, [String]
xs) -> (Bool
True, String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)) (String -> String -> Maybe String
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 = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
flag)