-- NOTE: accept -} at the end of a LINE pragma, for compatibility
-- with older versions of GHC which generated these.
--- We only want RULES pragmas to be picked up when -fglasgow-exts
--- is on, because the contents of the pragma is always written using
--- glasgow-exts syntax (using forall etc.), so if glasgow exts are not
--- enabled, we're sure to get a parse error.
+-- We only want RULES pragmas to be picked up when explicit forall
+-- syntax is enabled is on, because the contents of the pragma always
+-- uses it. If it's not on then we're sure to get a parse error.
-- (ToDo: we should really emit a warning when ignoring pragmas)
-<glaexts>
- "{-#" $whitechar* (RULES|rules) { token ITrules_prag }
+-- XXX Now that we can enable this without the -fglasgow-exts hammer,
+-- is it better just to let the parse error happen?
+<0,glaexts>
+ "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
<0,option_prags,glaexts> {
"{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) }
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
-<glaexts> {
- "(#" / { notFollowedBySymbol } { token IToubxparen }
- "#)" { token ITcubxparen }
- "{|" { token ITocurlybar }
- "|}" { token ITccurlybar }
+<0,glaexts> {
+ "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
+ { token IToubxparen }
+ "#)" / { ifExtension unboxedTuplesEnabled }
+ { token ITcubxparen }
+}
+
+<0,glaexts> {
+ "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
+ "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
}
<0,option_prags,glaexts> {
@floating_point { strtoken tok_float }
}
-<glaexts> {
+<0,glaexts> {
-- Unboxed ints (:: Int#)
-- It's simpler (and faster?) to give separate cases to the negatives,
-- especially considering octal/hexadecimal prefixes.
- @decimal \# { tok_primint positive 0 1 decimal }
- 0[oO] @octal \# { tok_primint positive 2 3 octal }
- 0[xX] @hexadecimal \# { tok_primint positive 2 3 hexadecimal }
- @negative @decimal \# { tok_primint negative 1 2 decimal }
- @negative 0[oO] @octal \# { tok_primint negative 3 4 octal }
- @negative 0[xX] @hexadecimal \# { tok_primint negative 3 4 hexadecimal }
+ @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
+ 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
+ 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
+ @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
+ @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
+ @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
-- Unboxed floats and doubles (:: Float#, :: Double#)
-- prim_{float,double} work with signed literals
- @signed @floating_point \# { init_strtoken 1 tok_primfloat }
- @signed @floating_point \# \# { init_strtoken 2 tok_primdouble }
+ @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
+ @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
}
-- Strings and chars are lexed by hand-written code. The reason is
( "where", ITwhere, 0 ),
( "_scc_", ITscc, 0 ), -- ToDo: remove
- ( "forall", ITforall, bit tvBit),
+ ( "forall", ITforall, bit explicitForallBit),
( "mdo", ITmdo, bit recursiveDoBit),
( "family", ITfamily, bit tyFamBit),
( "proc", ITproc, bit arrowsBit)
]
+reservedSymsFM :: UniqFM (Token, Int -> Bool)
reservedSymsFM = listToUFM $
- map (\ (x,y,z) -> (mkFastString x,(y,z)))
- [ ("..", ITdotdot, 0)
- ,(":", ITcolon, 0) -- (:) is a reserved op,
- -- meaning only list cons
- ,("::", ITdcolon, 0)
- ,("=", ITequal, 0)
- ,("\\", ITlam, 0)
- ,("|", ITvbar, 0)
- ,("<-", ITlarrow, 0)
- ,("->", ITrarrow, 0)
- ,("@", ITat, 0)
- ,("~", ITtilde, 0)
- ,("=>", ITdarrow, 0)
- ,("-", ITminus, 0)
- ,("!", ITbang, 0)
-
- ,("*", ITstar, bit glaExtsBit .|. bit kindSigsBit .|.
- bit tyFamBit) -- For data T (a::*) = MkT
- ,(".", ITdot, bit tvBit) -- For 'forall a . t'
-
- ,("-<", ITlarrowtail, bit arrowsBit)
- ,(">-", ITrarrowtail, bit arrowsBit)
- ,("-<<", ITLarrowtail, bit arrowsBit)
- ,(">>-", ITRarrowtail, bit arrowsBit)
+ map (\ (x,y,z) -> (mkFastString x,(y,z)))
+ [ ("..", ITdotdot, always)
+ -- (:) is a reserved op, meaning only list cons
+ ,(":", ITcolon, always)
+ ,("::", ITdcolon, always)
+ ,("=", ITequal, always)
+ ,("\\", ITlam, always)
+ ,("|", ITvbar, always)
+ ,("<-", ITlarrow, always)
+ ,("->", ITrarrow, always)
+ ,("@", ITat, always)
+ ,("~", ITtilde, always)
+ ,("=>", ITdarrow, always)
+ ,("-", ITminus, always)
+ ,("!", ITbang, always)
+
+ -- For data T (a::*) = MkT
+ ,("*", ITstar, \i -> glaExtsEnabled i ||
+ kindSigsEnabled i ||
+ tyFamEnabled i)
+ -- For 'forall a . t'
+ ,(".", ITdot, explicitForallEnabled)
+
+ ,("-<", ITlarrowtail, arrowsEnabled)
+ ,(">-", ITrarrowtail, arrowsEnabled)
+ ,("-<<", ITLarrowtail, arrowsEnabled)
+ ,(">>-", ITRarrowtail, arrowsEnabled)
#if __GLASGOW_HASKELL__ >= 605
- ,("∷", ITdcolon, bit glaExtsBit)
- ,("⇒", ITdarrow, bit glaExtsBit)
- ,("∀", ITforall, bit glaExtsBit)
- ,("→", ITrarrow, bit glaExtsBit)
- ,("←", ITlarrow, bit glaExtsBit)
- ,("⋯", ITdotdot, bit glaExtsBit)
+ ,("∷", ITdcolon, unicodeSyntaxEnabled)
+ ,("⇒", ITdarrow, unicodeSyntaxEnabled)
+ ,("∀", ITforall, \i -> unicodeSyntaxEnabled i &&
+ explicitForallEnabled i)
+ ,("→", ITrarrow, unicodeSyntaxEnabled)
+ ,("←", ITlarrow, unicodeSyntaxEnabled)
+ ,("⋯", ITdotdot, unicodeSyntaxEnabled)
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
-- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
sym con span buf len =
case lookupUFM reservedSymsFM fs of
- Just (keyword,0) -> return (L span keyword)
Just (keyword,exts) -> do
- b <- extension (\i -> exts .&. i /= 0)
+ b <- extension exts
if b then return (L span keyword)
else return (L span $! con fs)
_other -> return (L span $! con fs)
Just ('"',i) -> do
setInput i
- glaexts <- extension glaExtsEnabled
- if glaexts
+ magicHash <- extension magicHashEnabled
+ if magicHash
then do
i <- getInput
case alexGetChar' i of
finish_char_tok :: SrcLoc -> Char -> P (Located Token)
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
- = do glaexts <- extension glaExtsEnabled
+ = do magicHash <- extension magicHashEnabled
i@(AI end _ _) <- getInput
- if glaexts then do
+ if magicHash then do
case alexGetChar' i of
Just ('#',i@(AI end _ _)) -> do
setInput i
arrowsBit = 4
thBit = 5
ipBit = 6
-tvBit = 7 -- Scoped type variables enables 'forall' keyword
+explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs
magicHashBit = 11 -- # in both functions and operators
kindSigsBit = 12 -- Kind signatures on type variables
recursiveDoBit = 13 -- mdo
+unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
+unboxedTuplesBit = 15 -- (# and #)
+genericsBit = 16 -- {| and |}
glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
+always _ = True
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
+explicitForallEnabled flags = testBit flags explicitForallBit
bangPatEnabled flags = testBit flags bangPatBit
tyFamEnabled flags = testBit flags tyFamBit
haddockEnabled flags = testBit flags haddockBit
magicHashEnabled flags = testBit flags magicHashBit
kindSigsEnabled flags = testBit flags kindSigsBit
recursiveDoEnabled flags = testBit flags recursiveDoBit
+unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
+unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
+genericsEnabled flags = testBit flags genericsBit
-- PState for parsing options pragmas
--
.|. arrowsBit `setBitIf` dopt Opt_Arrows flags
.|. thBit `setBitIf` dopt Opt_TH flags
.|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
- .|. tvBit `setBitIf` dopt Opt_ScopedTypeVariables flags
+ .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
+ .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
+ .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
+ .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
+ .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes 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
.|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
+ .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
+ .|. genericsBit `setBitIf` dopt Opt_Generics flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b