X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=0a8c4104a76460aac29c54883cd53462a29445fc;hb=6517f499c5b7a7b9dd217e5394a159ba9df5dd8c;hp=11810a60601ce2b3fadc92709f5014d2a46a435a;hpb=c71662b207222b409ac678b5e6c55d0fec8df2b7;p=ghc-hetmet.git diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 11810a6..0a8c410 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -220,13 +220,14 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- 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) - - "{-#" $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) } @@ -308,9 +309,14 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } +<0,glaexts> { + "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol } + { token IToubxparen } + "#)" / { ifExtension unboxedTuplesEnabled } + { token ITcubxparen } +} + { - "(#" / { notFollowedBySymbol } { token IToubxparen } - "#)" { token ITcubxparen } "{|" { token ITocurlybar } "|}" { token ITccurlybar } } @@ -613,7 +619,7 @@ reservedWordsFM = listToUFM $ ( "where", ITwhere, 0 ), ( "_scc_", ITscc, 0 ), -- ToDo: remove - ( "forall", ITforall, bit tvBit), + ( "forall", ITforall, bit explicitForallBit), ( "mdo", ITmdo, bit recursiveDoBit), ( "family", ITfamily, bit tyFamBit), @@ -632,39 +638,44 @@ reservedWordsFM = listToUFM $ ( "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). @@ -943,9 +954,8 @@ consym = sym ITconsym 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) @@ -1512,7 +1522,7 @@ parrBit = 2 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 @@ -1520,21 +1530,26 @@ haddockBit = 10 -- Lex and parse Haddock comments 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 #) 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 -- PState for parsing options pragmas -- @@ -1582,13 +1597,19 @@ mkPState buf loc 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 + .|. 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 -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b