Add an extension to disable n+k patterns

3 files changed, 16 insertions, 5 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 500d257635..9ff139cdcd 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -226,6 +226,7 @@ data DynFlag
    | Opt_ViewPatterns
    | Opt_GADTs
    | Opt_RelaxedPolyRec
+   | Opt_NPlusKPatterns
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
@@ -693,6 +694,7 @@ defaultDynFlags =
 
             Opt_ImplicitPrelude,
             Opt_MonomorphismRestriction,
+            Opt_NPlusKPatterns,
 
             Opt_MethodSharing,
 
@@ -1808,6 +1810,8 @@ xFlags = [
   ( "BangPatterns",                     Opt_BangPatterns, const Supported ),
   -- On by default:
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, const Supported ),
+  -- On by default:
+  ( "NPlusKPatterns",                   Opt_NPlusKPatterns, const Supported ),
   -- On by default (which is not strictly H98):
   ( "MonoPatBinds",                     Opt_MonoPatBinds, const Supported ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, const Supported ),
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 7f5c3a435d..54045aa6ab 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -46,6 +46,7 @@
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
+   getPState,
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
@@ -1515,6 +1516,9 @@ failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
 failSpanMsgP :: SrcSpan -> SDoc -> P a
 failSpanMsgP span msg = P $ \_ -> PFailed span msg
 
+getPState :: P PState
+getPState = P $ \s -> POk s s
+
 extension :: (Int -> Bool) -> P Bool
 extension p = P $ \s -> POk s (p $! extsBitmap s)
 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 9d7f80c17d..51b77bc13d 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -63,13 +63,14 @@ import RdrName		( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
 import BasicTypes	( maxPrecedence, Activation, RuleMatchInfo,
                           InlinePragma(..),  InlineSpec(..),
                           alwaysInlineSpec, neverInlineSpec )
-import Lexer		( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
+import Lexer
 import TysWiredIn	( unitTyCon ) 
 import ForeignCall	( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
 			  DNCallSpec(..), DNKind(..), CLabelString )
 import OccName  	( srcDataName, varName, isDataOcc, isTcOcc, 
 			  occNameString )
 import PrelNames	( forall_tv_RDR )
+import DynFlags
 import SrcLoc
 import OrdList		( OrdList, fromOL )
 import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
@@ -725,12 +726,14 @@ checkPat loc e args 	-- OK to let this happen even if bang-patterns
 checkPat loc (L _ (HsApp f x)) args
   = do { x <- checkLPat x; checkPat loc f (x:args) }
 checkPat loc (L _ e) []
-  = do { p <- checkAPat loc e; return (L loc p) }
+  = do { pState <- getPState
+       ; p <- checkAPat (dflags pState) loc e
+       ; return (L loc p) }
 checkPat loc _ _
   = patFail loc
 
-checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
-checkAPat loc e = case e of
+checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
+checkAPat dynflags loc e = case e of
    EWildPat	       -> return (WildPat placeHolderType)
    HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
 					 ++ showRdrName x)
@@ -766,7 +769,7 @@ checkAPat loc e = case e of
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
 	 (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
-   		      | plus == plus_RDR
+   		      | dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
    		      -> return (mkNPlusKPat (L nloc n) lit)
    
    OpApp l op _fix r  -> do l <- checkLPat l