Commit 8415c28b authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Implement GADTSyntax extension

parent dea74f19
...@@ -321,6 +321,7 @@ data ExtensionFlag ...@@ -321,6 +321,7 @@ data ExtensionFlag
| Opt_RecordPuns | Opt_RecordPuns
| Opt_ViewPatterns | Opt_ViewPatterns
| Opt_GADTs | Opt_GADTs
| Opt_GADTSyntax
| Opt_NPlusKPatterns | Opt_NPlusKPatterns
| Opt_DoAndIfThenElse | Opt_DoAndIfThenElse
| Opt_RebindableSyntax | Opt_RebindableSyntax
...@@ -1585,6 +1586,7 @@ xFlags = [ ...@@ -1585,6 +1586,7 @@ xFlags = [
( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ),
( "OverloadedStrings", Opt_OverloadedStrings, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ),
( "GADTs", Opt_GADTs, nop ), ( "GADTs", Opt_GADTs, nop ),
( "GADTSyntax", Opt_GADTSyntax, nop ),
( "ViewPatterns", Opt_ViewPatterns, nop ), ( "ViewPatterns", Opt_ViewPatterns, nop ),
( "TypeFamilies", Opt_TypeFamilies, nop ), ( "TypeFamilies", Opt_TypeFamilies, nop ),
( "BangPatterns", Opt_BangPatterns, nop ), ( "BangPatterns", Opt_BangPatterns, nop ),
...@@ -1662,6 +1664,7 @@ impliedFlags ...@@ -1662,6 +1664,7 @@ impliedFlags
, (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off!
, (Opt_GADTs, turnOn, Opt_GADTSyntax)
, (Opt_GADTs, turnOn, Opt_MonoLocalBinds) , (Opt_GADTs, turnOn, Opt_MonoLocalBinds)
, (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds)
......
...@@ -753,11 +753,12 @@ tcTyClDecl1 parent calc_isrec ...@@ -753,11 +753,12 @@ tcTyClDecl1 parent calc_isrec
; kind_signatures <- xoptM Opt_KindSignatures ; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification ; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs ; gadt_ok <- xoptM Opt_GADTs
; gadtSyntax_ok <- xoptM Opt_GADTSyntax
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
-- Check that we don't use GADT syntax in H98 world -- Check that we don't use GADT syntax in H98 world
; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-- Check that we don't use kind signatures without Glasgow extensions -- Check that we don't use kind signatures without Glasgow extensions
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
...@@ -846,12 +847,12 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields ...@@ -846,12 +847,12 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields
-> TcM DataCon -> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
(ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
, con_details = details, con_res = res_ty }) , con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $ = addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt { ctxt' <- tcHsKindedContext ctxt
; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
(badExistential name) (badExistential name)
; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
; let ; let
...@@ -946,6 +947,21 @@ consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False ...@@ -946,6 +947,21 @@ consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
consUseH98Syntax _ = True consUseH98Syntax _ = True
-- All constructors have same shape -- All constructors have same shape
conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
conRepresentibleWithH98Syntax
(ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
= null tvs && null (unLoc ctxt)
conRepresentibleWithH98Syntax
(ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
= null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
where -- Each type variable should be used exactly once in the
-- result type, and the result type must just be the type
-- constructor applied to type variables
f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
= (v2 `elem` vs) && f t1 (delete v2 vs)
f (HsTyVar _) [] = True
f _ _ = False
------------------- -------------------
tcConArg :: Bool -- True <=> -funbox-strict_fields tcConArg :: Bool -- True <=> -funbox-strict_fields
-> LHsType Name -> LHsType Name
...@@ -1536,7 +1552,7 @@ badGadtDecl tc_name ...@@ -1536,7 +1552,7 @@ badGadtDecl tc_name
badExistential :: Located Name -> SDoc badExistential :: Located Name -> SDoc
badExistential con_name badExistential con_name
= hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+> = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
ptext (sLit "has existential type variables, or a context")) ptext (sLit "has existential type variables, a context, or a specialised result type"))
2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this")) 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
badStupidTheta :: Name -> SDoc badStupidTheta :: Name -> SDoc
......
Supports Markdown
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