X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=9c176d0f94bd1f7bcb18151531acc5d48b0ad278;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hp=5d804334fdf04f1a1bf3eb4acde90edd1532651d;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 5d80433..9c176d0 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -44,6 +44,7 @@ import Bag
 import ErrUtils
 import Digraph
 import Maybes
+import List
 import Util
 import BasicTypes
 import Outputable
@@ -310,6 +311,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
    	-- TYPECHECK THE BINDINGS
   ; ((binds', mono_bind_infos), lie_req) 
 	<- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
+  ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req))
 
 	-- CHECK FOR UNLIFTED BINDINGS
 	-- These must be non-recursive etc, and are not generalised
@@ -329,24 +331,19 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 
     else do	-- The normal lifted case: GENERALISE
   { dflags <- getDOpts 
-  ; (tyvars_to_gen, dict_binds, dict_ids)
+  ; (tyvars_to_gen, dicts, dict_binds)
 	<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
 	   generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
 
-	-- FINALISE THE QUANTIFIED TYPE VARIABLES
-	-- The quantified type variables often include meta type variables
-	-- we want to freeze them into ordinary type variables, and
-	-- default their kind (e.g. from OpenTypeKind to TypeKind)
-  ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
-
 	-- BUILD THE POLYMORPHIC RESULT IDs
-  ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
+  ; let dict_ids = map instToId dicts
+  ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids))
 		    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'
+  ; let abs_bind = L loc $ AbsBinds tyvars_to_gen
 	 		            dict_ids exports
 	 		    	    (dict_binds `unionBags` binds')
 
@@ -686,10 +683,13 @@ getMonoBindInfo tc_binds
 generalise :: DynFlags -> TopLevelFlag 
 	   -> [LHsBind Name] -> TcSigFun 
 	   -> [MonoBindInfo] -> [Inst]
-	   -> TcM ([TcTyVar], TcDictBinds, [TcId])
+	   -> TcM ([TyVar], [Inst], TcDictBinds)
+-- The returned [TyVar] are all ready to quantify
+
 generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
   | isMonoGroup dflags bind_list
-  = do { extendLIEs lie_req; return ([], emptyBag, []) }
+  = do	{ extendLIEs lie_req
+	; return ([], [], emptyBag) }
 
   | isRestrictedGroup dflags bind_list sig_fn 	-- RESTRICTED CASE
   = 	-- Check signature contexts are empty 
@@ -704,27 +704,28 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
    	-- Check that signature type variables are OK
 	; final_qtvs <- checkSigsTyVars qtvs sigs
 
-	; return (final_qtvs, binds, []) }
+	; return (final_qtvs, [], binds) }
 
   | null sigs	-- UNRESTRICTED CASE, NO TYPE SIGS
   = 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
+	; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
 	
    	-- Check that signature type variables are OK
-	; final_qtvs <- checkSigsTyVars forall_tvs sigs
+	; final_qtvs <- checkSigsTyVars qtvs sigs
 
-	; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
+	; returnM (final_qtvs, sig_lie, binds) }
   where
     bndrs   = bndrNames mono_infos
     sigs    = [sig | (_, Just sig, _) <- mono_infos]
@@ -754,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
 
@@ -824,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.
@@ -1060,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,