0 | ||| Facilities for testing Hedgehog using Hedgehog
 1 | |||
 2 | ||| Module contains properties to check how Hedgehog behaves on given properties
 3 | module Hedgehog.Meta
 4 |
 5 | import Control.Monad.Identity
 6 | import Control.Monad.Writer
 7 |
 8 | import Data.List
 9 | import Data.String
10 |
11 | import public Hedgehog
12 |
13 | %default total
14 |
15 | trimDeep : List String -> List String
16 | trimDeep = filter (not . null) . map trim
17 |
18 | annotateSeedIfNeeded : List String -> PropertyT ()
19 | annotateSeedIfNeeded outs = do
20 |   let seeds = filter (isInfixOf "rawStdGen") outs
21 |   for_ seeds $ footnote . delay
22 |
23 | containsEach :
24 |      (checkPrefixOnly : Bool)
25 |   -> (actual, expected : List String)
26 |   -> Bool
27 | containsEach _               []      (_::_)  = False
28 | containsEach checkPrefixOnly (_::_)  []      = checkPrefixOnly
29 | containsEach _               []      []      = True
30 | containsEach checkPrefixOnly (o::os) (i::is) =
31 |   (i `isInfixOf` o) && containsEach checkPrefixOnly os is
32 |
33 | doCheck :
34 |      (checkPrefixOnly : Bool)
35 |   -> (expected : String)
36 |   -> (forall m. HasTerminal m => Monad m => m ())
37 |   -> PropertyT ()
38 | doCheck checkPrefixOnly expected checker = do
39 |   let actual = trimDeep $ (>>= lines) $ execWriter $ checker @{StdoutOnly}
40 |   annotateSeedIfNeeded actual
41 |   diff actual (containsEach checkPrefixOnly) (trimDeep $ lines expected)
42 |
43 | ||| A property checking that Hedgehog being run on a particular property
44 | ||| with particular configuration prints expected string.
45 | |||
46 | ||| The check passes if every line of Hedgehog's output contains a corresponding
47 | ||| line of `expected` string as a substring. Empty lines, leading and traling
48 | ||| spaces are ignored in both the `expected` string, and Hedgehog's output.
49 | export
50 | recheckGivenOutput :
51 |      {default False checkPrefixOnly : Bool}
52 |   -> (expected : String)
53 |   -> (prop : Property)
54 |   -> Size
55 |   -> StdGen
56 |   -> Property
57 | recheckGivenOutput expected prop sz sd = property $
58 |   doCheck checkPrefixOnly expected $ recheck sz sd prop
59 |
60 | ||| A property checking that Hedgehog being run on a default configuration
61 | ||| and a random seed prints expected string.
62 | |||
63 | ||| The check passes if every line of Hedgehog's output contains a corresponding
64 | ||| line of `expected` string as a substring. Empty lines, leading and traling
65 | ||| spaces are ignored in both the `expected` string, and Hedgehog's output.
66 | export
67 | checkGivenOutput :
68 |      {default False checkPrefixOnly : Bool}
69 |   -> (expected : String)
70 |   -> (prop : Property)
71 |   -> Property
72 | checkGivenOutput expected prop = property $ do
73 |   initSeed <- forAll anyBits64
74 |   doCheck checkPrefixOnly expected $
75 |     ignore $ check @{ConstSeed $ mkStdGen initSeed} prop
76 |