Commit d95190ca authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent bd0bd647
...@@ -37,6 +37,7 @@ import TyCon ...@@ -37,6 +37,7 @@ import TyCon
import DataCon import DataCon
import PrelNames import PrelNames
import BasicTypes hiding (SuccessFlag(..)) import BasicTypes hiding (SuccessFlag(..))
import DynFlags ( DynFlag( Opt_GADTs ) )
import SrcLoc import SrcLoc
import ErrUtils import ErrUtils
import Util import Util
...@@ -670,6 +671,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ...@@ -670,6 +671,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
pstate' | no_equalities = pstate pstate' | no_equalities = pstate
| otherwise = pstate { pat_eqs = True } | 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) $ ; unless no_equalities $ checkTc (isRigidTy pat_ty) $
nonRigidMatch (pat_ctxt pstate) data_con nonRigidMatch (pat_ctxt pstate) data_con
......
...@@ -328,6 +328,10 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ...@@ -328,6 +328,10 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
-- foralls earlier) -- foralls earlier)
; mapM_ checkTyFamFreeness t_typats ; 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 -- (b) a newtype has exactly one constructor
; checkTc (new_or_data == DataType || isSingleton k_cons) $ ; checkTc (new_or_data == DataType || isSingleton k_cons) $
newtypeConError tc_name (length k_cons) newtypeConError tc_name (length k_cons)
...@@ -770,9 +774,7 @@ tcTyClDecl1 calc_isrec ...@@ -770,9 +774,7 @@ tcTyClDecl1 calc_isrec
} }
where where
is_rec = calc_isrec tc_name is_rec = calc_isrec tc_name
h98_syntax = case cons of -- All constructors have same shape h98_syntax = consUseH98Syntax cons
L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
_ -> True
tcTyClDecl1 calc_isrec tcTyClDecl1 calc_isrec
(ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
...@@ -919,6 +921,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) ...@@ -919,6 +921,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
name = tyVarName tv name = tyVarName tv
(env', occ') = tidyOccName env (getOccName name) (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 tcConArg :: Bool -- True <=> -funbox-strict_fields
-> LHsType Name -> LHsType Name
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment