Construction of EqPred dictionaries

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"

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}
 
 %************************************************************************

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.