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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
module Test.Framework (
TestTree,
testGroup,
testGroupCollapse,
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.Maybe (isJust)
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 Bool String [TestTree]
| forall a. Resource (IO a) (a -> IO ()) (a -> TestTree)
| HP String H.Property
type TestName = String
testGroup :: String -> [TestTree] -> TestTree
testGroup = Group False
testGroupCollapse :: String -> [TestTree] -> TestTree
testGroupCollapse = Group True
-- | 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 True name trees) = maximum (2*indent + length name : map (go (indent+1)) trees)
go indent (Group False _ 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
(success, stats) <- runStateT m initStats
endtm <- getCurrentTime
printStats stats (diffUTCTime endtm starttm)
return (if isJust success then ExitSuccess else ExitFailure 1)
where
-- If all tests are successful, returns the number of output lines produced
go :: (?maxlen :: Int) => Int -> TestTree -> M (Maybe Int)
go indent (Group collapse name trees) = do
liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name)
starttm <- liftIO getCurrentTime
mlns <- fmap (fmap sum . sequence) . forM trees $ go (indent + 1)
endtm <- liftIO getCurrentTime
case mlns of
Just lns | collapse -> do
let thislen = 2*indent + length name
liftIO $ putStrLn $ concat (replicate (lns+1) "\x1B[A\x1B[2K") ++ "\x1B[G" ++
replicate (2 * indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' ++
"\x1B[32mOK\x1B[0m" ++
prettyDuration False (realToFrac (diffUTCTime endtm starttm))
return (Just 1)
_ -> return mlns
go indent (Resource make cleanup fun) = do
value <- liftIO make
success <- go indent (fun value)
liftIO $ cleanup value
return success
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)
let ok = H.reportStatus report == H.OK
modifyStats $ \stats -> stats { statsOK = fromEnum ok + statsOK stats
, statsTotal = 1 + statsTotal stats }
return (if ok then Just 1 else Nothing)
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 H.reportStatus report == H.OK
then putStrLn ("\x1B[K" ++ str ++ prettyDuration False (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." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m"
| otherwise =
let nfailed = statsTotal stats - statsOK stats
in putStrLn $ "\x1B[31mFailed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++
" tests." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m"
prettyDuration :: Bool -> Double -> String
prettyDuration False x | x < 0.5 = ""
prettyDuration _ 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])
|
