Make datatype contexts an extension (on by default) (DatatypeContexts)

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 ),

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

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

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