Add a WARNING pragma

[ghc-hetmet.git] / compiler / typecheck / TcMType.lhs

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 1290e03..4cdbf01 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -179,7 +179,7 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
 --    (checkTauTvUpdate tv ty)
 -- We are about to update the TauTv tv with ty.
 -- Check (a) that tv doesn't occur in ty (occurs check)
---      (b) that ty is a monotype
+--       (b) that ty is a monotype
 -- Furthermore, in the interest of (b), if you find an
 -- empty box (BoxTv that is Flexi), fill it in with a TauTv
 -- 
@@ -218,7 +218,7 @@ checkTauTvUpdate orig_tv orig_ty
        | isSynTyCon tc  = go_syn tc tys
        | otherwise      = do { tys' <- mapM go tys
                               ; return $ occurs (TyConApp tc) tys' }
-    go (PredTy p)       = do { p' <- go_pred p
+    go (PredTy p)            = do { p' <- go_pred p
                               ; return $ occurs1 PredTy p' }
     go (FunTy arg res)   = do { arg' <- go arg
                               ; res' <- go res
@@ -1054,7 +1054,7 @@ nonZeroRank _        = True
 
 ----------------------------------------
 data UbxTupFlag = UT_Ok        | UT_NotOk
-       -- The "Ok" version means "ok if -fglasgow-exts is on"
+       -- The "Ok" version means "ok if UnboxedTuples is on"
 
 ----------------------------------------
 check_mono_type :: Type -> TcM ()      -- No foralls anywhere
@@ -1486,22 +1486,26 @@ checkValidInstHead ty   -- Should be a source type
 
 check_inst_head :: DynFlags -> Class -> [Type] -> TcM ()
 check_inst_head dflags clas tys
-       -- If GlasgowExts then check at least one isn't a type variable
-  = 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_mono_type tys
+  = do { -- If GlasgowExts then check at least one isn't a type variable
+       ; 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)
+         -- May not contain type family applications
+       ; mapM_ checkTyFamFreeness tys
+
+       ; mapM_ check_mono_type tys
        -- For now, I only allow tau-types (not polytypes) in 
        -- the head of an instance decl.  
        --      E.g.  instance C (forall a. a->a) is rejected
        -- One could imagine generalising that, but I'm not sure
        -- what all the consequences might be
+       }
 
   where
     head_type_synonym_msg = parens (
@@ -1595,7 +1599,7 @@ predUndecErr pred msg = sep [msg,
 nomoreMsg, smallerMsg, undecidableMsg :: SDoc
 nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")
 smallerMsg = ptext (sLit "Constraint is no smaller than the instance head")
-undecidableMsg = ptext (sLit "Use -fallow-undecidable-instances to permit this")
+undecidableMsg = ptext (sLit "Use -XUndecidableInstances to permit this")
 \end{code}
 
 
@@ -1635,7 +1639,7 @@ should have only type-variable constraints.
 
 Here is another example:
        data Fix f = In (f (Fix f)) deriving( Eq )
-Here, if we are prepared to allow -fallow-undecidable-instances we
+Here, if we are prepared to allow -XUndecidableInstances we
 could derive the instance
        instance Eq (f (Fix f)) => Eq (Fix f)
 but this is so delicate that I don't think it should happen inside
@@ -1672,7 +1676,7 @@ validDerivPred _              = False
 
 \begin{code}
 -- Check that a "type instance" is well-formed (which includes decidability
--- unless -fallow-undecidable-instances is given).
+-- unless -XUndecidableInstances is given).
 --
 checkValidTypeInst :: [Type] -> Type -> TcM ()
 checkValidTypeInst typats rhs
@@ -1681,8 +1685,7 @@ checkValidTypeInst typats rhs
        ; mapM_ checkTyFamFreeness typats
 
          -- the right-hand side is a tau type
-       ; checkTc (isTauTy rhs) $ 
-          polyTyErr rhs
+       ; checkValidMonoType rhs
 
          -- we have a decidable instance unless otherwise permitted
        ; undecidable_ok <- doptM Opt_UndecidableInstances
@@ -1720,7 +1723,7 @@ checkFamInst lhsTys famInsts
 checkTyFamFreeness :: Type -> TcM ()
 checkTyFamFreeness ty
   = checkTc (isTyFamFree ty) $
-      tyFamInstInIndexErr ty
+      tyFamInstIllegalErr ty
 
 -- Check that a type does not contain any type family applications.
 --
@@ -1729,17 +1732,12 @@ isTyFamFree = null . tyFamInsts
 
 -- Error messages
 
-tyFamInstInIndexErr :: Type -> SDoc
-tyFamInstInIndexErr ty
-  = hang (ptext (sLit "Illegal type family application in type instance") <> 
+tyFamInstIllegalErr :: Type -> SDoc
+tyFamInstIllegalErr ty
+  = hang (ptext (sLit "Illegal type synonym family application in instance") <> 
          colon) 4 $
       ppr ty
 
-polyTyErr :: Type -> SDoc
-polyTyErr ty 
-  = hang (ptext (sLit "Illegal polymorphic type in type instance") <> colon) 4 $
-      ppr ty
-
 famInstUndecErr :: Type -> SDoc -> SDoc
 famInstUndecErr ty msg 
   = sep [msg,