From: simonpj@microsoft.com <unknown>
Date: Sat, 27 Oct 2007 15:49:03 +0000 (+0000)
Subject: In an AbsBinds, the 'dicts' can include EqInsts
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6bb651084a0ebd572739ab9319c800c6ad83eb56

In an AbsBinds, the 'dicts' can include EqInsts

An AbsBinds abstrats over evidence, and the evidence can be both
Dicts (class constraints, implicit parameters) and EqInsts (equality
constraints).  So we need to
  - use varType rather than idType
  - use instToVar rather than instToId
  - use zonkDictBndr rather than zonkIdBndr in zonking

It actually all worked before, but gave warnings.
---

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index ba4bfc6..f27637d 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -42,7 +42,7 @@ import VarEnv
 import TysPrim
 import Id
 import IdInfo
-import Var ( TyVar )
+import Var ( TyVar, varType )
 import Name
 import NameSet
 import NameEnv
@@ -344,15 +344,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 	   generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
 
 	-- BUILD THE POLYMORPHIC RESULT IDs
-  ; let dict_ids = map instToId dicts
-  ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids))
+  ; let dict_vars = map instToVar dicts	-- May include equality constraints
+  ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars))
 		    mono_bind_infos
 
   ; let	poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
   ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
 
   ; let abs_bind = L loc $ AbsBinds tyvars_to_gen
-	 		            dict_ids exports
+	 		            dict_vars exports
 	 		    	    (dict_binds `unionBags` binds')
 
   ; return ([unitBag abs_bind], poly_ids)	-- poly_ids are guaranteed zonked by mkExport
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 075ae71..f9b390f 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -194,6 +194,13 @@ zonkIdBndr env id
 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
 
+zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
+-- "Dictionary" binders can be coercion variables or dictionary variables
+zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
+
+zonkDictBndr env var | isTyVar var = return var
+		     | otherwise   = zonkIdBndr env var
+
 zonkTopBndrs :: [TcId] -> TcM [Id]
 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 \end{code}
@@ -287,7 +294,7 @@ zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn
 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, 
 			  abs_exports = exports, abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
-    zonkIdBndrs env dicts		`thenM` \ new_dicts ->
+    zonkDictBndrs env dicts			`thenM` \ new_dicts ->
     fixM (\ ~(new_val_binds, _) ->
 	let
 	  env1 = extendZonkEnv env new_dicts
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 5d1e63a..0025ef2 100644
--- 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
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index f5bdc51..0516308 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -950,8 +950,10 @@ bindIrredsR loc qtvs co_vars reft givens irreds
   | null irreds
   = return emptyBag
   | otherwise
-  = do	{ let givens' = filter isDict givens
-		-- The givens can include methods
+  = do	{ let givens' = filter isAbstractableInst givens
+		-- The givens can (redundantly) include methods
+		-- We want to retain both EqInsts and Dicts
+		-- There should be no implicadtion constraints
 		-- See Note [Pruning the givens in an implication constraint]
 
 	   -- If there are no 'givens' *and* the refinement is empty
@@ -987,7 +989,8 @@ makeImplicationBind :: InstLoc -> [TcTyVar] -> Refinement
 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs reft
-		    givens 	-- Guaranteed all Dicts (TOMDO: true?)
+		    givens 	-- Guaranteed all Dicts
+				-- or EqInsts
 		    irreds
  | null irreds			-- If there are no irreds, we are done
  = return ([], emptyBag)