1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
module Test.Framework (
TestTree,
testGroup,
testProperty,
withResource,
withResource',
runTests,
defaultMain,
-- * Compatibility
TestName,
) where
import Control.Monad (forM_)
import Control.Monad.Trans.State.Strict
import Control.Monad.IO.Class
import Data.String (fromString)
import Data.Time.Clock
import System.Exit
import System.IO (hFlush, stdout)
import qualified Hedgehog as H
import qualified Hedgehog.Internal.Config as H
import qualified Hedgehog.Internal.Property as H
import qualified Hedgehog.Internal.Report as H
import qualified Hedgehog.Internal.Runner as H
import qualified Hedgehog.Internal.Seed as H.Seed
data TestTree
= Group String [TestTree]
| forall a. Resource (IO a) (a -> IO ()) (a -> TestTree)
| HP String H.Property
type TestName = String
testGroup :: String -> [TestTree] -> TestTree
testGroup = Group
-- | The @a -> TestTree@ function must use the @a@ only inside properties: when
-- not actually running properties, it will be passed 'undefined'.
withResource :: IO a -> (a -> IO ()) -> (a -> TestTree) -> TestTree
withResource = Resource
-- | Same caveats as 'withResource'.
withResource' :: IO a -> (a -> TestTree) -> TestTree
withResource' make fun = withResource make (\_ -> return ()) fun
testProperty :: String -> H.Property -> TestTree
testProperty = HP
computeMaxLen :: TestTree -> Int
computeMaxLen = go 0
where
go :: Int -> TestTree -> Int
-- go indent (Group name trees) = maximum (2*indent + length name : map (go (indent+1)) trees)
go indent (Group _ trees) = maximum (0 : map (go (indent+1)) trees)
go indent (Resource _ _ fun) = go indent (fun undefined)
go indent (HP name _) = 2 * indent + length name
data Stats = Stats
{ statsOK :: Int
, statsTotal :: Int }
deriving (Show)
initStats :: Stats
initStats = Stats 0 0
newtype M a = M (StateT Stats IO a)
deriving newtype (Functor, Applicative, Monad, MonadIO)
modifyStats :: (Stats -> Stats) -> M ()
modifyStats f = M (modify f)
defaultMain :: TestTree -> IO ()
defaultMain tree = runTests tree >>= exitWith
runTests :: TestTree -> IO ExitCode
runTests = \tree -> do
let M m = let ?maxlen = computeMaxLen tree in go 0 tree
starttm <- getCurrentTime
stats <- execStateT m initStats
endtm <- getCurrentTime
printStats stats (diffUTCTime endtm starttm)
return (if statsOK stats == statsTotal stats
then ExitSuccess else ExitFailure 1)
where
go :: (?maxlen :: Int) => Int -> TestTree -> M ()
go indent (Group name trees) = do
liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name)
forM_ trees $ go (indent + 1)
go indent (Resource make cleanup fun) = do
value <- liftIO make
go indent (fun value)
liftIO $ cleanup value
return ()
go indent (HP name (H.Property config test)) = do
let thislen = 2*indent + length name
liftIO $ putStr (replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ')
liftIO $ hFlush stdout
seed <- H.Seed.random
starttm <- liftIO getCurrentTime
report <- liftIO $ H.checkReport config 0 seed test (outputProgress (?maxlen + 2))
endtm <- liftIO getCurrentTime
liftIO $ printResult report (diffUTCTime endtm starttm)
modifyStats $ \stats -> stats { statsOK = fromEnum (H.reportStatus report == H.OK) + statsOK stats
, statsTotal = 1 + statsTotal stats }
outputProgress :: Int -> H.Report H.Progress -> IO ()
outputProgress indent report = do
str <- H.renderProgress H.EnableColor (Just (fromString "")) report
putStr (replace '\n' " " str ++ "\x1B[" ++ show (indent+1) ++ "G")
hFlush stdout
printResult :: H.Report H.Result -> NominalDiffTime -> IO ()
printResult report timeTaken = do
str <- H.renderResult H.EnableColor (Just (fromString "")) report
if timeTaken >= 0.5 && H.reportStatus report == H.OK
then putStrLn ("\x1B[K" ++ str ++ " (" ++ prettySeconds (realToFrac timeTaken) ++ ")")
else putStrLn ("\x1B[K" ++ str)
printStats :: Stats -> NominalDiffTime -> IO ()
printStats stats timeTaken
| statsOK stats == statsTotal stats = do
putStrLn $ "\x1B[32mAll " ++ show (statsTotal stats) ++
" tests passed. (" ++ prettySeconds (realToFrac timeTaken) ++ ")\x1B[0m"
| otherwise =
let nfailed = statsTotal stats - statsOK stats
in putStrLn $ "\x1B[31mFailed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++
" tests. (" ++ prettySeconds (realToFrac timeTaken) ++ ")\x1B[0m"
prettySeconds :: Double -> String
prettySeconds x =
let str = show (round (x * 100) :: Int)
str' = replicate (3 - length str) '0' ++ str
(pre, post) = splitAt (length str' - 2) str'
in pre ++ "." ++ post ++ "s"
replace :: Eq a => a -> [a] -> [a] -> [a]
replace x ys = concatMap (\y -> if y == x then ys else [y])
|
