Add an extension to disable n+k patterns

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 500d257..9ff139c 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -226,6 +226,7 @@ data DynFlag
    | Opt_ViewPatterns
    | Opt_GADTs
    | Opt_RelaxedPolyRec
    | Opt_ViewPatterns
    | Opt_GADTs
    | Opt_RelaxedPolyRec

+   | Opt_NPlusKPatterns

 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable

@@ -693,6 +694,7 @@ defaultDynFlags =
 
             Opt_ImplicitPrelude,
             Opt_MonomorphismRestriction,
 
             Opt_ImplicitPrelude,
             Opt_MonomorphismRestriction,

+            Opt_NPlusKPatterns,

 
             Opt_MethodSharing,
 
 
             Opt_MethodSharing,
 

@@ -1808,6 +1810,8 @@ xFlags = [
   ( "BangPatterns",                     Opt_BangPatterns, const Supported ),
   -- On by default:
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, const Supported ),
   ( "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 ),
   -- 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 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -46,6 +46,7 @@
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 

+   getPState,

    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    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
 
 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)
 
 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 (file)
--- 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 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 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 )
 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) []
 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
 
 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)
    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 {}})))
    -- 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
                      -> 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 (file)
--- 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>-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>
              <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 (file)
--- 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>
 
 
 </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">
     <!-- ===================== Recursive do-notation ===================  -->
 
 <sect2 id="mdo-notation">