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