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