{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} module Options ( Result(..) , Run(..) , parseOptions #ifdef TEST , defaultRun , 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 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 -> [String] runOptions :: [String] , Run -> Bool runMagicMode :: Bool , Run -> Bool runFastMode :: Bool , Run -> Bool runPreserveIt :: Bool , Run -> Bool runVerbose :: Bool } 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) 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 = [] , runOptions :: [String] runOptions = [] , runMagicMode :: Bool runMagicMode = Bool False , runFastMode :: Bool runFastMode = Bool False , runPreserveIt :: Bool runPreserveIt = Bool False , runVerbose :: Bool runVerbose = Bool False } 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 -> 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 RunGhc [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)