]> Git — Sourcephile - majurity.git/blob - test/HUnit.hs
Bump stack resolver to lts-9.0.
[majurity.git] / test / HUnit.hs
1 {-# LANGUAGE OverloadedLists #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module HUnit where
4
5 import Test.Tasty
6 import Test.Tasty.HUnit
7
8 import Control.Arrow (second)
9 import qualified Data.Map.Strict as Map
10
11 import Hjugement
12 import Types
13
14 hunits :: TestTree
15 hunits =
16 testGroup "HUnit"
17 [ testGroup "Value" $
18 [ testCompareValue
19 [(3,15), (2,7), (1,3), (0::Int,2)]
20 [(3,16), (2,6), (1,2), (0,3)]
21 , testGroup "OfMerits"
22 [ let m = mkMerit ['A'..'F'] in
23 testValueOfMerits
24 [ (The, m [136,307,251,148,84,74])
25 ]
26 [ (The, [('C',251),('B',307),('D',148),('E',84),('A',136),('F',74)])
27 ]
28 , let m = mkMerit [ToReject .. TooGood] in
29 testValueOfMerits
30 [ (This, m [12,10,21,5,5,5,2])
31 , (That, m [12,16,22,3,3,3,1])
32 ]
33 [ (This, [(Acceptable,21),(Insufficient,10),(Good,5),(ToReject,12),(Perfect,5),(VeryGood,5),(TooGood,2)])
34 , (That, [(Acceptable,22),(Insufficient,16),(ToReject,12),(VeryGood,3),(Perfect,3),(Good,3),(TooGood,1)])
35 ]
36 ]
37 , testGroup "OfOpinions"
38 [ testValueOfOpinions [No,Yes]
39 [The]
40 [ [No ]
41 , [No ]
42 , [No ]
43 , [No ]
44 , [Yes]
45 , [Yes]
46 ]
47 [ (The, [(No,4),(Yes,2)])
48 ]
49 , testValueOfOpinions [No,Yes]
50 [The]
51 [ [No ]
52 , [No ]
53 , [No ]
54 , [Yes]
55 , [Yes]
56 , [Yes]
57 ]
58 [ (The, [(No,3),(Yes,3)])
59 ]
60 , testValueOfOpinions [No,Yes]
61 [This, That]
62 [ [No , No ]
63 , [No , Yes]
64 , [No , Yes]
65 , [No , Yes]
66 , [Yes , Yes]
67 , [Yes , Yes]
68 ]
69 [ (This, [(No,4),(Yes,2)])
70 , (That, [(Yes,5),(No,1)])
71 ]
72 , testValueOfOpinions [No,Yes]
73 [This, That]
74 [ [No , No ]
75 , [No , No ]
76 , [No , No ]
77 , [No , Yes]
78 , [No , Yes]
79 , [No , Yes]
80 ]
81 [ (This, [(No,6),(Yes,0)])
82 , (That, [(No,3),(Yes,3)])
83 ]
84 , testValueOfOpinions [No,Yes]
85 [This, That]
86 [ [Yes , No ]
87 , [Yes , No ]
88 , [Yes , No ]
89 , [Yes , Yes]
90 , [Yes , Yes]
91 , [Yes , Yes]
92 ]
93 [ (This, [(Yes,6),(No,0)])
94 , (That, [(No,3),(Yes,3)])
95 ]
96 , testValueOfOpinions [No,Yes]
97 [This, That]
98 [ [No , No ]
99 , [No , No ]
100 , [Yes , No ]
101 , [Yes , Yes]
102 , [Yes , Yes]
103 , [Yes , Yes]
104 ]
105 [ (This, [(Yes,4),(No,2)])
106 , (That, [(No,3),(Yes,3)])
107 ]
108 , testValueOfOpinions [ToReject,Insufficient,Acceptable,Good,VeryGood,Perfect]
109 [1::Int ..6]
110 [ [Perfect,Perfect,Acceptable,VeryGood,Good,VeryGood]
111 , [Perfect,VeryGood,Perfect,Good,Acceptable,Acceptable]
112 , [VeryGood,VeryGood,Good,Acceptable,VeryGood,Insufficient]
113 , [Perfect,VeryGood,VeryGood,Good,Good,Acceptable]
114 , [Perfect,Good,VeryGood,Good,Good,Acceptable]
115 , [Perfect,VeryGood,Perfect,Good,Good,Good]
116 ]
117 [ (1, [(Perfect,5),(VeryGood,1),(ToReject,0),(Insufficient,0),(Acceptable,0),(Good,0)])
118 , (2, [(VeryGood,4),(Good,1),(Perfect,1),(ToReject,0),(Insufficient,0),(Acceptable,0)])
119 , (3, [(VeryGood,2),(Good,1),(Perfect,2),(Acceptable,1),(ToReject,0),(Insufficient,0)])
120 , (4, [(Good,4),(Acceptable,1),(VeryGood,1),(ToReject,0),(Insufficient,0),(Perfect,0)])
121 , (5, [(Good,4),(Acceptable,1),(VeryGood,1),(ToReject,0),(Insufficient,0),(Perfect,0)])
122 , (6, [(Acceptable,3),(Good,1),(Insufficient,1),(VeryGood,1),(ToReject,0),(Perfect,0)])
123 ]
124 ]
125 ]
126 ]
127
128
129 elide :: String -> String
130 elide s | length s > 42 = take 42 s ++ ['…']
131 | otherwise = s
132
133 mkOpinion :: Ord prop =>
134 Choices prop -> judge -> [grade] ->
135 (judge, Opinion prop grade)
136 mkOpinion props j gs = (j, Map.fromList $ toList props `zip` gs)
137
138 mkMerit :: (Ord grade, Show grade) => [grade] -> [Count] -> Merit grade
139 mkMerit scal = fromList . (scal`zip`)
140
141 mkMerits :: (Ord prop, Ord grade) =>
142 [grade] -> Choices prop -> [[grade]] ->
143 Merits prop grade
144 mkMerits scal props opins =
145 merits (Scale (fromList scal) (head scal)) props $ fromList $
146 zipWith (mkOpinion props) [1::Int ..] opins
147
148
149 testCompareValue :: (Ord grade, Show grade) =>
150 [(grade, Count)] -> [(grade, Count)] -> TestTree
151 testCompareValue x y =
152 testGroup (elide $ show (x,y))
153 [ testCase "x == x" $ Value x`compare`Value x @?= EQ
154 , testCase "y == y" $ Value y`compare`Value y @?= EQ
155 , testCase "x < y" $ Value x`compare`Value y @?= LT
156 , testCase "y > x" $ Value y`compare`Value x @?= GT
157 ]
158
159 testRanking :: (Ord prop, Ord grade, Show grade, Show prop) =>
160 [grade] -> Choices prop -> [[grade]] ->
161 Ranking prop -> TestTree
162 testRanking scal props opins expect =
163 testCase (elide $ show (toList props,opins)) $
164 majorityRanking (mkMerits scal props opins) @?= expect
165
166 testValueOfOpinions :: (Show grade, Show prop, Ord grade, Ord prop) =>
167 [grade] -> Choices prop -> [[grade]] ->
168 [(prop, [(grade,Count)])] -> TestTree
169 testValueOfOpinions scal props opins expect =
170 testCase (elide $ show (toList props,opins)) $
171 majorityValueByChoice (mkMerits scal props opins)
172 @?= ((Value`second`)<$>expect)
173
174 testValueOfMerits :: (Show grade, Show prop, Ord grade, Ord prop) =>
175 Merits prop grade ->
176 [(prop, [(grade,Count)])] -> TestTree
177 testValueOfMerits ms expect =
178 testCase (elide $ show ms) $
179 majorityValueByChoice ms
180 @?= ((Value`second`)<$>expect)