Monotonic locations (#17632)

When GHC is parsing a file generated by a tool, e.g. by the C preprocessor, the
tool may insert #line pragmas to adjust the locations reported to the user.

As the result, the locations recorded in RealSrcLoc are not monotonic. Elements
that appear later in the StringBuffer are not guaranteed to have a higher
line/column number.

In fact, there are no guarantees whatsoever, as #line pragmas can arbitrarily
modify locations. This lack of guarantees makes ideas such as #17544
infeasible.

This patch adds an additional bit of information to every SrcLoc:

	newtype BufPos = BufPos { bufPos :: Int }

A BufPos represents the location in the StringBuffer, unaffected by any
pragmas.

Updates haddock submodule.

Metric Increase:
    haddock.Cabal
    haddock.base
    haddock.compiler
    MultiLayerModules
    Naperian
    parsing001
    T12150

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)