From e5b79a6988880d8757634683eefe2f03e45cdfc6 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Sat, 25 Jul 2009 13:47:03 +0000
Subject: [PATCH] Add an extension to disable n+k patterns

---
 compiler/main/DynFlags.hs         |    4 ++++
 compiler/parser/Lexer.x           |    4 ++++
 compiler/parser/RdrHsSyn.lhs      |   13 ++++++++-----
 docs/users_guide/flags.xml        |    6 ++++++
 docs/users_guide/glasgow_exts.xml |   13 +++++++++++++
 5 files changed, 35 insertions(+), 5 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 500d257..9ff139c 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 7f5c3a4..54045aa 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 9d7f80c..51b77bc 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
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 005b139..65c7f8a 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -706,6 +706,12 @@
 	      <entry><option>-XMonomorphismRrestriction</option></entry>
 	    </row>
 	    <row>
+	      <entry><option>-XNoNPlusKPatterns</option></entry>
+	      <entry>Disable support for <literal>n+k</literal> patterns</entry>
+	      <entry>dynamic</entry>
+	      <entry><option>-XNPlusKPatterns</option></entry>
+	    </row>
+	    <row>
 	      <entry><option>-XNoMonoPatBinds</option></entry>
 	      <entry>Make <link linkend="monomorphism">pattern bindings polymorphic</link></entry>
 	      <entry>dynamic</entry>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index c0feb5b..ea31390 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -840,6 +840,19 @@ y)</literal> will not be coalesced.
 
 </sect2>
 
+    <!-- ===================== n+k patterns ===================  -->
+
+<sect2 id="n-k-patterns">
+<title>n+k patterns</title>
+<indexterm><primary><option>-XNoNPlusKPatterns</option></primary></indexterm>
+
+<para>
+<literal>n+k</literal> pattern support is enabled by default. To disable
+it, you can use the <option>-XNoNPlusKPatterns</option> flag.
+</para>
+
+</sect2>
+
     <!-- ===================== Recursive do-notation ===================  -->
 
 <sect2 id="mdo-notation">
-- 
1.7.10.4