{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}

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.Maybe (fromMaybe)
import           Text.Printf (printf)
import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
import           Data.Foldable (forM_)
import           GHC.Conc (numCapabilities)

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)
import           Test.DocTest.Internal.Location
import           Test.DocTest.Internal.Property
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 0 0 0 0

-- | Format a summary.
instance Show Summary where
  show :: Summary -> String
show (Summary examples :: Int
examples tried :: Int
tried errors :: Int
errors failures :: Int
failures) =
    String -> Int -> Int -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf "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 0 0 0 0
#if __GLASGOW_HASKELL__ < 804
  mappend = (<>)
#endif

instance Semigroup Summary where
  <> :: Summary -> Summary -> Summary
(<>) (Summary x1 :: Int
x1 x2 :: Int
x2 x3 :: Int
x3 x4 :: Int
x4) (Summary y1 :: Int
y1 y2 :: Int
y2 y3 :: Int
y3 y4 :: 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
  :: Maybe Int
  -- ^ Number of threads to use. Defaults to 'numCapabilities'.
  -> Bool
  -- ^ Preserve it
  -> Bool
  -- ^ Verbose
  -> Bool
  -- ^ Implicit Prelude
  -> [String]
  -- ^ Arguments passed to the GHCi process.
  -> [Module [Located DocTest]]
  -- ^ Modules under test
  -> IO Summary
runModules :: Maybe Int
-> Bool
-> Bool
-> Bool
-> [String]
-> [Module [Located DocTest]]
-> IO Summary
runModules nThreads :: Maybe Int
nThreads preserveIt :: Bool
preserveIt verbose :: Bool
verbose implicitPrelude :: Bool
implicitPrelude args :: [String]
args modules :: [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'.
  (input :: Chan (Module [Located DocTest])
input, output :: 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
numCapabilities Maybe Int
nThreads)
      (Bool
-> Bool
-> [String]
-> Chan ReportUpdate
-> Module [Located DocTest]
-> IO ()
runModule Bool
preserveIt 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 = Int -> Bool -> Bool -> Summary -> ReportState
ReportState 0 Bool
isInteractive Bool
verbose Summary
forall a. Monoid a => a
mempty {sExamples :: Int
sExamples = Int
nExamples}

  ReportState _ _ _ s :: Summary
s <- (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)
    String -> StateT ReportState IO ()
verboseReport "# 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
s
 where
  consumeUpdates :: Chan ReportUpdate -> a -> StateT ReportState IO ()
consumeUpdates _output :: Chan ReportUpdate
_output 0 = () -> StateT ReportState IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  consumeUpdates output :: Chan ReportUpdate
output modsLeft :: 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 fs :: FromSetup
fs loc :: Module [Located DocTest]
loc e :: 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
- 1)
        UpdateImportError modName :: String
modName -> String -> StateT ReportState IO ()
reportImportError String
modName 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
- 1)
        UpdateSuccess fs :: FromSetup
fs loc :: 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 fs :: FromSetup
fs loc :: Location
loc expr :: String
expr errs :: [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 fs :: FromSetup
fs loc :: Location
loc expr :: String
expr err :: 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
        UpdateVerbose msg :: 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 loc :: Location
loc expr :: String
expr msg :: 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
        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
- 1)

-- | Count number of expressions in given module.
count :: Module [Located DocTest] -> Int
count :: Module [Located DocTest] -> Int
count (Module _ _ tests :: [[Located DocTest]]
tests) = [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 -> Summary
reportStateSummary      :: Summary -- ^ test summary
}

-- | Add output to the report.
report :: String -> Report ()
report :: String -> StateT ReportState IO ()
report msg :: 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 ""
  (ReportState -> ReportState) -> StateT ReportState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\st :: ReportState
st -> ReportState
st {reportStateCount :: Int
reportStateCount = 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_ msg :: 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 (\st :: 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 msg :: 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 | 0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n     = "\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) ' '
          | 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)

-- | Run all examples from given module.
runModule
  :: Bool
  -> Bool
  -> [String]
  -> Chan ReportUpdate
  -> Module [Located DocTest]
  -> IO ()
runModule :: Bool
-> Bool
-> [String]
-> Chan ReportUpdate
-> Module [Located DocTest]
-> IO ()
runModule preserveIt :: Bool
preserveIt implicitPrelude :: Bool
implicitPrelude ghciArgs :: [String]
ghciArgs output :: Chan ReportUpdate
output (Module module_ :: String
module_ setup :: Maybe [Located DocTest]
setup examples :: [[Located DocTest]]
examples) = do
  [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
$ \repl :: 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 <- Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
importModule
    case Either String String
importResult of
      Right "" -> 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]]
examples)
      _ ->
        Chan ReportUpdate -> ReportUpdate -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan ReportUpdate
output (String -> ReportUpdate
UpdateImportError String
module_)

    -- 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
    importModule :: String
importModule = ":m +" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
module_

    reload :: Interpreter -> IO ()
reload repl :: 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 ":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 [":m Prelude", String
importModule]
        else [":m +" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
module_]

      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
$ "()"

    setup_ :: Interpreter -> IO ()
setup_ repl :: 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
$ \l :: [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 _ x :: DocTest
x) -> case DocTest
x of
        Property _  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Example e :: String
e _ -> 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

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
  -- ^ Could not import module

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 nThreads :: Int
nThreads mutator :: 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_ [1..Int
nThreads] ((Int -> IO ThreadId) -> IO ()) -> (Int -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ ->
    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)
        (\e :: 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 loc :: Location
loc expression :: String
expression testType :: String
testType = do
  String -> StateT ReportState IO ()
verboseReport (String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf "### 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
fromSetup loc :: Location
loc expression :: String
expression err :: [String]
err = do
  String -> StateT ReportState IO ()
report (String -> String -> ShowS
forall r. PrintfType r => String -> r
printf "%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 ""
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
fromSetup (Int -> Int -> Int -> Int -> Summary
Summary 0 1 0 1)

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

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

reportImportError :: ModuleName -> Report ()
reportImportError :: String -> StateT ReportState IO ()
reportImportError modName :: String
modName = do
  String -> StateT ReportState IO ()
report ("Could not import module: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
modName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ". This can be caused by a number of issues: ")
  String -> StateT ReportState IO ()
report ""
  String -> StateT ReportState IO ()
report " 1. A module found by GHC contained tests, but was not in 'exposed-modules'."
  String -> StateT ReportState IO ()
report ""
  String -> StateT ReportState IO ()
report " 2. For Cabal users: Cabal did not generate a GHC environment file. Either:"
  String -> StateT ReportState IO ()
report "   * Run with '--write-ghc-environment-files=always'"
  String -> StateT ReportState IO ()
report "   * Add 'write-ghc-environment-files: always' to your cabal.project"
  String -> StateT ReportState IO ()
report ""
  String -> StateT ReportState IO ()
report " 3. The testsuite executable does not have a dependency on your project library. Please add it to the 'build-depends' section of the testsuite executable."
  String -> StateT ReportState IO ()
report ""
  String -> StateT ReportState IO ()
report "See the example project at https://github.com/martijnbastiaan/doctest-parallel/tree/master/examples for more information."
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
FromSetup Summary
emptySummary{sErrors :: Int
sErrors=1}

reportSuccess :: FromSetup -> Location -> Report ()
reportSuccess :: FromSetup -> Location -> StateT ReportState IO ()
reportSuccess fromSetup :: FromSetup
fromSetup loc :: Location
loc = do
  String -> StateT ReportState IO ()
verboseReport (String -> ShowS
forall r. PrintfType r => String -> r
printf "### 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 0 1 0 0)

verboseReport :: String -> Report ()
verboseReport :: String -> StateT ReportState IO ()
verboseReport xs :: 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 -> 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 summary :: Summary
summary =
  -- Suppress counts, except for errors
  FromSetup -> Summary -> StateT ReportState IO ()
updateSummary FromSetup
NotFromSetup Summary
summary{sExamples :: Int
sExamples=0, sTried :: Int
sTried=0, sFailures :: Int
sFailures=0}
updateSummary NotFromSetup summary :: Summary
summary = do
  ReportState n :: Int
n f :: Bool
f v :: Bool
v s :: 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 -> Summary -> ReportState
ReportState Int
n Bool
f Bool
v (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 -> StateT ReportState IO () -> StateT ReportState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not 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
fromSetup preserveIt :: Bool
preserveIt repl :: Interpreter
repl setup :: IO ()
setup output :: Chan ReportUpdate
output tests :: [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
$ \(loc :: Location
loc, expression :: 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 "property")
      Interpreter -> String -> IO PropertyResult
runProperty Interpreter
repl String
expression

    case PropertyResult
r of
      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 err :: 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 msg :: 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 loc :: Location
loc (Property p :: 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 loc :: Location
loc (Example e :: String
e r :: 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
fromSetup preserveIt :: Bool
preserveIt repl :: Interpreter
repl output :: Chan ReportUpdate
output = [Located Interaction] -> IO Bool
go
  where
    go :: [Located Interaction] -> IO Bool
go ((Located loc :: Location
loc (expression :: String
expression, expected :: ExpectedResult
expected)) : xs :: [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 "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 err :: 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 actual :: [String]
actual -> case ExpectedResult -> [String] -> Result
mkResult ExpectedResult
expected [String]
actual of
          NotEqual err :: [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
          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 preserveIt :: Bool
preserveIt
  | Bool
preserveIt = Interpreter -> String -> IO (Either String String)
Interpreter.safeEvalIt
  | Bool
otherwise  = Interpreter -> String -> IO (Either String String)
Interpreter.safeEval