getLexState, popLexState, pushLexState,
extension, bangPatEnabled, datatypeContextsEnabled,
addWarning,
+ incrBracketDepth, incrBracketDepth1, decrBracketDepth, getParserBrakDepth, pushBracketDepth, popBracketDepth,
lexTokenStream
) where
import Ctype
import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
import Util ( readRational )
+import HsSyn (CodeFlavor(..))
import Control.Monad
import Data.Bits
}
<0> {
+ "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
+ { special ITopenBrak }
+ "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak }
+ "<{" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
+ { special ITopenBrak1 }
+ "}>" / { ifExtension hetMetEnabled } { special ITcloseBrak1 }
+ "~~" / { ifExtension hetMetEnabled } { special ITescape }
+ "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent }
+ "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar }
+}
+
+<0> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
| ITvbar
| ITlarrow
| ITrarrow
+ | ITkappa
| ITat
| ITtilde
| ITdarrow
| ITLarrowtail -- -<<
| ITRarrowtail -- >>-
+ -- Heterogeneous Metaprogramming extension
+ | ITopenBrak -- <[
+ | ITcloseBrak -- ]>
+ | ITopenBrak1 -- <{
+ | ITcloseBrak1 -- }>
+ | ITescape -- ~~
+ | ITescapeDollar -- ~~$
+ | ITdoublePercent -- %%
+
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
,("|", ITvbar, always)
,("<-", ITlarrow, always)
,("->", ITrarrow, always)
+ ,("~~>", ITkappa, always)
,("@", ITat, always)
,("~", ITtilde, always)
,("=>", ITdarrow, always)
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 :: [CodeFlavor],
+ code_type_bracket_depth_stack :: [CodeFlavor]
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
+incrBracketDepth :: P ()
+incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = KappaFlavor:(code_type_bracket_depth s)}) ()
+incrBracketDepth1 :: P ()
+incrBracketDepth1 = P $ \s -> POk (s{code_type_bracket_depth = LambdaFlavor:(code_type_bracket_depth s)}) ()
+decrBracketDepth :: P ()
+decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s)}) ()
+pushBracketDepth :: P ()
+pushBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s),
+ code_type_bracket_depth_stack = (head (code_type_bracket_depth s)):(code_type_bracket_depth_stack s)
+ }) ()
+popBracketDepth :: P ()
+popBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (head (code_type_bracket_depth_stack s)):(code_type_bracket_depth s),
+ code_type_bracket_depth_stack = tail (code_type_bracket_depth_stack s)
+ }) ()
+getParserBrakDepth :: P [CodeFlavor]
+getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
+
getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
relaxedLayoutBit = 24
nondecreasingIndentationBit :: Int
nondecreasingIndentationBit = 25
+hetMetBit :: Int
+hetMetBit = 31
always :: Int -> Bool
always _ = True
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
alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
+ alr_justClosedExplicitLetBlock = False,
+ code_type_bracket_depth = [],
+ code_type_bracket_depth_stack = []
}
where
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