{-# LANGUAGE CPP #-}
module Runner (
runModules
, Summary(..)
#ifdef TEST
, Report
, ReportState (..)
, report
, report_
#endif
) where
import Prelude hiding (putStr, putStrLn, error)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid hiding ((<>))
import Control.Applicative
#endif
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
data Summary = Summary {
sExamples :: Int
, sTried :: Int
, sErrors :: Int
, sFailures :: Int
} deriving Eq
instance Show Summary where
show (Summary examples tried errors failures) =
printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures
instance Monoid Summary where
mempty = Summary 0 0 0 0
#if MIN_VERSION_base(4,11,0)
instance Semigroup Summary where
(<>)
#else
mappend
#endif
(Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4)
runModules :: Bool -> Bool -> Bool -> Interpreter -> [Module [Located DocTest]] -> IO Summary
runModules fastMode preserveIt verbose repl modules = do
isInteractive <- hIsTerminalDevice stderr
ReportState _ _ _ s <- (`execStateT` ReportState 0 isInteractive verbose mempty {sExamples = c}) $ do
forM_ modules $ runModule fastMode preserveIt repl
verboseReport "# Final summary:"
gets (show . reportStateSummary) >>= report
return s
where
c = (sum . map count) modules
count :: Module [Located DocTest] -> Int
count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup
type Report = StateT ReportState IO
data ReportState = ReportState {
reportStateCount :: Int
, reportStateInteractive :: Bool
, reportStateVerbose :: Bool
, reportStateSummary :: Summary
}
report :: String -> Report ()
report msg = do
overwrite msg
liftIO $ hPutStrLn stderr ""
modify (\st -> st {reportStateCount = 0})
report_ :: String -> Report ()
report_ msg = do
f <- gets reportStateInteractive
when f $ do
overwrite msg
modify (\st -> st {reportStateCount = length msg})
overwrite :: String -> Report ()
overwrite msg = do
n <- gets reportStateCount
let str | 0 < n = "\r" ++ msg ++ replicate (n - length msg) ' '
| otherwise = msg
liftIO (hPutStr stderr str)
runModule :: Bool -> Bool -> Interpreter -> Module [Located DocTest] -> Report ()
runModule fastMode preserveIt repl (Module module_ setup examples) = do
Summary _ _ e0 f0 <- gets reportStateSummary
forM_ setup $
runTestGroup preserveIt repl reload
Summary _ _ e1 f1 <- gets reportStateSummary
when (e0 == e1 && f0 == f1) $
forM_ examples $
runTestGroup preserveIt repl setup_
where
reload :: IO ()
reload = do
unless fastMode $
void $ Interpreter.safeEval repl ":reload"
void $ Interpreter.safeEval repl $ ":m *" ++ module_
when preserveIt $
void $ Interpreter.safeEval repl $ "()"
setup_ :: IO ()
setup_ = do
reload
forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of
Property _ -> return ()
Example e _ -> void $ safeEvalWith preserveIt repl e
reportStart :: Location -> Expression -> String -> Report ()
reportStart loc expression testType = do
verboseReport (printf "### Started execution at %s.\n### %s:\n%s" (show loc) testType expression)
reportFailure :: Location -> Expression -> [String] -> Report ()
reportFailure loc expression err = do
report (printf "%s: failure in expression `%s'" (show loc) expression)
mapM_ report err
report ""
updateSummary (Summary 0 1 0 1)
reportError :: Location -> Expression -> String -> Report ()
reportError loc expression err = do
report (printf "%s: error in expression `%s'" (show loc) expression)
report err
report ""
updateSummary (Summary 0 1 1 0)
reportSuccess :: Report ()
reportSuccess = do
verboseReport "### Successful!\n"
updateSummary (Summary 0 1 0 0)
verboseReport :: String -> Report ()
verboseReport xs = do
verbose <- gets reportStateVerbose
when verbose $ report xs
updateSummary :: Summary -> Report ()
updateSummary summary = do
ReportState n f v s <- get
put (ReportState n f v $ s `mappend` summary)
reportProgress :: Report ()
reportProgress = do
verbose <- gets reportStateVerbose
when (not verbose) $ gets (show . reportStateSummary) >>= report_
runTestGroup :: Bool -> Interpreter -> IO () -> [Located DocTest] -> Report ()
runTestGroup preserveIt repl setup tests = do
reportProgress
liftIO setup
runExampleGroup preserveIt repl examples
forM_ properties $ \(loc, expression) -> do
r <- do
liftIO setup
reportStart loc expression "property"
liftIO $ runProperty repl expression
case r of
Success ->
reportSuccess
Error err -> do
reportError loc expression err
Failure msg -> do
reportFailure loc expression [msg]
where
properties = [(loc, p) | Located loc (Property p) <- tests]
examples :: [Located Interaction]
examples = [Located loc (e, r) | Located loc (Example e r) <- tests]
runExampleGroup :: Bool -> Interpreter -> [Located Interaction] -> Report ()
runExampleGroup preserveIt repl = go
where
go ((Located loc (expression, expected)) : xs) = do
reportStart loc expression "example"
r <- fmap lines <$> liftIO (safeEvalWith preserveIt repl expression)
case r of
Left err -> do
reportError loc expression err
Right actual -> case mkResult expected actual of
NotEqual err -> do
reportFailure loc expression err
Equal -> do
reportSuccess
go xs
go [] = return ()
safeEvalWith :: Bool -> Interpreter -> String -> IO (Either String String)
safeEvalWith preserveIt
| preserveIt = Interpreter.safeEvalIt
| otherwise = Interpreter.safeEval