mirror of
https://github.com/iritmaximus/haskell.git
synced 2026-10-12 19:13:39 +03:00
226 lines
9.8 KiB
Haskell
226 lines
9.8 KiB
Haskell
{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
|
|
|
|
module Set5aTest where
|
|
|
|
import Data.List
|
|
import Test.QuickCheck
|
|
|
|
import Mooc.Th
|
|
import Mooc.Test
|
|
|
|
import Set5a
|
|
|
|
main = score tests
|
|
|
|
tests = [(1,"Vehicle",[ex1])
|
|
,(2,"BusTicket",[ex2])
|
|
,(3,"ShippingEntry",[ex3_totalPrice, ex3_buyOneMore])
|
|
,(4,"Person",[ex4_name, ex4_age])
|
|
,(5,"Position",[ex5_simple, ex5_generate])
|
|
,(6,"Student",[ex6_freshman, ex6_nth, ex6_graduated, ex6_graduate])
|
|
,(7,"UpDown",[ex7_type, ex7_simple, ex7_generate])
|
|
,(8,"Color",[ex8_red, ex8_green, ex8_blue, ex8_simple, ex8_complicated])
|
|
,(9,"OneOrTwo",[ex9])
|
|
,(10,"KeyVals",[ex10_type, ex10_string_bool, ex10_int_int])
|
|
,(11,"Nat",[ex11_to, ex11_from, ex11_just, ex11_nothing])
|
|
,(12,"Bin",[ ex12_prettyPrint
|
|
, ex12_from_zero, ex12_to_zero, ex12_to_from_zero
|
|
, ex12_from_to_zero, ex12_from_one, ex12_to_one
|
|
, ex12_to_from_one, ex12_from_to_one, ex12_to_from
|
|
, ex12_from_to])
|
|
]
|
|
|
|
-- -- -- -- -- -- -- --
|
|
|
|
assertNormalConstructor (Constructor _ _) = property True
|
|
assertNormalConstructor (Weird n) = counterexample (" constructor "++n++" is not a normal constructor. Perhaps it's a record constructor or an infix constructor? Make it normal.") False
|
|
|
|
assertNoFields (Constructor n vs) = counterexample (" constructor "++n++" should have no fields") $ null vs
|
|
assertNoFields _ = property True
|
|
|
|
assertFields exp (Constructor n vs) = counterexample (" constructor "++n++" field types") $ vs ?== exp
|
|
assertFields _ _ = property True
|
|
|
|
ex1 = $(reifyType "Vehicle") $ \(DataType vars cs) ->
|
|
conjoin [counterexample " should have no type parameters" $ vars == []
|
|
,counterexample " should have 4 constructors" $ length cs ?== 4
|
|
,conjoin $ map assertNormalConstructor cs
|
|
,conjoin $ map assertNoFields cs
|
|
,counterexample " constructor names" $
|
|
hasElements ["Bike","Bus","Train","Tram"] [n | Constructor n _ <- cs]
|
|
]
|
|
|
|
ex2 = $(reifyType "BusTicket") $ \(DataType vars cs) ->
|
|
conjoin [counterexample " should have no type parameters" $ vars == []
|
|
,counterexample " should have 2 constructors" $ length cs ?== 2
|
|
,counterexample " constructor names" $
|
|
hasElements ["SingleTicket", "MonthlyTicket"] [n | Constructor n _ <- cs]
|
|
,conjoin $ map assertNormalConstructor cs
|
|
,counterexample " should have a constructor SingleTicket with no fields" $
|
|
any (==Constructor "SingleTicket" []) cs
|
|
,counterexample " should have a constructor MonthlyTicket with a String field" $
|
|
counterexample (show cs) $
|
|
any (==Constructor "MonthlyTicket" [SimpleType "String"]) cs
|
|
|| any (==Constructor "MonthlyTicket" [SimpleType "[Char]"]) cs
|
|
]
|
|
|
|
word = listOf1 (choose ('a','z'))
|
|
|
|
ex3_totalPrice = forAllBlind word $ \name ->
|
|
forAll_ $ \count ->
|
|
forAllBlind (elements [0.1,0.25..2.0]) $ \price ->
|
|
$(testing [|totalPrice (MkShoppingEntry name price count)|]) (?~=price * fromIntegral count)
|
|
|
|
eq (MkShoppingEntry n p c) (MkShoppingEntry n' p' c') = and [n==n',p==p',c==c']
|
|
|
|
ex3_buyOneMore = forAllBlind word $ \name -> forAll_ $ \(price,count) ->
|
|
let exp = MkShoppingEntry name price (succ count)
|
|
in $(testing [|buyOneMore (MkShoppingEntry name price count)|]) (\v -> expectation exp v (eq exp v))
|
|
|
|
ex4_name = property $ do
|
|
n <- word
|
|
return $ counterexample ("getName (setName "++show n++" fred)") $
|
|
getName (setName n fred) === n
|
|
|
|
ex4_age = property $ do
|
|
a <- choose (0,89)
|
|
return $ counterexample ("getAge (setAge "++show a++" fred)") $
|
|
getAge (setAge a fred) === a
|
|
|
|
ex5_simple = conjoin [$(testing' [|getX origin|]) (?==0)
|
|
,$(testing' [|getY origin|]) (?==0)
|
|
,$(testing' [|getX (right origin)|]) (?==1)
|
|
,$(testing' [|getY (up origin)|]) (?==1)]
|
|
|
|
ex5_generate = forAllShrink_ (choose (0,20)) $ \a ->
|
|
forAllShrink_ (choose (0,20)) $ \b' ->
|
|
let b = a+b'
|
|
pos0 = iterate (right . up) origin !! a
|
|
pos1 = iterate up pos0 !! b'
|
|
in counterexample ("After starting from origin and going right "++show a++" times and up "++show b++" times:") $
|
|
conjoin [counterexample "getX" (getX pos1 ?== a)
|
|
,counterexample "getY" (getY pos1 ?== b)]
|
|
|
|
ex6_freshman = $(testing [|study Freshman|]) (?==NthYear 1)
|
|
ex6_nth = forAllBlind (choose (1,6)) $ \i -> $(testing [|study (NthYear i)|]) (?==NthYear (i+1))
|
|
ex6_graduate = $(testing [|study (NthYear 7)|]) (?==Graduated)
|
|
ex6_graduated = $(testing [|study Graduated|]) (?==Graduated)
|
|
|
|
ex7_type = $(reifyType "UpDown") $ \(DataType vars cs) ->
|
|
conjoin [counterexample " should have no type parameters" $ vars == []
|
|
,counterexample " should have 2 constructors" $ length cs ?== 2
|
|
,conjoin $ map (assertFields [SimpleType "Int"]) cs
|
|
]
|
|
|
|
ex7_simple = conjoin [$(testing' [|get zero|]) (?== 0)
|
|
,$(testing' [|get (tick zero)|]) (?== 1)
|
|
,$(testing' [|get (tick (toggle zero))|]) (?== negate 1)
|
|
,$(testing' [|get (toggle (tick (zero)))|]) (?== 1)]
|
|
|
|
ex7_generate =
|
|
forAllShrink_ (choose (0,20)) $ \a ->
|
|
forAllShrink_ (choose (0,20)) $ \b ->
|
|
let tc0 = iterate tick zero !! a
|
|
tc1 = iterate tick (toggle tc0) !! b
|
|
in counterexample ("Did "++show a++" ticks, a toggle, and "++show b++" ticks:") $
|
|
counterexample "get:" (get tc1 ?== a-b)
|
|
|
|
ex8_red = $(testing [|rgb Red|]) (?==[1,0,0])
|
|
ex8_green = $(testing [|rgb Green|]) (?==[0,1,0])
|
|
ex8_blue = $(testing [|rgb Blue|]) (?==[0,0,1])
|
|
|
|
fcmp expected actual =
|
|
expectation expected actual (diff < eps)
|
|
where diff = sum . map abs $ zipWith (-) actual expected
|
|
eps = 0.01
|
|
|
|
ex8_simple = property $ do
|
|
~[c1,c2,c3,c4] <- shuffle [Red,Red,Red,Green]
|
|
return $ conjoin [$(testing [|rgb (Mix (Mix c1 c2) (Mix c3 c4))|]) (fcmp [0.75,0.25,0])
|
|
,$(testing [|rgb (Invert (Mix (Mix c1 c2) (Mix c3 c4)))|]) (fcmp [0.25,0.75,1.0])]
|
|
|
|
ex8_complicated = property $ do
|
|
cs <- vectorOf 4 (elements [Red,Invert Red,Green,Invert Green,Blue,Invert Blue])
|
|
let ~[c1,c2,c3,c4] = cs
|
|
r = fromIntegral $ length $ filter (has Red) cs
|
|
g = fromIntegral $ length $ filter (has Green) cs
|
|
b = fromIntegral $ length $ filter (has Blue) cs
|
|
return $ $(testing [|rgb (Mix (Mix c1 c2) (Mix c3 c4))|]) (fcmp [r/4, g/4, b/4])
|
|
where has Red Red = True
|
|
has Blue Blue = True
|
|
has Green Green = True
|
|
has x (Invert c) = not (has x c)
|
|
has _ _ = False
|
|
|
|
ex9 = $(reifyType "OneOrTwo") $ \(DataType vars cs) ->
|
|
conjoin [counterexample " should have one type parameter" $ length vars ?== 1
|
|
,counterexample " should have 2 constructors" $ length cs ?== 2
|
|
,counterexample " constructor names" $
|
|
hasElements ["One", "Two"] [n | Constructor n _ <- cs]
|
|
,conjoin $ map assertNormalConstructor cs
|
|
,counterexample " should have a constructor One with one field of the parameter type" $
|
|
any ((==) $ Constructor "One" $ map SimpleType vars) cs
|
|
,counterexample " should have a constructor Two with two fields of the parameter type" $
|
|
any ((==) $ Constructor "Two" $ map SimpleType $ vars++vars) cs
|
|
]
|
|
|
|
ex10_type = $(reifyType "KeyVals") $ \(DataType vars cs) ->
|
|
conjoin [counterexample " type parameters" $ ["k","v"] ?== vars
|
|
,counterexample " should have 2 constructors" $ length cs ?== 2
|
|
,conjoin $ map assertNormalConstructor cs
|
|
,counterexample " constructor names" $
|
|
hasElements ["Empty", "Pair"] [n | Constructor n _ <- cs]
|
|
,counterexample " should have a constructor Empty with no fields" $
|
|
any (==Constructor "Empty" []) cs
|
|
,counterexample " should have a constructor Pair with the right fields" $
|
|
any (==Constructor "Pair" [SimpleType "k",SimpleType "v",SimpleType "KeyVals k v"]) cs
|
|
]
|
|
|
|
m_ex10 vs = counterexample ("toList (fromList "++show vs++"))") $ vs ==? toList (fromList vs)
|
|
|
|
ex10_string_bool = forAll_ $ \(kvs::[(String,Bool)]) -> m_ex10 kvs
|
|
|
|
ex10_int_int = forAll_ $ \(kvs::[(Int,Int)]) -> m_ex10 kvs
|
|
|
|
instance Arbitrary Nat where
|
|
arbitrary = oneof $ map return $ take 20 $ iterate PlusOne Zero
|
|
|
|
ex11_to = $(testing [| toNat 0 |]) (?== Just Zero)
|
|
ex11_from = $(testing [| fromNat Zero |]) (?== 0)
|
|
ex11_just = forAll_ $ \(n :: Nat) ->
|
|
counterexample (" toNat (fromNat " ++ show n ++ ")")
|
|
(toNat (fromNat n) ?== Just n)
|
|
ex11_nothing = forAll_ $ \(Negative (z :: Int)) ->
|
|
$(testing [|toNat z|]) (?== Nothing)
|
|
|
|
instance Arbitrary Bin where
|
|
arbitrary = do
|
|
bs <- arbitrary :: Gen [Bool]
|
|
return $ foldr (\x b -> if x then I b else O b) (I End) (take 8 bs)
|
|
|
|
ex12_prettyPrint =
|
|
forAllBlind (listOf1 (elements "01")) $ \w->
|
|
let inp = foldl' (\acc i -> case i of '0' -> O acc; '1' -> I acc; _ -> error (show i)) End w
|
|
in $(testing [|prettyPrint inp|]) (?==w)
|
|
|
|
ex12_from_zero =
|
|
counterexample ("fromBin (O End)") (fromBin (O End) ?== 0)
|
|
ex12_to_zero =
|
|
counterexample ("toBin 0") (toBin 0 ?== O End)
|
|
ex12_to_from_zero =
|
|
counterexample ("toBin (fromBin (O End))") (toBin (fromBin (O End)) ?== O End)
|
|
ex12_from_to_zero =
|
|
counterexample ("fromBin (toBin 0)") (fromBin (toBin 0) ?== 0)
|
|
ex12_from_one =
|
|
counterexample ("fromBin (I End)") (fromBin (I End) ?== 1)
|
|
ex12_to_one =
|
|
counterexample ("toBin 1") (toBin 1 ?== I End)
|
|
ex12_to_from_one =
|
|
counterexample ("toBin (fromBin (I End))") (toBin (fromBin (I End)) ?== I End)
|
|
ex12_from_to_one =
|
|
counterexample ("fromBin (toBin 1)") (fromBin (toBin 1) ?== 1)
|
|
ex12_to_from = forAll_ $ \(b :: Bin) ->
|
|
counterexample ("toBin (fromBin (" ++ show b ++ "))") (toBin (fromBin b) ?== b)
|
|
ex12_from_to = forAll_ $ \(n :: Int) -> n < 0 .||.
|
|
counterexample ("fromBin (toBin (" ++ show n ++ "))") (fromBin (toBin n) ?== n)
|