{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NamedFieldPuns #-}

module Test.DocTest.Internal.Runner where

import           Prelude hiding (putStr, putStrLn, error)

import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO)
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 Test.DocTest.Internal.Property
    ( runProperty, PropertyResult(Failure, Success, Error) )
import           Test.DocTest.Internal.Runner.Example

import           System.IO.CodePage (withCP65001)

#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif

-- | Whether an "example" is part of setup block
data FromSetup = FromSetup | NotFromSetup

-- | Summary of a test run.
data Summary = Summary {
    Summary -> Int
sExamples :: Int  -- ^ Total number of lines of examples (excluding setup)
  , Summary -> Int
sTried    :: Int  -- ^ Executed /sTried/ lines so  far
  , Summary -> Int
sErrors   :: Int  -- ^ Couldn't execute /sErrors/ examples
  , Summary -> Int
sFailures :: Int  -- ^ Got unexpected output for /sFailures/ examples
} deriving Summary -> Summary -> Bool
(Summary -> Summary -> Bool)
-> (Summary -> Summary -> Bool) -> Eq Summary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Summary -> Summary -> Bool
$c/= :: Summary -> Summary -> Bool
== :: Summary -> Summary -> Bool
$c== :: Summary -> Summary -> Bool
Eq

emptySummary :: Summary
emptySummary :: Summary
emptySummary = Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
0 Int
0 Int
0

-- | Format a summary.
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


-- | Sum up summaries.
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)

-- | Run all examples from a list of modules.
runModules
  :: ModuleConfig
  -- ^ Configuration options specific to module
  -> Maybe Int
  -- ^ Number of threads to use. Defaults to 'getNumProcessors'.
  -> Bool
  -- ^ Verbose
  -> Bool
  -- ^ Implicit Prelude
  -> [String]
  -- ^ Arguments passed to the GHCi process.
  -> Bool
  -- ^ Quiet mode activated
  -> [Module [Located DocTest]]
  -- ^ Modules under test
  -> IO Summary
runModules :: ModuleConfig
-> Maybe Int
-> Bool
-> Bool
-> [String]
-> Bool
-> [Module [Located DocTest]]
-> IO Summary
runModules ModuleConfig
modConfig Maybe Int
nThreads Bool
verbose Bool
implicitPrelude [String]
args Bool
quiet [Module [Located DocTest]]
modules = do
  Bool
isInteractive <- Handle -> IO Bool
hIsTerminalDevice Handle
stderr

  -- Start a thread pool. It sends status updates to this thread through 'output'.
  Int
nCores <- IO Int
getNumProcessors
  (Chan (Module [Located DocTest])
input, Chan ReportUpdate
output) <-
    Int
-> (Chan ReportUpdate -> Module [Located DocTest] -> IO ())
-> IO (Chan (Module [Located DocTest]), Chan ReportUpdate)
makeThreadPool
      (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
nCores Maybe Int
nThreads)
      (ModuleConfig
-> Bool
-> [String]
-> Chan ReportUpdate
-> Module [Located DocTest]
-> IO ()
runModule ModuleConfig
modConfig Bool
implicitPrelude [String]
args)

  -- Send instructions to threads
  IO () -> IO ()
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 (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 :: Int -> Bool -> Bool -> Bool -> Summary -> ReportState
ReportState
      { reportStateCount :: Int
reportStateCount = Int
0
      , reportStateInteractive :: Bool
reportStateInteractive = Bool
isInteractive
      , reportStateVerbose :: Bool
reportStateVerbose = Bool
verbose
      , reportStateQuiet :: Bool
reportStateQuiet = Bool
quiet
      , reportStateSummary :: Summary
reportStateSummary = Summary
forall a. Monoid a => a
mempty{sExamples :: Int
sExamples=Int
nExamples}
      }

  ReportState{Summary
reportStateSummary :: Summary
reportStateSummary :: ReportState -> 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
    Chan ReportUpdate -> Int -> StateT ReportState IO ()
forall a.
(Eq a, Num a) =>
Chan ReportUpdate -> a -> StateT ReportState IO ()
consumeUpdates Chan ReportUpdate
output ([Module [Located DocTest]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Module [Located DocTest]]
modules)
    Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> StateT ReportState IO ()
verboseReport String
"# Final summary:"
      (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> StateT ReportState IO ()
report

  Summary -> IO Summary
forall (m :: * -> *) a. Monad m => a -> m a
return Summary
reportStateSummary
 where
  consumeUpdates :: Chan ReportUpdate -> a -> StateT ReportState IO ()
consumeUpdates Chan ReportUpdate
_output a
0 = () -> StateT ReportState IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  consumeUpdates Chan ReportUpdate
output a
modsLeft = do
    ReportUpdate
update <- IO ReportUpdate -> StateT ReportState IO ReportUpdate
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Chan ReportUpdate -> IO ReportUpdate
forall a. Chan a -> IO a
readChan Chan ReportUpdate
output)
    Chan ReportUpdate -> a -> StateT ReportState IO ()
consumeUpdates Chan ReportUpdate
output (a -> StateT ReportState IO ())
-> StateT ReportState IO a -> 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.
FromSetup -> Module a -> SomeException -> StateT ReportState IO ()
reportInternalError FromSetup
fs Module [Located DocTest]
loc SomeException
e StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
modsLeft a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
        UpdateImportError String
modName Either String String
result -> String -> Either String String -> StateT ReportState IO ()
reportImportError String
modName Either String String
result StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
modsLeft a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
        UpdateSuccess FromSetup
fs Location
loc -> FromSetup -> Location -> StateT ReportState IO ()
reportSuccess FromSetup
fs Location
loc StateT ReportState IO ()
-> StateT ReportState IO () -> StateT ReportState IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT ReportState IO ()
reportProgress StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
modsLeft
        UpdateFailure FromSetup
fs Location
loc String
expr [String]
errs -> FromSetup
-> Location -> String -> [String] -> StateT ReportState IO ()
reportFailure FromSetup
fs Location
loc String
expr [String]
errs StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
modsLeft
        UpdateError FromSetup
fs Location
loc String
expr String
err -> FromSetup
-> Location -> String -> String -> StateT ReportState IO ()
reportError FromSetup
fs Location
loc String
expr String
err StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
modsLeft
        UpdateOptionError Location
loc String
err -> Location -> String -> StateT ReportState IO ()
reportOptionError Location
loc String
err StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
modsLeft
        UpdateVerbose String
msg -> String -> StateT ReportState IO ()
verboseReport String
msg StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
modsLeft
        UpdateStart Location
loc String
expr String
msg -> Location -> String -> String -> StateT ReportState IO ()
reportStart Location
loc String
expr String
msg StateT ReportState IO ()
-> StateT ReportState IO a -> StateT ReportState IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
modsLeft
        ReportUpdate
UpdateModuleDone -> a -> StateT ReportState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
modsLeft a -> a -> a
forall a. Num a => a -> a -> a
- a
1)

-- | Count number of expressions in given module.
count :: Module [Located DocTest] -> Int
count :: Module [Located DocTest] -> Int
count (Module String
_ Maybe [Located DocTest]
_ [[Located DocTest]]
tests [Located String]
_) = [Int] -> Int
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 (t :: * -> *) a. Foldable t => t a -> Int
length [[Located DocTest]]
tests)

-- | A monad for generating test reports.
type Report = StateT ReportState IO

data ReportState = ReportState {
  ReportState -> Int
reportStateCount        :: Int     -- ^ characters on the current line
, ReportState -> Bool
reportStateInteractive  :: Bool    -- ^ should intermediate results be printed?
, ReportState -> Bool
reportStateVerbose      :: Bool
, ReportState -> Bool
reportStateQuiet        :: Bool
, ReportState -> Summary
reportStateSummary      :: Summary -- ^ test summary
}

-- | Add output to the report.
report :: String -> Report ()
report :: String -> StateT ReportState IO ()
report String
msg = do
  String -> StateT ReportState IO ()
overwrite String
msg

  -- add a newline, this makes the output permanent
  IO () -> StateT ReportState IO ()
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 :: Int
reportStateCount = Int
0})

-- | Add intermediate output to the report.
--
-- This will be overwritten by subsequent calls to `report`/`report_`.
-- Intermediate out may not contain any newlines.
report_ :: String -> Report ()
report_ :: String -> StateT ReportState IO ()
report_ String
msg = do
  Bool
f <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateInteractive
  Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
f (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 :: Int
reportStateCount = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
msg})

-- | Add output to the report, overwrite any intermediate out.
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 (t :: * -> *) a. Foldable t => t a -> Int
length String
msg) Char
' '
          | Bool
otherwise = String
msg
  IO () -> StateT ReportState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStr Handle
stderr String
str)

-- | Shuffle a list given a seed for an RNG
shuffle :: Int -> [a] -> [a]
shuffle :: 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 (StdGen -> [Int]
forall a g. (Random a, RandomGen g) => g -> [a]
randoms @Int (Int -> StdGen
mkStdGen Int
seed)) [a]
xs

-- | Run all examples from given module.
runModule
  :: ModuleConfig
  -> Bool
  -> [String]
  -> Chan ReportUpdate
  -> Module [Located DocTest]
  -> IO ()
runModule :: ModuleConfig
-> Bool
-> [String]
-> Chan ReportUpdate
-> Module [Located DocTest]
-> IO ()
runModule ModuleConfig
modConfig0 Bool
implicitPrelude [String]
ghciArgs Chan ReportUpdate
output Module [Located DocTest]
mod_ = do
  case Either (Location, String) ModuleConfig
modConfig2 of
    Left (Location
loc, String
flag) ->
      Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (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) -- Should have been set already

        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
$
            -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is
            -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in
            -- a fresh GHCi session.
            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 (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


      [String] -> (Interpreter -> IO ()) -> IO ()
forall a. [String] -> (Interpreter -> IO a) -> IO a
Interpreter.withInterpreter [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
        -- Try to import this module, if it fails, something is off
        Either String String
importResult <-
          case Maybe String
importModule of
            Maybe String
Nothing -> Either String String -> IO (Either String String)
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
            -- Run setup group
            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)
mapM
                (FromSetup
-> Bool
-> Interpreter
-> IO ()
-> Chan ReportUpdate
-> [Located DocTest]
-> IO Bool
runTestGroup FromSetup
FromSetup Bool
preserveIt Interpreter
repl (Interpreter -> IO ()
reload Interpreter
repl) Chan ReportUpdate
output)
                Maybe [Located DocTest]
setup

            -- only run tests, if setup does not produce any errors/failures
            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 ()
-> Chan ReportUpdate
-> [Located DocTest]
-> IO Bool
runTestGroup FromSetup
NotFromSetup Bool
preserveIt Interpreter
repl (Interpreter -> IO ()
setup_ Interpreter
repl) Chan ReportUpdate
output)
                [[Located DocTest]]
examples1)
          Either String String
_ ->
            Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (String -> Either String String -> ReportUpdate
UpdateImportError String
module_ Either String String
importResult)

  -- Signal main thread a module has been tested
  Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output ReportUpdate
UpdateModuleDone

  () -> IO ()
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 Location
  -- ^ Test succeeded
  | UpdateFailure FromSetup Location Expression [String]
  -- ^ Test failed with unexpected result
  | UpdateError FromSetup Location Expression String
  -- ^ Test failed with an error
  | UpdateVerbose String
  -- ^ Message to send when verbose output is activated
  | UpdateModuleDone
  -- ^ All examples tested in module
  | UpdateStart Location Expression String
  -- ^ Indicate test has started executing (verbose output)
  | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException
  -- ^ Exception caught while executing internal code
  | UpdateImportError ModuleName (Either String String)
  -- ^ Could not import module
  | UpdateOptionError Location String
  -- ^ Unrecognized flag in module specific option

makeThreadPool ::
  Int ->
  (Chan ReportUpdate -> Module [Located DocTest] -> IO ()) ->
  IO (Chan (Module [Located DocTest]), Chan ReportUpdate)
makeThreadPool :: Int
-> (Chan ReportUpdate -> Module [Located DocTest] -> IO ())
-> IO (Chan (Module [Located DocTest]), Chan ReportUpdate)
makeThreadPool Int
nThreads Chan ReportUpdate -> Module [Located DocTest] -> IO ()
mutator = do
  Chan (Module [Located DocTest])
input <- IO (Chan (Module [Located DocTest]))
forall a. IO (Chan a)
newChan
  Chan ReportUpdate
output <- IO (Chan 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
      IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
        (Chan ReportUpdate -> Module [Located DocTest] -> IO ()
mutator Chan ReportUpdate
output Module [Located DocTest]
i)
        (\SomeException
e -> Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup
-> Module [Located DocTest] -> SomeException -> ReportUpdate
UpdateInternalError FromSetup
NotFromSetup Module [Located DocTest]
i SomeException
e))
  (Chan (Module [Located DocTest]), Chan ReportUpdate)
-> IO (Chan (Module [Located DocTest]), Chan ReportUpdate)
forall (m :: * -> *) a. Monad m => a -> m a
return (Chan (Module [Located DocTest])
input, Chan ReportUpdate
output)

reportStart :: Location -> Expression -> String -> Report ()
reportStart :: Location -> String -> String -> StateT ReportState IO ()
reportStart Location
loc String
expression String
testType = do
  Bool
quiet <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateQuiet
  Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$
    String -> StateT ReportState IO ()
verboseReport
      (String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"### Started execution at %s.\n### %s:\n%s" (Location -> String
forall a. Show a => a -> String
show Location
loc) String
testType String
expression)

reportFailure :: FromSetup -> Location -> Expression -> [String] -> Report ()
reportFailure :: FromSetup
-> Location -> String -> [String] -> StateT ReportState IO ()
reportFailure FromSetup
fromSetup Location
loc String
expression [String]
err = do
  String -> StateT ReportState IO ()
report (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_ String -> StateT ReportState IO ()
report [String]
err
  String -> StateT ReportState IO ()
report String
""
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
0 Int
1)

reportError :: FromSetup -> Location -> Expression -> String -> Report ()
reportError :: FromSetup
-> Location -> String -> String -> StateT ReportState IO ()
reportError FromSetup
fromSetup Location
loc String
expression String
err = do
  String -> StateT ReportState IO ()
report (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)
  String -> StateT ReportState IO ()
report String
err
  String -> StateT ReportState IO ()
report String
""
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
1 Int
0)

reportOptionError :: Location -> String -> Report ()
reportOptionError :: Location -> String -> StateT ReportState IO ()
reportOptionError Location
loc String
opt = do
  String -> StateT ReportState IO ()
report (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)
  String -> StateT ReportState IO ()
report String
""
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
1 Int
0)

reportInternalError :: FromSetup -> Module a -> SomeException -> Report ()
reportInternalError :: FromSetup -> Module a -> SomeException -> StateT ReportState IO ()
reportInternalError FromSetup
fs Module a
mod_ SomeException
err = do
  String -> StateT ReportState IO ()
report (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_))
  String -> StateT ReportState IO ()
report (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
  String -> StateT ReportState IO ()
report String
""
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fs Summary
emptySummary{sErrors :: Int
sErrors=Int
1}

reportImportError :: ModuleName -> Either String String -> Report ()
reportImportError :: String -> Either String String -> StateT ReportState IO ()
reportImportError String
modName Either String String
importResult = do
  String -> StateT ReportState IO ()
report (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: ")
  String -> StateT ReportState IO ()
report String
""
  String -> StateT ReportState IO ()
report String
" 1. A module found by GHC contained tests, but was not in 'exposed-modules'. If you want"
  String -> StateT ReportState IO ()
report String
"    to test non-exposed modules follow the instructions here:"
  String -> StateT ReportState IO ()
report String
"    https://github.com/martijnbastiaan/doctest-parallel#test-non-exposed-modules"
  String -> StateT ReportState IO ()
report String
""
  String -> StateT ReportState IO ()
report String
" 2. For Cabal users: Cabal did not generate a GHC environment file. Either:"
  String -> StateT ReportState IO ()
report String
"   * Run with '--write-ghc-environment-files=always'"
  String -> StateT ReportState IO ()
report String
"   * Add 'write-ghc-environment-files: always' to your cabal.project"
  String -> StateT ReportState IO ()
report String
""
  String -> StateT ReportState IO ()
report String
" 3. For Cabal users: Cabal did not generate a GHC environment file in time. This"
  String -> StateT ReportState IO ()
report String
"    can happen if you use 'cabal test' instead of 'cabal run doctests'. See"
  String -> StateT ReportState IO ()
report String
"    https://github.com/martijnbastiaan/doctest-parallel/issues/22."
  String -> StateT ReportState IO ()
report String
""
  String -> StateT ReportState IO ()
report String
" 4. The testsuite executable does not have a dependency on your project library. Please"
  String -> StateT ReportState IO ()
report String
"    add it to the 'build-depends' section of the testsuite executable."
  String -> StateT ReportState IO ()
report String
""
  String -> StateT ReportState IO ()
report String
"See the example project at https://github.com/martijnbastiaan/doctest-parallel/blob/main/example/README.md for more information."
  String -> StateT ReportState IO ()
report String
""
  String -> StateT ReportState IO ()
report String
"The original reason given by GHCi was:"
  String -> StateT ReportState IO ()
report String
""
  case Either String String
importResult of
    Left String
out -> do
      String -> StateT ReportState IO ()
report String
"Unexpected output:"
      String -> StateT ReportState IO ()
report String
out
    Right String
err -> do
      String -> StateT ReportState IO ()
report String
"Error:"
      String -> StateT ReportState IO ()
report String
err

  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup Summary
emptySummary{sErrors :: Int
sErrors=Int
1}

reportSuccess :: FromSetup -> Location -> Report ()
reportSuccess :: FromSetup -> Location -> StateT ReportState IO ()
reportSuccess FromSetup
fromSetup Location
loc = do
  Bool
quiet <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateQuiet
  Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$
    String -> StateT ReportState IO ()
verboseReport (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"### Successful `%s'!\n" (Location -> String
forall a. Show a => a -> String
show Location
loc))
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
0 Int
0)

verboseReport :: String -> Report ()
verboseReport :: String -> StateT ReportState IO ()
verboseReport String
xs = do
  Bool
verbose <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateVerbose
  Bool
quiet <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateQuiet
  Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$
      String -> StateT ReportState IO ()
report String
xs

updateSummary :: FromSetup -> Summary -> Report ()
updateSummary :: FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup Summary
summary =
  -- Suppress counts, except for errors and unexpected outputs
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
NotFromSetup Summary
summary{sExamples :: Int
sExamples=Int
0, sTried :: Int
sTried=Int
0}
updateSummary FromSetup
NotFromSetup Summary
summary = do
  ReportState Int
n Bool
f Bool
v Bool
q 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 -> Bool -> Bool -> Summary -> ReportState
ReportState Int
n Bool
f Bool
v Bool
q (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 :: Report ()
reportProgress :: StateT ReportState IO ()
reportProgress = do
  Bool
verbose <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateVerbose
  Bool
quiet <- (ReportState -> Bool) -> StateT ReportState IO Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateQuiet
  Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verbose (StateT ReportState IO () -> StateT ReportState IO ())
-> StateT ReportState IO () -> StateT ReportState IO ()
forall a b. (a -> b) -> a -> b
$
      (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> StateT ReportState IO ()
report_

-- | Run given test group.
--
-- The interpreter state is zeroed with @:reload@ first.  This means that you
-- can reuse the same 'Interpreter' for several test groups.
runTestGroup ::
  FromSetup ->
  Bool ->
  Interpreter ->
  IO () ->
  Chan ReportUpdate ->
  [Located DocTest] ->
  IO Bool
runTestGroup :: FromSetup
-> Bool
-> Interpreter
-> IO ()
-> Chan ReportUpdate
-> [Located DocTest]
-> IO Bool
runTestGroup FromSetup
fromSetup Bool
preserveIt Interpreter
repl IO ()
setup Chan ReportUpdate
output [Located DocTest]
tests = do

  IO ()
setup
  Bool
successExamples <- FromSetup
-> Bool
-> Interpreter
-> Chan ReportUpdate
-> [Located Interaction]
-> IO Bool
runExampleGroup FromSetup
fromSetup Bool
preserveIt Interpreter
repl Chan ReportUpdate
output [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
      Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (Location -> String -> String -> ReportUpdate
UpdateStart Location
loc String
expression String
"property")
      Interpreter -> String -> IO PropertyResult
runProperty Interpreter
repl String
expression

    case PropertyResult
r of
      PropertyResult
Success -> do
        Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup -> Location -> ReportUpdate
UpdateSuccess FromSetup
fromSetup Location
loc)
        Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Error String
err -> do
        Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup -> Location -> String -> String -> ReportUpdate
UpdateError FromSetup
fromSetup Location
loc String
expression String
err)
        Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Failure String
msg -> do
        Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup -> Location -> String -> [String] -> ReportUpdate
UpdateFailure FromSetup
fromSetup Location
loc String
expression [String
msg])
        Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  Bool -> IO Bool
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]

-- |
-- Execute all expressions from given example in given 'Interpreter' and verify
-- the output.
runExampleGroup ::
  FromSetup ->
  Bool ->
  Interpreter ->
  Chan ReportUpdate ->
  [Located Interaction] ->
  IO Bool
runExampleGroup :: FromSetup
-> Bool
-> Interpreter
-> Chan ReportUpdate
-> [Located Interaction]
-> IO Bool
runExampleGroup FromSetup
fromSetup Bool
preserveIt Interpreter
repl Chan ReportUpdate
output = [Located Interaction] -> IO Bool
go
  where
    go :: [Located Interaction] -> IO Bool
go ((Located Location
loc (String
expression, ExpectedResult
expected)) : [Located Interaction]
xs) = do
      Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (Location -> String -> String -> ReportUpdate
UpdateStart Location
loc String
expression String
"example")
      Either String [String]
r <- (String -> [String])
-> Either String String -> Either String [String]
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
          Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup -> Location -> String -> String -> ReportUpdate
UpdateError FromSetup
fromSetup Location
loc String
expression String
err)
          Bool -> IO Bool
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
            Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup -> Location -> String -> [String] -> ReportUpdate
UpdateFailure FromSetup
fromSetup Location
loc String
expression [String]
err)
            Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Result
Equal -> do
            Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (FromSetup -> Location -> ReportUpdate
UpdateSuccess FromSetup
fromSetup Location
loc)
            [Located Interaction] -> IO Bool
go [Located Interaction]
xs
    go [] =
      Bool -> IO Bool
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