From 970d5b88b1554bbdd7e459dae41aab3668ae897a Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 20 Jun 2007 16:33:59 +0000 Subject: [PATCH] Implement -X=GADTs and -X=RelaxedPolyRec Two new -X flags, one for GADTs and one for relaxed polymorphic recursion This also fixes a rather confusing error message that the Darcs folk tripped over. --- compiler/typecheck/TcBinds.lhs | 18 +++++++++--------- compiler/typecheck/TcPat.lhs | 14 +++++++++----- compiler/typecheck/TcTyClsDecls.lhs | 7 ++++--- docs/users_guide/flags.xml | 27 ++++++++++++++++++++------- docs/users_guide/glasgow_exts.xml | 4 ++-- 5 files changed, 44 insertions(+), 26 deletions(-) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 96b2ed8..351b6d8 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -162,9 +162,9 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures - ; gla_exts <- doptM Opt_GlasgowExts + ; poly_rec <- doptM Opt_RelaxedPolyRec ; (binds', thing) <- tcExtendIdEnv poly_ids $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn + tc_val_binds poly_rec top_lvl sig_fn prag_fn binds thing_inside ; return (ValBindsOut binds' sigs, thing) } @@ -176,14 +176,14 @@ tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time -tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside +tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside = do { thing <- thing_inside ; return ([], thing) } -tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside +tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside = do { (group', (groups', thing)) - <- tc_group gla_exts top_lvl sig_fn prag_fn group $ - tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside + <- tc_group poly_rec top_lvl sig_fn prag_fn group $ + tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside ; return (group' ++ groups', thing) } ------------------------ @@ -195,15 +195,15 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun -- We get a list of groups back, because there may -- be specialisations etc as well -tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside +tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside -- A single non-recursive binding -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly = do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside ; return ([(NonRecursive, b) | b <- binds], thing) } -tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside - | not gla_exts -- Recursive group, normal Haskell 98 route +tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + | not poly_rec -- Recursive group, normal Haskell 98 route = do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside ; return ([(Recursive, unionManyBags binds1)], thing) } diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 5384e4a..ff08a28 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -34,6 +34,7 @@ import Type import StaticFlags import TyCon import DataCon +import DynFlags import PrelNames import BasicTypes hiding (SuccessFlag(..)) import SrcLoc @@ -729,8 +730,11 @@ refineAlt con pstate ex_tvs [] pat_ty = return pstate -- Common case: no equational constraints refineAlt con pstate ex_tvs co_vars pat_ty - | not (isRigidTy pat_ty) - = failWithTc (nonRigidMatch con) + = do { opt_gadt <- doptM Opt_GADTs -- No type-refinement unless GADTs are on + ; if (not opt_gadt) then return pstate + else do + + { checkTc (isRigidTy pat_ty) (nonRigidMatch con) -- We are matching against a GADT constructor with non-trivial -- constraints, but pattern type is wobbly. For now we fail. -- We can make sense of this, however: @@ -745,8 +749,8 @@ refineAlt con pstate ex_tvs co_vars pat_ty -- then unify these constraints to make pat_ty the right shape; -- then proceed exactly as in the rigid case - | otherwise -- In the rigid case, we perform type refinement - = case gadtRefine (pat_reft pstate) ex_tvs co_vars of { + -- In the rigid case, we perform type refinement + ; case gadtRefine (pat_reft pstate) ex_tvs co_vars of { Failed msg -> failWithTc (inaccessibleAlt msg) ; Succeeded reft -> do { traceTc trace_msg ; return (pstate { pat_reft = reft }) } @@ -758,7 +762,7 @@ refineAlt con pstate ex_tvs co_vars pat_ty vcat [ ppr con <+> ppr ex_tvs, ppr [(v, tyVarKind v) | v <- co_vars], ppr reft] - } + } } } \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index ee847f5..3217a95 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -657,10 +657,11 @@ tcTyClDecl1 calc_isrec ; want_generic <- doptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields ; gla_exts <- doptM Opt_GlasgowExts + ; gadt_ok <- doptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? -- Check that we don't use GADT syntax in H98 world - ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) -- Check that we don't use kind signatures without Glasgow extensions ; checkTc (gla_exts || isNothing mb_ksig) (badSigTyDecl tc_name) @@ -1142,7 +1143,7 @@ badDataConTyCon data_con badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] + , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ] badStupidTheta tc_name = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) @@ -1175,7 +1176,7 @@ badSigTyDecl tc_name badFamInstDecl tc_name = vcat [ ptext SLIT("Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -ftype-families to allow indexed type families")) ] + , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ] badGadtIdxTyDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 9fb9341..4035dc8 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -678,6 +678,12 @@ + + Relaxed checking for mutually-recursive polymorphic functions + dynamic + + + Use GHCi's extended default rules in a normal module dynamic @@ -688,7 +694,20 @@ Enable overloaded string literals. dynamic - + + + + + Enable generalised algebraic data types. + + dynamic + + + + + Enable type families. + dynamic + @@ -705,12 +724,6 @@ - - Enable type families. - dynamic - - - Enable bang patterns. dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index e7858ce..1881ff0 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -4039,7 +4039,7 @@ and all others are monomorphic until the group is generalised Following a suggestion of Mark Jones, in his paper Typing Haskell in Haskell, -GHC implements a more general scheme. If is +GHC implements a more general scheme. If is specified: the dependency analysis ignores references to variables that have an explicit type signature. @@ -4068,7 +4068,7 @@ Now, the defintion for f is typechecked, with this type for The same refined dependency analysis also allows the type signatures of mutually-recursive functions to have different contexts, something that is illegal in Haskell 98 (Section 4.5.2, last sentence). With - + GHC only insists that the type signatures of a refined group have identical type signatures; in practice this means that only variables bound by the same pattern binding must have the same context. For example, this is fine: -- 1.7.10.4