mirror of
https://github.com/iritmaximus/haskell.git
synced 2026-10-12 19:13:39 +03:00
Set6: Ex 11, Ex 12
This commit is contained in:
Joel Kaasinen
+20
-1
@@ -3,7 +3,7 @@
|
||||
module Mooc.Th (testing, testing',
|
||||
isDefined, withDefined, hasType, importsOnly, show',
|
||||
reifyType, DataType(..), FieldType(..), Constructor(..),
|
||||
withInstance, withInstance1)
|
||||
withInstance, withInstance1, classContains, defineInstance)
|
||||
where
|
||||
|
||||
import Data.Char
|
||||
@@ -124,6 +124,17 @@ withInstance cln typn val = do
|
||||
then [|\k -> k $val|]
|
||||
else [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
|
||||
|
||||
classContains :: String -> String -> Q Exp
|
||||
classContains cln varn = do
|
||||
var <- lookupValueName varn
|
||||
case var of
|
||||
Nothing -> [|counterexample ("Function "++varn++" not found") (property False)|]
|
||||
Just cl -> do
|
||||
info <- reify cl
|
||||
case info of
|
||||
(ClassOpI _ _ parent) -> let pn = nameBase parent in [|counterexample ("Function "++varn++ "is in the wrong class!") (pn ?== cln)|]
|
||||
_ -> [|counterexample ("Function "++varn++" is not a method of class "++cln) (property False)|]
|
||||
|
||||
lookupConstructor :: String -> Q (Maybe Type)
|
||||
lookupConstructor "[]" = return (Just ListT)
|
||||
lookupConstructor x = (fmap.fmap) ConT $ lookupTypeName x
|
||||
@@ -140,6 +151,14 @@ withInstance1 cln typn val = do
|
||||
then [|\k -> k $val|]
|
||||
else [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
|
||||
|
||||
defineInstance :: String -> Name -> String -> Q Exp -> Q [Dec]
|
||||
defineInstance cln typn methodn body = do
|
||||
cl <- lookupTypeName cln
|
||||
--let method = Name (OccName methodn) NameS
|
||||
case cl of
|
||||
Nothing -> return []
|
||||
(Just c) -> sequence [instanceD (cxt []) (appT (conT c) (conT typn)) [funD (mkName methodn) [clause [] (normalB body) []]]]
|
||||
|
||||
-- verbose testing
|
||||
|
||||
data Call = Prefix Name [Exp] | Operator Name Exp Exp
|
||||
|
||||
@@ -162,3 +162,42 @@ instance Num RationalNumber where
|
||||
signum q = todo
|
||||
fromInteger x = todo
|
||||
negate q = todo
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Ex 11: a class for adding things. Define a class Addable with a
|
||||
-- constant `zero` and a function `add`. Define instances of Addable
|
||||
-- for Integers and lists. Numbers are added with the usual addition,
|
||||
-- while lists are added by catenating them. Pick a value for `zero`
|
||||
-- such that: `add zero x == x`
|
||||
--
|
||||
-- Examples:
|
||||
-- add 1 2 ==> 3
|
||||
-- add 1 zero ==> 1
|
||||
-- add [1,2] [3,4] ==> [1,2,3,4]
|
||||
-- add zero [True,False] ==> [True,False]
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Ex 12: cycling. Implement a type class Cycle that contains a
|
||||
-- function `step` that cycles through the values of the type.
|
||||
-- Implement instances for Color and Suit that work like this:
|
||||
--
|
||||
-- step Red ==> Green
|
||||
-- step Green ==> Blue
|
||||
-- step Blue ==> Red
|
||||
--
|
||||
-- The suit instance should cycle suits in the order Club, Spade,
|
||||
-- Diamond, Heart, Club.
|
||||
--
|
||||
-- Also add a function `stepMany` and give it a default implementation
|
||||
-- using `step`. The function `stepMany` should take multiple
|
||||
-- (determined by an Int argument) steps like this:
|
||||
--
|
||||
-- cycleMany 2 Club ==> Diamond
|
||||
-- cycleMany 2 Diamond ==> Club
|
||||
|
||||
data Color = Red | Green | Blue
|
||||
deriving (Show, Eq)
|
||||
data Suit = Club | Spade | Diamond | Heart
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
+74
-23
@@ -13,28 +13,6 @@ import Mooc.Test
|
||||
|
||||
import Set6
|
||||
|
||||
main = score tests
|
||||
|
||||
tests = [(1,"Eq Country",[ex1])
|
||||
,(2,"Ord Country",[ex2])
|
||||
,(3,"Eq Name",[ex3])
|
||||
,(4,"Eq List",[ex4_eq, ex4_neq])
|
||||
,(5,"Price",[ex5_egg, ex5_milk])
|
||||
,(6,"Price List",[ex6_egg, ex6_milk])
|
||||
,(7,"Ord Number",[ex7_eq_check, ex7_finite, ex7_infinite])
|
||||
,(8,"Eq RationalNumber",[ex8_refl, ex8_eq])
|
||||
,(9,"simplify",[ex9_prime, ex9_eq])
|
||||
,(10,"Num RationalNumber",[ex10_add_zero, ex10_add_commut, ex10_add_whole, ex10_add
|
||||
,ex10_multiply_one, ex10_multiply_commut, ex10_multiply_inverse, ex10_multiply
|
||||
,ex10_abs
|
||||
,ex10_signum_abs
|
||||
,ex10_fromInteger
|
||||
,ex10_negate
|
||||
])
|
||||
]
|
||||
|
||||
-- -- -- -- -- -- -- --
|
||||
|
||||
testEquals x y exp = $(testing [|x == y|]) (?==exp)
|
||||
|
||||
ex1 = conjoin [testEquals Finland Finland True
|
||||
@@ -219,7 +197,7 @@ ex10_multiply = $(withInstance "Num" "RationalNumber" [|(*) :: RationalNumber ->
|
||||
ex10_abs = $(withInstance "Num" "RationalNumber" [|abs :: RationalNumber -> RationalNumber|]) $ \abs ->
|
||||
forAllBlind genSimpl $ \r@(RationalNumber p q) ->
|
||||
conjoin [$(testing [|abs (RationalNumber (-p) q)|]) (exactly r)
|
||||
,$(testing [|abs r|]) (exactly r)]
|
||||
,$(testing [|abs r|]) (exactly r)]
|
||||
|
||||
ex10_signum_abs = $(withInstance "Num" "RationalNumber" [|abs :: RationalNumber -> RationalNumber|]) $ \abs ->
|
||||
forAll_ $ \r ->
|
||||
@@ -236,3 +214,76 @@ ex10_negate = $(withInstance "Num" "RationalNumber" [|negate :: RationalNumber -
|
||||
forAll_ $ \r ->
|
||||
counterexample ("("++show r++") + negate ("++show r++")") $
|
||||
exactly (RationalNumber 0 1) (r + negate r)
|
||||
|
||||
ex11_integer = $(withInstance "Addable" "Integer" [|(zero::Integer,add::Integer->Integer->Integer)|]) $ \(zero,add) ->
|
||||
forAll_ $ \(x::Integer,y) ->
|
||||
conjoin [$(testing [|add x y|]) (?==x+y)
|
||||
,$(testing [|add zero x|]) (?==x)]
|
||||
|
||||
ex11_list = $(withInstance1 "Addable" "[]" [|(zero::[Bool],add::[Bool]->[Bool]->[Bool])|]) $ \(zero,add) ->
|
||||
forAll_ $ \(x::[Bool],y) ->
|
||||
conjoin [$(testing [|add x y|]) (?==x++y)
|
||||
,$(testing [|add zero x|]) (?==x)
|
||||
,$(testing [|add x zero|]) (?==x)]
|
||||
|
||||
ex12_step_color = $(withInstance "Cycle" "Color" [|step|]) $ \step ->
|
||||
conjoin [$(testing [|step Red|]) (?==Green)
|
||||
,$(testing [|step Green|]) (?==Blue)
|
||||
,$(testing [|step Blue|]) (?==Red)]
|
||||
|
||||
ex12_step_suit = $(withInstance "Cycle" "Suit" [|step|]) $ \step ->
|
||||
conjoin [$(testing [|step Club|]) (?==Spade)
|
||||
,$(testing [|step Spade|]) (?==Diamond)
|
||||
,$(testing [|step Diamond|]) (?==Heart)
|
||||
,$(testing [|step Heart|]) (?==Club)]
|
||||
|
||||
ex12_stepMany_color = $(withInstance "Cycle" "Color" [|stepMany|]) $ \stepMany ->
|
||||
property $ do
|
||||
let vals = [Red,Green,Blue]
|
||||
i <- choose (0,2)
|
||||
j <- choose (0,20)
|
||||
return $ $(testing [|stepMany j (vals!!i)|]) (?==vals!!(mod (i+j) 3))
|
||||
|
||||
ex12_stepMany_suit = $(withInstance "Cycle" "Suit" [|stepMany|]) $ \stepMany ->
|
||||
property $ do
|
||||
let vals = [Club,Spade,Diamond,Heart]
|
||||
i <- choose (0,3)
|
||||
j <- choose (0,20)
|
||||
return $ $(testing [|stepMany j (vals!!i)|]) (?==vals!!(mod (i+j) 4))
|
||||
|
||||
ex12_stepMany_class = $(classContains "Cycle" "stepMany")
|
||||
|
||||
$(defineInstance "Cycle" ''Int "step" [|succ|])
|
||||
|
||||
$(return []) -- hack to make next test see instance
|
||||
|
||||
ex12_stepMany_default = counterexample "After defining\n instance Cycle Int where step = succ" $
|
||||
$(withInstance "Cycle" "Int" [|stepMany|]) $ \stepMany ->
|
||||
forAllBlind (choose (0,100::Int)) $ \n ->
|
||||
forAllBlind (choose (0,100::Int)) $ \m ->
|
||||
$(testing [|stepMany n m|]) (?==n+m)
|
||||
|
||||
-- -- -- -- -- -- -- -- tests need to be defined after TH splice above
|
||||
|
||||
main = score tests
|
||||
|
||||
tests = [(1,"Eq Country",[ex1])
|
||||
,(2,"Ord Country",[ex2])
|
||||
,(3,"Eq Name",[ex3])
|
||||
,(4,"Eq List",[ex4_eq, ex4_neq])
|
||||
,(5,"Price",[ex5_egg, ex5_milk])
|
||||
,(6,"Price List",[ex6_egg, ex6_milk])
|
||||
,(7,"Ord Number",[ex7_eq_check, ex7_finite, ex7_infinite])
|
||||
,(8,"Eq RationalNumber",[ex8_refl, ex8_eq])
|
||||
,(9,"simplify",[ex9_prime, ex9_eq])
|
||||
,(10,"Num RationalNumber",[ex10_add_zero, ex10_add_commut, ex10_add_whole, ex10_add
|
||||
,ex10_multiply_one, ex10_multiply_commut, ex10_multiply_inverse, ex10_multiply
|
||||
,ex10_abs
|
||||
,ex10_signum_abs
|
||||
,ex10_fromInteger
|
||||
,ex10_negate
|
||||
])
|
||||
,(11,"Addable",[ex11_integer, ex11_list])
|
||||
,(12,"Cycle",[ex12_step_color, ex12_step_suit, ex12_stepMany_color, ex12_stepMany_suit
|
||||
,ex12_stepMany_class, ex12_stepMany_default])
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user