Template Haskell support for equality constraints

3 files changed, 98 insertions, 32 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5fb13dfc06..82dffd798f 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -314,7 +314,7 @@ repInstD' (L loc (InstDecl ty binds _ ats))	-- Ignore user pragmas for now
 		-- occurrences don't fail, even though the binders don't 
                 -- appear in the resulting data structure
 		do { cxt1 <- repContext cxt
-		   ; inst_ty1 <- repPred (HsClassP cls tys)
+		   ; inst_ty1 <- repPredTy (HsClassP cls tys)
 		   ; ss <- mkGenSyms (collectHsBindBinders binds)
 		   ; binds1 <- addBinds ss (rep_binds binds)
                    ; ats1   <- repLAssocFamInst ats
@@ -481,22 +481,36 @@ repLContext (L _ ctxt) = repContext ctxt
 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 repContext ctxt = do 
 	            preds    <- mapM repLPred ctxt
-		    predList <- coreList typeQTyConName preds
+		    predList <- coreList predQTyConName preds
 		    repCtxt predList
 
 -- represent a type predicate
 --
-repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
+repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
 repLPred (L _ p) = repPred p
 
-repPred :: HsPred Name -> DsM (Core TH.TypeQ)
-repPred (HsClassP cls tys) = do
-			       tcon <- repTy (HsTyVar cls)
-			       tys1 <- repLTys tys
-			       repTapps tcon tys1
-repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p)
+repPred :: HsPred Name -> DsM (Core TH.PredQ)
+repPred (HsClassP cls tys) 
+  = do
+      cls1 <- lookupOcc cls
+      tys1 <- repLTys tys
+      tys2 <- coreList typeQTyConName tys1
+      repClassP cls1 tys2
+repPred (HsEqualP tyleft tyright) 
+  = do
+      tyleft1  <- repLTy tyleft
+      tyright1 <- repLTy tyright
+      repEqualP tyleft1 tyright1
 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 
+repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
+repPredTy (HsClassP cls tys) 
+  = do
+      tcon <- repTy (HsTyVar cls)
+      tys1 <- repLTys tys
+      repTapps tcon tys1
+repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
+
 -- yield the representation of a list of types
 --
 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
@@ -546,7 +560,7 @@ repTy (HsTupleTy _ tys)	  = do
 repTy (HsOpTy ty1 n ty2) 	  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
 					   `nlHsAppTy` ty2)
 repTy (HsParTy t)  	       	  = repLTy t
-repTy (HsPredTy pred)             = repPred pred
+repTy (HsPredTy pred)             = repPredTy pred
 repTy ty@(HsNumTy _)              = notHandled "Number types (for generics)" (ppr ty)
 repTy ty			  = notHandled "Exotic form of type" (ppr ty)
 
@@ -1313,9 +1327,15 @@ repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
 
-repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
+repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
+repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
+repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
+
+repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
+repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
+
 repConstr :: Core TH.Name -> HsConDeclDetails Name
           -> DsM (Core TH.ConQ)
 repConstr con (PrefixCon ps)
@@ -1517,6 +1537,8 @@ templateHaskellNames = [
     newtypeInstDName, tySynInstDName,
     -- Cxt
     cxtName,
+    -- Pred
+    classPName, equalPName,
     -- Strict
     isStrictName, notStrictName,
     -- Con
@@ -1541,11 +1563,11 @@ templateHaskellNames = [
 
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
-    clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
-    decQTyConName, conQTyConName, strictTypeQTyConName,
+    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
+    stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
-    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
+    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName,
 
     -- Quasiquoting
     quoteExpName, quotePatName]
@@ -1568,7 +1590,7 @@ qqFun  = mk_known_key_name OccName.varName qqLib
 -------------------- TH.Syntax -----------------------
 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
-    matchTyConName, clauseTyConName, funDepTyConName :: Name
+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName :: Name
 qTyConName        = thTc (fsLit "Q")            qTyConKey
 nameTyConName     = thTc (fsLit "Name")         nameTyConKey
 fieldExpTyConName = thTc (fsLit "FieldExp")     fieldExpTyConKey
@@ -1580,6 +1602,7 @@ typeTyConName     = thTc (fsLit "Type")         typeTyConKey
 matchTyConName    = thTc (fsLit "Match")        matchTyConKey
 clauseTyConName   = thTc (fsLit "Clause")       clauseTyConKey
 funDepTyConName   = thTc (fsLit "FunDep")       funDepTyConKey
+predTyConName     = thTc (fsLit "Pred")         predTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
@@ -1711,6 +1734,11 @@ tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
 cxtName :: Name
 cxtName = libFun (fsLit "cxt") cxtIdKey
 
+-- data Pred = ...
+classPName, equalPName :: Name
+classPName = libFun (fsLit "classP") classPIdKey
+equalPName = libFun (fsLit "equalP") equalPIdKey
+
 -- data Strict = ...
 isStrictName, notStrictName :: Name
 isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
@@ -1765,7 +1793,7 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
-    patQTyConName, fieldPatQTyConName :: Name
+    patQTyConName, fieldPatQTyConName, predQTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")        matchQTyConKey
 clauseQTyConName        = libTc (fsLit "ClauseQ")       clauseQTyConKey
 expQTyConName           = libTc (fsLit "ExpQ")          expQTyConKey
@@ -1778,6 +1806,7 @@ typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
 fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
 fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
+predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
 
 -- quasiquoting
 quoteExpName, quotePatName :: Name
@@ -1792,7 +1821,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
-    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey :: Unique
+    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
+    predQTyConKey :: Unique
 expTyConKey             = mkPreludeTyConUnique 100
 matchTyConKey           = mkPreludeTyConUnique 101
 clauseTyConKey          = mkPreludeTyConUnique 102
@@ -1816,6 +1846,8 @@ patQTyConKey            = mkPreludeTyConUnique 119
 fieldPatQTyConKey       = mkPreludeTyConUnique 120
 fieldExpQTyConKey       = mkPreludeTyConUnique 121
 funDepTyConKey          = mkPreludeTyConUnique 122
+predTyConKey            = mkPreludeTyConUnique 123
+predQTyConKey           = mkPreludeTyConUnique 124
 
 -- IdUniques available: 200-399
 -- If you want to change this, make sure you check in PrelNames
@@ -1885,9 +1917,9 @@ conEIdKey         = mkPreludeMiscIdUnique 241
 litEIdKey         = mkPreludeMiscIdUnique 242
 appEIdKey         = mkPreludeMiscIdUnique 243
 infixEIdKey       = mkPreludeMiscIdUnique 244
-infixAppIdKey       = mkPreludeMiscIdUnique 245
-sectionLIdKey       = mkPreludeMiscIdUnique 246
-sectionRIdKey       = mkPreludeMiscIdUnique 247
+infixAppIdKey     = mkPreludeMiscIdUnique 245
+sectionLIdKey     = mkPreludeMiscIdUnique 246
+sectionRIdKey     = mkPreludeMiscIdUnique 247
 lamEIdKey         = mkPreludeMiscIdUnique 248
 tupEIdKey         = mkPreludeMiscIdUnique 249
 condEIdKey        = mkPreludeMiscIdUnique 250
@@ -1947,6 +1979,11 @@ tySynInstDIdKey   = mkPreludeMiscIdUnique 343
 cxtIdKey :: Unique
 cxtIdKey            = mkPreludeMiscIdUnique 280
 
+-- data Pred = ...
+classPIdKey, equalPIdKey :: Unique
+classPIdKey         = mkPreludeMiscIdUnique 346
+equalPIdKey         = mkPreludeMiscIdUnique 347
+
 -- data Strict = ...
 isStrictKey, notStrictKey :: Unique
 isStrictKey         = mkPreludeMiscIdUnique 281
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b48d361ad6..a6b24b6078 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -146,13 +146,13 @@ cvtTop (ClassD ctxt cl tvs fds decs)
     isFamilyD (FamilyD _ _ _) = True
     isFamilyD _               = False
 
-cvtTop (InstanceD tys ty decs)
+cvtTop (InstanceD ctxt ty decs)
   = do 	{ let (ats, bind_sig_decs) = partition isFamInstD decs
         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
         ; ats' <- mapM cvtTop ats
         ; let ats'' = map unTyClD ats'
-	; ctxt' <- cvtContext tys
-	; L loc pred' <- cvtPred ty
+	; ctxt' <- cvtContext ctxt
+	; L loc pred' <- cvtPredTy ty
 	; inst_ty' <- returnL $ 
                         mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
 	; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
@@ -603,16 +603,29 @@ cvtTvs tvs = mapM cvt_tv tvs
 cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
 
-cvtContext :: Cxt -> CvtM (LHsContext RdrName)
+cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 
-cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
-cvtPred ty 
+cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
+cvtPred (TH.ClassP cla tys)
+  = do { cla' <- if isVarName cla then tName cla else tconName cla
+       ; tys' <- mapM cvtType tys
+       ; returnL $ HsClassP cla' tys'
+       }
+cvtPred (TH.EqualP ty1 ty2)
+  = do { ty1' <- cvtType ty1
+       ; ty2' <- cvtType ty2
+       ; returnL $ HsEqualP ty1' ty2'
+       }
+
+cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
+cvtPredTy ty 
   = do	{ (head, tys') <- split_ty_app ty
 	; case head of
 	    ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 	    VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
-	    _       -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) }
+	    _       -> failWith (ptext (sLit "Malformed predicate") <+> 
+                       text (TH.pprint ty)) }
 
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 cvtType ty = do { (head_ty, tys') <- split_ty_app ty
@@ -697,6 +710,14 @@ okOcc ns str@(c:_)
   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
   | otherwise 	 	      = startsConId c || startsConSym c || str == "[]"
 
+-- Determine the name space of a name in a type
+--
+isVarName :: TH.Name -> Bool
+isVarName (TH.Name occ _)
+  = case TH.occString occ of
+      ""    -> False
+      (c:_) -> startsVarId c || startsVarSym c
+
 badOcc :: OccName.NameSpace -> String -> SDoc
 badOcc ctxt_ns occ 
   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 309874b26e..0bdcbbdc6d 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -918,7 +918,7 @@ reifyTyCon tc
 	      r_tvs  = reifyTyVars tvs
 	      deriv = []	-- Don't know about deriving
 	      decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
-		   | otherwise	   = TH.DataD    cxt name r_tvs cons 	  deriv
+		   | otherwise	   = TH.DataD    cxt name r_tvs cons 	    deriv
 	; return (TH.TyConI decl) }
 
 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
@@ -970,7 +970,8 @@ reifyType (PredTy {}) = panic "reifyType PredTy"
 
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
-reifyCxt :: [PredType] -> TcM [TH.Type]
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
 
 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
@@ -983,10 +984,17 @@ reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 reify_tc_app tc tys = do { tys' <- reifyTypes tys 
 			 ; return (foldl TH.AppT (TH.ConT tc) tys') }
 
-reifyPred :: TypeRep.PredType -> TcM TH.Type
-reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
+reifyPred :: TypeRep.PredType -> TcM TH.Pred
+reifyPred (ClassP cls tys) 
+  = do { tys' <- reifyTypes tys 
+       ; return $ TH.ClassP (reifyName cls) tys'
+       }
 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
-reifyPred (EqPred {})      = panic "reifyPred EqPred"
+reifyPred (EqPred ty1 ty2) 
+  = do { ty1' <- reifyType ty1
+       ; ty2' <- reifyType ty2
+       ; return $ TH.EqualP ty1' ty2'
+       }
 
 
 ------------------------------