From d95190caa3e09b33bca8544051043954ebd89c73 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 4 Feb 2009 15:09:19 +0000
Subject: [PATCH] Check -XGADTs in (a) type family decls (b) pattern matches

Following Trac #2905, we now require -XGADTs for *pattern matches* on
GADTs, not just on *definitions*.

Also I found that -XGADTs wasn't being checked when declaring type families,
so I fixed that too.
---
 compiler/typecheck/TcPat.lhs        |    7 +++++++
 compiler/typecheck/TcTyClsDecls.lhs |   13 ++++++++++---
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index e21fb68..82ac5e3 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -37,6 +37,7 @@ import TyCon
 import DataCon
 import PrelNames
 import BasicTypes hiding (SuccessFlag(..))
+import DynFlags	( DynFlag( Opt_GADTs ) )
 import SrcLoc
 import ErrUtils
 import Util
@@ -670,6 +671,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	      pstate' | no_equalities = pstate
 		      | otherwise     = pstate { pat_eqs = True }
 
+        ; gadts_on <- doptM Opt_GADTs
+	; checkTc (no_equalities || gadts_on)
+	  	  (ptext (sLit "A pattern match on a GADT requires -XGADTs"))
+		  -- Trac #2905 decided that a *pattern-match* of a GADT
+		  -- should require the GADT language flag
+
 	; unless no_equalities $ checkTc (isRigidTy pat_ty) $
                                  nonRigidMatch (pat_ctxt pstate) data_con
 
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4f6e7bd..1a9e054 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -328,6 +328,10 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
          --         foralls earlier)
        ; mapM_ checkTyFamFreeness t_typats
 
+	 -- Check that we don't use GADT syntax in H98 world
+       ; gadt_ok <- doptM Opt_GADTs
+       ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
+
 	 --     (b) a newtype has exactly one constructor
        ; checkTc (new_or_data == DataType || isSingleton k_cons) $
 	         newtypeConError tc_name (length k_cons)
@@ -770,9 +774,7 @@ tcTyClDecl1 calc_isrec
   }
   where
     is_rec   = calc_isrec tc_name
-    h98_syntax = case cons of 	-- All constructors have same shape
-			L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
-			_ -> True
+    h98_syntax = consUseH98Syntax cons
 
 tcTyClDecl1 calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
@@ -919,6 +921,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
 		 name = tyVarName tv
 		 (env', occ') = tidyOccName env (getOccName name) 
 
+consUseH98Syntax :: [LConDecl a] -> Bool
+consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
+consUseH98Syntax _                                             = True
+		 -- All constructors have same shape
+
 -------------------
 tcConArg :: Bool		-- True <=> -funbox-strict_fields
 	   -> LHsType Name
-- 
1.7.10.4