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