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)