X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=4ca028281ee119bb6519cc5dc37b8d8e7a8883b3;hp=61019b321414e255ae33d77009ddd3d4cfe19cac;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=478e69b303eb2e653a2ebf5c888b5efdfef1fb9d diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 61019b3..4ca0282 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -55,6 +55,7 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, decrBracketDepth, getParserBrakDepth, lexTokenStream ) where @@ -68,7 +69,7 @@ import UniqFM import DynFlags import Module import Ctype -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) import Util ( readRational ) import Control.Monad @@ -325,6 +326,15 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } } <0> { + "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak } + "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak } + "~~" / { ifExtension hetMetEnabled } { special ITescape } + "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent } + "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar } +} + +<0> { \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } @@ -335,11 +345,6 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } { token ITcubxparen } } -<0> { - "{|" / { ifExtension genericsEnabled } { token ITocurlybar } - "|}" / { ifExtension genericsEnabled } { token ITccurlybar } -} - <0,option_prags> { \( { special IToparen } \) { special ITcparen } @@ -541,14 +546,14 @@ data Token | ITchar Char | ITstring FastString | ITinteger Integer - | ITrational Rational + | ITrational FractionalLit | ITprimchar Char | ITprimstring FastString | ITprimint Integer | ITprimword Integer - | ITprimfloat Rational - | ITprimdouble Rational + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit -- Template Haskell extension tokens | ITopenExpQuote -- [| or [e| @@ -572,6 +577,13 @@ data Token | ITLarrowtail -- -<< | ITRarrowtail -- >>- + -- Heterogeneous Metaprogramming extension + | ITopenBrak -- <[ + | ITcloseBrak -- ]> + | ITescape -- ~~ + | ITescapeDollar -- ~~$ + | ITdoublePercent -- %% + | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@ -1061,9 +1073,12 @@ hexadecimal = (16,hexDigit) -- readRational can understand negative rationals, exponents, everything. tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readRational str -tok_primfloat str = ITprimfloat $! readRational str -tok_primdouble str = ITprimdouble $! readRational str +tok_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str -- ----------------------------------------------------------------------------- -- Layout processing @@ -1525,7 +1540,8 @@ data PState = PState { alr_expecting_ocurly :: Maybe ALRLayout, -- Have we just had the '}' for a let block? If so, than an 'in' -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool + alr_justClosedExplicitLetBlock :: Bool, + code_type_bracket_depth :: Int } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1592,6 +1608,13 @@ setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () setSrcLoc :: SrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () +incrBracketDepth :: P () +incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) () +decrBracketDepth :: P () +decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) () +getParserBrakDepth :: P Int +getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s) + getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc @@ -1751,8 +1774,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed -- integer -genericsBit :: Int -genericsBit = 0 -- {| and |} +-- The "genericsBit" is now unused, available for others +-- genericsBit :: Int +-- genericsBit = 0 -- {|, |} and "generic" + ffiBit :: Int ffiBit = 1 parrBit :: Int @@ -1800,15 +1825,17 @@ relaxedLayoutBit :: Int relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True -genericsEnabled :: Int -> Bool -genericsEnabled flags = testBit flags genericsBit parrEnabled :: Int -> Bool parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool arrowsEnabled flags = testBit flags arrowsBit +hetMetEnabled :: Int -> Bool +hetMetEnabled flags = testBit flags hetMetBit thEnabled :: Int -> Bool thEnabled flags = testBit flags thBit ipEnabled :: Int -> Bool @@ -1856,7 +1883,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) { mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, last_loc = mkSrcSpan loc loc, @@ -1870,38 +1897,39 @@ mkPState flags buf loc = alr_last_loc = noSrcSpan, alr_context = [], alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False + alr_justClosedExplicitLetBlock = False, + code_type_bracket_depth = 0 } where - bitmap = genericsBit `setBitIf` xopt Opt_Generics flags - .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags + .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 addWarning :: DynFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning