{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
module Test.DocTest.Internal.Runner where
import Prelude hiding (putStr, putStrLn, error)
import Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId)
import Control.Exception (SomeException, catch)
import Control.Monad hiding (forM_)
import Data.Foldable (forM_)
import Data.Function (on)
import Data.List (sortBy)
import Data.Maybe (fromMaybe, maybeToList)
import GHC.Conc (getNumProcessors)
import System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
import System.Random (randoms, mkStdGen)
import Text.Printf (printf)
import Control.Monad.Trans.State
import Control.Monad.IO.Class
import Test.DocTest.Internal.Interpreter (Interpreter)
import qualified Test.DocTest.Internal.Interpreter as Interpreter
import Test.DocTest.Internal.Parse
import Test.DocTest.Internal.Options
( ModuleName, ModuleConfig (cfgPreserveIt), cfgSeed, cfgPreserveIt
, cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions)
import Test.DocTest.Internal.Location
import qualified Test.DocTest.Internal.Property as Property
import Test.DocTest.Internal.Runner.Example
import Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog)
import System.IO.CodePage (withCP65001)
import Control.Monad.Extra (whenM)
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
data FromSetup = FromSetup | NotFromSetup
data Summary = Summary {
Summary -> Int
sExamples :: Int
, Summary -> Int
sTried :: Int
, Summary -> Int
sErrors :: Int
, Summary -> Int
sFailures :: Int
} deriving Summary -> Summary -> Bool
(Summary -> Summary -> Bool)
-> (Summary -> Summary -> Bool) -> Eq Summary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Summary -> Summary -> Bool
== :: Summary -> Summary -> Bool
$c/= :: Summary -> Summary -> Bool
/= :: Summary -> Summary -> Bool
Eq
emptySummary :: Summary
emptySummary :: Summary
emptySummary = Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
0 Int
0 Int
0
instance Show Summary where
show :: Summary -> String
show (Summary Int
examples Int
tried Int
errors Int
failures) =
String -> Int -> Int -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Examples: %d Tried: %d Errors: %d Unexpected output: %d" Int
examples Int
tried Int
errors Int
failures
instance Monoid Summary where
mempty :: Summary
mempty = Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
0 Int
0 Int
0
#if __GLASGOW_HASKELL__ < 804
mappend = (<>)
#endif
instance Semigroup Summary where
<> :: Summary -> Summary -> Summary
(<>) (Summary Int
x1 Int
x2 Int
x3 Int
x4) (Summary Int
y1 Int
y2 Int
y3 Int
y4) =
Int -> Int -> Int -> Int -> Summary
Summary (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y1) (Int
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y2) (Int
x3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y3) (Int
x4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y4)
runModules
:: (?verbosity::LogLevel)
=> ModuleConfig
-> Maybe Int
-> Bool
-> [String]
-> [Module [Located DocTest]]
-> IO Summary
runModules :: (?verbosity::LogLevel) =>
ModuleConfig
-> Maybe Int
-> Bool
-> [String]
-> [Module [Located DocTest]]
-> IO Summary
runModules ModuleConfig
modConfig Maybe Int
nThreads Bool
implicitPrelude [String]
args [Module [Located DocTest]]
modules = do
Bool
isInteractive <- Handle -> IO Bool
hIsTerminalDevice Handle
stderr
Int
nCores <- IO Int
getNumProcessors
(Chan (Module [Located DocTest])
input, Chan (ThreadId, ReportUpdate)
output) <-
Int
-> (Chan (ThreadId, ReportUpdate)
-> Module [Located DocTest] -> IO ())
-> IO
(Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate))
makeThreadPool
(Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
nCores Maybe Int
nThreads)
(ModuleConfig
-> Bool
-> [String]
-> Chan (ThreadId, ReportUpdate)
-> Module [Located DocTest]
-> IO ()
runModule ModuleConfig
modConfig Bool
implicitPrelude [String]
args)
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Module [Located DocTest] -> IO ())
-> [Module [Located DocTest]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Chan (Module [Located DocTest])
-> Module [Located DocTest] -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Module [Located DocTest])
input) [Module [Located DocTest]]
modules)
let
nExamples :: Int
nExamples = ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> ([Module [Located DocTest]] -> [Int])
-> [Module [Located DocTest]]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module [Located DocTest] -> Int)
-> [Module [Located DocTest]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Module [Located DocTest] -> Int
count) [Module [Located DocTest]]
modules
initState :: ReportState
initState = ReportState
{ reportStateCount :: Int
reportStateCount = Int
0
, reportStateInteractive :: Bool
reportStateInteractive = Bool
isInteractive
, reportStateSummary :: Summary
reportStateSummary = Summary
forall a. Monoid a => a
mempty{sExamples=nExamples}
}
ThreadId
threadId <- IO ThreadId
myThreadId
let ?threadId = ?threadId::ThreadId
ThreadId
threadId
ReportState{Summary
reportStateSummary :: ReportState -> Summary
reportStateSummary :: Summary
reportStateSummary} <- (StateT ReportState IO () -> ReportState -> IO ReportState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`execStateT` ReportState
initState) (StateT ReportState IO () -> IO ReportState)
-> StateT ReportState IO () -> IO ReportState
forall a b. (a -> b) -> a -> b
$ do
(?threadId::ThreadId) =>
Chan (ThreadId, ReportUpdate) -> Int -> StateT ReportState IO ()
Chan (ThreadId, ReportUpdate) -> Int -> StateT ReportState IO ()
consumeUpdates Chan (ThreadId, ReportUpdate)
output ([Module [Located DocTest]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Module [Located DocTest]]
modules)
(ReportState -> String) -> StateT ReportState IO String
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Summary -> String
forall a. Show a => a -> String
show (Summary -> String)
-> (ReportState -> Summary) -> ReportState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportState -> Summary
reportStateSummary) StateT ReportState IO String
-> (String -> StateT ReportState IO ()) -> StateT ReportState IO ()
forall a b.
StateT ReportState IO a
-> (a -> StateT ReportState IO b) -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Info
Summary -> IO Summary
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Summary
reportStateSummary
where
consumeUpdates ::
(?threadId :: ThreadId) =>
Chan (ThreadId, ReportUpdate) ->
Int ->
StateT ReportState IO ()
consumeUpdates :: (?threadId::ThreadId) =>
Chan (ThreadId, ReportUpdate) -> Int -> StateT ReportState IO ()
consumeUpdates Chan (ThreadId, ReportUpdate)
_output Int
0 = () -> StateT ReportState IO ()
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
consumeUpdates Chan (ThreadId, ReportUpdate)
output Int
modsLeft = do
(ThreadId
threadId, ReportUpdate
update) <- IO (ThreadId, ReportUpdate)
-> StateT ReportState IO (ThreadId, ReportUpdate)
forall a. IO a -> StateT ReportState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Chan (ThreadId, ReportUpdate) -> IO (ThreadId, ReportUpdate)
forall a. Chan a -> IO a
readChan Chan (ThreadId, ReportUpdate)
output)
let ?threadId = ?threadId::ThreadId
ThreadId
threadId
(?threadId::ThreadId) =>
Chan (ThreadId, ReportUpdate) -> Int -> StateT ReportState IO ()
Chan (ThreadId, ReportUpdate) -> Int -> StateT ReportState IO ()
consumeUpdates Chan (ThreadId, ReportUpdate)
output (Int -> StateT ReportState IO ())
-> StateT ReportState IO Int -> StateT ReportState IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
case ReportUpdate
update of
UpdateInternalError FromSetup
fs Module [Located DocTest]
loc SomeException
e -> FromSetup
-> Module [Located DocTest]
-> SomeException
-> StateT ReportState IO ()
forall a.
(?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup -> Module a -> SomeException -> StateT ReportState IO ()
reportInternalError FromSetup
fs Module [Located DocTest]
loc SomeException
e StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
modsLeft Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
UpdateImportError String
modName Either String String
result -> (?verbosity::LogLevel, ?threadId::ThreadId) =>
String -> Either String String -> StateT ReportState IO ()
String -> Either String String -> StateT ReportState IO ()
reportImportError String
modName Either String String
result StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
modsLeft Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
UpdateSuccess FromSetup
fs -> (?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup -> StateT ReportState IO ()
FromSetup -> StateT ReportState IO ()
reportSuccess FromSetup
fs StateT ReportState IO ()
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT ReportState IO ()
(?verbosity::LogLevel) => StateT ReportState IO ()
reportProgress StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
modsLeft
UpdateFailure FromSetup
fs Location
loc String
expr [String]
errs -> (?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup
-> Location -> String -> [String] -> StateT ReportState IO ()
FromSetup
-> Location -> String -> [String] -> StateT ReportState IO ()
reportFailure FromSetup
fs Location
loc String
expr [String]
errs StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
modsLeft
UpdateError FromSetup
fs Location
loc String
expr String
err -> (?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup
-> Location -> String -> String -> StateT ReportState IO ()
FromSetup
-> Location -> String -> String -> StateT ReportState IO ()
reportError FromSetup
fs Location
loc String
expr String
err StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
modsLeft
UpdateOptionError Location
loc String
err -> (?verbosity::LogLevel, ?threadId::ThreadId) =>
Location -> String -> StateT ReportState IO ()
Location -> String -> StateT ReportState IO ()
reportOptionError Location
loc String
err StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
modsLeft
ReportUpdate
UpdateModuleDone -> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
modsLeft Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
UpdateLog LogLevel
lvl String
msg -> (?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
lvl String
msg StateT ReportState IO ()
-> StateT ReportState IO Int -> StateT ReportState IO Int
forall a b.
StateT ReportState IO a
-> StateT ReportState IO b -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT ReportState IO Int
forall a. a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
modsLeft
count :: Module [Located DocTest] -> Int
count :: Module [Located DocTest] -> Int
count (Module String
_ Maybe [Located DocTest]
_ [[Located DocTest]]
tests [Located String]
_) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Located DocTest] -> Int) -> [[Located DocTest]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Located DocTest] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Located DocTest]]
tests)
type Report = StateT ReportState IO
data ReportState = ReportState {
ReportState -> Int
reportStateCount :: Int
, ReportState -> Bool
reportStateInteractive :: Bool
, ReportState -> Summary
reportStateSummary :: Summary
}
report ::
( ?verbosity :: LogLevel
, ?threadId :: ThreadId
) =>
LogLevel ->
String ->
Report ()
report :: (?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
lvl String
msg0 =
Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((?verbosity::LogLevel) => LogLevel -> Bool
LogLevel -> Bool
shouldLog LogLevel
lvl) (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$ do
let msg1 :: String
msg1 = ThreadId -> LogLevel -> ShowS
formatLog ?threadId::ThreadId
ThreadId
?threadId LogLevel
lvl String
msg0
String -> StateT ReportState IO ()
overwrite String
msg1
IO () -> StateT ReportState IO ()
forall a. IO a -> StateT ReportState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT ReportState IO ())
-> IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
""
(ReportState -> ReportState) -> StateT ReportState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\ReportState
st -> ReportState
st {reportStateCount = 0})
report_ :: (?verbosity :: LogLevel) => LogLevel -> String -> Report ()
report_ :: (?verbosity::LogLevel) =>
LogLevel -> String -> StateT ReportState IO ()
report_ LogLevel
lvl String
msg =
Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((?verbosity::LogLevel) => LogLevel -> Bool
LogLevel -> Bool
shouldLog LogLevel
lvl) (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$ do
StateT ReportState IO Bool
-> StateT ReportState IO () -> StateT ReportState IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateInteractive) (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> StateT ReportState IO ()
overwrite String
msg
(ReportState -> ReportState) -> StateT ReportState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\ReportState
st -> ReportState
st {reportStateCount = length msg})
overwrite :: String -> Report ()
overwrite :: String -> StateT ReportState IO ()
overwrite String
msg = do
Int
n <- (ReportState -> Int) -> StateT ReportState IO Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Int
reportStateCount
let str :: String
str | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = String
"\r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
msg) Char
' '
| Bool
otherwise = String
msg
IO () -> StateT ReportState IO ()
forall a. IO a -> StateT ReportState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStr Handle
stderr String
str)
shuffle :: Int -> [a] -> [a]
shuffle :: forall a. Int -> [a] -> [a]
shuffle Int
seed [a]
xs =
((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd
([(Int, a)] -> [a]) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> (Int, a) -> Ordering) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, a) -> Int) -> (Int, a) -> (Int, a) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, a) -> Int
forall a b. (a, b) -> a
fst)
([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [(Int, a)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (forall a g. (Random a, RandomGen g) => g -> [a]
randoms @Int (Int -> StdGen
mkStdGen Int
seed)) [a]
xs
runModule
:: ModuleConfig
-> Bool
-> [String]
-> Chan (ThreadId, ReportUpdate)
-> Module [Located DocTest]
-> IO ()
runModule :: ModuleConfig
-> Bool
-> [String]
-> Chan (ThreadId, ReportUpdate)
-> Module [Located DocTest]
-> IO ()
runModule ModuleConfig
modConfig0 Bool
implicitPrelude [String]
ghciArgs Chan (ThreadId, ReportUpdate)
output Module [Located DocTest]
mod_ = do
ThreadId
threadId <- IO ThreadId
myThreadId
let update :: ReportUpdate -> IO ()
update ReportUpdate
r = Chan (ThreadId, ReportUpdate) -> (ThreadId, ReportUpdate) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (ThreadId, ReportUpdate)
output (ThreadId
threadId, ReportUpdate
r)
case Either (Location, String) ModuleConfig
modConfig2 of
Left (Location
loc, String
flag) ->
ReportUpdate -> IO ()
update (Location -> String -> ReportUpdate
UpdateOptionError Location
loc String
flag)
Right ModuleConfig
modConfig3 -> do
let
examples1 :: [[Located DocTest]]
examples1
| ModuleConfig -> Bool
cfgRandomizeOrder ModuleConfig
modConfig3 = Int -> [[Located DocTest]] -> [[Located DocTest]]
forall a. Int -> [a] -> [a]
shuffle Int
seed [[Located DocTest]]
examples0
| Bool
otherwise = [[Located DocTest]]
examples0
importModule :: Maybe String
importModule
| ModuleConfig -> Bool
cfgImplicitModuleImport ModuleConfig
modConfig3 = String -> Maybe String
forall a. a -> Maybe a
Just (String
":m +" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
module_)
| Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
preserveIt :: Bool
preserveIt = ModuleConfig -> Bool
cfgPreserveIt ModuleConfig
modConfig3
seed :: Int
seed = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (ModuleConfig -> Maybe Int
cfgSeed ModuleConfig
modConfig3)
reload :: Interpreter -> IO ()
reload Interpreter
repl = do
IO (Either String String) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either String String) -> IO ())
-> IO (Either String String) -> IO ()
forall a b. (a -> b) -> a -> b
$ Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
":reload"
(String -> IO (Either String String)) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
if Bool
implicitPrelude
then String
":m Prelude" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
importModule
else Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
importModule
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO (Either String String) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either String String) -> IO ())
-> IO (Either String String) -> IO ()
forall a b. (a -> b) -> a -> b
$ Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl (String -> IO (Either String String))
-> String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String
"()"
setup_ :: Interpreter -> IO ()
setup_ Interpreter
repl = do
Interpreter -> IO ()
reload Interpreter
repl
Maybe [Located DocTest] -> ([Located DocTest] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Located DocTest]
setup (([Located DocTest] -> IO ()) -> IO ())
-> ([Located DocTest] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Located DocTest]
l -> [Located DocTest] -> (Located DocTest -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located DocTest]
l ((Located DocTest -> IO ()) -> IO ())
-> (Located DocTest -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Located Location
_ DocTest
x) -> case DocTest
x of
Property String
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Example String
e ExpectedResult
_ -> IO (Either String String) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either String String) -> IO ())
-> IO (Either String String) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith Bool
preserveIt Interpreter
repl String
e
let logger :: String -> IO ()
logger = ReportUpdate -> IO ()
update (ReportUpdate -> IO ())
-> (String -> ReportUpdate) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> String -> ReportUpdate
UpdateLog LogLevel
Debug
(String -> IO ()) -> [String] -> (Interpreter -> IO ()) -> IO ()
forall a.
(String -> IO ()) -> [String] -> (Interpreter -> IO a) -> IO a
Interpreter.withInterpreter String -> IO ()
logger [String]
ghciArgs ((Interpreter -> IO ()) -> IO ())
-> (Interpreter -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Interpreter
repl -> IO () -> IO ()
forall a. IO a -> IO a
withCP65001 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Either String String
importResult <-
case Maybe String
importModule of
Maybe String
Nothing -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String String
forall a b. b -> Either a b
Right String
"")
Just String
i -> Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
i
case Either String String
importResult of
Right String
"" -> do
Maybe Bool
successes <-
([Located DocTest] -> IO Bool)
-> Maybe [Located DocTest] -> IO (Maybe Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM
(FromSetup
-> Bool
-> Interpreter
-> IO ()
-> (ReportUpdate -> IO ())
-> [Located DocTest]
-> IO Bool
runTestGroup FromSetup
FromSetup Bool
preserveIt Interpreter
repl (Interpreter -> IO ()
reload Interpreter
repl) ReportUpdate -> IO ()
update)
Maybe [Located DocTest]
setup
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(Maybe Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and Maybe Bool
successes)
(([Located DocTest] -> IO Bool) -> [[Located DocTest]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
(FromSetup
-> Bool
-> Interpreter
-> IO ()
-> (ReportUpdate -> IO ())
-> [Located DocTest]
-> IO Bool
runTestGroup FromSetup
NotFromSetup Bool
preserveIt Interpreter
repl (Interpreter -> IO ()
setup_ Interpreter
repl) ReportUpdate -> IO ()
update)
[[Located DocTest]]
examples1)
Either String String
_ ->
ReportUpdate -> IO ()
update (String -> Either String String -> ReportUpdate
UpdateImportError String
module_ Either String String
importResult)
ReportUpdate -> IO ()
update ReportUpdate
UpdateModuleDone
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
Module String
module_ Maybe [Located DocTest]
setup [[Located DocTest]]
examples0 [Located String]
modArgs = Module [Located DocTest]
mod_
modConfig2 :: Either (Location, String) ModuleConfig
modConfig2 = String
-> ModuleConfig
-> [Located String]
-> Either (Location, String) ModuleConfig
parseLocatedModuleOptions String
module_ ModuleConfig
modConfig0 [Located String]
modArgs
data ReportUpdate
= UpdateSuccess FromSetup
| UpdateFailure FromSetup Location Expression [String]
| UpdateError FromSetup Location Expression String
| UpdateModuleDone
| UpdateInternalError FromSetup (Module [Located DocTest]) SomeException
| UpdateImportError ModuleName (Either String String)
| UpdateOptionError Location String
| UpdateLog LogLevel String
makeThreadPool ::
Int ->
(Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()) ->
IO (Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate))
makeThreadPool :: Int
-> (Chan (ThreadId, ReportUpdate)
-> Module [Located DocTest] -> IO ())
-> IO
(Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate))
makeThreadPool Int
nThreads Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()
mutator = do
Chan (Module [Located DocTest])
input <- IO (Chan (Module [Located DocTest]))
forall a. IO (Chan a)
newChan
Chan (ThreadId, ReportUpdate)
output <- IO (Chan (ThreadId, ReportUpdate))
forall a. IO (Chan a)
newChan
[Int] -> (Int -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
nThreads] ((Int -> IO ThreadId) -> IO ()) -> (Int -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ ->
IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Module [Located DocTest]
i <- Chan (Module [Located DocTest]) -> IO (Module [Located DocTest])
forall a. Chan a -> IO a
readChan Chan (Module [Located DocTest])
input
ThreadId
threadId <- IO ThreadId
myThreadId
IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()
mutator Chan (ThreadId, ReportUpdate)
output Module [Located DocTest]
i)
(\SomeException
e -> Chan (ThreadId, ReportUpdate) -> (ThreadId, ReportUpdate) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (ThreadId, ReportUpdate)
output (ThreadId
threadId, FromSetup
-> Module [Located DocTest] -> SomeException -> ReportUpdate
UpdateInternalError FromSetup
NotFromSetup Module [Located DocTest]
i SomeException
e))
(Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate))
-> IO
(Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Chan (Module [Located DocTest])
input, Chan (ThreadId, ReportUpdate)
output)
reportFailure :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> [String] -> Report ()
reportFailure :: (?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup
-> Location -> String -> [String] -> StateT ReportState IO ()
reportFailure FromSetup
fromSetup Location
loc String
expression [String]
err = do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error (String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s: failure in expression `%s'" (Location -> String
forall a. Show a => a -> String
show Location
loc) String
expression)
(String -> StateT ReportState IO ())
-> [String] -> StateT ReportState IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error) [String]
err
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
0 Int
1)
reportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> String -> Report ()
reportError :: (?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup
-> Location -> String -> String -> StateT ReportState IO ()
reportError FromSetup
fromSetup Location
loc String
expression String
err = do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error (String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s: error in expression `%s'" (Location -> String
forall a. Show a => a -> String
show Location
loc) String
expression)
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
err
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
1 Int
0)
reportOptionError :: (?verbosity::LogLevel, ?threadId::ThreadId) => Location -> String -> Report ()
reportOptionError :: (?verbosity::LogLevel, ?threadId::ThreadId) =>
Location -> String -> StateT ReportState IO ()
reportOptionError Location
loc String
opt = do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error (String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s: unrecognized option: %s. Try --help to see all options." (Location -> String
forall a. Show a => a -> String
show Location
loc) String
opt)
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
1 Int
0)
reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Module a -> SomeException -> Report ()
reportInternalError :: forall a.
(?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup -> Module a -> SomeException -> StateT ReportState IO ()
reportInternalError FromSetup
fs Module a
mod_ SomeException
err = do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Internal error when executing tests in %s" (Module a -> String
forall a. Module a -> String
moduleName Module a
mod_))
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fs Summary
emptySummary{sErrors=1}
reportImportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Either String String -> Report ()
reportImportError :: (?verbosity::LogLevel, ?threadId::ThreadId) =>
String -> Either String String -> StateT ReportState IO ()
reportImportError String
modName Either String String
importResult = do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error (String
"Could not import module: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
modName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". This can be caused by a number of issues: ")
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" 1. A module found by GHC contained tests, but was not in 'exposed-modules'. If you want"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" to test non-exposed modules follow the instructions here:"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" https://github.com/martijnbastiaan/doctest-parallel#test-non-exposed-modules"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" 2. For Cabal users: Cabal did not generate a GHC environment file. Either:"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" * Run with '--write-ghc-environment-files=always'"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" * Add 'write-ghc-environment-files: always' to your cabal.project"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" 3. For Cabal users: Cabal did not generate a GHC environment file in time. This"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" can happen if you use 'cabal test' instead of 'cabal run doctests'. See"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" https://github.com/martijnbastiaan/doctest-parallel/issues/22."
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" 4. The testsuite executable does not have a dependency on your project library. Please"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
" add it to the 'build-depends' section of the testsuite executable."
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
"See the example project at https://github.com/martijnbastiaan/doctest-parallel/blob/main/example/README.md for more information."
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
"The original reason given by GHCi was:"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
""
case Either String String
importResult of
Left String
out -> do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
"Unexpected output:"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
out
Right String
err -> do
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
"Error:"
(?verbosity::LogLevel, ?threadId::ThreadId) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report LogLevel
Error String
err
FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup Summary
emptySummary{sErrors=1}
reportSuccess :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Report ()
reportSuccess :: (?verbosity::LogLevel, ?threadId::ThreadId) =>
FromSetup -> StateT ReportState IO ()
reportSuccess FromSetup
fromSetup = FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
0 Int
0)
updateSummary :: FromSetup -> Summary -> Report ()
updateSummary :: FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup Summary
summary =
FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
NotFromSetup Summary
summary{sExamples=0, sTried=0}
updateSummary FromSetup
NotFromSetup Summary
summary = do
ReportState Int
n Bool
f Summary
s <- StateT ReportState IO ReportState
forall (m :: * -> *) s. Monad m => StateT s m s
get
ReportState -> StateT ReportState IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int -> Bool -> Summary -> ReportState
ReportState Int
n Bool
f (Summary -> ReportState) -> Summary -> ReportState
forall a b. (a -> b) -> a -> b
$ Summary
s Summary -> Summary -> Summary
forall a. Monoid a => a -> a -> a
`mappend` Summary
summary)
reportProgress :: (?verbosity::LogLevel) => Report ()
reportProgress :: (?verbosity::LogLevel) => StateT ReportState IO ()
reportProgress = (ReportState -> String) -> StateT ReportState IO String
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Summary -> String
forall a. Show a => a -> String
show (Summary -> String)
-> (ReportState -> Summary) -> ReportState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportState -> Summary
reportStateSummary) StateT ReportState IO String
-> (String -> StateT ReportState IO ()) -> StateT ReportState IO ()
forall a b.
StateT ReportState IO a
-> (a -> StateT ReportState IO b) -> StateT ReportState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (?verbosity::LogLevel) =>
LogLevel -> String -> StateT ReportState IO ()
LogLevel -> String -> StateT ReportState IO ()
report_ LogLevel
Info
runTestGroup ::
FromSetup ->
Bool ->
Interpreter ->
IO () ->
(ReportUpdate -> IO ()) ->
[Located DocTest] ->
IO Bool
runTestGroup :: FromSetup
-> Bool
-> Interpreter
-> IO ()
-> (ReportUpdate -> IO ())
-> [Located DocTest]
-> IO Bool
runTestGroup FromSetup
fromSetup Bool
preserveIt Interpreter
repl IO ()
setup ReportUpdate -> IO ()
update [Located DocTest]
tests = do
IO ()
setup
Bool
successExamples <- FromSetup
-> Bool
-> Interpreter
-> (ReportUpdate -> IO ())
-> [Located Interaction]
-> IO Bool
runExampleGroup FromSetup
fromSetup Bool
preserveIt Interpreter
repl ReportUpdate -> IO ()
update [Located Interaction]
examples
[Bool]
successesProperties <- [(Location, String)]
-> ((Location, String) -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Location, String)]
properties (((Location, String) -> IO Bool) -> IO [Bool])
-> ((Location, String) -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \(Location
loc, String
expression) -> do
PropertyResult
r <- do
IO ()
setup
ReportUpdate -> IO ()
update (LogLevel -> String -> ReportUpdate
UpdateLog LogLevel
Verbose (String
"Started property at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Location -> String
forall a. Show a => a -> String
show Location
loc))
Interpreter -> String -> IO PropertyResult
Property.runProperty Interpreter
repl String
expression
case PropertyResult
r of
PropertyResult
Property.Success -> do
ReportUpdate -> IO ()
update (FromSetup -> ReportUpdate
UpdateSuccess FromSetup
fromSetup)
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Property.Error String
err -> do
ReportUpdate -> IO ()
update (FromSetup -> Location -> String -> String -> ReportUpdate
UpdateError FromSetup
fromSetup Location
loc String
expression String
err)
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Property.Failure String
msg -> do
ReportUpdate -> IO ()
update (FromSetup -> Location -> String -> [String] -> ReportUpdate
UpdateFailure FromSetup
fromSetup Location
loc String
expression [String
msg])
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
successExamples Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
successesProperties)
where
properties :: [(Location, String)]
properties = [(Location
loc, String
p) | Located Location
loc (Property String
p) <- [Located DocTest]
tests]
examples :: [Located Interaction]
examples :: [Located Interaction]
examples = [Location -> Interaction -> Located Interaction
forall a. Location -> a -> Located a
Located Location
loc (String
e, ExpectedResult
r) | Located Location
loc (Example String
e ExpectedResult
r) <- [Located DocTest]
tests]
runExampleGroup ::
FromSetup ->
Bool ->
Interpreter ->
(ReportUpdate -> IO ()) ->
[Located Interaction] ->
IO Bool
runExampleGroup :: FromSetup
-> Bool
-> Interpreter
-> (ReportUpdate -> IO ())
-> [Located Interaction]
-> IO Bool
runExampleGroup FromSetup
fromSetup Bool
preserveIt Interpreter
repl ReportUpdate -> IO ()
update [Located Interaction]
examples = do
ThreadId
threadId <- IO ThreadId
myThreadId
ThreadId -> [Located Interaction] -> IO Bool
forall {t}. t -> [Located Interaction] -> IO Bool
go ThreadId
threadId [Located Interaction]
examples
where
go :: t -> [Located Interaction] -> IO Bool
go t
threadId ((Located Location
loc (String
expression, ExpectedResult
expected)) : [Located Interaction]
xs) = do
ReportUpdate -> IO ()
update (LogLevel -> String -> ReportUpdate
UpdateLog LogLevel
Verbose (String
"Started example at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Location -> String
forall a. Show a => a -> String
show Location
loc))
Either String [String]
r <- (String -> [String])
-> Either String String -> Either String [String]
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (Either String String -> Either String [String])
-> IO (Either String String) -> IO (Either String [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith Bool
preserveIt Interpreter
repl String
expression
case Either String [String]
r of
Left String
err -> do
ReportUpdate -> IO ()
update (FromSetup -> Location -> String -> String -> ReportUpdate
UpdateError FromSetup
fromSetup Location
loc String
expression String
err)
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Right [String]
actual -> case ExpectedResult -> [String] -> Result
mkResult ExpectedResult
expected [String]
actual of
NotEqual [String]
err -> do
ReportUpdate -> IO ()
update (FromSetup -> Location -> String -> [String] -> ReportUpdate
UpdateFailure FromSetup
fromSetup Location
loc String
expression [String]
err)
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Result
Equal -> do
ReportUpdate -> IO ()
update (FromSetup -> ReportUpdate
UpdateSuccess FromSetup
fromSetup)
t -> [Located Interaction] -> IO Bool
go t
threadId [Located Interaction]
xs
go t
_ [] =
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith Bool
preserveIt
| Bool
preserveIt = Interpreter -> String -> IO (Either String String)
Interpreter.safeEvalIt
| Bool
otherwise = Interpreter -> String -> IO (Either String String)
Interpreter.safeEval