{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Test.DocTest
( mainFromCabal
, mainFromLibrary
, mainFromCabalWithConfig
, mainFromLibraryWithConfig
, filterModules
, isSuccess
, setSeed
, run
) where
import Prelude ()
import Prelude.Compat
import qualified Data.Set as Set
import Data.List (intercalate)
import Control.Monad (unless)
import Control.Monad.Extra (ifM)
import System.Exit (exitFailure)
import System.IO
import System.Random (randomIO)
import qualified Control.Exception as E
#if __GLASGOW_HASKELL__ < 900
import Panic
#else
import GHC.Utils.Panic
#endif
import Test.DocTest.Internal.Parse
import Test.DocTest.Internal.Options
import Test.DocTest.Internal.Runner
import Test.DocTest.Internal.Nix (getNixGhciArgs)
import Distribution.Simple
( KnownExtension(ImplicitPrelude), Extension (DisableExtension) )
import Test.DocTest.Helpers
( Library (libDefaultExtensions), extractCabalLibrary, findCabalPackage
, libraryToGhciArgs )
import Test.DocTest.Internal.Logging (LogLevel(..))
import qualified Test.DocTest.Internal.Logging as Logging
mainFromCabal :: String -> [String] -> IO ()
mainFromCabal :: String -> [String] -> IO ()
mainFromCabal String
libName [String]
cmdArgs = do
Library
lib <- String -> IO Library
extractCabalLibrary (String -> IO Library) -> IO String -> IO Library
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => String -> IO String
String -> IO String
findCabalPackage String
libName
Library -> [String] -> IO ()
mainFromLibrary Library
lib [String]
cmdArgs
mainFromCabalWithConfig :: String -> Config -> IO ()
mainFromCabalWithConfig :: String -> Config -> IO ()
mainFromCabalWithConfig String
libName Config
config = do
Library
lib <- String -> IO Library
extractCabalLibrary (String -> IO Library) -> IO String -> IO Library
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => String -> IO String
String -> IO String
findCabalPackage String
libName
Library -> Config -> IO ()
mainFromLibraryWithConfig Library
lib Config
config
mainFromLibrary :: Library -> [String] -> IO ()
mainFromLibrary :: Library -> [String] -> IO ()
mainFromLibrary Library
lib ([String] -> Result Config
parseOptions -> Result Config
opts) =
case Result Config
opts of
ResultStdout String
s -> String -> IO ()
putStr String
s
ResultStderr String
s -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"doctest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Try `doctest --help' for more information."
IO ()
forall a. IO a
exitFailure
Result Config
config -> do
Library -> Config -> IO ()
mainFromLibraryWithConfig Library
lib Config
config
mainFromLibraryWithConfig :: Library -> Config -> IO ()
mainFromLibraryWithConfig :: Library -> Config -> IO ()
mainFromLibraryWithConfig Library
lib Config
config = do
Summary
r <- Library -> Config -> IO Summary
run Library
lib Config
config IO Summary -> (SomeException -> IO Summary) -> IO Summary
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
e -> do
case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just (UsageError String
err) -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"doctest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Try `doctest --help' for more information."
IO Summary
forall a. IO a
exitFailure
Maybe GhcException
_ -> SomeException -> IO Summary
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Summary -> Bool
isSuccess Summary
r) IO ()
forall a. IO a
exitFailure
isSuccess :: Summary -> Bool
isSuccess :: Summary -> Bool
isSuccess Summary
s = Summary -> Int
sErrors Summary
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Summary -> Int
sFailures Summary
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
filterModules :: [ModuleName] -> [Module a] -> [Module a]
filterModules :: forall a. [String] -> [Module a] -> [Module a]
filterModules [] [Module a]
mods = [Module a]
mods
filterModules [String]
wantedMods0 [Module a]
allMods0
| (String
_:[String]
_) <- [String]
nonExistingMods = String -> [Module a]
forall a. HasCallStack => String -> a
error (String
"Unknown modules specified: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
nonExistingMods)
| Bool
otherwise = (Module a -> Bool) -> [Module a] -> [Module a]
forall a. (a -> Bool) -> [a] -> [a]
filter Module a -> Bool
forall {a}. Module a -> Bool
isSpecifiedMod [Module a]
allMods0
where
wantedMods1 :: Set String
wantedMods1 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
wantedMods0
allMods1 :: Set String
allMods1 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((Module a -> String) -> [Module a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Module a -> String
forall a. Module a -> String
moduleName [Module a]
allMods0)
nonExistingMods :: [String]
nonExistingMods = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String
wantedMods1 Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
allMods1)
isSpecifiedMod :: Module a -> Bool
isSpecifiedMod Module{String
moduleName :: forall a. Module a -> String
moduleName :: String
moduleName} = String
moduleName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
wantedMods1
setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig
setSeed :: (?verbosity::LogLevel) => ModuleConfig -> IO ModuleConfig
setSeed cfg :: ModuleConfig
cfg@ModuleConfig{cfgRandomizeOrder :: ModuleConfig -> Bool
cfgRandomizeOrder=Bool
True, cfgSeed :: ModuleConfig -> Maybe Int
cfgSeed=Maybe Int
Nothing} = do
Int
seed <- Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
(?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Info (String
"Using freshly generated seed to randomize test order: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
seed)
ModuleConfig -> IO ModuleConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleConfig
cfg{cfgSeed=Just seed}
setSeed ModuleConfig
cfg = ModuleConfig -> IO ModuleConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleConfig
cfg
run :: Library -> Config -> IO Summary
run :: Library -> Config -> IO Summary
run Library
lib Config{Bool
[String]
Maybe Int
LogLevel
ModuleConfig
cfgLogLevel :: LogLevel
cfgModules :: [String]
cfgThreads :: Maybe Int
cfgModuleConfig :: ModuleConfig
cfgNix :: Bool
cfgGhcArgs :: [String]
cfgLogLevel :: Config -> LogLevel
cfgModules :: Config -> [String]
cfgThreads :: Config -> Maybe Int
cfgModuleConfig :: Config -> ModuleConfig
cfgNix :: Config -> Bool
cfgGhcArgs :: Config -> [String]
..} = do
[String]
nixGhciArgs <- IO Bool -> IO [String] -> IO [String] -> IO [String]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
cfgNix) IO [String]
getNixGhciArgs ([String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
let
implicitPrelude :: Bool
implicitPrelude = KnownExtension -> Extension
DisableExtension KnownExtension
ImplicitPrelude Extension -> [Extension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Library -> [Extension]
libDefaultExtensions Library
lib
([String]
includeArgs, [String]
moduleArgs, [String]
otherGhciArgs) = Library -> ([String], [String], [String])
libraryToGhciArgs Library
lib
evalGhciArgs :: [String]
evalGhciArgs = [String]
otherGhciArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-XNoImplicitPrelude"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nixGhciArgs
parseGhcArgs :: [String]
parseGhcArgs = [String]
includeArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
moduleArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
otherGhciArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nixGhciArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cfgGhcArgs
let
?verbosity = ?verbosity::LogLevel
LogLevel
cfgLogLevel
ModuleConfig
modConfig <- (?verbosity::LogLevel) => ModuleConfig -> IO ModuleConfig
ModuleConfig -> IO ModuleConfig
setSeed ModuleConfig
cfgModuleConfig
(?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Verbose String
"Parsing comments.."
(?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Debug (String
"Calling GHC API with: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
parseGhcArgs)
[Module [Located DocTest]]
allModules <- [String] -> IO [Module [Located DocTest]]
getDocTests [String]
parseGhcArgs
(?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Verbose String
"Running examples.."
let
filteredModules :: [Module [Located DocTest]]
filteredModules = [String]
-> [Module [Located DocTest]] -> [Module [Located DocTest]]
forall a. [String] -> [Module a] -> [Module a]
filterModules [String]
cfgModules [Module [Located DocTest]]
allModules
filteredModulesMsg :: String
filteredModulesMsg = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Module [Located DocTest] -> String)
-> [Module [Located DocTest]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Module [Located DocTest] -> String
forall a. Module a -> String
moduleName [Module [Located DocTest]]
filteredModules)
(?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Debug (String
"Running examples in modules: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filteredModulesMsg)
(?verbosity::LogLevel) =>
ModuleConfig
-> Maybe Int
-> Bool
-> [String]
-> [Module [Located DocTest]]
-> IO Summary
ModuleConfig
-> Maybe Int
-> Bool
-> [String]
-> [Module [Located DocTest]]
-> IO Summary
runModules ModuleConfig
modConfig Maybe Int
cfgThreads Bool
implicitPrelude [String]
evalGhciArgs [Module [Located DocTest]]
filteredModules