In an AbsBinds, the 'dicts' can include EqInsts

[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 7b2ca58..0025ef2 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -525,7 +525,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
        ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
 
        ; return (unitBag $ noLoc $
-                 AbsBinds  tvs (map instToId dfun_dicts)
+                 AbsBinds  tvs (map instToVar dfun_dicts)
                            [(tvs, dfun_id, instToId this_dict, [])] 
                            (dict_bind `consBag` sc_binds)) }
   where
@@ -688,23 +688,16 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     returnM (unitBag main_bind)
 
 mkCoVars :: [PredType] -> TcM [TyVar]
-mkCoVars [] = return []
-mkCoVars (pred:preds) = 
-       do { uniq <- newUnique
-          ; let name = mkSysTvName uniq FSLIT("mkCoVars")
-          ; let tv = mkCoVar name (PredTy pred)
-          ; tvs <- mkCoVars preds
-          ; return (tv:tvs)
-          }
+mkCoVars = newCoVars . map unEqPred
+  where
+    unEqPred (EqPred ty1 ty2) = (ty1, ty2)
+    unEqPred _                = panic "TcInstDcls.mkCoVars"
 
 mkMetaCoVars :: [PredType] -> TcM [TyVar]
-mkMetaCoVars [] = return []
-mkMetaCoVars (EqPred ty1 ty2:preds) = 
-       do { tv <- newMetaTyVar TauTv (mkCoKind ty1 ty2)          
-          ; tvs <- mkMetaCoVars preds
-          ; return (tv:tvs)
-          }
-
+mkMetaCoVars = mappM eqPredToCoVar
+  where
+    eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
+    eqPredToCoVar _                = panic "TcInstDcls.mkMetaCoVars"
 
 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
          avail_insts op_items monobinds uprags