{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
module Options (
  Result(..)
, Run(..)
, defaultMagic
, defaultFastMode
, defaultPreserveIt
, defaultVerbose
, parseOptions
#ifdef TEST
, usage
, info
, versionInfo
#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
import           Data.Monoid (Endo (Endo))

import qualified Paths_doctest
import           Data.Version (showVersion)

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

import           Interpreter (ghc)

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

version :: String
version :: String
version = Version -> String
showVersion Version
Paths_doctest.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 = 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
/= :: 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, (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
<$ :: 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 -> [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
/= :: Run -> Run -> Bool
$c/= :: Run -> Run -> Bool
== :: Run -> Run -> Bool
$c== :: Run -> Run -> Bool
Eq, Int -> Run -> String -> String
[Run] -> String -> String
Run -> String
(Int -> Run -> String -> String)
-> (Run -> String) -> ([Run] -> String -> String) -> Show Run
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Run] -> String -> String
$cshowList :: [Run] -> String -> String
show :: Run -> String
$cshow :: Run -> String
showsPrec :: Int -> Run -> String -> String
$cshowsPrec :: Int -> Run -> String -> String
Show)

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 :: [String] -> [String] -> Bool -> Bool -> Bool -> Bool -> Run
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
"--help" String -> [String] -> 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
"--info" String -> [String] -> 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
"--version" String -> [String] -> 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 (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 (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."