diff --git a/exercises/Mooc/Th.hs b/exercises/Mooc/Th.hs index 55378df..b61a019 100644 --- a/exercises/Mooc/Th.hs +++ b/exercises/Mooc/Th.hs @@ -3,7 +3,7 @@ module Mooc.Th (testing, testing', timeLimit, isDefined, withDefined, hasType, hasType', importsOnly, show', reifyType, DataType(..), FieldType(..), Constructor(..), withConstructor, - withInstance, withInstanceSilent, withInstance1, withInstances1, + withInstance, withInstanceType, withInstanceSilent, withInstance1, withInstances1, classContains, defineInstance) where @@ -152,6 +152,13 @@ withConstructor typName consName argTypes = do data Instance = Found | NotFound String String | NoClass String | NoType String deriving (Show, Eq) +lookupInstanceResolved :: Name -> Type -> Q Instance +lookupInstanceResolved cl t = do + b <- isInstance cl [t] + if b + then return Found + else return $ NotFound (nameBase cl) (showType t) + lookupInstance :: String -> String -> Q Instance lookupInstance cln typn = do cl <- lookupTypeName cln @@ -159,10 +166,7 @@ lookupInstance cln typn = do case (cl,typ) of (Nothing,_) -> return $ NoClass cln (_,Nothing) -> return $ NoType typn - (Just c, Just t) -> do b <- isInstance c [(ConT t)] - if b - then return Found - else return $ NotFound cln typn + (Just c, Just t) -> lookupInstanceResolved c (ConT t) withInstance :: String -> String -> Q Exp -> Q Exp withInstance cln typn val = do @@ -173,6 +177,17 @@ withInstance cln typn val = do NotFound cln typn -> [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|] Found -> [|\k -> k $val|] +withInstanceType :: String -> Q Type -> Q Exp -> Q Exp +withInstanceType cln qt val = do + cl <- lookupTypeName cln + t <- qt + case cl of + Nothing -> [|\k -> counterexample ("Class "++cln++" not found") (property False)|] + Just cl -> do ins <- lookupInstanceResolved cl t + case ins of + NotFound cln typn -> [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|] + Found -> [|\k -> k $val|] + withInstanceSilent :: String -> String -> Q Exp -> String -> Q Exp withInstanceSilent cln typn val err = do ins <- lookupInstance cln typn @@ -204,10 +219,7 @@ lookupInstance1 cln typn = do case (cl,cons) of (Nothing,_) -> return $ NoClass cln (_,Nothing) -> return $ NoType typn - (Just c, Just t) -> do b <- isInstance c [AppT t (VarT (mkName "a"))] - if b - then return Found - else return $ NotFound cln typn + (Just c, Just t) -> lookupInstanceResolved c (AppT t (VarT (mkName "a"))) withInstance1 :: String -> String -> Q Exp -> Q Exp withInstance1 cln typn val = do diff --git a/exercises/Set6Test.hs b/exercises/Set6Test.hs index 338846c..24f9651 100644 --- a/exercises/Set6Test.hs +++ b/exercises/Set6Test.hs @@ -69,14 +69,32 @@ ex5_milk = $(withInstance "Price" "Milk" [|price|]) $ \price -> forAllBlind (choose (0,100)) $ \l -> $(testing [|price (Milk l)|]) (?==(15*l)) -ex6_egg = - $(withInstances1 "Price" ["Maybe", "[]"] [|price|]) $ \price -> +ex6_maybe_egg = + $(withInstanceType "Price" [t|Maybe Egg|] [|price|]) $ \price -> + $(testing [|price [Just ChickenEgg]|]) (?==20) + +ex6_maybe_milk = + $(withInstanceType "Price" [t|Maybe Milk|] [|price|]) $ \price -> + forAllBlind (choose (0,100)) $ \l -> + $(testing [|price [Just (Milk l)]|]) (?==(15*l)) + +ex6_list_egg = + $(withInstanceType "Price" [t|[Egg]|] [|price|]) $ \price -> + $(testing [|price [ChocolateEgg, ChickenEgg]|]) (?==50) + +ex6_list_milk = + $(withInstanceType "Price" [t|[Milk]|] [|price|]) $ \price -> + forAllBlind (choose (0,100)) $ \l -> + $(testing [|price [Milk l, Milk 1]|]) (?==(15*(l+1))) + +ex6_list_maybe_egg = + $(withInstanceType "Price" [t|[Maybe Egg]|] [|price|]) $ \price -> conjoin [$(testing [|price [Just ChocolateEgg, Nothing, Just ChickenEgg]|]) (?==50) ,$(testing [|price [Nothing, Nothing, Nothing :: Maybe Egg]|]) (?==0)] -ex6_milk = - $(withInstances1 "Price" ["Maybe", "[]"] [|price|]) $ \price -> +ex6_list_maybe_milk = + $(withInstanceType "Price" [t|[Maybe Milk]|] [|price|]) $ \price -> forAllBlind (choose (0,10)) $ \milk1 -> forAllBlind (choose (0,10)) $ \milk2 -> conjoin [$(testing [|price [Just (Milk milk1), Nothing, Just (Milk milk2)]|]) (?==(15*milk1+15*milk2)) @@ -321,7 +339,9 @@ tests = [(1,"Eq Country",[ex1]) ,(3,"Eq Name",[ex3]) ,(4,"Eq List",[ex4_eq, ex4_neq]) ,(5,"Price",[ex5_egg, ex5_milk]) - ,(6,"Price List",[ex6_egg, ex6_milk]) + ,(6,"Price List",[ ex6_maybe_egg, ex6_maybe_milk + , ex6_list_egg, ex6_list_milk + , ex6_list_maybe_egg, ex6_list_maybe_milk]) ,(7,"Ord Number",[ ex7_eq_check , ex7_finite_finite, ex7_finite_infinite, ex7_infinite_infinite , ex7_max_finite, ex7_max_infinite ])