]> Git — Sourcephile - majurity.git/blob - hjugement/tests/QuickCheck/Merit.hs
protocol: add verification of trustees' public key
[majurity.git] / hjugement / tests / QuickCheck / Merit.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module QuickCheck.Merit where
3 import Control.Monad (Monad(..), replicateM)
4 import Data.Bool
5 import Data.Eq (Eq(..))
6 import Data.Foldable (Foldable(..))
7 import Data.Function (($), (.))
8 import Data.Functor ((<$>))
9 import Data.Hashable (Hashable)
10 import Data.Int (Int)
11 import Data.List ((++), head, zip)
12 import Data.Ord (Ord(..))
13 import Data.Ratio (Rational)
14 import GHC.Exts (IsList(..))
15 import Majority.Merit
16 import Prelude (Enum(..), Num(..), Integral(..), Bounded(..), fromIntegral, undefined)
17 import Test.QuickCheck
18 import Test.Tasty
19 import Test.Tasty.QuickCheck
20 import Text.Show (Show(..))
21 import qualified Data.Map.Strict as Map
22
23 import QuickCheck.Utils
24 import Types
25
26 quickcheck :: TestTree
27 quickcheck =
28 testGroup "Merit"
29 [ testProperty "arbitraryMerits" $ \(SameLength (Merit x::Merit SchoolGrade,Merit y::Merit SchoolGrade)) ->
30 Map.keys x == Map.keys y &&
31 sum x == sum y
32 ]
33
34 -- | @arbitraryMerits n@ arbitrarily generates 'n' lists of 'Merit'
35 -- for the same arbitrary grades,
36 -- and with the same total 'Share' of individual judgments.
37 arbitraryMerits :: forall g. (Bounded g, Enum g, Ord g) => Int -> Gen [Merit g]
38 arbitraryMerits n = sized $ \shareSum -> do
39 minG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g))
40 maxG <- choose (minG, fromEnum(maxBound::g))
41 let gs::[g] = toEnum minG`enumFromTo`toEnum maxG
42 let lenGrades = maxG - minG + 1
43 replicateM n $ do
44 shares <- resize shareSum $ arbitrarySizedPositiveRationalSum lenGrades
45 shares' :: [Share] <- arbitraryPad (lenGrades - length shares) (return 0) shares
46 return $ Merit $ fromList $ zip gs shares'
47
48 -- | @arbitrarySizedPositiveRationalSum maxLen@
49 -- arbitrarily chooses a list of 'length' at most 'maxLen',
50 -- containing positive 'Rational's summing up to 'sized'.
51 arbitrarySizedPositiveRationalSum :: Int -> Gen [Rational]
52 arbitrarySizedPositiveRationalSum maxLen = sized (go maxLen . fromIntegral)
53 where
54 go :: Int -> Rational -> Gen [Rational]
55 go len tot | len <= 0 = return []
56 | len == 1 = return [tot]
57 | tot <= 0 = return [tot]
58 go len tot = do
59 d <- choose (0, tot)
60 (d:) <$> go (len-1) (tot - d)
61
62 -- | @arbitrarySizedNaturalSum maxLen@
63 -- arbitrarily chooses a list of 'length' at most 'maxLen',
64 -- containing 'Int's summing up to 'sized'.
65 arbitrarySizedNaturalSum :: Int -> Gen [Int]
66 arbitrarySizedNaturalSum maxLen = sized (go maxLen)
67 where
68 go :: Int -> Int -> Gen [Int]
69 go len tot | len <= 0 = return []
70 | len == 1 = return [tot]
71 | tot <= 0 = return [tot]
72 go len tot = do
73 d <- choose (0, tot)
74 (d:) <$> go (len-1) (tot - d)
75
76 -- | @arbitraryPad n pad xs@
77 -- arbitrarily grows list 'xs' with 'pad' elements
78 -- up to length 'n'.
79 arbitraryPad :: (Num i, Integral i) => i -> Gen a -> [a] -> Gen [a]
80 arbitraryPad n pad [] = replicateM (fromIntegral n) pad
81 arbitraryPad n pad xs = do
82 (r, xs') <- go n xs
83 if r > 0
84 then arbitraryPad r pad xs'
85 else return xs'
86 where
87 go r xs' | r <= 0 = return (0,xs')
88 go r [] = arbitrary >>= \b ->
89 if b then pad >>= \p -> ((p:)<$>) <$> go (r-1) []
90 else return (r,[])
91 go r (x:xs') = arbitrary >>= \b ->
92 if b then pad >>= \p -> (([p,x] ++)<$>) <$> go (r-1) xs'
93 else ((x:)<$>) <$> go r xs'
94
95 instance
96 (Arbitrary g, Bounded g, Enum g, Ord g, Show g) =>
97 Arbitrary (Merit g) where
98 arbitrary = head <$> arbitraryMerits 1
99 shrink (Merit m) = Merit <$> shrink m
100 instance
101 ( Arbitrary c, Bounded c, Enum c, Eq c, Hashable c, Show c
102 , Arbitrary g, Bounded g, Enum g, Ord g, Show g
103 ) => Arbitrary (MeritByChoice c g) where
104 arbitrary = do
105 minP <- choose (fromEnum(minBound::c), fromEnum(maxBound::c))
106 maxP <- choose (minP, fromEnum(maxBound::c))
107 let ps = toEnum minP`enumFromTo`toEnum maxP
108 let ms = arbitraryMerits (maxP - minP + 1)
109 fromList . zip ps <$> ms
110 instance
111 (Arbitrary g, Bounded g, Enum g, Ord g) =>
112 Arbitrary (SameLength (Merit g, Merit g)) where
113 arbitrary = do
114 vs <- arbitraryMerits 2
115 case vs of
116 [x,y] -> return $ SameLength (x,y)
117 _ -> undefined