X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=e8974206c5b4f43c1037cf1778d7572e8a178f6f;hb=1c36a2c0f4bce8f3754b1b31d66b975c3688b221;hp=36cda5abc2174cdf24b7cf2bd2094b304a47f3fc;hpb=658e99a85870d02c734d78e488e963da107133ff;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 36cda5a..e897420 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -26,7 +26,7 @@ import HsSyn		( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
 import TcHsSyn		( hsLitType )
 import TcRnMonad
 import TcUnify		( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
-			  boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, 
+			  boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,, 
 			  unBox )
 import BasicTypes	( Arity, isMarkedStrict )
 import Inst		( newMethodFromName, newIPDict, instToId,
@@ -648,26 +648,7 @@ tcIdApp fun_name n_args arg_checker res_ty
 	; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
 	; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
 	      res_ty' 	     = mkFunTys extra_arg_tys' res_ty
-	      subst   	     = boxySubMatchType arg_qtvs fun_res_ty res_ty'
-				-- Only bind arg_qtvs, since only they will be
-				-- *definitely* be filled in by arg_checker
-				-- E.g.  error :: forall a. String -> a
-				--	 (error "foo") :: bx5
-				--  Don't make subst [a |-> bx5]
-				--  because then the result subsumption becomes
-				--	 	bx5 ~ bx5
-				--  and the unifer doesn't expect the 
-				--  same box on both sides
-	      inst_qtv tv | Just boxy_ty <- lookupTyVar subst tv = return boxy_ty
-			  | tv `elemVarSet` tau_qtvs = do { tv' <- tcInstBoxyTyVar tv
-					    	          ; return (mkTyVarTy tv') }
-			  | otherwise		     = do { tv' <- tcInstTyVar tv
-					    	          ; return (mkTyVarTy tv') }
-			-- The 'otherwise' case handles type variables that are
-			-- mentioned only in the constraints, not in argument or 
-			-- result types.  We'll make them tau-types
-
-	; qtys' <- mapM inst_qtv qtvs
+	; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
 	; let arg_subst    = zipOpenTvSubst qtvs qtys'
 	      fun_arg_tys' = substTys arg_subst fun_arg_tys
 
@@ -675,8 +656,12 @@ tcIdApp fun_name n_args arg_checker res_ty
 	-- Doing so will fill arg_qtvs and extra_arg_tys'
 	; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
 
+	-- Strip boxes from the qtvs that have been filled in by the arg checking
+	-- AND any variables that are mentioned in neither arg nor result
+	-- the latter are mentioned only in constraints; stripBoxyType will 
+	-- fill them with a monotype
 	; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
-			     | otherwise   		 = return qty'
+			     | otherwise		 = return qty'
 	; qtys'' <- zipWithM strip qtvs qtys'
 	; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
 
@@ -722,17 +707,13 @@ tcId orig fun_name res_ty
 
 	-- Split up the function type
 	; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy (idType fun_id)
-	      qtvs     = concatMap fst tv_theta_prs	-- Quantified tyvars
-	      tau_qtvs = exactTyVarsOfType fun_tau	-- Mentiond in the tau part
-	      inst_qtv tv | tv `elemVarSet` tau_qtvs = do { tv' <- tcInstBoxyTyVar tv
-					      		  ; return (mkTyVarTy tv') }
-			  | otherwise	  	     = do { tv' <- tcInstTyVar tv
-					                  ; return (mkTyVarTy tv') }
+	      qtvs = concatMap fst tv_theta_prs	-- Quantified tyvars
+	      tau_qtvs = exactTyVarsOfType fun_tau	-- Mentioned in the tau part
+	; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 
 	-- Do the subsumption check wrt the result type
-	; qtv_tys <- mapM inst_qtv qtvs
-	; let res_subst   = zipTopTvSubst qtvs qtv_tys
-	      fun_tau' = substTy res_subst fun_tau
+	; let res_subst = zipTopTvSubst qtvs qtv_tys
+	      fun_tau'  = substTy res_subst fun_tau
 
 	; co_fn <- tcFunResTy fun_name fun_tau' res_ty