getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
- extension, standaloneDerivingEnabled, bangPatEnabled,
+ extension, bangPatEnabled,
addWarning,
lexTokenStream
) where
\$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
"$(" / { ifExtension thEnabled } { token ITparenEscape }
- "[$" @varid "|" / { ifExtension qqEnabled }
+ "[" @varid "|" / { ifExtension qqEnabled }
{ lex_quasiquote_tok }
}
explicitForallEnabled i)
,("→", ITrarrow, unicodeSyntaxEnabled)
,("←", ITlarrow, unicodeSyntaxEnabled)
- ,("⋯", ITdotdot, unicodeSyntaxEnabled)
,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
lex_quasiquote_tok :: Action
lex_quasiquote_tok span buf len = do
- let quoter = reverse $ takeWhile (/= '$')
- $ reverse $ lexemeToString buf (len - 1)
+ let quoter = tail (lexemeToString buf (len - 1))
+ -- 'tail' drops the initial '[',
+ -- while the -1 drops the trailing '|'
quoteStart <- getSrcLoc
quote <- lex_quasiquote ""
end <- getSrcLoc
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
-- us what sort of layout the '{' will open:
- alr_expecting_ocurly :: Maybe ALRLayout
+ 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
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
-- implement pushCurrentContext (which is only called from one place).
data ALRContext = ALRNoLayout Bool{- does it contain commas? -}
+ Bool{- is it a 'let' block? -}
| ALRLayout ALRLayout Int
data ALRLayout = ALRLayoutLet
| ALRLayoutWhere
setALRContext :: [ALRContext] -> P ()
setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
+getJustClosedExplicitLetBlock :: P Bool
+getJustClosedExplicitLetBlock
+ = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
+
+setJustClosedExplicitLetBlock :: Bool -> P ()
+setJustClosedExplicitLetBlock b
+ = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
+
setNextToken :: Located Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit :: Int
unboxedTuplesBit = 15 -- (# and #)
-standaloneDerivingBit :: Int
-standaloneDerivingBit = 16 -- standalone instance deriving declarations
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
qqEnabled :: Int -> Bool
qqEnabled flags = testBit flags qqBit
-- inRulePrag :: Int -> Bool
alr_next_token = Nothing,
alr_last_loc = noSrcSpan,
alr_context = [],
- alr_expecting_ocurly = Nothing
+ alr_expecting_ocurly = Nothing,
+ alr_justClosedExplicitLetBlock = False
}
-- 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,
alr_context = [],
- alr_expecting_ocurly = Nothing
+ alr_expecting_ocurly = Nothing,
+ alr_justClosedExplicitLetBlock = False
}
where
bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
.|. recBit `setBitIf` dopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
- .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
.|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags
ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo)
+ ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo)
+ ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo)
_ -> return ()
return t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
mExpectingOCurly <- getAlrExpectingOCurly
- let thisLoc = getLoc t
+ justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
+ setJustClosedExplicitLetBlock False
+ dflags <- getDynFlags
+ let transitional = dopt Opt_AlternativeLayoutRuleTransitional dflags
+ thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
newLine = (lastLoc == noSrcSpan)
|| (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
- (ITocurly, _, Just _) ->
+ (ITocurly, _, Just alrLayout) ->
do setAlrExpectingOCurly Nothing
- setALRContext (ALRNoLayout (containsCommas ITocurly) : context)
+ let isLet = case alrLayout of
+ ALRLayoutLet -> True
+ _ -> False
+ setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context)
return t
-- ...and makes this case unnecessary
{-
(ITeof, _, _) ->
return t
-- the other ITeof case omitted; general case below covers it
+ (ITin, _, _)
+ | justClosedExplicitLetBlock ->
+ return t
(ITin, ALRLayout ALRLayoutLet _ : ls, _)
| newLine ->
do setPendingImplicitTokens [t]
setALRContext ls
return (L thisLoc ITccurly)
+ -- This next case is to handle a transitional issue:
+ (ITwhere, ALRLayout _ col : ls, _)
+ | newLine && thisCol == col && transitional ->
+ do addWarning Opt_WarnAlternativeLayoutRuleTransitional
+ thisLoc
+ (transitionalAlternativeLayoutWarning
+ "`where' clause 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)
+ -- 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) : 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
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
- ALRNoLayout _ : ls ->
- do setALRContext ls
+ ALRNoLayout _ isLet : 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]
-- the other ITwhere case omitted; general case below covers it
(_, _, _) -> return t
+transitionalAlternativeLayoutWarning :: String -> SDoc
+transitionalAlternativeLayoutWarning msg
+ = text "transitional layout will not be accepted in the future:"
+ $$ text msg
+
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
topNoLayoutContainsCommas :: [ALRContext] -> Bool
topNoLayoutContainsCommas [] = False
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
-topNoLayoutContainsCommas (ALRNoLayout b : _) = b
+topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
lexToken :: P (Located Token)
lexToken = do
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
projects / ghc-hetmet.git / blobdiff