]> Git — Sourcephile - majurity.git/blob - hjugement/tests/QuickCheck/Utils.hs
move test/ to tests/
[majurity.git] / hjugement / tests / QuickCheck / Utils.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module QuickCheck.Utils where
3 import Control.Arrow (first)
4 import Data.Bool
5 import Data.Eq (Eq(..))
6 import Data.Function (($), (.))
7 import Data.Functor (Functor(..))
8 import Data.Int (Int)
9 import Data.Ord (Ord(..))
10 import Data.Ratio ((%), Rational, numerator, denominator)
11 import Prelude (Num(..), Integral(..), Bounded(..))
12 import System.Random (Random(..))
13
14 import Test.QuickCheck
15 import Text.Show (Show(..))
16 import Types
17 import qualified Data.Set as Set
18
19 -- | Like 'nub', but O(n * log n).
20 nubList :: Ord a => [a] -> [a]
21 nubList = go Set.empty where
22 go _ [] = []
23 go s (x:xs) | x`Set.member`s = go s xs
24 | otherwise = x:go (Set.insert x s) xs
25
26 instance Random Rational where
27 random = randomR (toInteger (minBound::Int)%1, toInteger (maxBound::Int)%1)
28 randomR (minR, maxR) g =
29 if d - b == 0
30 then first (% b) $ randomR (a, c) g
31 else first (bd2ac . nat2bd) $ randomR (0, toInteger (maxBound::Int)) g
32 where
33 a = numerator minR
34 b = denominator minR
35 c = numerator maxR
36 d = denominator maxR
37 nat2bd x = ((d - b) % toInteger (maxBound::Int)) * (x%1) + (b%1)
38 bd2ac x = alpha * x + beta
39 where
40 alpha = (c-a) % (d-b)
41 beta = (a%1) - alpha * (b%1)
42 instance Arbitrary SchoolGrade where
43 arbitrary = arbitraryBoundedEnum
44 instance Arbitrary DanishSchoolGrade where
45 arbitrary = arbitraryBoundedEnum
46
47 -- * Type 'SameLength'
48 newtype SameLength a = SameLength a
49 deriving (Eq, Show)
50 instance Functor SameLength where
51 fmap f (SameLength x) = SameLength (f x)