]> Git — Sourcephile - webc.git/blob - tests/HUnits.hs
doc: update public presence
[webc.git] / tests / HUnits.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RankNTypes #-}
3
4 module HUnits where
5
6 import Network.URI.Slug ()
7 import Relude
8 import Symantic qualified as Sym
9 import Test.Tasty
10 import Test.Tasty.HUnit
11
12 import Examples.Ex01 qualified as Ex01
13 import Examples.Ex02 qualified as Ex02
14 import Text.Printf (printf)
15 import Utils
16 import Webc
17
18 test :: TestTree
19 test =
20 testGroup
21 "HUnits"
22 [ testGroup
23 "Generator"
24 [ testGenerator
25 "Ex01"
26 Ex01.site
27 [
28 ( ()
29 ,
30 [ Gen ["index.html"] $ Ex01.Index
31 , Gen ["about.html"] $ Ex01.About
32 -- , Gen ["user", "contact.html"] $ Ex01.Contact "user"
33 -- , Gen ["post"] $ Ex01.Post []
34 -- , Gen ["post", "dir"] $ Ex01.Post ["dir"]
35 -- , Gen ["post", "dir", "dir"] $ Ex01.Post ["dir", "dir"]
36 ]
37 )
38 ]
39 , testGenerator
40 "Ex02"
41 Ex02.site
42 [
43 ( Ex02.model0
44 ,
45 [ Gen ["static"] $ Ex02.SiteStatic
46 , Gen ["feed"] $ Ex02.SiteFeeds
47 , Gen ["filter", "all"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Nothing, filterTag = Nothing}
48 , Gen ["filter", "all", "tag0"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Nothing, filterTag = Just (Ex02.Tag{Ex02.unTag = "tag0"})}
49 , Gen ["filter", "fr"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Nothing}
50 , Gen ["filter", "fr", "tag0"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangEn, filterTag = Just (Ex02.Tag{Ex02.unTag = "tag0"})}
51 , Gen ["filter", "en"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Nothing}
52 , Gen ["filter", "en", "tag0"] $ Ex02.SiteFilter Ex02.Filter{filterLang = Just Ex02.LangFr, filterTag = Just (Ex02.Tag{Ex02.unTag = "tag0"})}
53 ]
54 )
55 ]
56 ]
57 , testGroup
58 "CoderIsomorphism"
59 [ testCoderIsomorphism "Ex01" Ex01.site ()
60 , testCoderIsomorphism "Ex02" Ex02.site Ex02.model0
61 ]
62 , testGroup
63 "Encoder"
64 [ testEncoder
65 "Ex01"
66 Ex01.site
67 [
68 ( ()
69 ,
70 [ Gen ["index.html"] $ Ex01.Index
71 , Gen ["about.html"] $ Ex01.About
72 -- , Gen ["user", "contact.html"] $ Ex01.Contact "user"
73 -- , Gen ["post", "a", "b"] $ Ex01.Post ["a", "b"]
74 ]
75 )
76 ]
77 ]
78 , testGroup
79 "Decoder"
80 [ testDecoder
81 "Ex01"
82 Ex01.site
83 [
84 ( ()
85 ,
86 [ Gen ["index.html"] $ Ex01.Index
87 , Gen ["about.html"] $ Ex01.About
88 -- , Gen ["user", "contact.html"] $ Ex01.Contact "user"
89 -- , Gen ["post", "a", "b"] $ Ex01.Post ["a", "b"]
90 ]
91 )
92 ]
93 , testDecoder
94 "Ex02"
95 Ex02.site
96 [
97 ( Ex02.model0
98 ,
99 [ Gen ["static"] $ Ex02.SiteStatic
100 , Gen
101 ["filter", "all", "tag0"]
102 $ Ex02.SiteFilter
103 Ex02.Filter
104 { Ex02.filterLang = Nothing
105 , Ex02.filterTag = Just (Ex02.Tag "tag0")
106 }
107 ]
108 )
109 ]
110 ]
111 ]
112
113 testGenerator ::
114 Eq a =>
115 Show a =>
116 String ->
117 Sym.Reader model Generator a ->
118 [(model, [Gen a])] ->
119 TestTree
120 testGenerator tn site models =
121 testGroup
122 tn
123 [ testCase (printf "Model%02d" modelNum) do
124 generate (Sym.unReader site model) @?= expectedGens
125 | (modelNum, (model, expectedGens)) <- ol models
126 ]
127
128 testCoderIsomorphism ::
129 Eq a =>
130 Show a =>
131 String ->
132 (forall repr. Testable model repr => Sym.Reader model repr a) ->
133 model ->
134 TestTree
135 testCoderIsomorphism tn site model =
136 testGroup tn $
137 [ testGroup (printf "Url%d" urlNum) $
138 [ ( testCase "decode . encode" do
139 decode @() decoder (encode encoder genValue)
140 >>= (@?= Right genValue)
141 )
142 , ( testCase "encode . decode" do
143 dec <- decode @() decoder genSlugs
144 encode encoder <$> dec @?= Right genSlugs
145 )
146 ]
147 | (urlNum, Gen{..}) <- ol $ generate (Sym.unReader site model)
148 ]
149 where
150 decoder = Sym.unReader site model
151 encoder = Sym.unReader site model
152
153 testDecoder ::
154 Eq a =>
155 Show a =>
156 String ->
157 Sym.Reader model (Decoder ()) a ->
158 [(model, [Gen a])] ->
159 TestTree
160 testDecoder tn site models =
161 testGroup
162 tn
163 [ testGroup
164 (printf "Model%d" modelNum)
165 [ testCase (printf "Gen%d" genNum) do
166 decode (Sym.unReader site model) genSlugs
167 >>= (@?= Right genValue)
168 | (genNum, Gen{..}) <- ol expectedGens
169 ]
170 | (modelNum, (model, expectedGens)) <- ol models
171 ]
172
173 testEncoder :: String -> Sym.Reader model Encoder a -> [(model, [Gen a])] -> TestTree
174 testEncoder tn site models =
175 testGroup
176 tn
177 [ testGroup
178 (printf "Model%d" modelNum)
179 [ testCase (printf "Gen%d" genNum) do
180 encode (Sym.unReader site model) genValue @?= genSlugs
181 | (genNum, Gen{..}) <- ol expectedGens
182 ]
183 | (modelNum, (model, expectedGens)) <- ol models
184 ]