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)
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
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
+ -- This next case is to handle a transitional issue:
+ (ITvbar, ALRLayout _ col : ls, _)
+ | newLine && thisCol == col && transitional ->
+ do addWarning Opt_WarnAlternativeLayoutRuleTransitional
+ thisLoc
+ (transitionalAlternativeLayoutWarning
+ "`|' at the same depth as implicit layout block")
+ setALRContext ls
+ setNextToken t
+ -- Note that we use lastLoc, as we may need to close
+ -- more layouts, or give a semicolon
+ return (L lastLoc ITccurly)
(_, ALRLayout _ col : ls, _)
| newLine && thisCol == col ->
do setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
return (L lastLoc ITccurly)
- (u, _, _)
- | isALRopen u ->
- do setALRContext (ALRNoLayout (containsCommas u) False : context)
- return t
+ -- We need to handle close before open, as 'then' is both
+ -- an open and a close
(u, _, _)
| isALRclose u ->
case context of
setNextToken t
return (L thisLoc ITccurly)
ALRNoLayout _ isLet : ls ->
- do setALRContext ls
+ do let ls' = if isALRopen u
+ then ALRNoLayout (containsCommas u) False : ls
+ else ls
+ setALRContext ls'
when isLet $ setJustClosedExplicitLetBlock True
return t
[] ->
- -- XXX This is an error in John's code, but
- -- it looks reachable to me at first glance
- return t
+ do let ls = if isALRopen u
+ then [ALRNoLayout (containsCommas u) False]
+ else ls
+ setALRContext ls
+ -- XXX This is an error in John's code, but
+ -- it looks reachable to me at first glance
+ return t
+ (u, _, _)
+ | isALRopen u ->
+ do setALRContext (ALRNoLayout (containsCommas u) False : context)
+ return t
(ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
do setALRContext ls
setPendingImplicitTokens [t]
isALRopen :: Token -> Bool
isALRopen ITcase = True
isALRopen ITif = True
+isALRopen ITthen = True
isALRopen IToparen = True
isALRopen ITobrack = True
isALRopen ITocurly = True
isALRclose :: Token -> Bool
isALRclose ITof = True
isALRclose ITthen = True
+isALRclose ITelse = True
isALRclose ITcparen = True
isALRclose ITcbrack = True
isALRclose ITccurly = True
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