X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=94af19c6eebdaf31668b66efbd06e1a455dcc658;hb=5656eb8f9bc7ee43da889da4847856a0f70d9461;hp=11c0f3fdd89f49ac0020af32baf2ef04f5570299;hpb=f16dbbbe59cf3aa19c5fd384560a1b89076d7bc8;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 11c0f3f..94af19c 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -123,8 +123,8 @@ subFunTys error_herald n_pats res_ty mb_ctxt thing_inside
         | isSigmaTy res_ty      -- Do this before checking n==0, because we
                                 -- guarantee to return a BoxyRhoType, not a
                                 -- BoxySigmaType
-        = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ 
-                                         loop n args_so_far
+        = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ \ _ res_ty ->
+                                         loop n args_so_far res_ty
              ; return (gen_fn <.> co_fn, res) }
 
     loop 0 args_so_far res_ty
@@ -770,7 +770,7 @@ tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
     if exp_ib then      -- SKOL does not apply if exp_ty is inside a box
         defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty
     else do
-        { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ body_exp_ty ->
+        { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ _ body_exp_ty ->
                              tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty
         ; return (gen_fn <.> co_fn) }
     }
@@ -896,21 +896,21 @@ wrapFunResCoercion arg_tys co_fn_res
 %************************************************************************
 
 \begin{code}
-tcGen :: BoxySigmaType                          -- expected_ty
-      -> TcTyVarSet                             -- Extra tyvars that the universally
-                                                --      quantified tyvars of expected_ty
-                                                --      must not be unified
-      -> Maybe UserTypeCtxt			-- Just ctxt => this polytype arose directly from
-      	       					-- 	        a user type sig; bring tyvars into scope
-						-- Nothing => a higher order situation
-      -> (BoxyRhoType -> TcM result)
+tcGen :: BoxySigmaType                -- expected_ty
+      -> TcTyVarSet                   -- Extra tyvars that the universally
+                                      --      quantified tyvars of expected_ty
+                                      --      must not be unified
+      -> Maybe UserTypeCtxt	      -- Just ctxt => this polytype arose directly
+      	       			      -- 	        from a user type sig
+				      -- Nothing => a higher order situation
+      -> ([TcTyVar] -> BoxyRhoType -> TcM result)
       -> TcM (HsWrapper, result)
         -- The expression has type: spec_ty -> expected_ty
 
 tcGen expected_ty extra_tvs mb_ctxt thing_inside        -- We expect expected_ty to be a forall-type
                                           		-- If not, the call is a no-op
   = do  { traceTc (text "tcGen")
-        ; ((tvs', theta', rho'), skol_info, scoped_tvs) <- instantiate expected_ty
+        ; ((tvs', theta', rho'), skol_info) <- instantiate expected_ty
 
         ; when debugIsOn $
               traceTc (text "tcGen" <+> vcat [
@@ -922,10 +922,7 @@ tcGen expected_ty extra_tvs mb_ctxt thing_inside        -- We expect expected_ty
 
         -- Type-check the arg and unify with poly type
         ; (result, lie) <- getLIE $ 
-	  	   	   tcExtendTyVarEnv2 (scoped_tvs `zip` mkTyVarTys tvs') $ 
-		   		-- Extend the lexical type-variable environment 
-				-- if we're in a user-type context
-			   thing_inside rho'
+			   thing_inside tvs' rho'
 
         -- Check that the "forall_tvs" havn't been constrained
         -- The interesting bit here is that we must include the free variables
@@ -953,23 +950,22 @@ tcGen expected_ty extra_tvs mb_ctxt thing_inside        -- We expect expected_ty
   where
     free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
 
-    instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo, [Name])
+    instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo)
     instantiate expected_ty
-      | Just ctxt <- mb_ctxt
+      | Just ctxt <- mb_ctxt	-- This case split is the wohle reason for mb_ctxt
       = do { let skol_info = SigSkol ctxt
-      	         tv_names  = map tyVarName (fst (tcSplitForAllTys expected_ty))
            ; stuff <- tcInstSigType True skol_info expected_ty
-	   ; return (stuff, skol_info, tv_names) }
+	   ; return (stuff, skol_info) }
 
       | otherwise   -- We want the GenSkol info in the skolemised type variables to
                     -- mention the *instantiated* tyvar names, so that we get a
 		    -- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
 		    -- Hence the tiresome but innocuous fixM
-      = fixM $ \ ~(_, skol_info, _) ->
+      = fixM $ \ ~(_, skol_info) ->
         do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
                 -- Get loation from *monad*, not from expected_ty
            ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
-           ; return (stuff, skol_info, []) }
+           ; return (stuff, skol_info) }
 \end{code}
 
 
@@ -2043,7 +2039,7 @@ check_sig_tyvars
 check_sig_tyvars _ []
   = return ()
 check_sig_tyvars extra_tvs sig_tvs
-  = ASSERT( all isSkolemTyVar sig_tvs )
+  = ASSERT( all isTcTyVar sig_tvs && all isSkolemTyVar sig_tvs )
     do  { gbl_tvs <- tcGetGlobalTyVars
         ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs,
                                       text "gbl_tvs" <+> ppr gbl_tvs,