[Git][ghc/ghc][wip/az/ghc-cpp] Move PpState into PreProcess
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Tue Oct 3 21:46:21 UTC 2023
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
3bfb1fd6 by Alan Zimmerman at 2023-10-03T22:45:18+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/Driver/Pipeline/Execute.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/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/Driver/Pipeline/Execute.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.Data.Maybe
import GHC.Iface.Make
import GHC.Driver.Config.Parser
import GHC.Parser.Header
+import GHC.Parser.PreProcess (initPpState)
import GHC.Data.StringBuffer
import GHC.Types.SourceError
import GHC.Unit.Finder
=====================================
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,18 @@ module GHC.Parser.PreProcess (
-- ppLexerDbg,
lexer,
lexerDbg,
+ initPpState,
+ initParserState,
+ initPragState,
) 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 +28,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.initPragState 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 +165,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
=====================================
@@ -50,9 +50,9 @@ isDecl pflags stmt =
_ -> True
Lexer.PFailed _ -> False
-parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
+parseThing :: Lexer.P () thing -> ParserOpts -> String -> Lexer.ParseResult () thing
parseThing parser opts stmt = do
let buf = stringToStringBuffer stmt
loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
- Lexer.unP parser (Lexer.initParserState opts buf loc)
+ Lexer.unP parser (Lexer.initParserState () opts buf loc)
=====================================
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/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 267207c66495388c76297f9bd3f57454c021b9a9
+Subproject commit fd39bed22d4ac1d5f691f65391df8628f5693848
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bfb1fd64c49e246ea72df5d5b3b4e4b1d70758e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3bfb1fd64c49e246ea72df5d5b3b4e4b1d70758e
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/08a3c384/attachment-0001.html>
More information about the ghc-commits
mailing list