X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=9a17b0f07d0338b65963ea48ddfb683f8612a1e2;hb=cc9a63c2552d74abc1fefae647aeba062ea76b71;hp=543c61c195197bd239c7e860620de9eff62e173b;hpb=1add6282808b5ae98e72ef7034634036c9b91b04;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 543c61c..9a17b0f 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -45,6 +45,7 @@ module TcMType (
   checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
   checkUpdateMeta, updateMeta, checkTauTvUpdate, fillBoxWithTau, unifyKindCtxt,
   unifyKindMisMatch, validDerivPred, arityErr, notMonoType, notMonoArgs,
+  growPredTyVars, growTyVars, growThetaTyVars,
 
   --------------------------------
   -- Zonking
@@ -523,7 +524,12 @@ writeMetaTyVar tyvar ty
   = ASSERT( isMetaTyVar tyvar )
     -- TOM: It should also work for coercions
     -- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
-    do	{ ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar )
+    do	{ if debugIsOn then do { details <- readMetaTyVar tyvar; 
+    	     	       	       ; WARN( not (isFlexi details), ppr tyvar )
+			       	 return () }
+			else return () 
+		-- Temporarily make this a warning, until we fix Trac #2999
+
 	; traceTc (text "writeMetaTyVar" <+> ppr tyvar <+> text ":=" <+> ppr ty)
 	; writeMutVar (metaTvRef tyvar) (Indirect ty) }
   where
@@ -1066,6 +1072,7 @@ checkValidMonoType ty = check_mono_type MustBeMonoType ty
 data Rank = ArbitraryRank	  -- Any rank ok
           | MustBeMonoType  	  -- Monotype regardless of flags
 	  | TyConArgMonoType	  -- Monotype but could be poly if -XImpredicativeTypes
+	  | SynArgMonoType	  -- Monotype but could be poly if -XLiberalTypeSynonyms
           | Rank Int		  -- Rank n, but could be more with -XRankNTypes
 
 decRank :: Rank -> Rank		  -- Function arguments
@@ -1139,7 +1146,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
 	; liberal <- doptM Opt_LiberalTypeSynonyms
 	; if not liberal || isOpenSynTyCon tc then
 		-- For H98 and synonym families, do check the type args
-		mapM_ (check_mono_type TyConArgMonoType) tys
+		mapM_ (check_mono_type SynArgMonoType) tys
 
 	  else	-- In the liberal case (only for closed syns), expand then check
 	  case tcView ty of   
@@ -1216,6 +1223,7 @@ forAllTyErr rank ty
     suggestion = case rank of
     	       	   Rank _ -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types")
     	       	   TyConArgMonoType -> ptext (sLit "Perhaps you intended to use -XImpredicativeTypes")
+    	       	   SynArgMonoType -> ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms")
 		   _ -> empty      -- Polytype is always illegal
 
 unliftedArgErr, ubxArgTyErr :: Type -> SDoc
@@ -1322,6 +1330,14 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys)
     arity_err  = arityErr "Class" class_name arity n_tys
     how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this"))
 
+check_pred_ty _ (ClassSCCtxt _) (EqPred _ _)
+  =   -- We do not yet support superclass equalities.
+    failWithTc $
+      sep [ ptext (sLit "The current implementation of type families does not")
+          , ptext (sLit "support equality constraints in superclass contexts.")
+          , ptext (sLit "They are planned for a future release.")
+          ]
+
 check_pred_ty dflags _ pred@(EqPred ty1 ty2)
   = do {	-- Equational constraints are valid in all contexts if type
 		-- families are permitted
@@ -1406,7 +1422,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars
   = mapM_ complain (filter is_ambig theta)
   where
     complain pred     = addErrTc (ambigErr pred)
-    extended_tau_vars = grow theta tau_tyvars
+    extended_tau_vars = growThetaTyVars theta tau_tyvars
 
 	-- See Note [Implicit parameters and ambiguity] in TcSimplify
     is_ambig pred     = isClassPred  pred &&
@@ -1420,6 +1436,28 @@ ambigErr pred
   = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
 	 nest 4 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
 		 ptext (sLit "must be reachable from the type after the '=>'"))]
+
+--------------------------
+-- For this 'grow' stuff see Note [Growing the tau-tvs using constraints] in Inst
+
+growThetaTyVars :: TcThetaType -> TyVarSet -> TyVarSet
+-- Finds a fixpoint
+growThetaTyVars theta tvs
+  | null theta = tvs
+  | otherwise  = fixVarSet mk_next tvs
+  where
+    mk_next tvs = foldr growPredTyVars tvs theta
+
+
+growPredTyVars :: TcPredType -> TyVarSet -> TyVarSet
+-- Here is where the special case for inplicit parameters happens
+growPredTyVars (IParam _ ty) tvs = tvs `unionVarSet` tyVarsOfType ty
+growPredTyVars pred          tvs = growTyVars (tyVarsOfPred pred) tvs
+
+growTyVars :: TyVarSet -> TyVarSet -> TyVarSet
+growTyVars new_tvs tvs 
+  | new_tvs `intersectsVarSet` tvs = tvs `unionVarSet` new_tvs
+  | otherwise			   = tvs
 \end{code}
     
 In addition, GHC insists that at least one type variable