X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=95f3d4137e097120481e09ad6075714108bd1fce;hb=5adfdfb259415ca99d67d3c8b9e5df68cb736326;hp=99832677f065f74e14f2d2aff28b68ef6f6bb214;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 9983267..95f3d41 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -526,7 +526,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
 	; let mono_id = mkLocalId mono_name zonked_rhs_ty
 	; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
 					      fun_matches = matches', bind_fvs = fvs,
-					      fun_co_fn = co_fn })),
+					      fun_co_fn = co_fn, fun_tick = Nothing })),
 		  [(name, Nothing, mono_id)]) }
 
 tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
@@ -550,7 +550,8 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
 
 	; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
 				    fun_infix = inf, fun_matches = matches',
-			            bind_fvs = placeHolderNames, fun_co_fn = co_fn }
+			            bind_fvs = placeHolderNames, fun_co_fn = co_fn, 
+				    fun_tick = Nothing }
 	; return (unitBag (L b_loc fun_bind'),
 		  [(name, Just tc_sig, mono_id)]) }
 
@@ -655,7 +656,8 @@ tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
   = do	{ (co_fn, matches') <- tcMatchesFun (idName mono_id) matches 
 				    	    (idType mono_id)
 	; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
-			    bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
+			    bind_fvs = placeHolderNames, fun_co_fn = co_fn,
+			    fun_tick = Nothing }) }
 
 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
   = do	{ grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
@@ -708,16 +710,17 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
   = tcSimplifyInfer doc tau_tvs lie_req
 
   | otherwise	-- UNRESTRICTED CASE, WITH TYPE SIGS
-  = do	{ sig_lie <- unifyCtxts sigs	-- sigs is non-empty
+  = do	{ sig_lie <- unifyCtxts sigs	-- sigs is non-empty; sig_lie is zonked
 	; let	-- The "sig_avails" is the stuff available.  We get that from
 		-- the context of the type signature, BUT ALSO the lie_avail
 		-- so that polymorphic recursion works right (see Note [Polymorphic recursion])
 		local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
 		sig_avails = sig_lie ++ local_meths
+		loc = sig_loc (head sigs)
 
 	-- Check that the needed dicts can be
 	-- expressed in terms of the signature ones
-	; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
+	; (forall_tvs, dict_binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
 	
    	-- Check that signature type variables are OK
 	; final_qtvs <- checkSigsTyVars forall_tvs sigs
@@ -734,7 +737,8 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
 
     mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, 
 		            sig_theta = theta, sig_loc = loc }) mono_id
-      = Method mono_id poly_id (mkTyVarTys tvs) theta loc
+      = Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs,
+		tci_theta = theta, tci_loc = loc}
 \end{code}
 
 unifyCtxts checks that all the signature contexts are the same
@@ -751,14 +755,16 @@ might not otherwise be related.  This is a rather subtle issue.
 
 \begin{code}
 unifyCtxts :: [TcSigInfo] -> TcM [Inst]
+-- Post-condition: the returned Insts are full zonked
 unifyCtxts (sig1 : sigs) 	-- Argument is always non-empty
   = do	{ mapM unify_ctxt sigs
-	; newDictBndrs (sig_loc sig1) (sig_theta sig1) }
+	; theta <- zonkTcThetaType (sig_theta sig1)
+	; newDictBndrs (sig_loc sig1) theta }
   where
     theta1 = sig_theta sig1
     unify_ctxt :: TcSigInfo -> TcM ()
     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
-	= setSrcSpan (instLocSrcSpan (sig_loc sig)) 	$
+	= setSrcSpan (instLocSpan (sig_loc sig)) 	$
 	  addErrCtxt (sigContextsCtxt sig1 sig)		$
 	  unifyTheta theta1 theta
 
@@ -821,7 +827,7 @@ checkDistinctTyVars sig_tvs
 		         <+> quotes (ppr tidy_tv2)
 	    ; failWithTcM (env2, msg) }
        where
-\end{code}    
+\end{code}
 
 
 @getTyVarsToGen@ decides what type variables to generalise over.
@@ -1057,8 +1063,7 @@ tcInstSig use_skols name scoped_names
   = do	{ poly_id <- tcLookupId name	-- Cannot fail; the poly ids are put into 
 					-- scope when starting the binding group
 	; let skol_info = SigSkol (FunSigCtxt name)
-	      inst_tyvars | use_skols = tcInstSkolTyVars skol_info
-			  | otherwise = tcInstSigTyVars  skol_info
+	      inst_tyvars = tcInstSigTyVars use_skols skol_info
 	; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
 	; loc <- getInstLoc (SigOrigin skol_info)
 	; return (TcSigInfo { sig_id = poly_id,