\$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
"$(" / { ifExtension thEnabled } { token ITparenEscape }
- "[$" @varid "|" / { ifExtension qqEnabled }
+ "[" @varid "|" / { ifExtension qqEnabled }
{ lex_quasiquote_tok }
}
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}) ()
alr_next_token = Nothing,
alr_last_loc = noSrcSpan,
alr_context = [],
- alr_expecting_ocurly = Nothing
+ alr_expecting_ocurly = Nothing,
+ alr_justClosedExplicitLetBlock = False
}
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
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
+ justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
+ setJustClosedExplicitLetBlock False
let thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
newLine = (lastLoc == noSrcSpan)
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]
return (L lastLoc ITccurly)
(u, _, _)
| isALRopen u ->
- do setALRContext (ALRNoLayout (containsCommas u) : context)
+ do setALRContext (ALRNoLayout (containsCommas u) False : context)
return t
(u, _, _)
| isALRclose u ->
do setALRContext ls
setNextToken t
return (L thisLoc ITccurly)
- ALRNoLayout _ : ls ->
+ ALRNoLayout _ isLet : ls ->
do setALRContext ls
+ when isLet $ setJustClosedExplicitLetBlock True
return t
[] ->
-- XXX This is an error in John's code, but
(_, _, _) -> return t
isALRopen :: Token -> Bool
-isALRopen ITcase = True
-isALRopen ITif = True
-isALRopen IToparen = True
-isALRopen ITobrack = True
-isALRopen ITocurly = True
+isALRopen ITcase = True
+isALRopen ITif = True
+isALRopen IToparen = True
+isALRopen ITobrack = True
+isALRopen ITocurly = True
-- GHC Extensions:
-isALRopen IToubxparen = True
-isALRopen _ = False
+isALRopen IToubxparen = True
+isALRopen ITparenEscape = True
+isALRopen _ = False
isALRclose :: Token -> Bool
isALRclose ITof = 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