Set 6 Ex 6: improve 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(..),
-                withInstance, withInstance1, classContains, defineInstance)
+                withInstance, withInstance1, withInstances1, classContains, defineInstance)
 where
 
 import Data.Char
@@ -121,17 +121,29 @@ constructorName' c = case c of
 
 -- testing classes
 
-withInstance :: String -> String -> Q Exp -> Q Exp
+data Instance = Found | NotFound String String | NoClass String | NoType String
-withInstance cln typn val = do
+  deriving (Show, Eq)
+
+lookupInstance :: String -> String -> Q Instance
+lookupInstance cln typn = do
   cl <- lookupTypeName cln
   typ <- lookupTypeName typn
   case (cl,typ) of
-    (Nothing,_) -> [|\k -> counterexample ("Class "++cln++" not found") (property False)|]
+    (Nothing,_) -> return $ NoClass cln
-    (_,Nothing) -> [|\k -> counterexample ("Type "++typn++" not found") (property False)|]
+    (_,Nothing) -> return $ NoType typn
     (Just c, Just t) -> do b <- isInstance c [(ConT t)]
                            if b
-                             then [|\k -> k $val|]
+                             then return Found
-                             else [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
+                             else return $ NotFound cln typn
+
+withInstance :: String -> String -> Q Exp -> Q Exp
+withInstance cln typn val = do
+  ins <- lookupInstance cln typn
+  case ins of
+    NoClass cln -> [|\k -> counterexample ("Class "++cln++" not found") (property False)|]
+    NoType typn -> [|\k -> counterexample ("Type "++typn++" not found") (property False)|]
+    NotFound cln typn -> [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
+    Found -> [|\k -> k $val|]
 
 classContains :: String -> String -> Q Exp
 classContains cln varn = do
@@ -148,17 +160,35 @@ lookupConstructor :: String -> Q (Maybe Type)
 lookupConstructor "[]" = return (Just ListT)
 lookupConstructor x = (fmap.fmap) ConT $ lookupTypeName x
 
-withInstance1 :: String -> String -> Q Exp -> Q Exp
+lookupInstance1 :: String -> String -> Q Instance
-withInstance1 cln typn val = do
+lookupInstance1 cln typn = do
   cl <- lookupTypeName cln
   cons <- lookupConstructor typn
   case (cl,cons) of
-    (Nothing,_) -> [|\k -> counterexample ("Class "++cln++" not found") (property False)|]
+    (Nothing,_) -> return $ NoClass cln
-    (_,Nothing) -> [|\k -> counterexample ("Type "++typn++" not found") (property False)|]
+    (_,Nothing) -> return $ NoType typn
-    (Just c, Just t) -> do b <- isInstance c [(AppT t (VarT (mkName "a")))]
+    (Just c, Just t) -> do b <- isInstance c [AppT t (VarT (mkName "a"))]
                            if b
-                             then [|\k -> k $val|]
+                             then return Found
-                             else [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
+                             else return $ NotFound cln typn
+
+withInstance1 :: String -> String -> Q Exp -> Q Exp
+withInstance1 cln typn val = do
+  ins <- lookupInstance1 cln typn
+  case ins of
+    NoClass cln -> [|\k -> counterexample ("Class "++cln++" not found") (property False)|]
+    NoType typn -> [|\k -> counterexample ("Type "++typn++" not found") (property False)|]
+    NotFound cln typn -> [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
+    Found -> [|\k -> k $val|]
+
+withInstances1 :: String -> [String] -> Q Exp -> Q Exp
+withInstances1 cln typns val = do
+  instances <- mapM (lookupInstance1 cln) typns
+  case filter (/=Found) instances of
+    (NoClass cln:_) -> [|\k -> counterexample ("Class "++cln++" not found") (property False)|]
+    (NoType typn:_) -> [|\k -> counterexample ("Type "++typn++" not found") (property False)|]
+    (NotFound cln typn:_) -> [|\k -> counterexample ("Type "++typn++" is not an instance of class "++cln) (property False)|]
+    _ -> [|\k -> k $val|]
 
 defineInstance :: String -> Name -> String -> Q Exp -> Q [Dec]
 defineInstance cln typn methodn body = do

exercises/Set6Test.hs

@@ -70,17 +70,13 @@ ex5_milk = $(withInstance "Price" "Milk" [|price|]) $ \price ->
   $(testing [|price (Milk l)|]) (?==(15*l))
 
 ex6_egg =
-  $(withInstance "Price" "Egg" [|price :: Egg -> Int|]) $ \_ ->
+  $(withInstances1 "Price" ["Maybe", "[]"] [|price|]) $ \price ->
-  $(withInstance1 "Price" "[]" [|price :: [Egg] -> Int|]) $ \_ ->
-  $(withInstance1 "Price" "Maybe" [|price|]) $ \price ->
   conjoin [$(testing [|price [Just ChocolateEgg, Nothing, Just ChickenEgg]|]) (?==50)
           ,$(testing [|price [Nothing, Nothing, Nothing :: Maybe Egg]|]) (?==0)]
 
 
 ex6_milk =
-  $(withInstance "Price" "Milk" [|price :: Milk -> Int|]) $ \_ ->
+  $(withInstances1 "Price" ["Maybe", "[]"] [|price|]) $ \price ->
-  $(withInstance1 "Price" "[]" [|price :: [Milk] -> Int|]) $ \_ ->
-  $(withInstance1 "Price" "Maybe" [|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))