{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
module Options (
  Result(..)
, Run(..)
, defaultMagic
, defaultFastMode
, defaultPreserveIt
, defaultVerbose
, parseOptions
#ifdef TEST
, usage
, info
, versionInfo
, nonInteractiveGhcOptions
#endif
) where

import           Prelude ()
import           Prelude.Compat

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

import           Control.Monad (when)
import           Data.List.Compat (stripPrefix)
import           Data.Monoid (Endo (Endo))

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 = RunGhc [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 -> [String]
runOptions :: [String]
, Run -> Bool
runMagicMode :: Bool
, Run -> Bool
runFastMode :: Bool
, Run -> Bool
runPreserveIt :: Bool
, Run -> Bool
runVerbose :: Bool
} 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)

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"
  ]

defaultMagic :: Bool
defaultMagic :: Bool
defaultMagic = Bool
True

defaultFastMode :: Bool
defaultFastMode :: Bool
defaultFastMode = Bool
False

defaultPreserveIt :: Bool
defaultPreserveIt :: Bool
defaultPreserveIt = Bool
False

defaultVerbose :: Bool
defaultVerbose :: Bool
defaultVerbose = Bool
False

defaultRun :: Run
defaultRun :: Run
defaultRun = Run {
  runWarnings :: [String]
runWarnings = []
, runOptions :: [String]
runOptions = []
, runMagicMode :: Bool
runMagicMode = Bool
defaultMagic
, runFastMode :: Bool
runFastMode = Bool
defaultFastMode
, runPreserveIt :: Bool
runPreserveIt = Bool
defaultPreserveIt
, runVerbose :: Bool
runVerbose = Bool
defaultVerbose
}

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]
opts Run
run = Run
run { runOptions :: [String]
runOptions = [String]
opts }

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
fast Run
run = Run
run { runFastMode :: Bool
runFastMode = Bool
fast }

setPreserveIt :: Bool -> Run -> Run
setPreserveIt :: Bool -> Run -> Run
setPreserveIt Bool
preserveIt Run
run = Run
run { runPreserveIt :: Bool
runPreserveIt = Bool
preserveIt }

setVerbose :: Bool -> Run -> Run
setVerbose :: Bool -> Run -> Run
setVerbose Bool
verbose Run
run = Run
run { runVerbose :: Bool
runVerbose = Bool
verbose }

parseOptions :: [String] -> Result Run
parseOptions :: [String] -> Result Run
parseOptions [String]
args
  | String
"--info" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args = String -> Result Run
forall a. String -> Result a
Output String
info
  | String
"--interactive" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args = Run -> Result Run
forall a. a -> Result a
Result Run {
        runWarnings :: [String]
runWarnings = []
      , runOptions :: [String]
runOptions = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"--interactive") [String]
args
      , runMagicMode :: Bool
runMagicMode = Bool
False
      , runFastMode :: Bool
runFastMode = Bool
False
      , runPreserveIt :: Bool
runPreserveIt = Bool
False
      , runVerbose :: Bool
runVerbose = Bool
False
      }
  | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nonInteractiveGhcOptions) [String]
args = [String] -> Result Run
forall a. [String] -> Result a
RunGhc [String]
args
  | String
"--help" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args = String -> Result Run
forall a. String -> Result a
Output String
usage
  | String
"--version" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args = String -> Result Run
forall a. String -> Result a
Output String
versionInfo
  | Bool
otherwise = case RWS () (Endo Run) [String] ()
-> () -> [String] -> ([String], Endo Run)
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS RWS () (Endo Run) [String] ()
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
defaultRun)
    where
      parse :: RWS () (Endo Run) [String] ()
      parse :: RWS () (Endo Run) [String] ()
parse = do
        RWS () (Endo Run) [String] ()
stripNoMagic
        RWS () (Endo Run) [String] ()
stripFast
        RWS () (Endo Run) [String] ()
stripPreserveIt
        RWS () (Endo Run) [String] ()
stripVerbose
        RWS () (Endo Run) [String] ()
stripOptGhc

stripNoMagic :: RWS () (Endo Run) [String] ()
stripNoMagic :: RWS () (Endo Run) [String] ()
stripNoMagic = (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
stripFlag (Bool -> Run -> Run
setMagicMode Bool
False) String
"--no-magic"

stripFast :: RWS () (Endo Run) [String] ()
stripFast :: RWS () (Endo Run) [String] ()
stripFast = (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
stripFlag (Bool -> Run -> Run
setFastMode Bool
True) String
"--fast"

stripPreserveIt :: RWS () (Endo Run) [String] ()
stripPreserveIt :: RWS () (Endo Run) [String] ()
stripPreserveIt = (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
stripFlag (Bool -> Run -> Run
setPreserveIt Bool
True) String
"--preserve-it"

stripVerbose :: RWS () (Endo Run) [String] ()
stripVerbose :: RWS () (Endo Run) [String] ()
stripVerbose = (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
stripFlag (Bool -> Run -> Run
setVerbose Bool
True) String
"--verbose"

stripFlag :: (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
stripFlag :: (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
stripFlag Run -> Run
setter String
flag = 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
-> RWS () (Endo Run) [String] () -> RWS () (Endo Run) [String] ()
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) (RWS () (Endo Run) [String] () -> RWS () (Endo Run) [String] ())
-> RWS () (Endo Run) [String] () -> RWS () (Endo Run) [String] ()
forall a b. (a -> b) -> a -> b
$
    Endo Run -> RWS () (Endo Run) [String] ()
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] -> RWS () (Endo Run) [String] ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.put ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
flag) [String]
args)

stripOptGhc :: RWS () (Endo Run) [String] ()
stripOptGhc :: RWS () (Endo Run) [String] ()
stripOptGhc = 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
-> RWS () (Endo Run) [String] () -> RWS () (Endo Run) [String] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
issueWarning (RWS () (Endo Run) [String] () -> RWS () (Endo Run) [String] ())
-> RWS () (Endo Run) [String] () -> RWS () (Endo Run) [String] ()
forall a b. (a -> b) -> a -> b
$
    Endo Run -> RWS () (Endo Run) [String] ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.tell (Endo Run -> RWS () (Endo Run) [String] ())
-> Endo Run -> RWS () (Endo Run) [String] ()
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."