Set 6 Ex 6: more robust tests

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)]
+    (Just c, Just t) -> lookupInstanceResolved c (ConT t)
-                           if b
-                             then return Found
-                             else return $ NotFound cln typn
 
 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"))]
+    (Just c, Just t) -> lookupInstanceResolved c (AppT t (VarT (mkName "a")))
-                           if b
-                             then return Found
-                             else return $ NotFound cln typn
 
 withInstance1 :: String -> String -> Q Exp -> Q Exp
 withInstance1 cln typn val = do

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 =
+ex6_maybe_egg =
-  $(withInstances1 "Price" ["Maybe", "[]"] [|price|]) $ \price ->
+  $(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 =
+ex6_list_maybe_milk =
-  $(withInstances1 "Price" ["Maybe", "[]"] [|price|]) $ \price ->
+  $(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 ])