X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=9746e0cbde2bc7e554b2c47ab69b178f82d56537;hb=a4980c2c58727d4337b48b7e4a7dcd4747d0fec7;hp=18e58fcc8ffa844d50c33e779c8b8203d6794081;hpb=597cbf7059161adfd8cbc935091d76aa4515f962;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 18e58fc..9746e0c 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -697,6 +697,7 @@ checkValidType ctxt ty
     doptM Opt_GlasgowExts	`thenM` \ gla_exts ->
     doptM Opt_Rank2Types	`thenM` \ rank2 ->
     doptM Opt_RankNTypes	`thenM` \ rankn ->
+    doptM Opt_PolymorphicComponents	`thenM` \ polycomp ->
     let 
 	rank | rankn = Arbitrary
 	     | rank2 = Rank 2
@@ -710,8 +711,11 @@ checkValidType ctxt ty
 		 TySynCtxt _    -> Rank 0
 		 ExprSigCtxt 	-> Rank 1
 		 FunSigCtxt _   -> Rank 1
-		 ConArgCtxt _   -> Rank 1	-- We are given the type of the entire
-						-- constructor, hence rank 1
+		 ConArgCtxt _   -> if polycomp
+                           then Rank 2
+                                -- We are given the type of the entire
+                                -- constructor, hence rank 1
+                           else Rank 1
 		 ForSigCtxt _	-> Rank 1
 		 SpecInstCtxt   -> Rank 1
 
@@ -834,10 +838,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
 			        && tyConArity tc <= length tys) $
 		          failWithTc arity_msg
 
-	; gla_exts <- doptM Opt_GlasgowExts
-	; if gla_exts && not (isOpenTyCon tc) then
-	-- If -fglasgow-exts then don't check the type arguments of 
-	-- *closed* synonyms.
+	; ok <- doptM Opt_PartiallyAppliedClosedTypeSynonyms
+	; if ok && not (isOpenTyCon tc) then
+	-- Don't check the type arguments of *closed* synonyms.
 	-- This allows us to instantiate a synonym defn with a 
 	-- for-all type, or with a partially-applied type synonym.
 	-- 	e.g.   type T a b = a
@@ -943,7 +946,7 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys)
     arity      = classArity cls
     n_tys      = length tys
     arity_err  = arityErr "Class" class_name arity n_tys
-    how_to_allow = parens (ptext SLIT("Use -fglasgow-exts to permit this"))
+    how_to_allow = parens (ptext SLIT("Use -XFlexibleContexts to permit this"))
 
 check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
   = do {	-- Equational constraints are valid in all contexts if type
@@ -975,12 +978,12 @@ check_pred_ty dflags ctxt sty = failWithTc (badPredTyErr sty)
 check_class_pred_tys dflags ctxt tys 
   = case ctxt of
 	TypeCtxt      -> True	-- {-# SPECIALISE instance Eq (T Int) #-} is fine
-	InstThetaCtxt -> gla_exts || undecidable_ok || all tcIsTyVarTy tys
+	InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
 				-- Further checks on head and theta in
 				-- checkInstTermination
-	other	      -> gla_exts || all tyvar_head tys
+	other	      -> flexible_contexts || all tyvar_head tys
   where
-    gla_exts       = dopt Opt_GlasgowExts dflags
+    flexible_contexts = dopt Opt_FlexibleContexts dflags
     undecidable_ok = dopt Opt_AllowUndecidableInstances dflags
 
 -------------------------
@@ -1054,9 +1057,8 @@ even in a scope where b is in scope.
 
 \begin{code}
 checkFreeness forall_tyvars theta
-  = do	{ gla_exts <- doptM Opt_GlasgowExts
-	; if gla_exts then return ()	-- New!  Oct06
-	  else mappM_ complain (filter is_free theta) }
+  = do	{ flexible_contexts <- doptM Opt_FlexibleContexts
+	; unless flexible_contexts $ mappM_ complain (filter is_free theta) }
   where    
     is_free pred     =  not (isIPPred pred)
 		     && not (any bound_var (varSetElems (tyVarsOfPred pred)))
@@ -1177,15 +1179,15 @@ instTypeErr pp_ty msg
 \begin{code}
 checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
 checkValidInstance tyvars theta clas inst_tys
-  = do	{ gla_exts <- doptM Opt_GlasgowExts
-	; undecidable_ok <- doptM Opt_AllowUndecidableInstances
+  = do	{ undecidable_ok <- doptM Opt_AllowUndecidableInstances
 
 	; checkValidTheta InstThetaCtxt theta
 	; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
 
 	-- Check that instance inference will terminate (if we care)
-	-- For Haskell 98, checkValidTheta has already done that
-	; when (gla_exts && not undecidable_ok) $
+	-- For Haskell 98 this will already have been done by checkValidTheta,
+    -- but as we may be using other extensions we need to check.
+	; unless undecidable_ok $
 	  mapM_ addErrTc (checkInstTermination inst_tys theta)
 	
 	-- The Coverage Condition