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
|
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
-- |
-- Template Haskell to generate defaultMain with a list of "Test" from
-- \"doc_test\", \"case_\<somthing\>\", and \"prop_\<somthing\>\".
--
-- An example of source code (Data/MySet.hs):
--
-- > {-| Creating a set from a list. O(N log N)
-- >
-- > >>> empty == fromList []
-- > True
-- > >>> singleton 'a' == fromList ['a']
-- > True
-- > >>> fromList [5,3,5] == fromList [5,3]
-- > True
-- > -}
-- >
-- > fromList :: Ord a => [a] -> RBTree a
-- > fromList = foldl' (flip insert) empty
--
-- An example of test code in the src directory (test/Test.hs):
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > module Main where
-- >
-- > import Test.Framework.TH.Prime
-- > import Test.Framework.Providers.DocTest
-- > import Test.Framework.Providers.HUnit
-- > import Test.Framework.Providers.QuickCheck2
-- > import Test.QuickCheck2
-- > import Test.HUnit
-- >
-- > import Data.MySet
-- >
-- > main :: IO ()
-- > main = $(defaultMainGenerator)
-- >
-- > doc_test :: DocTests
-- > doc_test = docTest ["../Data/MySet.hs"] ["-i.."]
-- >
-- > prop_toList :: [Int] -> Bool
-- > prop_toList xs = ordered ys
-- > where
-- > ys = toList . fromList $ xs
-- > ordered (x:y:xys) = x <= y && ordered (y:xys)
-- > ordered _ = True
-- >
-- > case_ticket4242 :: Assertion
-- > case_ticket4242 = (valid $ deleteMin $ deleteMin $ fromList [0,2,5,1,6,4,8,9,7,11,10,3]) @?= True
--
-- And run:
--
-- > test% runghc -i.. Test.hs
--
-- "defaultMainGenerator" generates the following:
--
-- > main = do
-- > TestGroup _ doctests <- docTest ["../Data/MySet.hs"] ["-i.."]
-- > defaultMain [
-- > testGroup "Doc tests" doctests
-- > , testGroup "Unit tests" [
-- > testCase "case_ticket4242" case_ticket4242
-- > ]
-- > , testGroup "Property tests" [
-- > testProperty "prop_toList" prop_toList
-- > ]
-- > ]
--
-- Note: examples in haddock document is only used as unit tests at this
-- moment. I hope that properties of QuickCheck2 can also be specified in
-- haddock document in the future. I guess it's Haskell way of Behavior
-- Driven Development.
module Test.Framework.TH.Prime (
defaultMainGenerator
, DocTests
) where
import Control.Applicative
import Language.Haskell.TH hiding (Match)
import Language.Haskell.TH.Syntax hiding (Match)
import Test.Framework (defaultMain)
import Test.Framework.Providers.API
import Test.Framework.TH.Prime.Parser
----------------------------------------------------------------
-- | Type for \"doc_test\".
type DocTests = IO Test
----------------------------------------------------------------
{-|
Generating defaultMain with a list of "Test" from \"doc_test\",
\"case_\<somthing\>\", and \"prop_\<somthing\>\".
-}
defaultMainGenerator :: ExpQ
defaultMainGenerator = do
defined <- isDefined docTestKeyword
if defined then [|
do TestGroup _ doctests <- $(docTests)
let (unittests, proptests) = $(unitPropTests)
defaultMain [ testGroup "Doc tests" doctests
, testGroup "Unit tests" unittests
, testGroup "Property tests" proptests
]
|] else [|
do let (unittests, proptests) = $(unitPropTests)
defaultMain [ testGroup "Unit tests" unittests
, testGroup "Property tests" proptests
]
|]
----------------------------------------------------------------
-- code from Hiromi Ishii
isDefined :: String -> Q Bool
isDefined n = return False `recover` do
VarI (Name _ flavour) _ _ _ <- reify (mkName n)
modul <- loc_module <$> location
case flavour of
NameG ns _ mdl -> return (ns == VarName && modString mdl == modul)
_ -> return False
----------------------------------------------------------------
docTestKeyword :: String
docTestKeyword = "doc_test"
docTests :: ExpQ
docTests = return $ symbol docTestKeyword
|
