preparing for GHC 9

exercises/Mooc/Th.hs

@@ -2,7 +2,7 @@
 
 module Mooc.Th (testing, testing', timeLimit,
                 isDefined, withDefined, hasType, hasType', importsOnly, show',
-                reifyType, DataType(..), FieldType(..), Constructor(..),
+                reifyType, DataType(..), FieldType(..), Constructor(..), withConstructor,
                 withInstance, withInstanceSilent, withInstance1, withInstances1,
                 classContains, defineInstance)
 where
@@ -12,6 +12,7 @@ import Data.List
 import Data.Maybe
 import Language.Haskell.TH hiding (reifyType)
 import Language.Haskell.TH.Syntax hiding (reifyType)
+import Language.Haskell.TH.Datatype (tvName)
 
 -- testing presence of definitions
 
@@ -101,20 +102,24 @@ interpretConstructor c = Weird (constructorName c)
 data DataType = DataType [String] [Constructor]
   deriving (Eq,Show,Lift)
 
-reifyType :: String -> Q Exp
-reifyType s = do
-  n <- lookupTypeName s
-  case n of
-    Nothing -> [|\k -> counterexample ("Type "++s++" not defined!") False|]
+lookupType' s =
+    do n <- lookupTypeName s
+       case n of Nothing -> return Nothing
                  Just n -> do info <- reify n
-                 case info of
+                              return $ case info of
                                          TyConI (DataD _ _ vs _ cs _) -> let cons = map interpretConstructor cs
                                                                              vars = map bndrName vs
-                                                   in [|\k -> counterexample ("The type "++s) $ k (DataType vars cons)|]
-                   _ -> [|\k -> counterexample ("Definition "++s++" is not a data declaration!") False|]
+                                                                         in Just (DataType vars cons)
+                                         _ -> Nothing
 
-bndrName (PlainTV n) = nameBase n
-bndrName (KindedTV n _) = nameBase n
+reifyType :: String -> Q Exp
+reifyType s = do
+  info <- lookupType' s
+  case info of
+    Nothing -> [|\k -> counterexample ("Type "++s++" not defined!") False|]
+    Just d -> [|\k -> counterexample ("The type "++s) $ k d|]
+
+bndrName = nameBase . tvName
 
 constructorName = nameBase . constructorName'
 
@@ -127,6 +132,21 @@ constructorName' c = case c of
   GadtC (n:_) _ _ -> n
   RecGadtC (n:_) _ _ -> n
 
+withConstructor :: String -> String -> [String] -> Q Exp
+withConstructor typName consName argTypes = do
+  d <- lookupType' typName
+  case d of
+    Nothing -> [|\k -> counterexample ("Type "++typName++" not defined!") False|]
+    Just (DataType _ cs) ->
+        case filter ok cs of
+          [] -> [|\k -> counterexample ("Type "++typName++" should have a constructor named "++consName) False|]
+          [Weird _] -> [|\k -> counterexample ("Constructor "++consName++" of type "++typName++" is weird. Make it normal.") False|]
+          [Constructor _ ts]
+              | ts == map SimpleType argTypes -> [|\k -> counterexample consName (k $(varOrCon $ mkName consName))|]
+              | otherwise -> [|\k -> counterexample ("Constructor "++consName++" of type "++typName++" should have fields of types "++intercalate ", " argTypes) False |]
+    where ok (Constructor n _) = n == consName
+          ok (Weird n) = n == consName
+
 -- testing classes
 
 data Instance = Found | NotFound String String | NoClass String | NoType String

exercises/Set13a.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-} -- this silences an uninteresting warning
+
 module Set13a where
 
 import Mooc.Todo

exercises/Set13aTest.hs

@@ -86,7 +86,7 @@ ex2_fail =
   forAllBlind (word `suchThat` (not.flip elem names)) $ \nok1 ->
   forAllBlind (word `suchThat` (not.flip elem names)) $ \nok2 ->
   let inp = zip names scores
-  in conjoin $[$(testing [|winner inp ok nok1|]) (?==Nothing)
+  in conjoin [$(testing [|winner inp ok nok1|]) (?==Nothing)
              ,$(testing [|winner inp nok1 ok|]) (?==Nothing)
              ,$(testing [|winner inp nok1 nok2|]) (?==Nothing)]
 

exercises/Set13b.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-} -- this silences an uninteresting warning
+
 module Set13b where
 
 import Mooc.Todo

exercises/Set7Test.hs

@@ -147,11 +147,23 @@ ex7_mempty = $(withInstance1 "Monoid" "Set" [|((<>),mempty)|]) $ \((<>),mempty)
 
 smallInt = choose (0,100::Int)
 
-ex8_multiply1 = $(hasType "Multiply1" [t|Int -> Int -> Operation1|]) $ \mul1 ->
+ex8_multiply1 = $(withConstructor "Operation1" "Multiply1" ["Int","Int"]) $ \mul1 ->
   forAllBlind smallInt $ \i ->
   forAllBlind smallInt $ \j ->
   $(testing [|compute1 (mul1 i j)|]) (?==(i*j))
 
+{-
+ex8_multiply1 = $(reifyType "Operation1") $ \(DataType vars cs) ->
+  case filter ok cs of
+    [Constructor _ ts] -> counterexample "  constructor Multiply1 should have type Int -> Int -> Operation1" $
+                          property $ ts == [SimpleType "Int", SimpleType "Int"]
+    [_] -> counterexample ("  constructor Multiply1 is weid. Make it normal.") $ property False
+    _ -> counterexample ("  should have a constructor named Multiply1") $ property False
+  where ok (Constructor "Multiply1" _) = True
+        ok (Weird "Multiply1") = True
+        ok _ = False
+-}
+
 ex8_multiply2 =
   $(withInstance "Operation2" "Multiply2" [|compute2|]) $ \compute2 ->
   $(withDefined "Multiply2") $ \mul2 ->
@@ -169,7 +181,7 @@ ex8_show1 =
           ,$(testing [|show1 (Subtract1 i j)|]) (?==show i++"-"++show j)]
 
 ex8_show1_multiply1 =
-  $(hasType "Multiply1" [t|Int -> Int -> Operation1|]) $ \mul1 ->
+  $(withConstructor "Operation1" "Multiply1" ["Int","Int"]) $ \mul1 ->
   $(hasType "show1" [t|Operation1 -> String|]) $ \show1 ->
   forAllBlind smallInt $ \i ->
   forAllBlind smallInt $ \j ->

exercises/tests.cabal

@@ -11,6 +11,7 @@ library
                , array==0.5.4.0
                , transformers==0.5.6.2
                , template-haskell==2.16.0.0
+               , th-abstraction==0.4.3.0
                , generic-random==1.4.0.0
                , JuicyPixels==3.3.6
                , HTTP==4000.3.16