test/QuickCheck.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module QuickCheck where
   5
   6 import Test.QuickCheck
   7 import Test.Tasty
   8 import Test.Tasty.QuickCheck
   9
  10 import Control.Arrow (second)
  11 import Control.Monad (replicateM)
  12 import Data.Hashable (Hashable)
  13 import Data.Ratio
  14 import GHC.Exts (IsList(..))
  15 import Prelude
  16 import qualified Data.Set as Set
  17
  18 import Hjugement
  19 import Types
  20
  21 quickchecks :: TestTree
  22 quickchecks =
  23         testGroup "QuickCheck"
  24          [ testProperty "arbitraryJudgments" $ \(SameLength (x::[(G6,Share)],y)) ->
  25                 let (gx, cx) = unzip x in
  26                 let (gy, cy) = unzip y in
  27                 gx == gy && sum cx == sum cy
  28          , testGroup "MajorityValue"
  29                  [ testProperty "compare" $ \(SameLength (x::MajorityValue G6,y)) ->
  30                         expandValue x`compare` expandValue y == x`compare`y
  31                  ]
  32          {-
  33          , testProperty "majorityGauge and majorityValue consistency" $
  34                  \(SameLength (x@(Merit xs)::Merit G6,y@(Merit ys))) ->
  35                         not (all (==0) xs || all (==0) ys) ==>
  36                         case majorityGauge x`compare`majorityGauge y of
  37                          LT -> majorityValue x < majorityValue y
  38                          GT -> majorityValue x > majorityValue y
  39                          EQ -> True
  40          -}
  41          ]
  42
  43 -- | Decompress a 'MajorityValue'.
  44 expandValue :: MajorityValue a -> [a]
  45 expandValue (MajorityValue as) =
  46         let m = foldr lcm 1 (denominator . snd <$> as) in
  47         go $ second (\s -> numerator s * m) <$> as
  48         where
  49         go [] = []
  50         go ((x,c):xs) = replicate (fromIntegral c) x ++ go xs
  51
  52 -- | @arbitraryJudgments n@ arbitrarily generates 'n' lists of pairs of grade and 'Share'
  53 -- for the same arbitrary grades,
  54 -- and with the same total 'Share' of individual judgments.
  55 arbitraryJudgments :: forall g. (Bounded g, Enum g) => Int -> Gen [[(g, Share)]]
  56 arbitraryJudgments n = sized $ \s -> do
  57         minG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g))
  58         maxG <- choose (minG, fromEnum(maxBound::g))
  59         let gs::[g] = toEnum minG`enumFromTo`toEnum maxG
  60         let lg = maxG - minG + 1
  61         replicateM n $ do
  62                 cs  <- resize s $ arbitrarySizedNaturalSum lg
  63                 cs' <- arbitraryPad (lg - length cs) (return 0) cs
  64                 return $ zip gs $ fromIntegral <$> cs'
  65
  66 -- | @arbitrarySizedNaturalSum maxLen@
  67 -- arbitrarily chooses a list of 'length' at most 'maxLen',
  68 -- containing 'Int's summing up to 'sized'.
  69 arbitrarySizedNaturalSum :: Int -> Gen [Int]
  70 arbitrarySizedNaturalSum maxLen = sized (go maxLen)
  71         where
  72         go :: Int -> Int -> Gen [Int]
  73         go len tot | len <= 0 = return []
  74                    | len == 1 = return [tot]
  75                    | tot <= 0 = return [tot]
  76         go len tot = do
  77                 d <- choose (0, tot)
  78                 (d:) <$> go (len-1) (tot - d)
  79
  80 -- | @arbitraryPad n pad xs@
  81 -- arbitrarily grows list 'xs' with 'pad' elements
  82 -- up to length 'n'.
  83 arbitraryPad :: (Num i, Integral i) => i -> Gen a -> [a] -> Gen [a]
  84 arbitraryPad n pad [] = replicateM (fromIntegral n) pad
  85 arbitraryPad n pad xs = do
  86         (r, xs') <- go n xs
  87         if r > 0
  88          then arbitraryPad r pad xs'
  89          else return xs'
  90         where
  91         go r xs' | r <= 0 = return (0,xs')
  92         go r [] =  arbitrary >>= \b ->
  93                 if b then pad >>= \p -> ((p:)<$>) <$> go (r-1) []
  94                      else return (r,[])
  95         go r (x:xs') = arbitrary >>= \b ->
  96                 if b then pad >>= \p -> (([p,x]++)<$>) <$> go (r-1) xs'
  97                      else ((x:)<$>) <$> go r xs'
  98
  99 -- | Like 'nub', but O(n * log n).
 100 nubList :: Ord a => [a] -> [a]
 101 nubList = go Set.empty where
 102         go _ [] = []
 103         go s (x:xs) | x`Set.member`s = go s xs
 104                     | otherwise      = x:go (Set.insert x s) xs
 105
 106 instance Arbitrary G6 where
 107         arbitrary = arbitraryBoundedEnum
 108 instance (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => Arbitrary (Merit g) where
 109         arbitrary = fromList . head <$> arbitraryJudgments 1
 110         shrink (Merit m) = Merit <$> shrink m
 111 instance
 112  ( Arbitrary c, Bounded c, Enum c, Eq c, Hashable c, Show c
 113  , Arbitrary g, Bounded g, Enum g, Ord g, Show g
 114  ) => Arbitrary (MeritByChoice c g) where
 115         arbitrary = do
 116                 minP <- choose (fromEnum(minBound::c), fromEnum(maxBound::c))
 117                 maxP <- choose (minP, fromEnum(maxBound::c))
 118                 let ps = toEnum minP`enumFromTo`toEnum maxP
 119                 let ms = (fromList <$>) <$> arbitraryJudgments (maxP - minP + 1)
 120                 fromList . zip ps <$> ms
 121 instance (Bounded g, Eq g, Integral g, Arbitrary g) => Arbitrary (MajorityValue g) where
 122         arbitrary = head . (MajorityValue <$>) <$> arbitraryJudgments 1
 123         shrink (MajorityValue vs) = MajorityValue <$> shrink vs
 124
 125 -- * Type 'SameLength'
 126 newtype SameLength a = SameLength a
 127  deriving (Eq, Show)
 128 instance Functor SameLength where
 129         fmap f (SameLength x) = SameLength (f x)
 130 instance (Arbitrary g, Bounded g, Enum g) => Arbitrary (SameLength (MajorityValue g, MajorityValue g)) where
 131         arbitrary = do
 132                 SameLength (x,y) <- arbitrary
 133                 return $ SameLength (MajorityValue x, MajorityValue y)
 134 instance (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => Arbitrary (SameLength (Merit g, Merit g)) where
 135         arbitrary = do
 136                 SameLength (x,y) <- arbitrary
 137                 return $ SameLength (fromList x, fromList y)
 138 instance (Arbitrary g, Bounded g, Enum g) => Arbitrary (SameLength ([(g,Share)], [(g,Share)])) where
 139         arbitrary = do
 140                 vs <- arbitraryJudgments 2
 141                 case vs of
 142                  [x,y] -> return $ SameLength (x,y)
 143                  _ -> undefined