+lexTokenAlr :: P (Located Token)
+lexTokenAlr = do mPending <- popPendingImplicitToken
+ t <- case mPending of
+ Nothing ->
+ do mNext <- popNextToken
+ t <- case mNext of
+ Nothing -> lexToken
+ Just next -> return next
+ alternativeLayoutRuleToken t
+ Just t ->
+ return t
+ setAlrLastLoc (getLoc t)
+ case unLoc t of
+ ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
+ ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
+ ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
+ ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo)
+ _ -> return ()
+ return t
+
+alternativeLayoutRuleToken :: Located Token -> P (Located Token)
+alternativeLayoutRuleToken t
+ = do context <- getALRContext
+ lastLoc <- getAlrLastLoc
+ mExpectingOCurly <- getAlrExpectingOCurly
+ let 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 _) ->
+ do setAlrExpectingOCurly Nothing
+ setALRContext (ALRNoLayout (containsCommas ITocurly) : context)
+ return t
+ -- ...and makes this case unnecessary
+ {-
+ -- I think our implicit open-curly handling is slightly
+ -- different to John's, in how it interacts with newlines
+ -- and "in"
+ (ITocurly, _, Just _) ->
+ do setAlrExpectingOCurly Nothing
+ setNextToken t
+ lexTokenAlr
+ -}
+ (_, ALRLayout _ col : ls, Just expectingOCurly)
+ | (thisCol > col) ||
+ (thisCol == col &&
+ isNonDecreasingIntentation expectingOCurly) ->
+ do setAlrExpectingOCurly Nothing
+ setALRContext (ALRLayout expectingOCurly thisCol : context)
+ setNextToken t
+ return (L thisLoc ITocurly)
+ | otherwise ->
+ do setAlrExpectingOCurly Nothing
+ setPendingImplicitTokens [L lastLoc ITccurly]
+ setNextToken t
+ return (L lastLoc ITocurly)
+ (_, _, Just expectingOCurly) ->
+ do setAlrExpectingOCurly Nothing
+ setALRContext (ALRLayout expectingOCurly thisCol : context)
+ setNextToken t
+ return (L thisLoc ITocurly)
+ -- We do the [] cases earlier than in the spec, as we
+ -- have an actual EOF token
+ (ITeof, ALRLayout _ _ : ls, _) ->
+ do setALRContext ls
+ setNextToken t
+ return (L thisLoc ITccurly)
+ (ITeof, _, _) ->
+ return t
+ -- the other ITeof case omitted; general case below covers it
+ (ITin, ALRLayout ALRLayoutLet _ : ls, _)
+ | newLine ->
+ do setPendingImplicitTokens [t]
+ setALRContext ls
+ return (L thisLoc ITccurly)
+ (_, ALRLayout _ col : ls, _)
+ | newLine && thisCol == col ->
+ do setNextToken t
+ return (L thisLoc ITsemi)
+ | newLine && thisCol < col ->
+ do 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)
+ (u, _, _)
+ | isALRopen u ->
+ do setALRContext (ALRNoLayout (containsCommas u) : context)
+ return t
+ (u, _, _)
+ | isALRclose u ->
+ case context of
+ ALRLayout _ _ : ls ->
+ do setALRContext ls
+ setNextToken t
+ return (L thisLoc ITccurly)
+ ALRNoLayout _ : ls ->
+ do setALRContext ls
+ return t
+ [] ->
+ -- XXX This is an error in John's code, but
+ -- it looks reachable to me at first glance
+ return t
+ (ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
+ do setALRContext ls
+ setPendingImplicitTokens [t]
+ return (L thisLoc ITccurly)
+ (ITin, ALRLayout _ _ : ls, _) ->
+ do setALRContext ls
+ setNextToken t
+ return (L thisLoc ITccurly)
+ -- the other ITin case omitted; general case below covers it
+ (ITcomma, ALRLayout _ _ : ls, _)
+ | topNoLayoutContainsCommas ls ->
+ do setALRContext ls
+ setNextToken t
+ return (L thisLoc ITccurly)
+ (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
+ do setALRContext ls
+ setPendingImplicitTokens [t]
+ return (L thisLoc ITccurly)
+ -- the other ITwhere case omitted; general case below covers it
+ (_, _, _) -> return t
+
+isALRopen :: Token -> Bool
+isALRopen ITcase = True
+isALRopen ITif = True
+isALRopen IToparen = True
+isALRopen ITobrack = True
+isALRopen ITocurly = True
+-- GHC Extensions:
+isALRopen IToubxparen = True
+isALRopen _ = False
+
+isALRclose :: Token -> Bool
+isALRclose ITof = True
+isALRclose ITthen = True
+isALRclose ITcparen = True
+isALRclose ITcbrack = True
+isALRclose ITccurly = True
+-- GHC Extensions:
+isALRclose ITcubxparen = True
+isALRclose _ = False
+
+isNonDecreasingIntentation :: ALRLayout -> Bool
+isNonDecreasingIntentation ALRLayoutDo = True
+isNonDecreasingIntentation _ = False
+
+containsCommas :: Token -> Bool
+containsCommas IToparen = True
+containsCommas ITobrack = True
+-- John doesn't have {} as containing commas, but records contain them,
+-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs
+-- (defaultInstallDirs).
+containsCommas ITocurly = True
+-- GHC Extensions:
+containsCommas IToubxparen = True
+containsCommas _ = False
+
+topNoLayoutContainsCommas :: [ALRContext] -> Bool
+topNoLayoutContainsCommas [] = False
+topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
+topNoLayoutContainsCommas (ALRNoLayout b : _) = b
+