diff options
| author | simonpj@microsoft.com <unknown> | 2009-02-04 15:09:19 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2009-02-04 15:09:19 +0000 |
| commit | d95190caa3e09b33bca8544051043954ebd89c73 (patch) | |
| tree | f4c8bdcf06642e73dbb00b5ed736263abc9d1ec1 | |
| parent | bd0bd647062bad646dd8b2d0f85cce67c2079907 (diff) | |
| download | haskell-d95190caa3e09b33bca8544051043954ebd89c73.tar.gz | |
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.
| -rw-r--r-- | compiler/typecheck/TcPat.lhs | 7 | ||||
| -rw-r--r-- | 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 e21fb6883e..82ac5e3596 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 4f6e7bdfc1..1a9e054448 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 |