[Git][ghc/ghc][wip/az/ghc-cpp] Move PpState into PreProcess

Alan Zimmerman (@alanz) gitlab at gitlab.haskell.org
Tue Oct 3 22:17:10 UTC 2023



Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC


Commits:
289fee54 by Alan Zimmerman at 2023-10-03T23:16:40+01:00
Move PpState into PreProcess

And initParserState, initPragState too

- - - - -


17 changed files:

- compiler/GHC.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Parser/Monad.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Parser.hs-boot
- compiler/GHC/Parser.y
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Parser/PreProcess.hs
- compiler/GHC/Parser/Utils.hs
- ghc/GHCi/UI.hs
- utils/check-cpp/Main.hs
- utils/haddock


Changes:

=====================================
compiler/GHC.hs
=====================================
@@ -333,7 +333,8 @@ import GHC.Runtime.Context
 import GHCi.RemoteTypes
 
 import qualified GHC.Parser as Parser
-import GHC.Parser.Lexer
+import GHC.Parser.Lexer hiding (initParserState)
+import GHC.Parser.PreProcess   (initParserState)
 import GHC.Parser.Annotation
 import GHC.Parser.Utils
 
@@ -1627,7 +1628,7 @@ getTokenStream :: ModSummary -> IO [Located Token]
 getTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
-  case lexTokenStream (initParserOpts dflags) source startLoc of
+  case lexTokenStream initPpState (initParserOpts dflags) source startLoc of
     POk _ ts    -> return ts
     PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
 
@@ -1638,7 +1639,7 @@ getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
 getRichTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
-  case lexTokenStream (initParserOpts dflags) source startLoc of
+  case lexTokenStream initPpState (initParserOpts dflags) source startLoc of
     POk _ ts    -> return $ addSourceToTokens startLoc source ts
     PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
 


=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1576,7 +1576,7 @@ parseCmmFile cmmpConfig this_mod home_unit filename = do
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
-        init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] }
+        init_state = (initParserState () (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] }
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
         pdConfig = cmmpPDConfig cmmpConfig


=====================================
compiler/GHC/Cmm/Parser/Monad.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Types.SrcLoc
 import GHC.Unit.Types
 import GHC.Unit.Home
 
-newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }
+newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState () -> ParseResult () a }
 
 instance Functor PD where
   fmap = liftM
@@ -46,7 +46,7 @@ instance Applicative PD where
 instance Monad PD where
   (>>=) = thenPD
 
-liftP :: P a -> PD a
+liftP :: P () a -> PD a
 liftP (P f) = PD $ \_ _ s -> f s
 
 failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a


=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -37,7 +37,8 @@ import GHC.Driver.Errors.Types
 
 import GHC.Parser
 import GHC.Parser.Header
-import GHC.Parser.Lexer
+import GHC.Parser.Lexer hiding (initParserState)
+import GHC.Parser.PreProcess   (initParserState)
 import GHC.Parser.Annotation
 
 import GHC.Rename.Names


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -193,7 +193,8 @@ import GHC.CoreToStg    ( coreToStg )
 
 import GHC.Parser.Errors.Types
 import GHC.Parser
-import GHC.Parser.Lexer as Lexer
+import GHC.Parser.Lexer as Lexer hiding (initPpState, initParserState)
+import GHC.Parser.PreProcess (initParserState)
 
 import GHC.Tc.Module
 import GHC.Tc.Utils.Monad
@@ -2468,11 +2469,11 @@ hscParseIdentifier hsc_env str =
     runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
 
 hscParseThing :: (Outputable thing, Data thing)
-              => Lexer.P thing -> String -> Hsc thing
+              => Lexer.P PpState thing -> String -> Hsc thing
 hscParseThing = hscParseThingWithLocation "<interactive>" 1
 
 hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-                          -> Lexer.P thing -> String -> Hsc thing
+                          -> Lexer.P PpState thing -> String -> Hsc thing
 hscParseThingWithLocation source linenumber parser str = do
     dflags <- getDynFlags
     logger <- getLogger


=====================================
compiler/GHC/Parser.hs-boot
=====================================
@@ -4,4 +4,4 @@ import GHC.Types.Name.Reader (RdrName)
 import GHC.Parser.Lexer (P)
 import GHC.Parser.Annotation (LocatedN)
 
-parseIdentifier :: P (LocatedN RdrName)
+parseIdentifier :: P p (LocatedN RdrName)


=====================================
compiler/GHC/Parser.y
=====================================
@@ -83,8 +83,9 @@ import GHC.Core.DataCon ( DataCon, dataConName )
 
 import GHC.Parser.PostProcess
 import GHC.Parser.PostProcess.Haddock
-import GHC.Parser.Lexer hiding (lexer, lexerDbg)
-import GHC.Parser.PreProcess
+-- import GHC.Parser.Lexer hiding (lexer, lexerDbg)
+import GHC.Parser.Lexer
+import GHC.Parser.PreProcess hiding (lexer, lexerDbg)
 import GHC.Parser.HaddockLex
 import GHC.Parser.Annotation
 import GHC.Parser.Errors.Types
@@ -756,7 +757,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 -- '#else'         { L _ ITcppElse }
 -- '#endif'        { L _ ITcppEndif }
 
-%monad { P } { >>= } { return }
+%monad { P p } { >>= } { return }
 %lexer { (lexer True) } { L _ ITeof }
 -- %lexer { (lexerDbg True) } { L _ ITeof }
   -- Replace 'lexer' above with 'lexerDbg'
@@ -3986,7 +3987,7 @@ bars :: { ([SrcSpan],Int) }     -- One or more bars
         | '|'                    { ([gl $1],1) }
 
 {
-happyError :: P a
+happyError :: P p a
 happyError = srcParseFail
 
 getVARID          (L _ (ITvarid    x)) = x
@@ -4088,7 +4089,7 @@ hasE (L _ (ITopenExpQuote HasE _)) = True
 hasE (L _ (ITopenTExpQuote HasE))  = True
 hasE _                             = False
 
-getSCC :: Located Token -> P FastString
+getSCC :: Located Token -> P p FastString
 getSCC lt = do let s = getSTRING lt
                -- We probably actually want to be more restrictive than this
                if ' ' `elem` unpackFS s
@@ -4192,7 +4193,7 @@ incorrect.
 -- Make a source location for the file.  We're a bit lazy here and just
 -- make a point SrcSpan at line 1, column 0.  Strictly speaking we should
 -- try to find the span of the whole file (ToDo).
-fileSrcSpan :: P SrcSpan
+fileSrcSpan :: P p SrcSpan
 fileSrcSpan = do
   l <- getRealSrcLoc;
   let loc = mkSrcLoc (srcLocFile l) 1 1;
@@ -4218,13 +4219,13 @@ looksLikeMult ty1 l_op ty2
   | otherwise = False
 
 -- Hint about the MultiWayIf extension
-hintMultiWayIf :: SrcSpan -> P ()
+hintMultiWayIf :: SrcSpan -> P p ()
 hintMultiWayIf span = do
   mwiEnabled <- getBit MultiWayIfBit
   unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf
 
 -- Hint about explicit-forall
-hintExplicitForall :: Located Token -> P ()
+hintExplicitForall :: Located Token -> P p ()
 hintExplicitForall tok = do
     forall   <- getBit ExplicitForallBit
     rulePrag <- getBit InRulePragBit
@@ -4232,7 +4233,7 @@ hintExplicitForall tok = do
       (PsErrExplicitForall (isUnicode tok))
 
 -- Hint about qualified-do
-hintQualifiedDo :: Located Token -> P ()
+hintQualifiedDo :: Located Token -> P p ()
 hintQualifiedDo tok = do
     qualifiedDo   <- getBit QualifiedDoBit
     case maybeQDoDoc of
@@ -4249,7 +4250,7 @@ hintQualifiedDo tok = do
 -- When two single quotes don't followed by tyvar or gtycon, we report the
 -- error as empty character literal, or TH quote that missing proper type
 -- variable or constructor. See #13450.
-reportEmptyDoubleQuotes :: SrcSpan -> P a
+reportEmptyDoubleQuotes :: SrcSpan -> P p a
 reportEmptyDoubleQuotes span = do
     thQuotes <- getBit ThQuotesBit
     addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes
@@ -4343,7 +4344,7 @@ acs a = do
   return (a cs)
 
 -- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.
-acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)
+acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P p (Located a)
 acsFinal a = do
   let (L l _) = a emptyComments Nothing
   cs <- getCommentsFor l
@@ -4364,7 +4365,7 @@ acsa a = do
 acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
 acsA a = reLocA <$> acs a
 
-acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP
+acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P p ECP
 acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a
                ; return (ecpFromExp $ expr) }
 
@@ -4440,7 +4441,7 @@ pvL a = do { av <- a
 -- This and the signature module parser are the only parser entry points that
 -- deal with Haddock comments. The other entry points ('parseDeclaration',
 -- 'parseExpression', etc) do not insert them into the AST.
-parseModule :: P (Located (HsModule GhcPs))
+parseModule :: P p (Located (HsModule GhcPs))
 parseModule = parseModuleNoHaddock >>= addHaddockToModule
 
 -- | Parse a Haskell signature module with Haddock comments. This is done in two
@@ -4452,7 +4453,7 @@ parseModule = parseModuleNoHaddock >>= addHaddockToModule
 -- This and the module parser are the only parser entry points that deal with
 -- Haddock comments. The other entry points ('parseDeclaration',
 -- 'parseExpression', etc) do not insert them into the AST.
-parseSignature :: P (Located (HsModule GhcPs))
+parseSignature :: P p (Located (HsModule GhcPs))
 parseSignature = parseSignatureNoHaddock >>= addHaddockToModule
 
 commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)
@@ -4461,7 +4462,7 @@ commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs
 -- | Instead of getting the *enclosed* comments, this includes the
 -- *preceding* ones.  It is used at the top level to get comments
 -- between top level declarations.
-commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)
+commentsPA :: (Monoid ann) => LocatedAn ann a -> P p (LocatedAn ann a)
 commentsPA la@(L l a) = do
   cs <- getPriorCommentsFor (getLocA la)
   return (L (addCommentsToSrcAnn l cs) a)


=====================================
compiler/GHC/Parser/HaddockLex.x
=====================================
@@ -132,7 +132,7 @@ advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of
   Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs'
 
 -- | Lex 'StringLiteral' for warning messages
-lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser
+lexStringLiteral :: P () (LocatedN RdrName) -- ^ A precise identifier parser
                  -> Located StringLiteral
                  -> Located (WithHsDocIdentifiers StringLiteral GhcPs)
 lexStringLiteral identParser (L l sl@(StringLiteral _ fs _))
@@ -150,7 +150,7 @@ lexStringLiteral identParser (L l sl@(StringLiteral _ fs _))
     fakeLoc = mkRealSrcLoc nilFS 0 0
 
 -- | Lex identifiers from a docstring.
-lexHsDoc :: P (LocatedN RdrName)      -- ^ A precise identifier parser
+lexHsDoc :: P () (LocatedN RdrName)      -- ^ A precise identifier parser
          -> HsDocString
          -> HsDoc GhcPs
 lexHsDoc identParser doc =
@@ -170,7 +170,7 @@ lexHsDoc identParser doc =
 
     fakeLoc = mkRealSrcLoc nilFS 0 0
 
-validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName)
+validateIdentWith :: P () (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName)
 validateIdentWith identParser mloc str0 =
   let -- These ParserFlags should be as "inclusive" as possible, allowing
       -- identifiers defined with any language extension.
@@ -184,7 +184,7 @@ validateIdentWith identParser mloc str0 =
       realSrcLc = case mloc of
         RealSrcSpan loc _ -> realSrcSpanStart loc
         UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0
-      pstate = initParserState pflags buffer realSrcLc
+      pstate = initParserState () pflags buffer realSrcLc
   in case unP identParser pstate of
     POk _ name -> Just $ case mloc of
        RealSrcSpan _ _ -> reLoc name


=====================================
compiler/GHC/Parser/Header.hs
=====================================
@@ -28,7 +28,8 @@ import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw e
 
 import GHC.Parser.Errors.Types
 import GHC.Parser           ( parseHeader )
-import GHC.Parser.Lexer
+import GHC.Parser.Lexer hiding (initPragState, initParserState)
+import GHC.Parser.PreProcess   (initPragState, initParserState)
 
 import GHC.Hs
 import GHC.Unit.Module
@@ -200,7 +201,7 @@ lazyGetToks popts filename handle = do
  where
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
-  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
+  lazyLexBuf :: Handle -> PState p -> Bool -> Int -> IO [Located Token]
   lazyLexBuf handle state eof size =
     case unP (lexer False return) state of
       POk state' t -> do
@@ -218,7 +219,7 @@ lazyGetToks popts filename handle = do
         | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof]
                          -- parser assumes an ITeof sentinel at the end
 
-  getMore :: Handle -> PState -> Int -> IO [Located Token]
+  getMore :: Handle -> PState p -> Int -> IO [Located Token]
   getMore handle state size = do
      -- pprTrace "getMore" (text (show (buffer state))) (return ())
      let new_size = size * 2


=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -1234,56 +1234,56 @@ reservedSymsFM = listToUFM $
 -- -----------------------------------------------------------------------------
 -- Lexer actions
 
-type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token)
+type Action p = PsSpan -> StringBuffer -> Int -> StringBuffer -> P p (PsLocated Token)
 
-special :: Token -> Action
+special :: Token -> Action p
 special tok span _buf _len _buf2 = return (L span tok)
 
-token, layout_token :: Token -> Action
+token, layout_token :: Token -> Action p
 token t span _buf _len _buf2 = return (L span t)
 layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t)
 
-idtoken :: (StringBuffer -> Int -> Token) -> Action
+idtoken :: (StringBuffer -> Int -> Token) -> Action p
 idtoken f span buf len _buf2 = return (L span $! (f buf len))
 
-qdo_token :: (Maybe FastString -> Token) -> Action
+qdo_token :: (Maybe FastString -> Token) -> Action p
 qdo_token con span buf len _buf2 = do
     maybe_layout token
     return (L span $! token)
   where
     !token = con $! Just $! fst $! splitQualName buf len False
 
-skip_one_varid :: (FastString -> Token) -> Action
+skip_one_varid :: (FastString -> Token) -> Action p
 skip_one_varid f span buf len _buf2
   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 
-skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action
+skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action p
 skip_one_varid_src f span buf len _buf2
   = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1))
                         (lexemeToFastString (stepOn buf) (len-1)))
 
-skip_two_varid :: (FastString -> Token) -> Action
+skip_two_varid :: (FastString -> Token) -> Action p
 skip_two_varid f span buf len _buf2
   = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))
 
-strtoken :: (String -> Token) -> Action
+strtoken :: (String -> Token) -> Action p
 strtoken f span buf len _buf2 =
   return (L span $! (f $! lexemeToString buf len))
 
-fstrtoken :: (FastString -> Token) -> Action
+fstrtoken :: (FastString -> Token) -> Action p
 fstrtoken f span buf len _buf2 =
   return (L span $! (f $! lexemeToFastString buf len))
 
-begin :: Int -> Action
+begin :: Int -> Action p
 begin code _span _str _len _buf2 = do pushLexState code; lexToken
 
-pop :: Action
+pop :: Action p
 pop _span _buf _len _buf2 =
   do _ <- popLexState
      lexToken
      -- trace "pop" $ do lexToken
 
-cppToken :: Int -> Action
+cppToken :: Int -> Action p
 cppToken code span buf len _buf2 =
   do
      let tokStr = lexemeToFastString buf len
@@ -1297,7 +1297,7 @@ cppToken code span buf len _buf2 =
      return (L span (ITcpp continue $! lexemeToFastString buf len0))
      -- trace ("cppToken:" ++ show (code, t)) $ do return (L span t)
 
-cppTokenCont :: (FastString -> Token)-> Action
+cppTokenCont :: (FastString -> Token)-> Action p
 cppTokenCont code span buf len _buf2 =
   do
      let tokStr = lexemeToFastString buf len
@@ -1309,34 +1309,34 @@ cppTokenCont code span buf len _buf2 =
         _ -> return (len, False)
      return (L span (ITcpp continue $! lexemeToFastString buf len0))
 
-cppTokenPop :: (FastString -> Token)-> Action
+cppTokenPop :: (FastString -> Token)-> Action p
 cppTokenPop t span buf len _buf2 =
   do _ <- popLexState
      -- return (L span (t $! lexemeToFastString buf (len - 1)))
      return (L span (t $! lexemeToFastString buf (trace "cppTokenPop" len)))
 
-popCpp :: Action
+popCpp :: Action p
 popCpp _span _buf _len _buf2 =
   do _ <- popLexState
      -- lexToken
      trace "pop" $ do lexToken
 
 -- See Note [Nested comment line pragmas]
-failLinePrag1 :: Action
+failLinePrag1 :: Action p
 failLinePrag1 span _buf _len _buf2 = do
   b <- getBit InNestedCommentBit
   if b then return (L span ITcomment_line_prag)
        else lexError LexErrorInPragma
 
 -- See Note [Nested comment line pragmas]
-popLinePrag1 :: Action
+popLinePrag1 :: Action p
 popLinePrag1 span _buf _len _buf2 = do
   b <- getBit InNestedCommentBit
   if b then return (L span ITcomment_line_prag) else do
     _ <- popLexState
     lexToken
 
-hopefully_open_brace :: Action
+hopefully_open_brace :: Action p
 hopefully_open_brace span buf len buf2
  = do relaxed <- getBit RelaxedLayoutBit
       ctx <- getContext
@@ -1350,7 +1350,7 @@ hopefully_open_brace span buf len buf2
               else addFatalError $
                      mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock
 
-pop_and :: Action -> Action
+pop_and :: Action p -> Action p
 pop_and act span buf len buf2 =
   do _ <- popLexState
      act span buf len buf2
@@ -1400,7 +1400,7 @@ get_op_ws buf1 buf2 =
     mk_op_ws False False = OpWsLooseInfix
 
 {-# INLINE with_op_ws #-}
-with_op_ws :: (OpWs -> Action) -> Action
+with_op_ws :: (OpWs -> Action p) -> Action p
 with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2
 
 {-# INLINE nextCharIs #-}
@@ -1501,7 +1501,7 @@ alexNotPred p userState in1 len in2
 alexOrPred p1 p2 userState in1 len in2
   = p1 userState in1 len in2 || p2 userState in1 len in2
 
-multiline_doc_comment :: Action
+multiline_doc_comment :: Action p
 multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker
   where
     worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input
@@ -1547,7 +1547,7 @@ multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-}
             | otherwise -> input
           Nothing -> input
 
-lineCommentToken :: Action
+lineCommentToken :: Action p
 lineCommentToken span buf len buf2 = do
   b <- getBit RawTokenStreamBit
   if b then do
@@ -1560,7 +1560,7 @@ lineCommentToken span buf len buf2 = do
   nested comments require traversing by hand, they can't be parsed
   using regular expressions.
 -}
-nested_comment :: Action
+nested_comment :: Action p
 nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do
   l <- getLastLocIncludingComments
   let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span
@@ -1569,7 +1569,7 @@ nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do
   let start_decorator = reverse $ lexemeToString buf len
   nested_comment_logic endComment start_decorator input span
 
-nested_doc_comment :: Action
+nested_doc_comment :: Action p
 nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker
   where
     worker input docType _checkNextLine = nested_comment_logic endComment "" input span
@@ -1585,11 +1585,11 @@ nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLe
 -- | Includes the trailing '-}' decorators
 -- drop the last two elements with the callback if you don't want them to be included
 nested_comment_logic
-  :: (AlexInput -> Located String -> P (PsLocated Token))  -- ^ Continuation that gets the rest of the input and the lexed comment
+  :: (AlexInput -> Located String -> P p (PsLocated Token))  -- ^ Continuation that gets the rest of the input and the lexed comment
   -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment
   -> AlexInput
   -> PsSpan
-  -> P (PsLocated Token)
+  -> P p (PsLocated Token)
 nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input
   where
     go commentAcc 0 input@(AI end_loc _) = do
@@ -1623,13 +1623,13 @@ nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) i
         Just (_,_)   -> go ('\n':commentAcc) n input
       (_, Just (c,input)) -> go (c:commentAcc) n input
 
-ghcCppSet :: P Bool
+ghcCppSet :: P p Bool
 ghcCppSet = do
   exts <- getExts
   return $ xtest GhcCppBit exts
 
 -- See Note [Nested comment line pragmas]
-parseNestedPragma :: AlexInput -> P (String,AlexInput)
+parseNestedPragma :: AlexInput -> P p (String,AlexInput)
 parseNestedPragma input@(AI _ buf) = do
   origInput <- getInput
   setInput input
@@ -1675,8 +1675,8 @@ See #314 for more background on the bug this fixes.
 -}
 
 {-# INLINE withLexedDocType #-}
-withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token))
-                 -> P (PsLocated Token)
+withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P p (PsLocated Token))
+                 -> P p (PsLocated Token)
 withLexedDocType lexDocComment = do
   input@(AI _ buf) <- getInput
   l <- getLastLocIncludingComments
@@ -1721,7 +1721,7 @@ mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)
 
 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
 -- off again at the end of the pragma.
-rulePrag :: Action
+rulePrag :: Action p
 rulePrag span buf len _buf2 = do
   setExts (.|. xbit InRulePragBit)
   let !src = lexemeToFastString buf len
@@ -1729,7 +1729,7 @@ rulePrag span buf len _buf2 = do
 
 -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
 -- of updating the position in 'PState'
-linePrag :: Action
+linePrag :: Action p
 linePrag span buf len buf2 = do
   usePosPrags <- getBit UsePosPragsBit
   if usePosPrags
@@ -1739,7 +1739,7 @@ linePrag span buf len buf2 = do
 
 -- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
 -- of updating the position in 'PState'
-columnPrag :: Action
+columnPrag :: Action p
 columnPrag span buf len buf2 = do
   usePosPrags <- getBit UsePosPragsBit
   if usePosPrags
@@ -1747,7 +1747,7 @@ columnPrag span buf len buf2 = do
     else let !src = lexemeToFastString buf len
          in return (L span (ITcolumn_prag (SourceText src)))
 
-endPrag :: Action
+endPrag :: Action p
 endPrag span _buf _len _buf2 = do
   setExts (.&. complement (xbit InRulePragBit))
   return (L span ITclose_prag)
@@ -1761,12 +1761,12 @@ endPrag span _buf _len _buf2 = do
 -- called afterwards, so it can just update the state.
 
 {-# INLINE commentEnd #-}
-commentEnd :: P (PsLocated Token)
+commentEnd :: P p (PsLocated Token)
            -> AlexInput
            -> (Maybe HdkComment, Token)
            -> StringBuffer
            -> PsSpan
-           -> P (PsLocated Token)
+           -> P p (PsLocated Token)
 commentEnd cont input (m_hdk_comment, hdk_token) buf span = do
   setInput input
   let (AI loc nextBuf) = input
@@ -1781,17 +1781,17 @@ commentEnd cont input (m_hdk_comment, hdk_token) buf span = do
 
 {-# INLINE docCommentEnd #-}
 docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer ->
-                 PsSpan -> P (PsLocated Token)
+                 PsSpan -> P p (PsLocated Token)
 docCommentEnd input (hdk_comment, tok) buf span
   = commentEnd lexToken input (Just hdk_comment, tok) buf span
 
-errBrace :: AlexInput -> RealSrcSpan -> P a
+errBrace :: AlexInput -> RealSrcSpan -> P p a
 errBrace (AI end _) span =
   failLocMsgP (realSrcSpanStart span)
               (psRealLoc end)
               (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF))
 
-open_brace, close_brace :: Action
+open_brace, close_brace :: Action p
 open_brace span _str _len _buf2 = do
   ctx <- getContext
   setContext (NoLayout:ctx)
@@ -1838,7 +1838,7 @@ splitQualName orig_buf len parens = split orig_buf orig_buf
       where
         qual_size = orig_buf `byteDiff` dot_buf
 
-varid :: Action
+varid :: Action p
 varid span buf len _buf2 =
   case lookupUFM reservedWordsFM fs of
     Just (ITcase, _) -> do
@@ -1885,7 +1885,7 @@ qvarsym buf len = ITqvarsym $! splitQualName buf len False
 qconsym buf len = ITqconsym $! splitQualName buf len False
 
 -- See Note [Whitespace-sensitive operator parsing]
-varsym :: OpWs -> Action
+varsym :: OpWs -> Action p
 varsym opws at OpWsPrefix = sym $ \span exts s ->
   let warnExtConflict errtok =
         do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok)
@@ -1935,12 +1935,12 @@ varsym OpWsLooseInfix = sym $ \_ _ s ->
      | otherwise
      -> return $ ITvarsym s
 
-consym :: OpWs -> Action
+consym :: OpWs -> Action p
 consym opws = sym $ \span _exts s ->
   do { warnOperatorWhitespace opws span s
      ; return (ITconsym s) }
 
-warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P ()
+warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P p ()
 warnOperatorWhitespace opws span s =
   whenIsJust (check_unusual_opws opws) $ \opws' ->
     addPsMessage
@@ -1957,7 +1957,7 @@ check_unusual_opws opws =
     OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix
     OpWsLooseInfix -> Nothing
 
-sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action
+sym :: (PsSpan -> ExtsBitmap -> FastString -> P p Token) -> Action p
 sym con span buf len _buf2 =
   case lookupUFM reservedSymsFM fs of
     Just (keyword, NormalSyntax, 0) ->
@@ -1988,7 +1988,7 @@ tok_integral :: (SourceText -> Integer -> Token)
              -> (Integer -> Integer)
              -> Int -> Int
              -> (Integer, (Char -> Int))
-             -> Action
+             -> Action p
 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do
   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
   let src = lexemeToFastString buf len
@@ -2002,7 +2002,7 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _
 
 tok_num :: (Integer -> Integer)
         -> Int -> Int
-        -> (Integer, (Char->Int)) -> Action
+        -> (Integer, (Char->Int)) -> Action p
 tok_num = tok_integral $ \case
     st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True)
     st@(SourceText _)       -> itint st (const False)
@@ -2013,12 +2013,12 @@ tok_num = tok_integral $ \case
 
 tok_primint :: (Integer -> Integer)
             -> Int -> Int
-            -> (Integer, (Char->Int)) -> Action
+            -> (Integer, (Char->Int)) -> Action p
 tok_primint = tok_integral ITprimint
 
 
 tok_primword :: Int -> Int
-             -> (Integer, (Char->Int)) -> Action
+             -> (Integer, (Char->Int)) -> Action p
 tok_primword = tok_integral ITprimword positive
 positive, negative :: (Integer -> Integer)
 positive = id
@@ -2035,13 +2035,13 @@ tok_primintX :: (SourceText -> Integer -> Token)
              -> Int
              -> (Integer -> Integer)
              -> Int
-             -> (Integer, (Char->Int)) -> Action
+             -> (Integer, (Char->Int)) -> Action p
 tok_primintX itint addlen transint transbuf =
     tok_integral itint transint transbuf (transbuf+addlen)
 
 tok_primint8,     tok_primint16,  tok_primint32,  tok_primint64
     :: (Integer -> Integer)
-    -> Int -> (Integer, (Char->Int)) -> Action
+    -> Int -> (Integer, (Char->Int)) -> Action p
 tok_primint8  = tok_primintX ITprimint8   5
 tok_primint16 = tok_primintX ITprimint16  6
 tok_primint32 = tok_primintX ITprimint32  6
@@ -2052,19 +2052,19 @@ tok_primint64 = tok_primintX ITprimint64  6
 tok_primwordX :: (SourceText -> Integer -> Token)
               -> Int
               -> Int
-              -> (Integer, (Char->Int)) -> Action
+              -> (Integer, (Char->Int)) -> Action p
 tok_primwordX itint addlen transbuf =
     tok_integral itint positive transbuf (transbuf+addlen)
 
 tok_primword8, tok_primword16, tok_primword32, tok_primword64
-    :: Int -> (Integer, (Char->Int)) -> Action
+    :: Int -> (Integer, (Char->Int)) -> Action p
 tok_primword8  = tok_primwordX ITprimword8  6
 tok_primword16 = tok_primwordX ITprimword16 7
 tok_primword32 = tok_primwordX ITprimword32 7
 tok_primword64 = tok_primwordX ITprimword64 7
 
 -- readSignificandExponentPair can understand negative rationals, exponents, everything.
-tok_frac :: Int -> (String -> Token) -> Action
+tok_frac :: Int -> (String -> Token) -> Action p
 tok_frac drop f span buf len _buf2 = do
   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
   let src = lexemeToString buf (len-drop)
@@ -2099,7 +2099,7 @@ readFractionalLitX readStr b str =
 -- Layout processing
 
 -- we're at the first token on a line, insert layout tokens if necessary
-do_bol :: Action
+do_bol :: Action p
 do_bol span _str _len _buf2 = do
         -- See Note [Nested comment line pragmas]
         b <- getBit InNestedCommentBit
@@ -2121,7 +2121,7 @@ do_bol span _str _len _buf2 = do
 
 -- certain keywords put us in the "layout" state, where we might
 -- add an opening curly brace.
-maybe_layout :: Token -> P ()
+maybe_layout :: Token -> P p ()
 maybe_layout t = do -- If the alternative layout rule is enabled then
                     -- we never create an implicit layout context here.
                     -- Layout is handled XXX instead.
@@ -2150,7 +2150,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
 -- We are slightly more lenient than this: when the new context is started
 -- by a 'do', then we allow the new context to be at the same indentation as
 -- the previous context.  This is what the 'strict' argument is for.
-new_layout_context :: Bool -> Bool -> Token -> Action
+new_layout_context :: Bool -> Bool -> Token -> Action p
 new_layout_context strict gen_semic tok span _buf len _buf2 = do
     _ <- popLexState
     (AI l _) <- getInput
@@ -2169,7 +2169,7 @@ new_layout_context strict gen_semic tok span _buf len _buf2 = do
         _ -> do setContext (Layout offset gen_semic : ctx)
                 return (L span tok)
 
-do_layout_left :: Action
+do_layout_left :: Action p
 do_layout_left span _buf _len _buf2 = do
     _ <- popLexState
     pushLexState bol  -- we must be at the start of a line
@@ -2178,7 +2178,7 @@ do_layout_left span _buf _len _buf2 = do
 -- -----------------------------------------------------------------------------
 -- LINE pragmas
 
-setLineAndFile :: Int -> Action
+setLineAndFile :: Int -> Action p
 setLineAndFile code (PsSpan span _) buf len _buf2 = do
   let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark
       linenumLen = length $ head $ words src
@@ -2205,7 +2205,7 @@ setLineAndFile code (PsSpan span _) buf len _buf2 = do
   pushLexState code
   lexToken
 
-setColumn :: Action
+setColumn :: Action p
 setColumn (PsSpan span _) buf len _buf2 = do
   let column =
         case reads (lexemeToString buf len) of
@@ -2226,12 +2226,12 @@ alrInitialLoc file = mkRealSrcSpan loc loc
 -- Options, includes and language pragmas.
 
 
-lex_string_prag :: (String -> Token) -> Action
+lex_string_prag :: (String -> Token) -> Action p
 lex_string_prag mkTok = lex_string_prag_comment mkTok'
   where
     mkTok' s _ = mkTok s
 
-lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action
+lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action p
 lex_string_prag_comment mkTok span _buf _len _buf2
     = do input <- getInput
          start <- getParsedLoc
@@ -2260,7 +2260,7 @@ lex_string_prag_comment mkTok span _buf _len _buf2
 
 -- This stuff is horrible.  I hates it.
 
-lex_string_tok :: Action
+lex_string_tok :: Action p
 lex_string_tok span buf _len _buf2 = do
   lexed <- lex_string
   (AI end bufEnd) <- getInput
@@ -2272,7 +2272,7 @@ lex_string_tok span buf _len _buf2 = do
   return $ L (mkPsSpan (psSpanStart span) end) tok
 
 
-lex_quoted_label :: Action
+lex_quoted_label :: Action p
 lex_quoted_label span buf _len _buf2 = do
   start <- getInput
   s <- lex_string_helper "" start
@@ -2287,7 +2287,7 @@ lex_quoted_label span buf _len _buf2 = do
 
 data LexedString = LexedRegularString String | LexedPrimString String
 
-lex_string :: P LexedString
+lex_string :: P p LexedString
 lex_string = do
   start <- getInput
   s <- lex_string_helper "" start
@@ -2310,7 +2310,7 @@ lex_string = do
       return $ LexedRegularString s
 
 
-lex_string_helper :: String -> AlexInput -> P String
+lex_string_helper :: String -> AlexInput -> P p String
 lex_string_helper s start = do
   i <- getInput
   case alexGetChar' i of
@@ -2345,7 +2345,7 @@ lex_string_helper s start = do
           _other -> lit_error i
 
 
-lex_stringgap :: String -> AlexInput -> P String
+lex_stringgap :: String -> AlexInput -> P p String
 lex_stringgap s start = do
   i <- getInput
   c <- getCharOrFail i
@@ -2356,7 +2356,7 @@ lex_stringgap s start = do
     _other -> lit_error i
 
 
-lex_char_tok :: Action
+lex_char_tok :: Action p
 -- Here we are basically parsing character literals, such as 'x' or '\n'
 -- but we additionally spot 'x and ''T, returning ITsimpleQuote and
 -- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part
@@ -2399,7 +2399,7 @@ lex_char_tok span buf _len _buf2 = do        -- We've seen '
                         let (AI end _) = i1
                         return (L (mkPsSpan loc end) ITsimpleQuote)
 
-finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token)
+finish_char_tok :: StringBuffer -> PsLoc -> Char -> P 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
@@ -2423,7 +2423,7 @@ isAny :: Char -> Bool
 isAny c | c > '\x7f' = isPrint c
         | otherwise  = is_any c
 
-lex_escape :: P Char
+lex_escape :: P p Char
 lex_escape = do
   i0@(AI loc _) <- getInput
   c <- getCharOrFail i0
@@ -2472,7 +2472,7 @@ lex_escape = do
                                 return escape_char
                           [] -> lit_error i0
 
-readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char
+readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P p Char
 readNum is_digit base conv = do
   i <- getInput
   c <- getCharOrFail i
@@ -2480,7 +2480,7 @@ readNum is_digit base conv = do
         then readNum2 is_digit base conv (conv c)
         else lit_error i
 
-readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char
+readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P p Char
 readNum2 is_digit base conv i = do
   input <- getInput
   read i input
@@ -2537,10 +2537,10 @@ silly_escape_chars = [
 -- the position of the error in the buffer.  This is so that we can report
 -- a correct location to the user, but also so we can detect UTF-8 decoding
 -- errors if they occur.
-lit_error :: AlexInput -> P a
+lit_error :: AlexInput -> P p a
 lit_error i = do setInput i; lexError LexStringCharLit
 
-getCharOrFail :: AlexInput -> P Char
+getCharOrFail :: AlexInput -> P p Char
 getCharOrFail i =  do
   case alexGetChar' i of
         Nothing -> lexError LexStringCharLitEOF
@@ -2549,7 +2549,7 @@ getCharOrFail i =  do
 -- -----------------------------------------------------------------------------
 -- QuasiQuote
 
-lex_qquasiquote_tok :: Action
+lex_qquasiquote_tok :: Action p
 lex_qquasiquote_tok span buf len _buf2 = do
   let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False
   quoteStart <- getParsedLoc
@@ -2561,7 +2561,7 @@ lex_qquasiquote_tok span buf len _buf2 = do
                            mkFastString (reverse quote),
                            mkPsSpan quoteStart end)))
 
-lex_quasiquote_tok :: Action
+lex_quasiquote_tok :: Action p
 lex_quasiquote_tok span buf len _buf2 = do
   let quoter = tail (lexemeToString buf (len - 1))
                 -- 'tail' drops the initial '[',
@@ -2574,7 +2574,7 @@ lex_quasiquote_tok span buf len _buf2 = do
                           mkFastString (reverse quote),
                           mkPsSpan quoteStart end)))
 
-lex_quasiquote :: RealSrcLoc -> String -> P String
+lex_quasiquote :: RealSrcLoc -> String -> P p String
 lex_quasiquote start s = do
   i <- getInput
   case alexGetChar' i of
@@ -2591,7 +2591,7 @@ lex_quasiquote start s = do
     Just (c, i) -> do
          setInput i; lex_quasiquote start (c : s)
 
-quasiquote_error :: RealSrcLoc -> P a
+quasiquote_error :: RealSrcLoc -> P p a
 quasiquote_error start = do
   (AI end buf) <- getInput
   reportLexError start (psRealLoc end) buf
@@ -2621,18 +2621,18 @@ smart_quote_error_message c loc =
               PsErrUnicodeCharLooksLike c correct_char correct_char_name in
     err
 
-smart_quote_error :: Action
+smart_quote_error :: Action p
 smart_quote_error span buf _len _buf2 = do
   let c = currentChar buf
   addFatalError (smart_quote_error_message c (psSpanStart span))
 
-add_smart_quote_error :: Char -> PsLoc -> P a
+add_smart_quote_error :: Char -> PsLoc -> P p a
 add_smart_quote_error c loc = addFatalError (smart_quote_error_message c loc)
 
-add_nonfatal_smart_quote_error :: Char -> PsLoc -> P ()
+add_nonfatal_smart_quote_error :: Char -> PsLoc -> P p ()
 add_nonfatal_smart_quote_error c loc = addError (smart_quote_error_message c loc)
 
-advance_to_smart_quote_character :: P ()
+advance_to_smart_quote_character :: P p ()
 advance_to_smart_quote_character  = do
   i <- getInput
   case alexGetChar' i of
@@ -2643,12 +2643,12 @@ advance_to_smart_quote_character  = do
 -- -----------------------------------------------------------------------------
 -- Warnings
 
-warnTab :: Action
+warnTab :: Action p
 warnTab srcspan _buf _len _buf2 = do
     addTabWarning (psRealSpan srcspan)
     lexToken
 
-warnThen :: PsMessage -> Action -> Action
+warnThen :: PsMessage -> Action p -> Action p
 warnThen warning action srcspan buf len buf2 = do
     addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning
     action srcspan buf len buf2
@@ -2672,14 +2672,14 @@ data LayoutContext
   deriving Show
 
 -- | The result of running a parser.
-newtype ParseResult a = PR (# (# PState, a #) | PState #)
+newtype ParseResult p a = PR (# (# PState p, a #) | PState p #)
 
 -- | The parser has consumed a (possibly empty) prefix of the input and produced
 -- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal
 -- errors.
 --
 -- The carried parsing state can be used to resume parsing.
-pattern POk :: PState -> a -> ParseResult a
+pattern POk :: PState p -> a -> ParseResult p a
 pattern POk s a = PR (# (# s , a #) | #)
 
 -- | The parser has consumed a (possibly empty) prefix of the input and failed.
@@ -2687,7 +2687,7 @@ pattern POk s a = PR (# (# s , a #) | #)
 -- The carried parsing state can be used to resume parsing. It is the state
 -- right before failure, including the fatal parse error. 'getPsMessages' and
 -- 'getPsErrorMessages' must return a non-empty bag of errors.
-pattern PFailed :: PState -> ParseResult a
+pattern PFailed :: PState p -> ParseResult p a
 pattern PFailed s = PR (# | s #)
 
 {-# COMPLETE POk, PFailed #-}
@@ -2721,7 +2721,7 @@ data HdkComment
   | HdkCommentSection Int HsDocString
   deriving Show
 
-data PState = PState {
+data PState a = PState {
         buffer     :: StringBuffer,
         options    :: ParserOpts,
         warnings   :: Messages PsMessage,
@@ -2770,7 +2770,8 @@ data PState = PState {
         hdk_comments :: OrdList (PsLocated HdkComment),
 
         -- See Note [CPP in GHC] in GHC.Parser.PreProcess
-        pp :: !PpState
+        -- pp :: !PpState
+        pp :: !a
      }
         -- last_loc and last_len are used when generating error messages,
         -- and in pushCurrentContext only.  Sigh, if only Happy passed the
@@ -2798,6 +2799,7 @@ data PpState = PpState {
 data PpContext = PpContextIf [Located Token]
     deriving (Show)
 
+-- TODO: delete
 initPpState :: PpState
 initPpState = PpState
    { pp_defines = Map.empty
@@ -2815,90 +2817,90 @@ data ALRLayout = ALRLayoutLet
                | ALRLayoutDo
 
 -- | The parsing monad, isomorphic to @StateT PState Maybe at .
-newtype P a = P { unP :: PState -> ParseResult a }
+newtype P p a = P { unP :: PState p -> ParseResult p a }
 
-instance Functor P where
+instance Functor (P p) where
   fmap = liftM
 
-instance Applicative P where
+instance Applicative (P p) where
   pure = returnP
   (<*>) = ap
 
-instance Monad P where
+instance Monad (P p) where
   (>>=) = thenP
 
-returnP :: a -> P a
+returnP :: a -> P p a
 returnP a = a `seq` (P $ \s -> POk s a)
 
-thenP :: P a -> (a -> P b) -> P b
+thenP :: P p a -> (a -> P p b) -> P p b
 (P m) `thenP` k = P $ \ s ->
         case m s of
                 POk s1 a         -> (unP (k a)) s1
                 PFailed s1 -> PFailed s1
 
-failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a
+failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P p a
 failMsgP f = do
   pState <- getPState
   addFatalError (f (mkSrcSpanPs (last_loc pState)))
 
-failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P p a
 failLocMsgP loc1 loc2 f =
   addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))
 
-getPState :: P PState
+getPState :: P p (PState p)
 getPState = P $ \s -> POk s s
 
-getExts :: P ExtsBitmap
+getExts :: P p ExtsBitmap
 getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
 
-setExts :: (ExtsBitmap -> ExtsBitmap) -> P ()
+setExts :: (ExtsBitmap -> ExtsBitmap) -> P p ()
 setExts f = P $ \s -> POk s {
   options =
     let p = options s
     in  p { pExtsBitmap = f (pExtsBitmap p) }
   } ()
 
-setSrcLoc :: RealSrcLoc -> P ()
+setSrcLoc :: RealSrcLoc -> P p ()
 setSrcLoc new_loc =
   P $ \s@(PState{ loc = PsLoc _ buf_loc }) ->
   POk s{ loc = PsLoc new_loc buf_loc } ()
 
-getRealSrcLoc :: P RealSrcLoc
+getRealSrcLoc :: P p RealSrcLoc
 getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc)
 
-getParsedLoc :: P PsLoc
+getParsedLoc :: P p PsLoc
 getParsedLoc  = P $ \s@(PState{ loc=loc }) -> POk s loc
 
-addSrcFile :: FastString -> P ()
+addSrcFile :: FastString -> P p ()
 addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
 
-setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()
+setEofPos :: RealSrcSpan -> RealSrcSpan -> P p ()
 setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } ()
 
-setLastToken :: PsSpan -> Int -> P ()
+setLastToken :: PsSpan -> Int -> P p ()
 setLastToken loc len = P $ \s -> POk s {
   last_loc=loc,
   last_len=len
   } ()
 
-setLastTk :: PsLocated Token -> P ()
+setLastTk :: PsLocated Token -> P p ()
 setLastTk tk@(L l _) = P $ \s ->
   if isPointRealSpan (psRealSpan l)
     then POk s { last_tk = Strict.Just tk } ()
     else POk s { last_tk = Strict.Just tk
                , prev_loc = l } ()
 
-setLastComment :: PsLocated Token -> P ()
+setLastComment :: PsLocated Token -> P p ()
 setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } ()
 
-getLastTk :: P (Strict.Maybe (PsLocated Token))
+getLastTk :: P p (Strict.Maybe (PsLocated Token))
 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
 
 -- see Note [PsSpan in Comments]
-getLastLocIncludingComments :: P PsSpan
+getLastLocIncludingComments :: P p PsSpan
 getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc
 
-getLastLoc :: P PsSpan
+getLastLoc :: P p PsSpan
 getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc
 
 data AlexInput = AI !PsLoc !StringBuffer
@@ -3009,34 +3011,34 @@ alexGetChar' (AI loc s)
   where (c,s') = nextChar s
         loc'   = advancePsLoc loc c
 
-getInput :: P AlexInput
+getInput :: P p AlexInput
 getInput = P $ \s at PState{ loc=l, buffer=b } -> POk s (AI l b)
 
-setInput :: AlexInput -> P ()
+setInput :: AlexInput -> P p ()
 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
 
-nextIsEOF :: P Bool
+nextIsEOF :: P p Bool
 nextIsEOF = do
   AI _ s <- getInput
   return $ atEnd s
 
-pushLexState :: Int -> P ()
+pushLexState :: Int -> P p ()
 pushLexState ls = P $ \s at PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
 -- pushLexState ls = P $ \s at PState{ lex_state= l } -> POk s{lex_state= trace ("pushLexState:" ++ show ls) ls:l} ()
 
-popLexState :: P Int
+popLexState :: P p Int
 popLexState = P $ \s at PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
 -- popLexState = P $ \s at PState{ lex_state=ls:l } -> POk s{ lex_state= trace ("popLexState:" ++ show (ls,l)) l } ls
 
-getLexState :: P Int
+getLexState :: P p Int
 getLexState = P $ \s at PState{ lex_state=ls:_ } -> POk s ls
 
-popNextToken :: P (Maybe (PsLocated Token))
+popNextToken :: P p (Maybe (PsLocated Token))
 popNextToken
     = P $ \s at PState{ alr_next_token = m } ->
               POk (s {alr_next_token = Nothing}) m
 
-activeContext :: P Bool
+activeContext :: P p Bool
 activeContext = do
   ctxt <- getALRContext
   expc <- getAlrExpectingOCurly
@@ -3045,55 +3047,55 @@ activeContext = do
     ([],Nothing) -> return impt
     _other       -> return True
 
-resetAlrLastLoc :: FastString -> P ()
+resetAlrLastLoc :: FastString -> P 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 :: PsSpan -> P p ()
 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
 
-getAlrLastLoc :: P PsSpan
+getAlrLastLoc :: P p PsSpan
 getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
 
-getALRContext :: P [ALRContext]
+getALRContext :: P p [ALRContext]
 getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs
 
-setALRContext :: [ALRContext] -> P ()
+setALRContext :: [ALRContext] -> P p ()
 setALRContext cs = P $ \s -> POk (s {alr_context = cs}) ()
 
-getJustClosedExplicitLetBlock :: P Bool
+getJustClosedExplicitLetBlock :: P p Bool
 getJustClosedExplicitLetBlock
  = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b
 
-setJustClosedExplicitLetBlock :: Bool -> P ()
+setJustClosedExplicitLetBlock :: Bool -> P p ()
 setJustClosedExplicitLetBlock b
  = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
 
-setNextToken :: PsLocated Token -> P ()
+setNextToken :: PsLocated Token -> P p ()
 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
 
-implicitTokenPending :: P Bool
+implicitTokenPending :: P p Bool
 implicitTokenPending
     = P $ \s at PState{ alr_pending_implicit_tokens = ts } ->
               case ts of
               [] -> POk s False
               _  -> POk s True
 
-popPendingImplicitToken :: P (Maybe (PsLocated Token))
+popPendingImplicitToken :: P p (Maybe (PsLocated Token))
 popPendingImplicitToken
     = P $ \s at PState{ alr_pending_implicit_tokens = ts } ->
               case ts of
               [] -> POk s Nothing
               (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
 
-setPendingImplicitTokens :: [PsLocated Token] -> P ()
+setPendingImplicitTokens :: [PsLocated Token] -> P p ()
 setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
 
-getAlrExpectingOCurly :: P (Maybe ALRLayout)
+getAlrExpectingOCurly :: P p (Maybe ALRLayout)
 getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b
 
-setAlrExpectingOCurly :: Maybe ALRLayout -> P ()
+setAlrExpectingOCurly :: Maybe ALRLayout -> P p ()
 setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 
 -- | For reasons of efficiency, boolean parsing flags (eg, language extensions
@@ -3270,15 +3272,15 @@ disableHaddock opts = upd_bitmap (xunset HaddockBit)
 
 
 -- | Set parser options for parsing OPTIONS pragmas
-initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
-initPragState options buf loc = (initParserState options buf loc)
+initPragState :: p -> ParserOpts -> StringBuffer -> RealSrcLoc -> PState p
+initPragState p options buf loc = (initParserState p options buf loc)
 -- initPragState options buf loc = (initParserState options buf (trace ("initPragState:" ++ show bol) loc))
    { lex_state = [bol, option_prags, 0]
    }
 
 -- | Creates a parse state from a 'ParserOpts' value
-initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState
-initParserState options buf loc =
+initParserState :: p -> ParserOpts -> StringBuffer -> RealSrcLoc -> PState p
+initParserState ppState options buf loc =
   PState {
       buffer        = buf,
       options       = options,
@@ -3304,7 +3306,8 @@ initParserState options buf loc =
       header_comments = Strict.Nothing,
       comment_q = [],
       hdk_comments = nilOL,
-      pp = initPpState
+      -- pp = initPpState
+      pp = ppState
     }
   where init_loc = PsLoc loc (BufPos 0)
 
@@ -3352,7 +3355,7 @@ class Monad m => MonadP m where
   -- that come after the given span
   allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments
 
-instance MonadP P where
+instance MonadP (P p) where
   addError err
    = P $ \s -> POk s { errors = err `addMessage` errors s} ()
 
@@ -3399,15 +3402,15 @@ getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments
 getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l
 getFinalCommentsFor _ = return emptyComments
 
-getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))
+getEofPos :: P p (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))
 getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos
 
-addPsMessage :: SrcSpan -> PsMessage -> P ()
+addPsMessage :: SrcSpan -> PsMessage -> P p ()
 addPsMessage srcspan msg = do
   diag_opts <- (pDiagOpts . options) <$> getPState
   addWarning (mkPlainMsgEnvelope diag_opts srcspan msg)
 
-addTabWarning :: RealSrcSpan -> P ()
+addTabWarning :: RealSrcSpan -> P p ()
 addTabWarning srcspan
  = P $ \s at PState{tab_first=tf, tab_count=tc, options=o} ->
        let tf' = tf <|> Strict.Just srcspan
@@ -3419,12 +3422,12 @@ addTabWarning srcspan
 
 -- | Get a bag of the errors that have been accumulated so far.
 --   Does not take -Werror into account.
-getPsErrorMessages :: PState -> Messages PsMessage
+getPsErrorMessages :: PState p -> Messages PsMessage
 getPsErrorMessages p = errors p
 
 -- | Get the warnings and errors accumulated so far.
 --   Does not take -Werror into account.
-getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage)
+getPsMessages :: PState p -> (Messages PsMessage, Messages PsMessage)
 getPsMessages p =
   let ws = warnings p
       diag_opts = pDiagOpts (options p)
@@ -3439,13 +3442,13 @@ getPsMessages p =
           in msg `addMessage` ws
   in (ws', errors p)
 
-getContext :: P [LayoutContext]
+getContext :: P p [LayoutContext]
 getContext = P $ \s at PState{context=ctx} -> POk s ctx
 
-setContext :: [LayoutContext] -> P ()
+setContext :: [LayoutContext] -> P p ()
 setContext ctx = P $ \s -> POk s{context=ctx} ()
 
-popContext :: P ()
+popContext :: P p ()
 popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
                               last_len = len, last_loc = last_loc }) ->
   case ctx of
@@ -3455,16 +3458,16 @@ popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx,
           unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s
 
 -- Push a new layout context at the indentation of the last token read.
-pushCurrentContext :: GenSemic -> P ()
+pushCurrentContext :: GenSemic -> P p ()
 pushCurrentContext gen_semic = P $ \ s at PState{ last_loc=loc, context=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.
-pushModuleContext :: P ()
+pushModuleContext :: P p ()
 pushModuleContext = pushCurrentContext generateSemic
 
-getOffside :: P (Ordering, Bool)
+getOffside :: P p (Ordering, Bool)
 getOffside = P $ \s at PState{last_loc=loc, context=stk} ->
                 let offs = srcSpanStartCol (psRealSpan loc) in
                 let ord = case stk of
@@ -3504,14 +3507,14 @@ srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token
 -- Report a parse failure, giving the span of the previous token as
 -- the location of the error.  This is the entry point for errors
 -- detected during parsing.
-srcParseFail :: P a
+srcParseFail :: P p a
 srcParseFail = P $ \s at PState{ buffer = buf, options = o, last_len = len,
                             last_loc = last_loc } ->
     unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s
 
 -- A lexical error is reported at a particular position in the source file,
 -- not over a token range.
-lexError :: LexErr -> P a
+lexError :: LexErr -> P p a
 lexError e = do
   loc <- getRealSrcLoc
   (AI end buf) <- getInput
@@ -3522,7 +3525,7 @@ lexError e = do
 -- This is the top-level function: called from the parser each time a
 -- new token is to be read from the input.
 
-lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a
+lexer, lexerDbg :: Bool -> (Located Token -> P p a) -> P p a
 
 lexer queueComments cont = do
   alr <- getBit AlternativeLayoutRuleBit
@@ -3539,7 +3542,7 @@ lexerDbg queueComments cont = lexer queueComments contDbg
   where
     contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok)
 
-lexTokenAlr :: P (PsLocated Token)
+lexTokenAlr :: P p (PsLocated Token)
 lexTokenAlr = do mPending <- popPendingImplicitToken
                  t <- case mPending of
                       Nothing ->
@@ -3563,7 +3566,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
                      _        -> return ()
                  return t
 
-alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)
+alternativeLayoutRuleToken :: PsLocated Token -> P p (PsLocated Token)
 alternativeLayoutRuleToken t
     = do context <- getALRContext
          lastLoc <- getAlrLastLoc
@@ -3754,7 +3757,7 @@ topNoLayoutContainsCommas [] = False
 topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
 topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
 
-lexToken :: P (PsLocated Token)
+lexToken :: P p (PsLocated Token)
 lexToken = do
   inp@(AI loc1 buf) <- getInput
   sc <- getLexState
@@ -3787,7 +3790,7 @@ reportLexError :: RealSrcLoc
                -> RealSrcLoc
                -> StringBuffer
                -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage)
-               -> P a
+               -> P p a
 reportLexError loc1 loc2 buf f
   | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)
   | otherwise =
@@ -3796,14 +3799,14 @@ reportLexError loc1 loc2 buf f
      then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)
      else failLocMsgP loc1 loc2 (f (LexErrKind_Char c))
 
-lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]
-lexTokenStream opts buf loc = unP go initState{ options = opts' }
+lexTokenStream :: p -> ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult p [Located Token]
+lexTokenStream pp opts buf loc = unP go initState{ options = opts' }
     where
     new_exts  =   xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens
                 $ xset RawTokenStreamBit -- include comments
                 $ pExtsBitmap opts
     opts'     = opts { pExtsBitmap = new_exts }
-    initState = initParserState opts' buf loc
+    initState = initParserState pp opts' buf loc
     go = do
       ltok <- lexer False return
       case ltok of
@@ -3866,13 +3869,13 @@ twoWordPrags = Map.fromList [
          fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
      ]
 
-dispatch_pragmas :: Map String Action -> Action
+dispatch_pragmas :: Map String (Action p) -> Action p
 dispatch_pragmas prags span buf len buf2 =
   case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
     Just found -> found span buf len buf2
     Nothing -> lexError LexUnknownPragma
 
-known_pragma :: Map String Action -> AlexAccPred ExtsBitmap
+known_pragma :: Map String (Action p) -> AlexAccPred ExtsBitmap
 known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)
  = isKnown && nextCharIsNot curbuf pragmaNameChar
     where l = lexemeToString startbuf (byteDiff startbuf curbuf)
@@ -3891,7 +3894,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
                                               _ -> prag'
                           canon_ws s = unwords (map canonical (words s))
 
-warn_unknown_prag :: Map String Action -> Action
+warn_unknown_prag :: Map String (Action p) -> Action p
 warn_unknown_prag prags span buf len buf2 = do
   let uppercase    = map toUpper
       unknown_prag = uppercase (clean_pragma (lexemeToString buf len))
@@ -3923,12 +3926,12 @@ mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCl
     lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))
     lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)
 
-queueComment :: RealLocated Token -> P()
+queueComment :: RealLocated Token -> P p ()
 queueComment c = P $ \s -> POk s {
   comment_q = commentToAnnotation c : comment_q s
   } ()
 
-queueIgnoredToken :: PsLocated Token -> P()
+queueIgnoredToken :: PsLocated Token -> P p ()
 queueIgnoredToken (L l tok) = do
   ll <- getLastLocIncludingComments
   let


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -195,7 +195,7 @@ mkClassDecl :: SrcSpan
             -> OrdList (LHsDecl GhcPs)
             -> LayoutInfo GhcPs
             -> [AddEpAnn]
-            -> P (LTyClDecl GhcPs)
+            -> P p (LTyClDecl GhcPs)
 
 mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn
   = do { let loc = noAnnSrcSpan loc'
@@ -224,7 +224,7 @@ mkTyData :: SrcSpan
          -> [LConDecl GhcPs]
          -> Located (HsDeriving GhcPs)
          -> [AddEpAnn]
-         -> P (LTyClDecl GhcPs)
+         -> P p (LTyClDecl GhcPs)
 mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
          ksig data_cons (L _ maybe_deriv) annsIn
   = do { let loc = noAnnSrcSpan loc'
@@ -244,7 +244,7 @@ mkDataDefn :: Maybe (LocatedP CType)
            -> Maybe (LHsKind GhcPs)
            -> DataDefnCons (LConDecl GhcPs)
            -> HsDeriving GhcPs
-           -> P (HsDataDefn GhcPs)
+           -> P p (HsDataDefn GhcPs)
 mkDataDefn cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
        ; return (HsDataDefn { dd_ext = noExtField
@@ -258,7 +258,7 @@ mkTySynonym :: SrcSpan
             -> LHsType GhcPs  -- LHS
             -> LHsType GhcPs  -- RHS
             -> [AddEpAnn]
-            -> P (LTyClDecl GhcPs)
+            -> P p (LTyClDecl GhcPs)
 mkTySynonym loc lhs rhs annsIn
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]
@@ -276,7 +276,7 @@ mkStandaloneKindSig
   -> Located [LocatedN RdrName]   -- LHS
   -> LHsSigType GhcPs             -- RHS
   -> [AddEpAnn]
-  -> P (LStandaloneKindSig GhcPs)
+  -> P p (LStandaloneKindSig GhcPs)
 mkStandaloneKindSig loc lhs rhs anns =
   do { vs <- mapM check_lhs_name (unLoc lhs)
      ; v <- check_singular_lhs (reverse vs)
@@ -301,7 +301,7 @@ mkTyFamInstEqn :: SrcSpan
                -> LHsType GhcPs
                -> LHsType GhcPs
                -> [AddEpAnn]
-               -> P (LTyFamInstEqn GhcPs)
+               -> P p (LTyFamInstEqn GhcPs)
 mkTyFamInstEqn loc bndrs lhs rhs anns
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; cs <- getCommentsFor loc
@@ -322,7 +322,7 @@ mkDataFamInst :: SrcSpan
               -> [LConDecl GhcPs]
               -> Located (HsDeriving GhcPs)
               -> [AddEpAnn]
-              -> P (LInstDecl GhcPs)
+              -> P p (LInstDecl GhcPs)
 mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
               ksig data_cons (L _ maybe_deriv) anns
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
@@ -357,7 +357,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
 mkTyFamInst :: SrcSpan
             -> TyFamInstEqn GhcPs
             -> [AddEpAnn]
-            -> P (LInstDecl GhcPs)
+            -> P p (LInstDecl GhcPs)
 mkTyFamInst loc eqn anns = do
   cs <- getCommentsFor loc
   return (L (noAnnSrcSpan loc) (TyFamInstD noExtField
@@ -370,7 +370,7 @@ mkFamDecl :: SrcSpan
           -> LFamilyResultSig GhcPs          -- Optional result signature
           -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation
           -> [AddEpAnn]
-          -> P (LTyClDecl GhcPs)
+          -> P p (LTyClDecl GhcPs)
 mkFamDecl loc info topLevel lhs ksig injAnn annsIn
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]
@@ -392,7 +392,7 @@ mkFamDecl loc info topLevel lhs ksig injAnn annsIn
                         OpenTypeFamily      -> empty
                         ClosedTypeFamily {} -> whereDots
 
-mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
+mkSpliceDecl :: LHsExpr GhcPs -> P p (LHsDecl GhcPs)
 -- If the user wrote
 --      [pads| ... ]   then return a QuasiQuoteD
 --      $(e)           then return a SpliceD
@@ -421,7 +421,7 @@ mkRoleAnnotDecl :: SrcSpan
                 -> LocatedN RdrName                -- type being annotated
                 -> [Located (Maybe FastString)]    -- roles
                 -> [AddEpAnn]
-                -> P (LRoleAnnotDecl GhcPs)
+                -> P p (LRoleAnnotDecl GhcPs)
 mkRoleAnnotDecl loc tycon roles anns
   = do { roles' <- mapM parse_role roles
        ; cs <- getCommentsFor loc
@@ -446,20 +446,20 @@ mkRoleAnnotDecl loc tycon roles anns
 -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
 -- binders without annotations. Only accepts specified variables, and errors if
 -- any of the provided binders has an 'InferredSpec' annotation.
-fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]
+fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P p [LHsTyVarBndr () GhcPs]
 fromSpecTyVarBndrs = mapM fromSpecTyVarBndr
 
 -- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without
 -- annotations. Only accepts specified variables, and errors if the provided
 -- binder has an 'InferredSpec' annotation.
-fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)
+fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P p (LHsTyVarBndr () GhcPs)
 fromSpecTyVarBndr bndr = case bndr of
   (L loc (UserTyVar xtv flag idp))     -> (check_spec flag loc)
                                           >> return (L loc $ UserTyVar xtv () idp)
   (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)
                                           >> return (L loc $ KindedTyVar xtv () idp k)
   where
-    check_spec :: Specificity -> SrcSpanAnnA -> P ()
+    check_spec :: Specificity -> SrcSpanAnnA -> P p ()
     check_spec SpecifiedSpec _   = return ()
     check_spec InferredSpec  loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
                                      PsErrInferredTypeVarNotAllowed
@@ -527,7 +527,7 @@ cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
 cvTopDecls decls = getMonoBindAll (fromOL decls)
 
 -- Declaration list may only contain value bindings and signatures.
-cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
+cvBindGroup :: OrdList (LHsDecl GhcPs) -> P p (HsValBinds GhcPs)
 cvBindGroup binding
   = do { (mbs, sigs, fam_ds, tfam_insts
          , dfam_insts, _) <- cvBindsAndSigs binding
@@ -535,7 +535,7 @@ cvBindGroup binding
        ; return $ ValBinds NoAnnSortKey mbs sigs }
 
 cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
-  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
+  -> P p (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
           , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
@@ -733,7 +733,7 @@ tyConToDataCon (L loc tc)
 
 mkPatSynMatchGroup :: LocatedN RdrName
                    -> LocatedL (OrdList (LHsDecl GhcPs))
-                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))
+                   -> P p (MatchGroup GhcPs (LHsExpr GhcPs))
 mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
     do { matches <- mapM fromDecl (fromOL decls)
        ; when (null matches) (wrongNumberErr (locA loc))
@@ -779,7 +779,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
       addFatalError $ mkPlainErrorMsgEnvelope loc $
         (PsErrEmptyWhereInPatSynDecl patsyn_name)
 
-recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a
+recordPatSynErr :: SrcSpan -> LPat GhcPs -> P p a
 recordPatSynErr loc pat =
     addFatalError $ mkPlainErrorMsgEnvelope loc $
       (PsErrRecordSyntaxInPatSynDecl pat)
@@ -808,7 +808,7 @@ mkGadtDecl :: SrcSpan
            -> NonEmpty (LocatedN RdrName)
            -> LHsUniToken "::" "∷" GhcPs
            -> LHsSigType GhcPs
-           -> P (LConDecl GhcPs)
+           -> P p (LConDecl GhcPs)
 mkGadtDecl loc names dcol ty = do
   cs <- getCommentsFor loc
   let l = noAnnSrcSpan loc
@@ -935,7 +935,7 @@ eitherToP (Left err)    = addFatalError err
 eitherToP (Right thing) = return thing
 
 checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]
-            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables
+            -> P p (LHsQTyVars GhcPs)  -- the synthesized type variables
 -- ^ Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).
 checkTyVars pp_what equals_or_where tc tparms
@@ -948,7 +948,7 @@ checkTyVars pp_what equals_or_where tc tparms
                             (PsErrMalformedDecl pp_what (unLoc tc))
         -- Keep around an action for adjusting the annotations of extra parens
     chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs
-              -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
+              -> P p (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
     chkParens ops cps cs bvis (L l (HsParTy an ty))
       = let
           (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
@@ -957,7 +957,7 @@ checkTyVars pp_what equals_or_where tc tparms
     chkParens ops cps cs bvis ty = chk ops cps cs bvis ty
 
         -- Check that the name space is correct!
-    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
+    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P p (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
     chk ops cps cs bvis (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))
         | isRdrTyVar tv
             = let
@@ -993,7 +993,7 @@ whereDots, equalsDots :: SDoc
 whereDots  = text "where ..."
 equalsDots = text "= ..."
 
-checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
+checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P p ()
 checkDatatypeContext Nothing = return ()
 checkDatatypeContext (Just c)
     = do allowed <- getBit DatatypeContextsBit
@@ -1023,7 +1023,7 @@ mkRuleTyVarBndrs = fmap cvt_one
         tm_to_ty _ = panic "mkRuleTyVarBndrs"
 
 -- See Note [Parsing explicit foralls in Rules] in Parser.y
-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
+checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P p ()
 checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
   where check (L loc (Unqual occ)) =
           when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"])
@@ -1041,7 +1041,7 @@ checkRecordSyntax lr@(L loc r)
 -- | Check if the gadt_constrlist is empty. Only raise parse error for
 -- `data T where` to avoid affecting existing error message, see #8258.
 checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])
-                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))
+                -> P p (Located ([AddEpAnn], [LConDecl GhcPs]))
 checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.
     = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax
          unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $
@@ -1052,10 +1052,10 @@ checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.
 checkTyClHdr :: Bool               -- True  <=> class header
                                    -- False <=> type header
              -> LHsType GhcPs
-             -> P (LocatedN RdrName,     -- the head symbol (type or class name)
-                   [LHsTypeArg GhcPs],   -- parameters of head symbol
-                   LexicalFixity,        -- the declaration is in infix format
-                   [AddEpAnn])           -- API Annotation for HsParTy
+             -> P p (LocatedN RdrName,     -- the head symbol (type or class name)
+                    [LHsTypeArg GhcPs],   -- parameters of head symbol
+                    LexicalFixity,        -- the declaration is in infix format
+                    [AddEpAnn])           -- API Annotation for HsParTy
                                          -- when stripping parens
 -- Well-formedness check and decomposition of type and class heads.
 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
@@ -1152,12 +1152,12 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
 --     (Eq a)               -->  [Eq a]
 --     (((Eq a)))           -->  [Eq a]
 -- @
-checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
+checkContext :: LHsType GhcPs -> P p (LHsContext GhcPs)
 checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =
   check ([],[],emptyComments) orig_t
  where
   check :: ([EpaLocation],[EpaLocation],EpAnnComments)
-        -> LHsType GhcPs -> P (LHsContext GhcPs)
+        -> LHsType GhcPs -> P p (LHsContext GhcPs)
   check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))
     -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
     -- be used as context constraints.
@@ -1184,7 +1184,7 @@ checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =
 
 checkImportDecl :: Maybe EpaLocation
                 -> Maybe EpaLocation
-                -> P ()
+                -> P p ()
 checkImportDecl mPre mPost = do
   let whenJust mg f = maybe (pure ()) f mg
 
@@ -1213,10 +1213,10 @@ checkImportDecl mPre mPost = do
 -- We parse patterns as expressions and check for valid patterns below,
 -- converting the expression into a pattern at the same time.
 
-checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)
+checkPattern :: LocatedA (PatBuilder GhcPs) -> P p (LPat GhcPs)
 checkPattern = runPV . checkLPat
 
-checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)
+checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P p (LPat GhcPs)
 checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
 
 checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
@@ -1320,7 +1320,7 @@ checkValDef :: SrcSpan
             -> LocatedA (PatBuilder GhcPs)
             -> Maybe (AddEpAnn, LHsType GhcPs)
             -> Located (GRHSs GhcPs (LHsExpr GhcPs))
-            -> P (HsBind GhcPs)
+            -> P p (HsBind GhcPs)
 
 checkValDef loc lhs (Just (sigAnn, sig)) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
@@ -1345,7 +1345,7 @@ checkFunBind :: SrcStrictness
              -> LexicalFixity
              -> [LocatedA (PatBuilder GhcPs)]
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
-             -> P (HsBind GhcPs)
+             -> P p (HsBind GhcPs)
 checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
   = do  ps <- runPV_details extraDetails (mapM checkLPat pats)
         let match_span = noAnnSrcSpan $ locF
@@ -1378,7 +1378,7 @@ checkPatBind :: SrcSpan
              -> [AddEpAnn]
              -> LPat GhcPs
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
-             -> P (HsBind GhcPs)
+             -> P p (HsBind GhcPs)
 checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))
                         (L _match_span grhss)
       = return (makeFunBind v (L (noAnnSrcSpan loc)
@@ -1395,7 +1395,7 @@ checkPatBind loc annsIn lhs (L _ grhss) = do
   cs <- getCommentsFor loc
   return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss)
 
-checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
+checkValSigLhs :: LHsExpr GhcPs -> P p (LocatedN RdrName)
 checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
   | isUnqual v
   , not (isDataOcc (rdrNameOcc v))
@@ -1420,8 +1420,8 @@ checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr
   | otherwise = return ()
 
 isFunLhs :: LocatedA (PatBuilder GhcPs)
-      -> P (Maybe (LocatedN RdrName, LexicalFixity,
-                   [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))
+      -> P p (Maybe (LocatedN RdrName, LexicalFixity,
+                    [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))
 -- A variable binding is parsed as a FunBind.
 -- Just (fun, is_infix, arg_pats) if e is a function LHS
 isFunLhs e = go e [] [] []
@@ -2558,7 +2558,7 @@ pattern match on the pattern stored inside 'PatBuilderPat'.
 checkPrecP
         :: Located (SourceText,Int)              -- ^ precedence
         -> Located (OrdList (LocatedN RdrName))  -- ^ operators
-        -> P ()
+        -> P p ()
 checkPrecP (L l (_,i)) (L _ ol)
  | 0 <= i, i <= maxPrecedence = pure ()
  | all specialOp ol = pure ()
@@ -2694,7 +2694,7 @@ mkOpaquePragma src
                  }
 
 checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]
-               -> P (DataDefnCons (LConDecl GhcPs))
+               -> P p (DataDefnCons (LConDecl GhcPs))
 checkNewOrData span name is_type_data = curry $ \ case
     (NewType, [a]) -> pure $ NewTypeCon a
     (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)
@@ -2723,7 +2723,7 @@ checkNewOrData span name is_type_data = curry $ \ case
 mkImport :: Located CCallConv
          -> Located Safety
          -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
+         -> P p (EpAnn [AddEpAnn] -> HsDecl GhcPs)
 mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
     case unLoc cconv of
       CCallConv          -> returnSpec =<< mkCImport
@@ -2833,7 +2833,7 @@ parseCImport cconv safety nm str sourceText =
 --
 mkExport :: Located CCallConv
          -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)
-         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
+         -> P p (EpAnn [AddEpAnn] -> HsDecl GhcPs)
 mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
  = return $ \ann -> ForD noExtField $
    ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
@@ -2864,7 +2864,7 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
                   | ImpExpQcWildcard
 
 mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec
-               -> ImpExpSubSpec -> P (IE GhcPs)
+               -> ImpExpSubSpec -> P p (IE GhcPs)
 mkModuleImpExp warning anns (L l specname) subs = do
   cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments
   let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs
@@ -2912,12 +2912,12 @@ mkModuleImpExp warning anns (L l specname) subs = do
     wrapped = map (fmap ieNameFromSpec)
 
 mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space
-             -> P (LocatedN RdrName)
+             -> P p (LocatedN RdrName)
 mkTypeImpExp name =
   do requireExplicitNamespaces (getLocA name)
      return (fmap (`setRdrNameSpace` tcClsName) name)
 
-checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])
+checkImportSpec :: LocatedL [LIE GhcPs] -> P p (LocatedL [LIE GhcPs])
 checkImportSpec ie@(L _ specs) =
     case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of
       [] -> return ie
@@ -2927,7 +2927,7 @@ checkImportSpec ie@(L _ specs) =
       addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm
 
 -- In the correct order
-mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)
+mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P p ([AddEpAnn], ImpExpSubSpec)
 mkImpExpSubSpec [] = return ([], ImpExpList [])
 mkImpExpSubSpec [L la ImpExpQcWildcard] =
   return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll)
@@ -2943,19 +2943,19 @@ isImpExpQcWildcard _                = False
 -----------------------------------------------------------------------------
 -- Warnings and failures
 
-warnPrepositiveQualifiedModule :: SrcSpan -> P ()
+warnPrepositiveQualifiedModule :: SrcSpan -> P p ()
 warnPrepositiveQualifiedModule span =
   addPsMessage span PsWarnImportPreQualified
 
-failNotEnabledImportQualifiedPost :: SrcSpan -> P ()
+failNotEnabledImportQualifiedPost :: SrcSpan -> P p ()
 failNotEnabledImportQualifiedPost loc =
   addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified
 
-failImportQualifiedTwice :: SrcSpan -> P ()
+failImportQualifiedTwice :: SrcSpan -> P p ()
 failImportQualifiedTwice loc =
   addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice
 
-warnStarIsType :: SrcSpan -> P ()
+warnStarIsType :: SrcSpan -> P p ()
 warnStarIsType span = addPsMessage span PsWarnStarIsType
 
 failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
@@ -3023,13 +3023,13 @@ instance Monad PV where
       PV_Ok acc' a -> unPV (f a) ctx acc'
       PV_Failed acc' -> PV_Failed acc'
 
-runPV :: PV a -> P a
+runPV :: PV a -> P p a
 runPV = runPV_details noParseContext
 
 askParseContext :: PV ParseContext
 askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details
 
-runPV_details :: ParseContext -> PV a -> P a
+runPV_details :: ParseContext -> PV a -> P p a
 runPV_details details m =
   P $ \s ->
     let


=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -180,7 +180,7 @@ we have to use 'flattenBindsAndSigs' to traverse it in the correct order.
 -- to a parsed HsModule.
 --
 -- Reports badly positioned comments when -Winvalid-haddock is enabled.
-addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs))
+addHaddockToModule :: Located (HsModule GhcPs) -> P p (Located (HsModule GhcPs))
 addHaddockToModule lmod = do
   pState <- getPState
   let all_comments = toList (hdk_comments pState)
@@ -192,7 +192,7 @@ addHaddockToModule lmod = do
   mapM_ reportHdkWarning hdk_warnings
   return lmod'
 
-reportHdkWarning :: HdkWarn -> P ()
+reportHdkWarning :: HdkWarn -> P p ()
 reportHdkWarning (HdkWarnInvalidComment (L l _)) =
   addPsMessage (mkSrcSpanPs l) PsWarnHaddockInvalidPos
 reportHdkWarning (HdkWarnExtraComment (L l _)) =


=====================================
compiler/GHC/Parser/PreProcess.hs
=====================================
@@ -8,13 +8,19 @@ module GHC.Parser.PreProcess (
     -- ppLexerDbg,
     lexer,
     lexerDbg,
+    initPpState,
+    initParserState,
+    initPragState,
+    PpState
 ) where
 
 import Data.Char
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Debug.Trace (trace)
 import GHC.Data.FastString
 import qualified GHC.Data.Strict as Strict
+import GHC.Data.StringBuffer
 import GHC.Parser.Errors.Ppr ()
 import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..), PpState (..), Token (..))
 import qualified GHC.Parser.Lexer as Lexer
@@ -23,7 +29,26 @@ import GHC.Types.SrcLoc
 
 -- ---------------------------------------------------------------------
 
-lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a
+-- | Set parser options for parsing OPTIONS pragmas
+initPragState :: Lexer.ParserOpts -> StringBuffer -> RealSrcLoc -> PState PpState
+initPragState = Lexer.initPragState initPpState
+
+-- | Creates a parse state from a 'ParserOpts' value
+initParserState :: Lexer.ParserOpts -> StringBuffer -> RealSrcLoc -> PState PpState
+initParserState = Lexer.initParserState initPpState
+
+initPpState :: PpState
+initPpState =
+    PpState
+        { pp_defines = Map.empty
+        , pp_continuation = []
+        , pp_context = []
+        , pp_accepting = True
+        }
+
+-- ---------------------------------------------------------------------
+
+lexer, lexerDbg :: Bool -> (Located Token -> P PpState a) -> P PpState a
 -- bypass for now, work in ghci
 lexer = Lexer.lexer
 lexerDbg = Lexer.lexerDbg
@@ -141,11 +166,11 @@ lexerDbg = Lexer.lexerDbg
 --          in
 --             POk s r
 
-setAccepting :: Bool -> P ()
+setAccepting :: Bool -> P PpState ()
 setAccepting on =
     P $ \s -> POk s{pp = (pp s){pp_accepting = on}} ()
 
-getAccepting :: P Bool
+getAccepting :: P PpState Bool
 getAccepting = P $ \s -> POk s (pp_accepting (pp s))
 
 -- pp_context stack end -------------------


=====================================
compiler/GHC/Parser/Utils.hs
=====================================
@@ -12,7 +12,8 @@ import GHC.Data.StringBuffer
 import GHC.Data.FastString
 import GHC.Types.SrcLoc
 
-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)
+import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP )
+import qualified GHC.Parser.PreProcess as Lexer  (initParserState, PpState)
 import GHC.Parser.Lexer (ParserOpts)
 import qualified GHC.Parser       as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
 
@@ -50,7 +51,7 @@ isDecl pflags stmt =
         _ -> True
     Lexer.PFailed _ -> False
 
-parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
+parseThing :: Lexer.P Lexer.PpState thing -> ParserOpts -> String -> Lexer.ParseResult Lexer.PpState thing
 parseThing parser opts stmt = do
   let buf = stringToStringBuffer stmt
       loc = mkRealSrcLoc (fsLit "<interactive>") 1 1


=====================================
ghc/GHCi/UI.hs
=====================================
@@ -77,7 +77,8 @@ import GHC.Builtin.Names
 import GHC.Builtin.Types( stringTyCon_RDR )
 import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )
 import GHC.Types.SrcLoc as SrcLoc
-import qualified GHC.Parser.Lexer as Lexer
+import qualified GHC.Parser.Lexer as Lexer hiding (initParserState)
+import qualified GHC.Parser.PreProcess as Lexer  (initParserState)
 import GHC.Parser.Header ( toArgs )
 import qualified GHC.Parser.Header as Header
 import GHC.Types.PkgQual


=====================================
utils/check-cpp/Main.hs
=====================================
@@ -21,7 +21,8 @@ import qualified GHC.LanguageExtensions as LangExt
 import GHC.Parser.Errors.Ppr ()
 import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..), PpState (..), Token (..))
 import qualified GHC.Parser.Lexer as GHC
-import qualified GHC.Parser.Lexer as Lexer
+import qualified GHC.Parser.Lexer as Lexer hiding (initParserState)
+import qualified GHC.Parser.PreProcess as Lexer  (initParserState)
 import GHC.Types.Error
 import GHC.Types.SrcLoc
 import GHC.Utils.Error
@@ -49,7 +50,11 @@ showAst ast =
 
 -- =====================================================================
 
-ppLexer, ppLexerDbg :: Bool -> (Located Token -> P a) -> P a
+type PP = P PpState
+
+-- =====================================================================
+
+ppLexer, ppLexerDbg :: Bool -> (Located Token -> PP a) -> PP a
 -- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging.
 ppLexerDbg queueComments cont = ppLexer queueComments contDbg
   where
@@ -82,17 +87,17 @@ ppLexer queueComments cont =
                             _ -> contInner tk
         )
 
-preprocessElse :: P ()
+preprocessElse :: PP ()
 preprocessElse = do
     accepting <- getAccepting
     setAccepting (not accepting)
 
-preprocessEnd :: P ()
+preprocessEnd :: PP ()
 preprocessEnd = do
     -- TODO: nested context
     setAccepting True
 
-processCppToks :: FastString -> P ()
+processCppToks :: FastString -> PP ()
 processCppToks fs = do
     let
         get (L _ (ITcpp _ s)) = s
@@ -102,7 +107,7 @@ processCppToks fs = do
     processCpp (reverse $ fs : map get cs)
     return ()
 
-processCpp :: [FastString] -> P ()
+processCpp :: [FastString] -> PP ()
 processCpp fs = do
     -- traceM $ "processCpp: fs=" ++ show fs
     -- let s = cppInitial fs
@@ -136,7 +141,7 @@ data CppState
     | CppNormal
     deriving (Show)
 
-getCppState :: P CppState
+getCppState :: PP CppState
 getCppState = do
     accepting <- getAccepting
     if accepting
@@ -145,11 +150,11 @@ getCppState = do
 
 -- pp_context stack start -----------------
 
-pushContext :: Token -> P ()
+pushContext :: Token -> PP ()
 pushContext new =
     P $ \s -> POk s{pp = (pp s){pp_context = new : pp_context (pp s)}} ()
 
-popContext :: P ()
+popContext :: PP ()
 popContext =
     P $ \s ->
         let
@@ -159,7 +164,7 @@ popContext =
          in
             POk s{pp = (pp s){pp_context = new_context}} ()
 
-peekContext :: P Token
+peekContext :: PP Token
 peekContext =
     P $ \s ->
         let
@@ -169,20 +174,20 @@ peekContext =
          in
             POk s r
 
-setAccepting :: Bool -> P ()
+setAccepting :: Bool -> PP ()
 setAccepting on =
     P $ \s -> POk s{pp = (pp s){pp_accepting = on}} ()
 
-getAccepting :: P Bool
+getAccepting :: PP Bool
 getAccepting = P $ \s -> POk s (pp_accepting (pp s))
 
 -- -------------------------------------
 
-pushContinuation :: Located Token -> P ()
+pushContinuation :: Located Token -> PP ()
 pushContinuation new =
     P $ \s -> POk s{pp = (pp s){pp_continuation = new : pp_continuation (pp s)}} ()
 
-popContinuation :: P [Located Token]
+popContinuation :: PP [Located Token]
 popContinuation =
     P $ \s -> POk s{pp = (pp s){pp_continuation = []}} (pp_continuation (pp s))
 
@@ -190,12 +195,12 @@ popContinuation =
 
 -- definitions start --------------------
 
-ppDefine :: String -> [String] -> P ()
+ppDefine :: String -> [String] -> PP ()
 ppDefine name val = P $ \s ->
     -- POk s{pp = (pp s){pp_defines = Set.insert (cleanTokenString def) (pp_defines (pp s))}} ()
     POk s{pp = (pp s){pp_defines = Map.insert (trace ("ppDefine:def=[" ++ name ++ "]") name) val (pp_defines (pp s))}} ()
 
-ppIsDefined :: String -> P Bool
+ppIsDefined :: String -> PP Bool
 ppIsDefined def = P $ \s ->
     -- POk s (Map.member def (pp_defines (pp s)))
     POk s (Map.member (trace ("ppIsDefined:def=[" ++ def ++ "]") def) (pp_defines (pp s)))
@@ -415,16 +420,16 @@ ghcWrapper libdir a =
 
 -- ---------------------------------------------------------------------
 
-parseModuleNoHaddock :: P [Located Token]
+parseModuleNoHaddock :: PP [Located Token]
 parseModuleNoHaddock = happySomeParser
   where
     -- happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap35 x') = happyOut35 x} in x'))
     happySomeParser = (>>=) (happyParse 0) (\x -> return x)
 
-happyParse :: Int -> P [Located Token]
+happyParse :: Int -> PP [Located Token]
 happyParse start_state = happyNewToken start_state [] []
 
-happyNewToken :: Int -> [Int] -> [Located Token] -> P [Located Token]
+happyNewToken :: Int -> [Int] -> [Located Token] -> PP [Located Token]
 happyNewToken action sts stk =
     -- lexer
     ppLexerDbg
@@ -439,7 +444,7 @@ happyNewToken action sts stk =
                     -- _ -> happyError' (tk, [])
         )
 
-happyDoAction :: Int -> Located Token -> Int -> [Int] -> [Located Token] -> P [Located Token]
+happyDoAction :: Int -> Located Token -> Int -> [Int] -> [Located Token] -> PP [Located Token]
 -- happyDoAction num tk action sts stk = P $ \s -> POk s tk
 happyDoAction num tk action sts stk =
     case num of
@@ -455,7 +460,7 @@ happyDoAction num tk action sts stk =
 -- happyAccept j tk st sts (HappyStk ans _) =
 --         (happyTcHack j (happyTcHack st)) (happyReturn1 ans)
 
-happyAccept :: Int -> Located Token -> Int -> [Int] -> [Located Token] -> P [Located Token]
+happyAccept :: Int -> Located Token -> Int -> [Int] -> [Located Token] -> PP [Located Token]
 happyAccept _j tk _st _sts stk =
     trace ("happyAccept:" ++ show tk)
         $ return stk
@@ -463,28 +468,28 @@ happyAccept _j tk _st _sts stk =
 -- happyReturn1 :: a -> P a
 -- happyReturn1 = return
 
-happyShift :: Int -> Int -> Located Token -> Int -> [Int] -> [Located Token] -> P [Located Token]
+happyShift :: Int -> Int -> Located Token -> Int -> [Int] -> [Located Token] -> PP [Located Token]
 happyShift new_state _i tk st sts stk = do
     happyNewToken new_state (st : sts) (tk : stk)
 
 -- happyShift new_state i tk st sts stk =
 --      happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)
 
-happyFail :: [String] -> Int -> Located Token -> p2 -> p3 -> p4 -> P a
+happyFail :: [String] -> Int -> Located Token -> p2 -> p3 -> p4 -> PP a
 happyFail explist i tk _old_st _ _stk =
     trace ("failing" ++ show explist)
         $ happyError_ explist i tk
 
-happyError_ :: [String] -> p -> Located Token -> P a
+happyError_ :: [String] -> p1 -> Located Token -> PP a
 happyError_ explist _ tk = happyError' (tk, explist)
 
 notHappyAtAll :: a
 notHappyAtAll = Prelude.error "Internal Happy error\n"
 
-happyError' :: (Located Token, [String]) -> P a
+happyError' :: (Located Token, [String]) -> PP a
 happyError' tk = (\(_tokens, _explist) -> happyError) tk
 
-happyError :: P a
+happyError :: PP a
 happyError = Lexer.srcParseFail
 
 -- =====================================================================


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 267207c66495388c76297f9bd3f57454c021b9a9
+Subproject commit fd39bed22d4ac1d5f691f65391df8628f5693848



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/289fee545c92909f55f6c4a439be6d5d17fe8461

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/289fee545c92909f55f6c4a439be6d5d17fe8461
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231003/2696ae29/attachment-0001.html>


More information about the ghc-commits mailing list