getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
- extension, standaloneDerivingEnabled, bangPatEnabled,
+ extension, bangPatEnabled, datatypeContextsEnabled,
addWarning,
lexTokenStream
) where
-- Haddock comments
-<0> {
+<0,option_prags> {
"-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
}
explicitForallEnabled i)
,("→", ITrarrow, unicodeSyntaxEnabled)
,("←", ITlarrow, unicodeSyntaxEnabled)
- ,("⋯", ITdotdot, unicodeSyntaxEnabled)
,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
where read i input = do
case alexGetChar' input of
Just (c,input') | is_digit c -> do
- read (i*base + conv c) input'
+ let i' = i*base + conv c
+ if i' > 0x10ffff
+ then setInput input >> lexError "numeric escape sequence out of range"
+ else read i' input'
_other -> do
- if i >= 0 && i <= 0x10FFFF
- then do setInput input; return (chr i)
- else lit_error input
+ setInput input; return (chr i)
+
silly_escape_chars :: [(String, Char)]
silly_escape_chars = [
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit :: Int
unboxedTuplesBit = 15 -- (# and #)
-standaloneDerivingBit :: Int
-standaloneDerivingBit = 16 -- standalone instance deriving declarations
+datatypeContextsBit :: Int
+datatypeContextsBit = 16
transformComprehensionsBit :: Int
transformComprehensionsBit = 17
qqBit :: Int
unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
unboxedTuplesEnabled :: Int -> Bool
unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
-standaloneDerivingEnabled :: Int -> Bool
-standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
+datatypeContextsEnabled :: Int -> Bool
+datatypeContextsEnabled flags = testBit flags datatypeContextsBit
qqEnabled :: Int -> Bool
qqEnabled flags = testBit flags qqBit
-- inRulePrag :: Int -> Bool
-- PState for parsing options pragmas
--
pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
-pragState dynflags buf loc =
- PState {
- buffer = buf,
- messages = emptyMessages,
- dflags = dynflags,
- last_loc = mkSrcSpan loc loc,
- last_len = 0,
- loc = loc,
- extsBitmap = 0,
- context = [],
- lex_state = [bol, option_prags, 0],
- alr_pending_implicit_tokens = [],
- alr_next_token = Nothing,
- alr_last_loc = noSrcSpan,
- alr_context = [],
- alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
- }
-
+pragState dynflags buf loc = (mkPState dynflags buf loc) {
+ lex_state = [bol, option_prags, 0]
+ }
-- create a parse state
--
-mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
-mkPState buf loc flags =
+mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
extsBitmap = fromIntegral bitmap,
context = [],
lex_state = [bol, 0],
- -- we begin in the layout state if toplev_layout is set
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
alr_last_loc = noSrcSpan,
.|. recBit `setBitIf` dopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
- .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
+ .|. datatypeContextsBit `setBitIf` dopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags
lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
- where initState = mkPState buf loc (dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream)
+ where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
+ initState = mkPState dflags' buf loc
go = do
ltok <- lexer return
case ltok of