From 0aa1d46a1e5c19553c410dc6ff65b29594a2499f Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Fri, 29 Dec 2006 18:13:57 +0000
Subject: [PATCH] Construction of EqPred dictionaries

---
 compiler/basicTypes/OccName.lhs   |    3 ++-
 compiler/typecheck/Inst.lhs       |   15 +++++++++++----
 compiler/typecheck/TcInstDcls.lhs |    2 +-
 3 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index a5b32ed..48aa6db 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -31,7 +31,7 @@ module OccName (
  	mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
 	mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
 	mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
-	mkInstTyCoOcc, 
+	mkInstTyCoOcc, mkEqPredCoOcc,
 
 	-- ** Deconstruction
 	occNameFS, occNameString, occNameSpace, 
@@ -445,6 +445,7 @@ mkSpecOcc	    = mk_simple_deriv varName  "$s"
 mkForeignExportOcc  = mk_simple_deriv varName  "$f"
 mkNewTyCoOcc        = mk_simple_deriv tcName  ":Co"
 mkInstTyCoOcc       = mk_simple_deriv tcName  ":Co"      -- derived from rep ty
+mkEqPredCoOcc	    = mk_simple_deriv tcName  "$co"
 
 -- Generic derivable classes
 mkGenOcc1           = mk_simple_deriv varName  "$gfrom"
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index c34bf6d..b0fe5f9 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -83,7 +83,7 @@ Selection
 ~~~~~~~~~
 \begin{code}
 instName :: Inst -> Name
-instName inst = idName (instToId inst)
+instName inst = Var.varName (instToVar inst)
 
 instToId :: Inst -> TcId
 instToId inst = ASSERT2( isId id, ppr inst ) id 
@@ -329,9 +329,16 @@ mkPredName uniq loc pred_ty
   = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
   where
     occ = case pred_ty of
-	    ClassP cls tys -> mkDictOcc (getOccName cls)
-	    IParam ip ty   -> getOccName (ipNameName ip)
-	    EqPred _ _     -> pprPanic "mkPredName" (ppr pred_ty)
+	    ClassP cls _ -> mkDictOcc (getOccName cls)
+	    IParam ip  _ -> getOccName (ipNameName ip)
+	    EqPred ty  _ -> mkEqPredCoOcc baseOcc
+	      where
+		-- we use the outermost tycon of the lhs, which must be a type
+		-- function, as the base name for an equality
+	        baseOcc = case splitTyConApp_maybe ty of
+			    Nothing      -> 
+			      pprPanic "Inst.mkPredName:" (ppr ty)
+                            Just (tc, _) -> getOccName tc
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index b0ca87a..0be7724 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -611,7 +611,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     newDictBndrs sc_loc sc_theta'			`thenM` \ sc_dicts ->
     getInstLoc origin					`thenM` \ inst_loc -> 
     newDictBndrs inst_loc dfun_theta'			`thenM` \ dfun_arg_dicts ->
-    newDictBndr inst_loc (mkClassPred clas inst_tys') 	`thenM` \ this_dict ->
+    newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
 		-- Default-method Ids may be mentioned in synthesised RHSs,
 		-- but they'll already be in the environment.
 
-- 
1.7.10.4