X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=3ae9cef048002ee3253ab0c816cda2a98feb8fe5;hb=230dc0b04ad444140cab040073adfd0efba24878;hp=87e2d94d02287cf901d523b20aa09d27639f490e;hpb=b0e7c6f2d78e856761944c27755b442e36ead60f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 87e2d94..3ae9cef 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -695,8 +695,12 @@ checkValidType :: UserTypeCtxt -> Type -> TcM ()
 checkValidType ctxt ty
   = traceTc (text "checkValidType" <+> ppr ty)	`thenM_`
     doptM Opt_GlasgowExts	`thenM` \ gla_exts ->
+    doptM Opt_Rank2Types	`thenM` \ rank2 ->
+    doptM Opt_RankNTypes	`thenM` \ rankn ->
+    doptM Opt_PolymorphicComponents	`thenM` \ polycomp ->
     let 
-	rank | gla_exts = Arbitrary
+	rank | rankn = Arbitrary
+	     | rank2 = Rank 2
 	     | otherwise
 	     = case ctxt of	-- Haskell 98
 		 GenPatCtxt	-> Rank 0
@@ -707,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
 
@@ -940,7 +947,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
@@ -972,12 +979,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
 
 -------------------------
@@ -1051,9 +1058,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)))
@@ -1125,19 +1131,30 @@ checkValidInstHead ty	-- Should be a source type
 
 check_inst_head dflags clas tys
 	-- If GlasgowExts then check at least one isn't a type variable
-  | dopt Opt_GlasgowExts dflags
-  = mapM_ check_one tys
-
-	-- WITH HASKELL 98, MUST HAVE C (T a b c)
-  | otherwise
-  = checkTc (isSingleton tys && tcValidInstHeadTy first_ty)
-	    (instTypeErr (pprClassPred clas tys) head_shape_msg)
-
+  = do checkTc (dopt Opt_TypeSynonymInstances dflags ||
+                all tcInstHeadTyNotSynonym tys)
+               (instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
+       checkTc (dopt Opt_FlexibleInstances dflags ||
+                all tcInstHeadTyAppAllTyVars tys)
+               (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
+       checkTc (dopt Opt_MultiParamTypeClasses dflags ||
+                isSingleton tys)
+               (instTypeErr (pprClassPred clas tys) head_one_type_msg)
+       mapM_ check_one tys
   where
-    (first_ty : _) = tys
-
-    head_shape_msg = parens (text "The instance type must be of form (T a1 ... an)" $$
-			     text "where T is not a synonym, and a1 ... an are distinct type *variables*")
+    head_type_synonym_msg = parens (
+                text "All instance types must be of the form (T t1 ... tn)" $$
+                text "where T is not a synonym." $$
+                text "Use -XTypeSynonymInstances if you want to disable this.")
+
+    head_type_args_tyvars_msg = parens (
+                text "All instance types must be of the form (T a1 ... an)" $$
+                text "where a1 ... an are distinct type *variables*" $$
+                text "Use -XFlexibleInstances if you want to disable this.")
+
+    head_one_type_msg = parens (
+                text "Only one type can be given in an instance head." $$
+                text "Use -XMultiParamTypeClasses if you want to allow more.")
 
 	-- For now, I only allow tau-types (not polytypes) in 
 	-- the head of an instance decl.