From c9bb6b63aa1f479a3dd3679c7e4c2c69471a4912 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 7 Jul 2010 21:25:29 +0000 Subject: [PATCH] Make datatype contexts an extension (on by default) (DatatypeContexts) --- compiler/main/DynFlags.hs | 4 ++++ compiler/parser/Lexer.x | 7 ++++++- compiler/parser/Parser.y.pp | 6 +++--- compiler/parser/RdrHsSyn.lhs | 19 +++++++++++++++---- 4 files changed, 28 insertions(+), 8 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index f420f21..3c117c4 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -256,6 +256,7 @@ data DynFlag | Opt_ExplicitForAll | Opt_AlternativeLayoutRule | Opt_AlternativeLayoutRuleTransitional + | Opt_DatatypeContexts | Opt_PrintExplicitForalls @@ -716,6 +717,7 @@ defaultDynFlags = Opt_ImplicitPrelude, Opt_MonomorphismRestriction, Opt_NPlusKPatterns, + Opt_DatatypeContexts, Opt_MethodSharing, @@ -1646,6 +1648,8 @@ xFlags = [ ( "ExplicitForAll", Opt_ExplicitForAll, const Supported ), ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, const Supported ), ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, const Supported ), + -- On by default: + ( "DatatypeContexts", Opt_DatatypeContexts, const Supported ), ( "MonoLocalBinds", Opt_MonoLocalBinds, const Supported ), ( "RelaxedPolyRec", Opt_RelaxedPolyRec, const Supported ), ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, const Supported ), diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index fdf4bdd..05fe063 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -51,7 +51,7 @@ module Lexer ( getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, getLexState, popLexState, pushLexState, - extension, bangPatEnabled, + extension, bangPatEnabled, datatypeContextsEnabled, addWarning, lexTokenStream ) where @@ -1735,6 +1735,8 @@ unicodeSyntaxBit :: Int unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc unboxedTuplesBit :: Int unboxedTuplesBit = 15 -- (# and #) +datatypeContextsBit :: Int +datatypeContextsBit = 16 transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int @@ -1778,6 +1780,8 @@ unicodeSyntaxEnabled :: Int -> Bool unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit unboxedTuplesEnabled :: Int -> Bool unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit +datatypeContextsEnabled :: Int -> Bool +datatypeContextsEnabled flags = testBit flags datatypeContextsBit qqEnabled :: Int -> Bool qqEnabled flags = testBit flags qqBit -- inRulePrag :: Int -> Bool @@ -1838,6 +1842,7 @@ mkPState flags buf loc = .|. recBit `setBitIf` dopt Opt_Arrows flags .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags + .|. datatypeContextsBit `setBitIf` dopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 37f9ba6..a2e2ff0 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -697,9 +697,9 @@ opt_kind_sig :: { Located (Maybe Kind) } -- (Eq a, Ord b) => T a b -- T Int [a] -- for associated types -- Rather a lot of inlining here, else we get reduce/reduce errors -tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) } - : context '=>' type { LL ($1, $3) } - | type { L1 (noLoc [], $1) } +tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } + : context '=>' type { LL (Just $1, $3) } + | type { L1 (Nothing, $1) } ----------------------------------------------------------------------------- -- Stand-alone deriving diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index ef761e6..ac1a028 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -70,6 +70,7 @@ import FastString import Maybes import Control.Applicative ((<$>)) +import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.List ( nubBy ) import Data.Char @@ -172,13 +173,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. \begin{code} mkClassDecl :: SrcSpan - -> Located (LHsContext RdrName, LHsType RdrName) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Located [Located (FunDep RdrName)] -> Located (OrdList (LHsDecl RdrName)) -> P (LTyClDecl RdrName) -mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls) + ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVars tparams -- Only type vars allowed ; checkKindSigs ats @@ -189,14 +191,16 @@ mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls mkTyData :: SrcSpan -> NewOrData -> Bool -- True <=> data family instance - -> Located (LHsContext RdrName, LHsType RdrName) + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe Kind -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) -mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr + ; checkDatatypeContext mcxt + ; let cxt = fromMaybe (noLoc []) mcxt ; (tyvars, typats) <- checkTParams is_family tparams ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc, tcdTyVars = tyvars, tcdTyPats = typats, @@ -521,6 +525,13 @@ checkTyVars tparms = mapM chk tparms chk (L l _) = parseError l "Type found where type variable expected" +checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just (L loc _)) + = do allowed <- extension datatypeContextsEnabled + unless allowed $ + parseError loc "Illegal datatype context (use -XDatatypeContexts)" + checkTyClHdr :: LHsType RdrName -> P (Located RdrName, -- the head symbol (type or class name) [LHsType RdrName]) -- parameters of head symbol -- 1.7.10.4