{-# LANGUAGE CPP #-}
module Runner (
  runModules
, Summary(..)

#ifdef TEST
, Report
, ReportState (..)
, report
, report_
#endif
) where

import           Prelude hiding (putStr, putStrLn, error)

import           Control.Monad hiding (forM_)
import           Text.Printf (printf)
import           System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice)
import           Data.Foldable (forM_)

import           Control.Monad.Trans.State
import           Control.Monad.IO.Class

import           Interpreter (Interpreter)
import qualified Interpreter
import           Parse
import           Location
import           Property
import           Runner.Example

-- | Summary of a test run.
data Summary = Summary {
  Summary -> Int
sExamples :: Int
, Summary -> Int
sTried    :: Int
, Summary -> Int
sErrors   :: Int
, Summary -> Int
sFailures :: Int
} deriving Summary -> Summary -> Bool
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

-- | Format a summary.
instance Show Summary where
  show :: Summary -> String
show (Summary Int
examples Int
tried Int
errors Int
failures) =
    forall r. PrintfType r => String -> r
printf String
"Examples: %d  Tried: %d  Errors: %d  Failures: %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
#else
instance Semigroup Summary where
  <> :: Summary -> Summary -> Summary
(<>)
#endif
    (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 forall a. Num a => a -> a -> a
+ Int
y1) (Int
x2 forall a. Num a => a -> a -> a
+ Int
y2) (Int
x3 forall a. Num a => a -> a -> a
+ Int
y3) (Int
x4 forall a. Num a => a -> a -> a
+ Int
y4)

-- | Run all examples from a list of modules.
runModules :: Bool -> Bool -> Bool -> Interpreter -> [Module [Located DocTest]] -> IO Summary
runModules :: Bool
-> Bool
-> Bool
-> Interpreter
-> [Module [Located DocTest]]
-> IO Summary
runModules Bool
fastMode Bool
preserveIt Bool
verbose Interpreter
repl [Module [Located DocTest]]
modules = do
  Bool
isInteractive <- Handle -> IO Bool
hIsTerminalDevice Handle
stderr
  ReportState Int
_ Bool
_ Bool
_ Summary
s <- (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`execStateT` Int -> Bool -> Bool -> Summary -> ReportState
ReportState Int
0 Bool
isInteractive Bool
verbose forall a. Monoid a => a
mempty {sExamples :: Int
sExamples = Int
c}) forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Module [Located DocTest]]
modules forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Interpreter
-> Module [Located DocTest]
-> StateT ReportState IO ()
runModule Bool
fastMode Bool
preserveIt Interpreter
repl

    String -> StateT ReportState IO ()
verboseReport String
"# Final summary:"
    forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportState -> Summary
reportStateSummary) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> StateT ReportState IO ()
report

  forall (m :: * -> *) a. Monad m => a -> m a
return Summary
s
  where
    c :: Int
c = (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Module [Located DocTest] -> Int
count) [Module [Located DocTest]]
modules

-- | Count number of expressions in given module.
count :: Module [Located DocTest] -> Int
count :: Module [Located DocTest] -> Int
count (Module String
_ Maybe [Located DocTest]
setup [[Located DocTest]]
tests) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Located DocTest]]
tests) forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe [Located DocTest]
setup

-- | 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 String
msg = do
  String -> StateT ReportState IO ()
overwrite String
msg

  -- add a newline, this makes the output permanent
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
""
  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 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateInteractive
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
f forall a b. (a -> b) -> a -> b
$ do
    String -> StateT ReportState IO ()
overwrite String
msg
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\ReportState
st -> ReportState
st {reportStateCount :: Int
reportStateCount = 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 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Int
reportStateCount
  let str :: String
str | Int
0 forall a. Ord a => a -> a -> Bool
< Int
n     = String
"\r" forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
msg) Char
' '
          | Bool
otherwise = String
msg
  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 -> Interpreter -> Module [Located DocTest] -> Report ()
runModule :: Bool
-> Bool
-> Interpreter
-> Module [Located DocTest]
-> StateT ReportState IO ()
runModule Bool
fastMode Bool
preserveIt Interpreter
repl (Module String
module_ Maybe [Located DocTest]
setup [[Located DocTest]]
examples) = do

  Summary Int
_ Int
_ Int
e0 Int
f0 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Summary
reportStateSummary

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Located DocTest]
setup forall a b. (a -> b) -> a -> b
$
    Bool
-> Interpreter
-> IO ()
-> [Located DocTest]
-> StateT ReportState IO ()
runTestGroup Bool
preserveIt Interpreter
repl IO ()
reload

  Summary Int
_ Int
_ Int
e1 Int
f1 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Summary
reportStateSummary

  -- only run tests, if setup does not produce any errors/failures
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
e0 forall a. Eq a => a -> a -> Bool
== Int
e1 Bool -> Bool -> Bool
&& Int
f0 forall a. Eq a => a -> a -> Bool
== Int
f1) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Located DocTest]]
examples forall a b. (a -> b) -> a -> b
$
      Bool
-> Interpreter
-> IO ()
-> [Located DocTest]
-> StateT ReportState IO ()
runTestGroup Bool
preserveIt Interpreter
repl IO ()
setup_
  where
    reload :: IO ()
    reload :: IO ()
reload = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fastMode forall a b. (a -> b) -> a -> b
$
        -- NOTE: It is important to do the :reload first! See
        -- https://gitlab.haskell.org/ghc/ghc/-/issues/5904, which results in a
        -- panic on GHC 7.4.1 if you do the :reload second.
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl String
":reload"
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl forall a b. (a -> b) -> a -> b
$ String
":m *" forall a. [a] -> [a] -> [a]
++ String
module_

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preserveIt 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.
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Interpreter -> String -> IO (Either String String)
Interpreter.safeEval Interpreter
repl forall a b. (a -> b) -> a -> b
$ String
"()"

    setup_ :: IO ()
    setup_ :: IO ()
setup_ = do
      IO ()
reload
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [Located DocTest]
setup forall a b. (a -> b) -> a -> b
$ \[Located DocTest]
l -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located DocTest]
l forall a b. (a -> b) -> a -> b
$ \(Located Location
_ DocTest
x) -> case DocTest
x of
        Property String
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Example String
e ExpectedResult
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith Bool
preserveIt Interpreter
repl String
e

reportStart :: Location -> Expression -> String -> Report ()
reportStart :: Location -> String -> String -> StateT ReportState IO ()
reportStart Location
loc String
expression String
testType = do
  String -> StateT ReportState IO ()
verboseReport (forall r. PrintfType r => String -> r
printf String
"### Started execution at %s.\n### %s:\n%s" (forall a. Show a => a -> String
show Location
loc) String
testType String
expression)

reportFailure :: Location -> Expression -> [String] -> Report ()
reportFailure :: Location -> String -> [String] -> StateT ReportState IO ()
reportFailure Location
loc String
expression [String]
err = do
  String -> StateT ReportState IO ()
report (forall r. PrintfType r => String -> r
printf String
"%s: failure in expression `%s'" (forall a. Show a => a -> String
show Location
loc) String
expression)
  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
""
  Summary -> StateT ReportState IO ()
updateSummary (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
0 Int
1)

reportError :: Location -> Expression -> String -> Report ()
reportError :: Location -> String -> String -> StateT ReportState IO ()
reportError Location
loc String
expression String
err = do
  String -> StateT ReportState IO ()
report (forall r. PrintfType r => String -> r
printf String
"%s: error in expression `%s'" (forall a. Show a => a -> String
show Location
loc) String
expression)
  String -> StateT ReportState IO ()
report String
err
  String -> StateT ReportState IO ()
report String
""
  Summary -> StateT ReportState IO ()
updateSummary (Int -> Int -> Int -> Int -> Summary
Summary Int
0 Int
1 Int
1 Int
0)

reportSuccess :: Report ()
reportSuccess :: StateT ReportState IO ()
reportSuccess = do
  String -> StateT ReportState IO ()
verboseReport String
"### Successful!\n"
  Summary -> StateT ReportState IO ()
updateSummary (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 <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateVerbose
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose forall a b. (a -> b) -> a -> b
$ String -> StateT ReportState IO ()
report String
xs

updateSummary :: Summary -> Report ()
updateSummary :: Summary -> StateT ReportState IO ()
updateSummary Summary
summary = do
  ReportState Int
n Bool
f Bool
v Summary
s <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int -> Bool -> Bool -> Summary -> ReportState
ReportState Int
n Bool
f Bool
v forall a b. (a -> b) -> a -> b
$ Summary
s forall a. Monoid a => a -> a -> a
`mappend` Summary
summary)

reportProgress :: Report ()
reportProgress :: StateT ReportState IO ()
reportProgress = do
  Bool
verbose <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ReportState -> Bool
reportStateVerbose
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
verbose) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportState -> Summary
reportStateSummary) 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 :: Bool -> Interpreter -> IO () -> [Located DocTest] -> Report ()
runTestGroup :: Bool
-> Interpreter
-> IO ()
-> [Located DocTest]
-> StateT ReportState IO ()
runTestGroup Bool
preserveIt Interpreter
repl IO ()
setup [Located DocTest]
tests = do

  StateT ReportState IO ()
reportProgress

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
setup
  Bool
-> Interpreter -> [Located Interaction] -> StateT ReportState IO ()
runExampleGroup Bool
preserveIt Interpreter
repl [Located Interaction]
examples

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Location, String)]
properties forall a b. (a -> b) -> a -> b
$ \(Location
loc, String
expression) -> do
    PropertyResult
r <- do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
setup
      Location -> String -> String -> StateT ReportState IO ()
reportStart Location
loc String
expression String
"property"
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interpreter -> String -> IO PropertyResult
runProperty Interpreter
repl String
expression
    case PropertyResult
r of
      PropertyResult
Success ->
        StateT ReportState IO ()
reportSuccess
      Error String
err -> do
        Location -> String -> String -> StateT ReportState IO ()
reportError Location
loc String
expression String
err
      Failure String
msg -> do
        Location -> String -> [String] -> StateT ReportState IO ()
reportFailure Location
loc String
expression [String
msg]
  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 = [forall a. Location -> a -> Located a
Located Location
loc (String
e, ExpectedResult
r) | Located Location
loc (Example String
e ExpectedResult
r) <- [Located DocTest]
tests]

type Interaction = (Expression, ExpectedResult)

-- |
-- Execute all expressions from given example in given 'Interpreter' and verify
-- the output.
runExampleGroup :: Bool -> Interpreter -> [Located Interaction] -> Report ()
runExampleGroup :: Bool
-> Interpreter -> [Located Interaction] -> StateT ReportState IO ()
runExampleGroup Bool
preserveIt Interpreter
repl = [Located Interaction] -> StateT ReportState IO ()
go
  where
    go :: [Located Interaction] -> StateT ReportState IO ()
go ((Located Location
loc (String
expression, ExpectedResult
expected)) : [Located Interaction]
xs) = do
      Location -> String -> String -> StateT ReportState IO ()
reportStart Location
loc String
expression String
"example"
      Either String [String]
r <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith Bool
preserveIt Interpreter
repl String
expression)
      case Either String [String]
r of
        Left String
err -> do
          Location -> String -> String -> StateT ReportState IO ()
reportError Location
loc String
expression String
err
        Right [String]
actual -> case ExpectedResult -> [String] -> Result
mkResult ExpectedResult
expected [String]
actual of
          NotEqual [String]
err -> do
            Location -> String -> [String] -> StateT ReportState IO ()
reportFailure Location
loc String
expression [String]
err
          Result
Equal -> do
            StateT ReportState IO ()
reportSuccess
            [Located Interaction] -> StateT ReportState IO ()
go [Located Interaction]
xs
    go [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()

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