{-# 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)