X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=aab8f012ac5eaf68857675df928ef340a0330ea6;hb=3787d9878e4d62829a555f01b2a4c5866f24f303;hp=ba4bfc61ade052ffd8034bb222b8cf70c33a21fe;hpb=08ea4e6d331cb4bf1b5ea6ddcc688890a17d9097;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index ba4bfc6..aab8f01 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
@@ -424,8 +424,9 @@ tcPrag poly_id (InlineSig v inl)             = return (InlinePrag inl)
 
 tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
 tcSpecPrag poly_id hs_ty inl
-  = do	{ spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
-	; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
+  = do	{ let name = idName poly_id
+	; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
+	; (co_fn, lie) <- getLIE (tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty)
 	; extendLIEs lie
 	; let const_dicts = map instToId lie
 	; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
@@ -741,9 +742,9 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
   where
     bndrs   = bndrNames mono_infos
     sigs    = [sig | (_, Just sig, _) <- mono_infos]
-    tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos
-		-- NB: exactTyVarsOfType; see Note [Silly type synonym] 
-		--     near defn of TcType.exactTyVarsOfType
+    get_tvs | isTopLevel top_lvl = tyVarsOfType	 -- See Note [Silly type synonym] in TcType
+	    | otherwise		 = exactTyVarsOfType
+    tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
     is_mono_sig sig = null (sig_theta sig)
     doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs