X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=fe51df121b681fa9d8b6d96cba5a792bb78a916b;hb=c295ee8ac9d7afb4d660dc3b63c10cca0a0b26e7;hp=fa129d3927fd04c2a6beb0372160927c648cca42;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index fa129d3..fe51df1 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -24,7 +24,7 @@ module TcMType (
 
   --------------------------------
   -- Instantiation
-  tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxy, tcInstBoxyTyVar,
+  tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
   tcInstSigTyVars, zonkSigTyVar,
   tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType, 
   tcSkolSigType, tcSkolSigTyVars,
@@ -58,8 +58,7 @@ import TypeRep		( Type(..), PredType(..),  -- Friend; can see representation
 import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), 
 			  MetaDetails(..), SkolemInfo(..), BoxInfo(..), 
-			  BoxyTyVar, BoxyType, BoxyThetaType, BoxySigmaType, 
-			  UserTypeCtxt(..),
+			  BoxyTyVar, BoxyType, UserTypeCtxt(..),
 			  isMetaTyVar, isSigTyVar, metaTvRef,
 			  tcCmpPred, isClassPred, tcGetTyVar,
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
@@ -327,12 +326,6 @@ readFilledBox box_tv = ASSERT( isBoxyTyVar box_tv )
 tcInstBoxyTyVar :: TyVar -> TcM BoxyTyVar
 -- Instantiate with a BOXY type variable
 tcInstBoxyTyVar tyvar = instMetaTyVar BoxTv tyvar
-
-tcInstBoxy :: TcType -> TcM ([BoxyTyVar], BoxyThetaType, BoxySigmaType)
--- tcInstType instantiates the outer-level for-alls of a TcType with
--- fresh BOXY type variables, splits off the dictionary part, 
--- and returns the pieces.
-tcInstBoxy ty = tcInstType (mapM tcInstBoxyTyVar) ty
 \end{code}
 
 
@@ -731,14 +724,16 @@ check_poly_type (Rank 0) ubx_tup ty
   = check_tau_type (Rank 0) ubx_tup ty
 
 check_poly_type rank ubx_tup ty 
-  = let
-	(tvs, theta, tau) = tcSplitSigmaTy ty
-    in
-    check_valid_theta SigmaCtxt theta		`thenM_`
-    check_tau_type (decRank rank) ubx_tup tau 	`thenM_`
-    checkFreeness tvs theta			`thenM_`
-    checkAmbiguity tvs theta (tyVarsOfType tau)
-
+  | null tvs && null theta
+  = check_tau_type rank ubx_tup ty
+  | otherwise
+  = do	{ check_valid_theta SigmaCtxt theta
+	; check_poly_type rank ubx_tup tau	-- Allow foralls to right of arrow
+	; checkFreeness tvs theta
+	; checkAmbiguity tvs theta (tyVarsOfType tau) }
+  where
+    (tvs, theta, tau) = tcSplitSigmaTy ty
+   
 ----------------------------------------
 check_arg_type :: Type -> TcM ()
 -- The sort of type that can instantiate a type variable,
@@ -781,8 +776,8 @@ check_tau_type rank ubx_tup (PredTy sty) = getDOpts		`thenM` \ dflags ->
 
 check_tau_type rank ubx_tup (TyVarTy _)       = returnM ()
 check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty)
-  = check_poly_type rank UT_NotOk arg_ty	`thenM_`
-    check_poly_type rank UT_Ok    res_ty
+  = check_poly_type (decRank rank) UT_NotOk arg_ty	`thenM_`
+    check_poly_type rank 	   UT_Ok    res_ty
 
 check_tau_type rank ubx_tup (AppTy ty1 ty2)
   = check_arg_type ty1 `thenM_` check_arg_type ty2