test/QuickCheck/Value.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module QuickCheck.Value where
   3 import Majority.Value
   4 import Types
   5 import Data.List (head)
   6
   7 import QuickCheck.Merit
   8 import QuickCheck.Utils
   9
  10 import Control.Monad (Monad(..))
  11 import Data.Function (($), (.))
  12 import Data.Functor ((<$>))
  13 import Test.Tasty
  14 import Test.Tasty.QuickCheck
  15 import Data.Eq (Eq(..))
  16 import Data.Ord (Ord(..))
  17 import Prelude (Enum(..), Integral(..), Bounded(..))
  18
  19 quickcheck :: TestTree
  20 quickcheck =
  21         testGroup "Value"
  22          [ testGroup "MajorityValue"
  23                  [ testProperty "compare" $ \(SameLength (x::MajorityValue G6,y)) ->
  24                         expandValue x`compare` expandValue y == x`compare`y
  25                  ]
  26          ]
  27
  28 instance
  29  (Bounded g, Eq g, Integral g, Arbitrary g) =>
  30  Arbitrary (MajorityValue g) where
  31         arbitrary = head . (majorityValue <$>) <$> arbitraryMerits 1
  32         shrink (MajorityValue vs) = MajorityValue <$> shrink vs
  33 instance (Bounded g, Enum g) => Arbitrary (Middle g) where
  34         arbitrary = do
  35                 lowG  <- choose (fromEnum(minBound::g), fromEnum(maxBound::g))
  36                 highG <- choose (lowG, fromEnum(maxBound::g))
  37                 share <- choose (0, 1)
  38                 return $ Middle share (toEnum lowG) (toEnum highG)
  39 instance
  40  (Arbitrary g, Bounded g, Enum g, Ord g) =>
  41  Arbitrary (SameLength (MajorityValue g, MajorityValue g)) where
  42         arbitrary = do
  43                 SameLength (x,y) <- arbitrary
  44                 return $ SameLength (MajorityValue x, MajorityValue y)
  45 instance
  46  (Arbitrary g, Bounded g, Enum g, Ord g) =>
  47   Arbitrary (SameLength ([Middle g], [Middle g])) where
  48         arbitrary = do
  49                 SameLength (m0, m1) <- arbitrary
  50                 return $ SameLength
  51                  ( unMajorityValue $ majorityValue m0
  52                  , unMajorityValue $ majorityValue m1 )