Support the MagicHash extension as a flag and LANGUAGE pragma

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 4aea083..e0aca33 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -183,6 +183,7 @@ data DynFlag
    | Opt_RecordPuns
    | Opt_GADTs
    | Opt_RelaxedPolyRec                        -- -X=RelaxedPolyRec
+   | Opt_MagicHash
 
    -- optimisation opts
    | Opt_Strictness
@@ -1092,6 +1093,7 @@ fFlags = [
 -- These -X<blah> flags can all be reversed with -Xno-<blah>
 xFlags :: [(String, DynFlag)]
 xFlags = [
+  ( "MagicHash",                        Opt_MagicHash ),
   ( "FI",                              Opt_FFI ),  -- support `-ffi'...
   ( "FFI",                             Opt_FFI ),  -- ...and also `-fffi'
   ( "ForeignFunctionInterface",                Opt_FFI ),
@@ -1135,6 +1137,7 @@ glasgowExtsFlags = [ Opt_GlasgowExts
                   , Opt_GADTs
                   , Opt_ImplicitParams 
                   , Opt_ScopedTypeVariables
+                  , Opt_MagicHash
                   , Opt_TypeFamilies ]
 
 ------------------

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index db48dbe..d1a9bb7 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -342,11 +342,11 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   @qual @conid                 { pop_and (idtoken qconid) }
 }
 
-<glaexts> {
-  @qual @varid "#"+            { idtoken qvarid }
-  @qual @conid "#"+            { idtoken qconid }
-  @varid "#"+                  { varid }
-  @conid "#"+                  { idtoken conid }
+<0,glaexts> {
+  @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
+  @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
+  @varid "#"+       / { ifExtension magicHashEnabled } { varid }
+  @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
 }
 
 -- ToDo: M.(,,,)
@@ -1517,18 +1517,20 @@ bangPatBit = 8  -- Tells the parser to understand bang-patterns
                -- (doesn't affect the lexer)
 tyFamBit   = 9 -- indexed type families: 'family' keyword and kind sigs
 haddockBit = 10 -- Lex and parse Haddock comments
+magicHashBit = 11 -- # in both functions and operators
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
-glaExtsEnabled flags = testBit flags glaExtsBit
-ffiEnabled     flags = testBit flags ffiBit
-parrEnabled    flags = testBit flags parrBit
-arrowsEnabled  flags = testBit flags arrowsBit
-thEnabled      flags = testBit flags thBit
-ipEnabled      flags = testBit flags ipBit
-tvEnabled      flags = testBit flags tvBit
-bangPatEnabled flags = testBit flags bangPatBit
-tyFamEnabled   flags = testBit flags tyFamBit
-haddockEnabled flags = testBit flags haddockBit
+glaExtsEnabled   flags = testBit flags glaExtsBit
+ffiEnabled       flags = testBit flags ffiBit
+parrEnabled      flags = testBit flags parrBit
+arrowsEnabled    flags = testBit flags arrowsBit
+thEnabled        flags = testBit flags thBit
+ipEnabled        flags = testBit flags ipBit
+tvEnabled        flags = testBit flags tvBit
+bangPatEnabled   flags = testBit flags bangPatBit
+tyFamEnabled     flags = testBit flags tyFamBit
+haddockEnabled   flags = testBit flags haddockBit
+magicHashEnabled flags = testBit flags magicHashBit
 
 -- PState for parsing options pragmas
 --
@@ -1571,15 +1573,16 @@ mkPState buf loc flags  =
     }
     where
       bitmap =     glaExtsBit `setBitIf` dopt Opt_GlasgowExts  flags
-              .|. ffiBit     `setBitIf` dopt Opt_FFI          flags
-              .|. parrBit    `setBitIf` dopt Opt_PArr         flags
-              .|. arrowsBit  `setBitIf` dopt Opt_Arrows       flags
-              .|. thBit      `setBitIf` dopt Opt_TH           flags
-              .|. ipBit      `setBitIf` dopt Opt_ImplicitParams flags
-              .|. tvBit      `setBitIf` dopt Opt_ScopedTypeVariables flags
-              .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
-              .|. tyFamBit   `setBitIf` dopt Opt_TypeFamilies flags
-              .|. haddockBit `setBitIf` dopt Opt_Haddock      flags
+              .|. ffiBit       `setBitIf` dopt Opt_FFI          flags
+              .|. parrBit      `setBitIf` dopt Opt_PArr         flags
+              .|. arrowsBit    `setBitIf` dopt Opt_Arrows       flags
+              .|. thBit        `setBitIf` dopt Opt_TH           flags
+              .|. ipBit        `setBitIf` dopt Opt_ImplicitParams flags
+              .|. tvBit        `setBitIf` dopt Opt_ScopedTypeVariables flags
+              .|. bangPatBit   `setBitIf` dopt Opt_BangPatterns flags
+              .|. tyFamBit     `setBitIf` dopt Opt_TypeFamilies flags
+              .|. haddockBit   `setBitIf` dopt Opt_Haddock      flags
+              .|. magicHashBit `setBitIf` dopt Opt_MagicHash    flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b