summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/Lexer.x223
-rw-r--r--compiler/parser/Parser.y4
-rw-r--r--compiler/parser/RdrHsSyn.hs2
3 files changed, 120 insertions, 109 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 050a49c8c6..5fa0af85ad 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -822,11 +822,11 @@ data Token
| ITdollar -- prefix $
| ITdollardollar -- prefix $$
| ITtyQuote -- ''
- | ITquasiQuote (FastString,FastString,RealSrcSpan)
+ | ITquasiQuote (FastString,FastString,PsSpan)
-- ITquasiQuote(quoter, quote, loc)
-- represents a quasi-quote of the form
-- [quoter| quote |]
- | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan)
+ | ITqQuasiQuote (FastString,FastString,FastString,PsSpan)
-- ITqQuasiQuote(Qual, quoter, quote, loc)
-- represents a qualified quasi-quote of the form
-- [Qual.quoter| quote |]
@@ -995,7 +995,7 @@ reservedSymsFM = listToUFM $
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
+type Action = PsSpan -> StringBuffer -> Int -> P (PsLocated Token)
special :: Token -> Action
special tok span _buf _len = return (L span tok)
@@ -1045,13 +1045,13 @@ hopefully_open_brace span buf len
= do relaxed <- getBit RelaxedLayoutBit
ctx <- getContext
(AI l _) <- getInput
- let offset = srcLocCol l
+ let offset = srcLocCol (psRealLoc l)
isOK = relaxed ||
case ctx of
Layout prev_off _ : _ -> prev_off < offset
_ -> True
if isOK then pop_and open_brace span buf len
- else addFatalError (RealSrcSpan span) (text "Missing block")
+ else addFatalError (mkSrcSpanPs span) (text "Missing block")
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
@@ -1186,7 +1186,7 @@ lineCommentToken span buf len = do
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
-nested_comment :: P (RealLocated Token) -> Action
+nested_comment :: P (PsLocated Token) -> Action
nested_comment cont span buf len = do
input <- getInput
go (reverse $ lexemeToString buf len) (1::Int) input
@@ -1198,18 +1198,18 @@ nested_comment cont span buf len = do
then docCommentEnd input commentAcc ITblockComment buf span
else cont
go commentAcc n input = case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('-',input) -> case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}'
Just (_,_) -> go ('-':commentAcc) n input
Just ('\123',input) -> case alexGetChar' input of -- '{' char
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
Just (_,_) -> go ('\123':commentAcc) n input
-- See Note [Nested comment line pragmas]
Just ('\n',input) -> case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
go (parsedAcc ++ '\n':commentAcc) n input
Just (_,_) -> go ('\n':commentAcc) n input
@@ -1219,14 +1219,14 @@ nested_doc_comment :: Action
nested_doc_comment span buf _len = withLexedDocType (go "")
where
go commentAcc input docType _ = case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('-',input) -> case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('\125',input) ->
docCommentEnd input commentAcc docType buf span
Just (_,_) -> go ('-':commentAcc) input docType False
Just ('\123', input) -> case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('-',input) -> do
setInput input
let cont = do input <- getInput; go commentAcc input docType False
@@ -1234,7 +1234,7 @@ nested_doc_comment span buf _len = withLexedDocType (go "")
Just (_,_) -> go ('\123':commentAcc) input docType False
-- See Note [Nested comment line pragmas]
Just ('\n',input) -> case alexGetChar' input of
- Nothing -> errBrace input span
+ Nothing -> errBrace input (psRealSpan span)
Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
go (parsedAcc ++ '\n':commentAcc) input docType False
Just (_,_) -> go ('\n':commentAcc) input docType False
@@ -1252,7 +1252,7 @@ parseNestedPragma input@(AI _ buf) = do
setExts (.&. complement (xbit InNestedCommentBit))
postInput@(AI _ postBuf) <- getInput
setInput origInput
- case unRealSrcSpan lt of
+ case unLoc lt of
ITcomment_line_prag -> do
let bytes = byteDiff buf postBuf
diff = lexemeToString buf bytes
@@ -1286,8 +1286,8 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token.
See #314 for more background on the bug this fixes.
-}
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
- -> P (RealLocated Token)
+withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (PsLocated Token))
+ -> P (PsLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
@@ -1347,19 +1347,19 @@ endPrag span _buf _len = do
-- called afterwards, so it can just update the state.
docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
- RealSrcSpan -> P (RealLocated Token)
+ PsSpan -> P (PsLocated Token)
docCommentEnd input commentAcc docType buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
- span' = mkRealSrcSpan (realSrcSpanStart span) loc
+ span' = mkPsSpan (psSpanStart span) loc
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
return (L span' (docType comment))
errBrace :: AlexInput -> RealSrcSpan -> P a
-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'"
open_brace, close_brace :: Action
open_brace span _str _len = do
@@ -1414,7 +1414,7 @@ varid span buf len =
lambdaCase <- getBit LambdaCaseBit
unless lambdaCase $ do
pState <- getPState
- addError (RealSrcSpan (last_loc pState)) $ text
+ addError (mkSrcSpanPs (last_loc pState)) $ text
"Illegal lambda-case (use LambdaCase)"
return ITlcase
_ -> return ITcase
@@ -1513,7 +1513,7 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
let src = lexemeToString buf len
when ((not numericUnderscores) && ('_' `elem` src)) $ do
pState <- getPState
- addError (RealSrcSpan (last_loc pState)) $ text
+ addError (mkSrcSpanPs (last_loc pState)) $ text
"Use NumericUnderscores to allow underscores in integer literals"
return $ L span $ itint (SourceText src)
$! transint $ parseUnsignedInteger
@@ -1555,7 +1555,7 @@ tok_frac drop f span buf len = do
let src = lexemeToString buf (len-drop)
when ((not numericUnderscores) && ('_' `elem` src)) $ do
pState <- getPState
- addError (RealSrcSpan (last_loc pState)) $ text
+ addError (mkSrcSpanPs (last_loc pState)) $ text
"Use NumericUnderscores to allow underscores in floating literals"
return (L span $! (f $! src))
@@ -1636,7 +1636,7 @@ new_layout_context :: Bool -> Bool -> Token -> Action
new_layout_context strict gen_semic tok span _buf len = do
_ <- popLexState
(AI l _) <- getInput
- let offset = srcLocCol l - len
+ let offset = srcLocCol (psRealLoc l) - len
ctx <- getContext
nondecreasing <- getBit NondecreasingIndentationBit
let strict' = strict || not nondecreasing
@@ -1661,7 +1661,7 @@ do_layout_left span _buf _len = do
-- LINE pragmas
setLineAndFile :: Int -> Action
-setLineAndFile code span buf len = do
+setLineAndFile code (PsSpan span _) buf len = do
let src = lexemeToString buf (len - 1) -- drop trailing quotation mark
linenumLen = length $ head $ words src
linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit
@@ -1679,7 +1679,7 @@ setLineAndFile code span buf len = do
-- System.FilePath.normalise before printing out
-- filenames and it does not remove duplicate
-- backslashes after the drive letter (should it?).
- setAlrLastLoc $ alrInitialLoc file
+ resetAlrLastLoc file
setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))
-- subtract one: the line number refers to the *following* line
addSrcFile file
@@ -1688,7 +1688,7 @@ setLineAndFile code span buf len = do
lexToken
setColumn :: Action
-setColumn span buf len = do
+setColumn (PsSpan span _) buf len = do
let column =
case reads (lexemeToString buf len) of
[(column, _)] -> column
@@ -1710,10 +1710,10 @@ alrInitialLoc file = mkRealSrcSpan loc loc
lex_string_prag :: (String -> Token) -> Action
lex_string_prag mkTok span _buf _len
= do input <- getInput
- start <- getRealSrcLoc
+ start <- getParsedLoc
tok <- go [] input
- end <- getRealSrcLoc
- return (L (mkRealSrcSpan start end) tok)
+ end <- getParsedLoc
+ return (L (mkPsSpan start end) tok)
where go acc input
= if isString input "#-}"
then do setInput input
@@ -1726,7 +1726,7 @@ lex_string_prag mkTok span _buf _len
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
_other -> False
- err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
+ err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) "unterminated options pragma"
-- -----------------------------------------------------------------------------
@@ -1744,7 +1744,7 @@ lex_string_tok span buf _len = do
ITstring _ s -> ITstring (SourceText src) s
_ -> panic "lex_string_tok"
src = lexemeToString buf (cur bufEnd - cur buf)
- return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')
+ return (L (mkPsSpan (psSpanStart span) end) tok')
lex_string :: String -> P Token
lex_string s = do
@@ -1764,7 +1764,7 @@ lex_string s = do
setInput i
when (any (> '\xFF') s') $ do
pState <- getPState
- addError (RealSrcSpan (last_loc pState)) $ text
+ addError (mkSrcSpanPs (last_loc pState)) $ text
"primitive string literal must contain only characters <= \'\\xFF\'"
return (ITprimstring (SourceText s') (unsafeMkByteString s'))
_other ->
@@ -1806,13 +1806,13 @@ lex_char_tok :: Action
-- see if there's a trailing quote
lex_char_tok span buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
- let loc = realSrcSpanStart span
+ let loc = psSpanStart span
case alexGetChar' i1 of
Nothing -> lit_error i1
Just ('\'', i2@(AI end2 _)) -> do -- We've seen ''
setInput i2
- return (L (mkRealSrcSpan loc end2) ITtyQuote)
+ return (L (mkPsSpan loc end2) ITtyQuote)
Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash
setInput i2
@@ -1836,9 +1836,9 @@ lex_char_tok span buf _len = do -- We've seen '
-- (including the possibility of EOF)
-- Just parse the quote only
let (AI end _) = i1
- return (L (mkRealSrcSpan loc end) ITsimpleQuote)
+ return (L (mkPsSpan loc end) ITsimpleQuote)
-finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)
+finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token)
finish_char_tok buf loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- getBit MagicHashBit
@@ -1848,13 +1848,13 @@ finish_char_tok buf loc ch -- We've already seen the closing quote
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
- return (L (mkRealSrcSpan loc end)
+ return (L (mkPsSpan loc end)
(ITprimchar (SourceText src) ch))
_other ->
- return (L (mkRealSrcSpan loc end)
+ return (L (mkPsSpan loc end)
(ITchar (SourceText src) ch))
else do
- return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch))
+ return (L (mkPsSpan loc end) (ITchar (SourceText src) ch))
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
@@ -1984,27 +1984,27 @@ getCharOrFail i = do
lex_qquasiquote_tok :: Action
lex_qquasiquote_tok span buf len = do
let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
- quoteStart <- getRealSrcLoc
- quote <- lex_quasiquote quoteStart ""
- end <- getRealSrcLoc
- return (L (mkRealSrcSpan (realSrcSpanStart span) end)
+ quoteStart <- getParsedLoc
+ quote <- lex_quasiquote (psRealLoc quoteStart) ""
+ end <- getParsedLoc
+ return (L (mkPsSpan (psSpanStart span) end)
(ITqQuasiQuote (qual,
quoter,
mkFastString (reverse quote),
- mkRealSrcSpan quoteStart end)))
+ mkPsSpan quoteStart end)))
lex_quasiquote_tok :: Action
lex_quasiquote_tok span buf len = do
let quoter = tail (lexemeToString buf (len - 1))
-- 'tail' drops the initial '[',
-- while the -1 drops the trailing '|'
- quoteStart <- getRealSrcLoc
- quote <- lex_quasiquote quoteStart ""
- end <- getRealSrcLoc
- return (L (mkRealSrcSpan (realSrcSpanStart span) end)
+ quoteStart <- getParsedLoc
+ quote <- lex_quasiquote (psRealLoc quoteStart) ""
+ end <- getParsedLoc
+ return (L (mkPsSpan (psSpanStart span) end)
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
- mkRealSrcSpan quoteStart end)))
+ mkPsSpan quoteStart end)))
lex_quasiquote :: RealSrcLoc -> String -> P String
lex_quasiquote start s = do
@@ -2026,19 +2026,19 @@ lex_quasiquote start s = do
quasiquote_error :: RealSrcLoc -> P a
quasiquote_error start = do
(AI end buf) <- getInput
- reportLexError start end buf "unterminated quasiquotation"
+ reportLexError start (psRealLoc end) buf "unterminated quasiquotation"
-- -----------------------------------------------------------------------------
-- Warnings
warnTab :: Action
warnTab srcspan _buf _len = do
- addTabWarning srcspan
+ addTabWarning (psRealSpan srcspan)
lexToken
warnThen :: WarningFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do
- addWarning option (RealSrcSpan srcspan) warning
+ addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning
action srcspan buf len
-- -----------------------------------------------------------------------------
@@ -2093,22 +2093,22 @@ data PState = PState {
tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file
tab_count :: !Int, -- number of tab warnings in the file
last_tk :: Maybe Token,
- last_loc :: RealSrcSpan, -- pos of previous token
+ last_loc :: PsSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
- loc :: RealSrcLoc, -- current loc (end of prev token + 1)
+ loc :: PsLoc, -- current loc (end of prev token + 1)
context :: [LayoutContext],
lex_state :: [Int],
srcfiles :: [FastString],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
- alr_pending_implicit_tokens :: [RealLocated Token],
+ alr_pending_implicit_tokens :: [PsLocated Token],
-- This is the next token to be considered or, if it is Nothing,
-- we need to get the next token from the input stream:
- alr_next_token :: Maybe (RealLocated Token),
+ alr_next_token :: Maybe (PsLocated Token),
-- This is what we consider to be the location of the last token
-- emitted:
- alr_last_loc :: RealSrcSpan,
+ alr_last_loc :: PsSpan,
-- The stack of layout contexts:
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
@@ -2166,11 +2166,11 @@ thenP :: P a -> (a -> P b) -> P b
failMsgP :: String -> P a
failMsgP msg = do
pState <- getPState
- addFatalError (RealSrcSpan (last_loc pState)) (text msg)
+ addFatalError (mkSrcSpanPs (last_loc pState)) (text msg)
failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
failLocMsgP loc1 loc2 str =
- addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
+ addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str)
getPState :: P PState
getPState = P $ \s -> POk s s
@@ -2189,10 +2189,15 @@ setExts f = P $ \s -> POk s {
} ()
setSrcLoc :: RealSrcLoc -> P ()
-setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
+setSrcLoc new_loc =
+ P $ \s@(PState{ loc = PsLoc _ buf_loc }) ->
+ POk s{ loc = PsLoc new_loc buf_loc } ()
getRealSrcLoc :: P RealSrcLoc
-getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
+getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc)
+
+getParsedLoc :: P PsLoc
+getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
addSrcFile :: FastString -> P ()
addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
@@ -2200,7 +2205,7 @@ addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
setEofPos :: RealSrcSpan -> P ()
setEofPos span = P $ \s -> POk s{ eof_pos = Just span } ()
-setLastToken :: RealSrcSpan -> Int -> P ()
+setLastToken :: PsSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
last_len=len
@@ -2212,7 +2217,7 @@ setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
getLastTk :: P (Maybe Token)
getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
-data AlexInput = AI RealSrcLoc StringBuffer
+data AlexInput = AI PsLoc StringBuffer
{-
Note [Unicode in Alex]
@@ -2305,7 +2310,7 @@ alexGetByte (AI loc s)
--trace (show (ord c)) $
Just (byte, (AI loc' s'))
where (c,s') = nextChar s
- loc' = advanceSrcLoc loc c
+ loc' = advancePsLoc loc c
byte = adjustChar c
-- This version does not squash unicode characters, it is used when
@@ -2317,7 +2322,7 @@ alexGetChar' (AI loc s)
--trace (show (ord c)) $
Just (c, (AI loc' s'))
where (c,s') = nextChar s
- loc' = advanceSrcLoc loc c
+ loc' = advancePsLoc loc c
getInput :: P AlexInput
getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
@@ -2339,7 +2344,7 @@ popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
getLexState :: P Int
getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
-popNextToken :: P (Maybe (RealLocated Token))
+popNextToken :: P (Maybe (PsLocated Token))
popNextToken
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
@@ -2353,10 +2358,15 @@ activeContext = do
([],Nothing) -> return impt
_other -> return True
-setAlrLastLoc :: RealSrcSpan -> P ()
+resetAlrLastLoc :: FastString -> P ()
+resetAlrLastLoc file =
+ P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) ->
+ POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } ()
+
+setAlrLastLoc :: PsSpan -> P ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
-getAlrLastLoc :: P RealSrcSpan
+getAlrLastLoc :: P PsSpan
getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
getALRContext :: P [ALRContext]
@@ -2373,7 +2383,7 @@ setJustClosedExplicitLetBlock :: Bool -> P ()
setJustClosedExplicitLetBlock b
= P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
-setNextToken :: RealLocated Token -> P ()
+setNextToken :: PsLocated Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
implicitTokenPending :: P Bool
@@ -2383,14 +2393,14 @@ implicitTokenPending
[] -> POk s False
_ -> POk s True
-popPendingImplicitToken :: P (Maybe (RealLocated Token))
+popPendingImplicitToken :: P (Maybe (PsLocated Token))
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
case ts of
[] -> POk s Nothing
(t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
-setPendingImplicitTokens :: [RealLocated Token] -> P ()
+setPendingImplicitTokens :: [PsLocated Token] -> P ()
setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
getAlrExpectingOCurly :: P (Maybe ALRLayout)
@@ -2582,15 +2592,15 @@ mkPStatePure options buf loc =
tab_first = Nothing,
tab_count = 0,
last_tk = Nothing,
- last_loc = mkRealSrcSpan loc loc,
+ last_loc = mkPsSpan init_loc init_loc,
last_len = 0,
- loc = loc,
+ loc = init_loc,
context = [],
lex_state = [bol, 0],
srcfiles = [],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
- alr_last_loc = alrInitialLoc (fsLit "<no file>"),
+ alr_last_loc = PsSpan (alrInitialLoc (fsLit "<no file>")) (BufSpan (BufPos 0) (BufPos 0)),
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
@@ -2599,6 +2609,7 @@ mkPStatePure options buf loc =
comment_q = [],
annotations_comments = []
}
+ where init_loc = PsLoc loc (BufPos 0)
-- | An mtl-style class for monads that support parsing-related operations.
-- For example, sometimes we make a second pass over the parsing results to validate,
@@ -2675,7 +2686,7 @@ instance MonadP P where
addError span msg >> P PFailed
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
in b `seq` POk s b
- addAnnotation (RealSrcSpan l) a (RealSrcSpan v) = do
+ addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do
addAnnotationOnly l a v
allocateCommentsP l
addAnnotation _ _ _ = return ()
@@ -2703,7 +2714,7 @@ mkTabWarning PState{tab_first=tf, tab_count=tc} d =
<> text "."
$+$ text "Please use spaces instead."
in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $
- mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf
+ mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf
-- | Get a bag of the errors that have been accumulated so far.
-- Does not take -Werror into account.
@@ -2733,12 +2744,12 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
(_:tl) ->
POk s{ context = tl } ()
[] ->
- unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
+ unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s
-- Push a new layout context at the indentation of the last token read.
pushCurrentContext :: GenSemic -> P ()
pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } ->
- POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} ()
+ POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} ()
-- This is only used at the outer level of a module when the 'module' keyword is
-- missing.
@@ -2747,7 +2758,7 @@ pushModuleContext = pushCurrentContext generateSemic
getOffside :: P (Ordering, Bool)
getOffside = P $ \s@PState{last_loc=loc, context=stk} ->
- let offs = srcSpanStartCol loc in
+ let offs = srcSpanStartCol (psRealSpan loc) in
let ord = case stk of
Layout n gen_semic : _ ->
--trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $
@@ -2793,7 +2804,7 @@ srcParseErr options buf len
srcParseFail :: P a
srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,
last_loc = last_loc } ->
- unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s
+ unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
@@ -2801,7 +2812,7 @@ lexError :: String -> P a
lexError str = do
loc <- getRealSrcLoc
(AI end buf) <- getInput
- reportLexError loc end buf str
+ reportLexError loc (psRealLoc end) buf str
-- -----------------------------------------------------------------------------
-- This is the top-level function: called from the parser each time a
@@ -2816,19 +2827,19 @@ lexer queueComments cont = do
--trace ("token: " ++ show tok) $ do
if (queueComments && isDocComment tok)
- then queueComment (L span tok)
+ then queueComment (L (psRealSpan span) tok)
else return ()
if (queueComments && isComment tok)
- then queueComment (L span tok) >> lexer queueComments cont
- else cont (L (RealSrcSpan span) tok)
+ then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont
+ else cont (L (mkSrcSpanPs span) tok)
-- Use this instead of 'lexer' in Parser.y to dump the tokens for debugging.
lexerDbg queueComments cont = lexer queueComments contDbg
where
contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok)
-lexTokenAlr :: P (RealLocated Token)
+lexTokenAlr :: P (PsLocated Token)
lexTokenAlr = do mPending <- popPendingImplicitToken
t <- case mPending of
Nothing ->
@@ -2839,8 +2850,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
alternativeLayoutRuleToken t
Just t ->
return t
- setAlrLastLoc (getRealSrcSpan t)
- case unRealSrcSpan t of
+ setAlrLastLoc (getLoc t)
+ case unLoc t of
ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
@@ -2851,7 +2862,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
_ -> return ()
return t
-alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
+alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)
alternativeLayoutRuleToken t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
@@ -2859,10 +2870,10 @@ alternativeLayoutRuleToken t
transitional <- getBit ALRTransitionalBit
justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
setJustClosedExplicitLetBlock False
- let thisLoc = getRealSrcSpan t
- thisCol = srcSpanStartCol thisLoc
- newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
- case (unRealSrcSpan t, context, mExpectingOCurly) of
+ let thisLoc = getLoc t
+ thisCol = srcSpanStartCol (psRealSpan thisLoc)
+ newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc)
+ case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
(ITocurly, _, Just alrLayout) ->
@@ -2921,7 +2932,7 @@ alternativeLayoutRuleToken t
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- (RealSrcSpan thisLoc)
+ (mkSrcSpanPs thisLoc)
(transitionalAlternativeLayoutWarning
"`where' clause at the same depth as implicit layout block")
setALRContext ls
@@ -2933,7 +2944,7 @@ alternativeLayoutRuleToken t
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- (RealSrcSpan thisLoc)
+ (mkSrcSpanPs thisLoc)
(transitionalAlternativeLayoutWarning
"`|' at the same depth as implicit layout block")
setALRContext ls
@@ -2944,8 +2955,8 @@ alternativeLayoutRuleToken t
(_, ALRLayout _ col : ls, _)
| newLine && thisCol == col ->
do setNextToken t
- let loc = realSrcSpanStart thisLoc
- zeroWidthLoc = mkRealSrcSpan loc loc
+ let loc = psSpanStart thisLoc
+ zeroWidthLoc = mkPsSpan loc loc
return (L zeroWidthLoc ITsemi)
| newLine && thisCol < col ->
do setALRContext ls
@@ -3049,29 +3060,29 @@ topNoLayoutContainsCommas [] = False
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
-lexToken :: P (RealLocated Token)
+lexToken :: P (PsLocated Token)
lexToken = do
inp@(AI loc1 buf) <- getInput
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do
- let span = mkRealSrcSpan loc1 loc1
- setEofPos span
+ let span = mkPsSpan loc1 loc1
+ setEofPos (psRealSpan span)
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
- reportLexError loc1 loc2 buf "lexical error"
+ reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error"
AlexSkip inp2 _ -> do
setInput inp2
lexToken
AlexToken inp2@(AI end buf2) _ t -> do
setInput inp2
- let span = mkRealSrcSpan loc1 end
+ let span = mkPsSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
lt <- t span buf bytes
- let lt' = unRealSrcSpan lt
+ let lt' = unLoc lt
unless (isComment lt') (setLastTk lt')
return lt
@@ -3216,15 +3227,15 @@ addAnnotationOnly l a v = P $ \s -> POk s {
-- and end of the span
mkParensApiAnn :: SrcSpan -> [AddAnn]
mkParensApiAnn (UnhelpfulSpan _) = []
-mkParensApiAnn (RealSrcSpan ss) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
+mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
sc = srcSpanStartCol ss
el = srcSpanEndLine ss
ec = srcSpanEndCol ss
- lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)))
- lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss))
+ lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing
+ lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing
queueComment :: RealLocated Token -> P()
queueComment c = P $ \s -> POk s {
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 73e3c52851..26c56d062b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2565,11 +2565,11 @@ quasiquote :: { Located (HsSplice GhcPs) }
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
- in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
+ in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }
| TH_QQUASIQUOTE { let { loc = getLoc $1
; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkQual varName (qual, quoter) }
- in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
+ in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }
exp :: { ECP }
: infixexp '::' sigtype
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 8bf18fc928..1be2c76864 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -2918,7 +2918,7 @@ instance MonadP PV where
PV $ \ctx acc ->
let b = ext `xtest` pExtsBitmap (pv_options ctx) in
PV_Ok acc $! b
- addAnnotation (RealSrcSpan l) a (RealSrcSpan v) =
+ addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) =
PV $ \_ acc ->
let
(comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc)
View Lorry Controller Status