[Git][ghc/ghc][wip/az/ghc-cpp] Proress. Renamed module State from Types
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Wed Feb 5 22:42:49 UTC 2025
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
0137afec by Alan Zimmerman at 2025-02-05T22:41:51+00:00
Proress. Renamed module State from Types
And at first blush it seems to handle preprocessor scopes properly.
- - - - -
11 changed files:
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PreProcess.hs
- compiler/GHC/Parser/PreProcess/Eval.hs
- compiler/GHC/Parser/PreProcess/Macro.hs
- compiler/GHC/Parser/PreProcess/ParsePP.hs
- compiler/GHC/Parser/PreProcess/Parser.y
- compiler/GHC/Parser/PreProcess/Types.hs → compiler/GHC/Parser/PreProcess/State.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsParser.stdout
- utils/check-cpp/Main.hs
Changes:
=====================================
compiler/GHC/Parser/HaddockLex.x
=====================================
@@ -10,7 +10,7 @@ import GHC.Hs.Doc
import GHC.Parser.Lexer hiding (AlexInput)
import GHC.Parser.Lexer.Interface (adjustChar)
import GHC.Parser.Annotation
-import GHC.Parser.PreProcess.Types (PpState(..), initPpState)
+import GHC.Parser.PreProcess.State (PpState(..), initPpState)
import GHC.Types.SrcLoc
import GHC.Types.SourceText
import GHC.Data.StringBuffer
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -247,6 +247,7 @@ $docsym = [\| \^ \* \$]
-- recognise any of the GhcCPP keywords introduced by a leading #
@cppkeyword = "define" | "include" | "undef" | "error" | "ifdef"
| "ifndef" | "if" | "elif" | "else" | "endif"
+ | "dumpghccpp"
-- -----------------------------------------------------------------------------
-- Alex "Identifier"
=====================================
compiler/GHC/Parser/PreProcess.hs
=====================================
@@ -4,8 +4,6 @@
{-# LANGUAGE BangPatterns #-}
module GHC.Parser.PreProcess (
- -- ppLexer,
- -- ppLexerDbg,
lexer,
lexerDbg,
initPpState,
@@ -24,7 +22,7 @@ import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..), Token (..))
import GHC.Parser.Lexer qualified as Lexer
import GHC.Parser.PreProcess.Macro
import GHC.Parser.PreProcess.ParsePP
-import GHC.Parser.PreProcess.Types
+import GHC.Parser.PreProcess.State
import GHC.Prelude
import GHC.Types.SrcLoc
@@ -75,11 +73,18 @@ ppLexer queueComments cont =
Just inp -> do
Lexer.setInput inp
ppLexer queueComments cont
- L _ (ITcpp continuation s) -> do
+ L l (ITcpp continuation s) -> do
if continuation
- then pushContinuation tk
- else processCppToks s
- contIgnoreTok tk
+ then do
+ pushContinuation tk
+ contIgnoreTok tk
+ else do
+ mdump <- processCppToks s
+ case mdump of
+ Just dump ->
+ -- We have a dump of the state, put it into an ignored token
+ contIgnoreTok (L l (ITcpp continuation (appendFS s (fsLit dump))))
+ Nothing -> contIgnoreTok tk
_ -> do
state <- getCppState
-- case (trace ("CPP state:" ++ show state) state) of
@@ -90,17 +95,7 @@ ppLexer queueComments cont =
-- ---------------------------------------------------------------------
-preprocessElse :: PP ()
-preprocessElse = do
- accepting <- getAccepting
- setAccepting (not accepting)
-
-preprocessEnd :: PP ()
-preprocessEnd = do
- -- TODO: nested context
- setAccepting True
-
-processCppToks :: FastString -> PP ()
+processCppToks :: FastString -> PP (Maybe String)
processCppToks fs = do
let
get (L _ (ITcpp _ s)) = s
@@ -108,36 +103,38 @@ processCppToks fs = do
-- Combine any prior continuation tokens
cs <- popContinuation
processCpp (reverse $ fs : map get cs)
- return ()
-processCpp :: [FastString] -> PP ()
+processCpp :: [FastString] -> PP (Maybe String)
processCpp fs = do
let s = concatMap unpackFS fs
- case parseDirective s of
- Left err -> error $ show (err, s)
- Right (CppInclude filename) -> do
- ppInclude filename
- Right (CppDefine name def) -> do
- ppDefine (MacroName name Nothing) def
- Right (CppIf cond) -> do
- ppIf cond
- return ()
- Right (CppIfdef name) -> do
- defined <- ppIsDefined (MacroName name Nothing)
- setAccepting defined
- Right (CppIfndef name) -> do
- defined <- ppIsDefined (MacroName name Nothing)
- setAccepting (not defined)
- Right CppElse -> do
- accepting <- getAccepting
- setAccepting (not accepting)
- return ()
- Right CppEndif -> do
- -- TODO: nested states
- setAccepting True
- return ()
-
- return ()
+ let directive = parseDirective s
+ if directive == Right CppDumpState
+ then return (Just "\ndumped state\n")
+ else do
+ case directive of
+ Left err -> error $ show (err, s)
+ Right (CppInclude filename) -> do
+ ppInclude filename
+ Right (CppDefine name def) -> do
+ ppDefine (MacroName name Nothing) def
+ Right (CppIf cond) -> do
+ ppIf cond
+ Right (CppIfdef name) -> do
+ defined <- ppIsDefined (MacroName name Nothing)
+ pushAccepting defined
+ Right (CppIfndef name) -> do
+ defined <- ppIsDefined (MacroName name Nothing)
+ pushAccepting (not defined)
+ Right CppElse -> do
+ accepting <- getAccepting
+ setAccepting (not accepting)
+ Right CppEndif -> do
+ popScope
+ Right CppDumpState -> do
+ return ()
+ -- accepting <- getAccepting
+ -- return (trace ("processCpp:" ++ show (accepting,directive)) Nothing)
+ return Nothing
-- pp_include start -----------------------
=====================================
compiler/GHC/Parser/PreProcess/Eval.hs
=====================================
@@ -1,6 +1,6 @@
module GHC.Parser.PreProcess.Eval where
-import GHC.Parser.PreProcess.Types
+import GHC.Parser.PreProcess.State
import GHC.Prelude
-- ---------------------------------------------------------------------
=====================================
compiler/GHC/Parser/PreProcess/Macro.hs
=====================================
@@ -28,7 +28,7 @@ import GHC.Parser.PreProcess.Eval
import GHC.Parser.PreProcess.ParsePP
import GHC.Parser.PreProcess.Parser qualified as Parser
import GHC.Parser.PreProcess.ParserM
-import GHC.Parser.PreProcess.Types
+import GHC.Parser.PreProcess.State
import GHC.Prelude
-- ---------------------------------------------------------------------
=====================================
compiler/GHC/Parser/PreProcess/ParsePP.hs
=====================================
@@ -7,7 +7,7 @@ import Data.List (intercalate)
import GHC.Parser.Errors.Ppr ()
import GHC.Parser.PreProcess.Lexer
import GHC.Parser.PreProcess.ParserM (Token (..), init_state)
-import GHC.Parser.PreProcess.Types
+import GHC.Parser.PreProcess.State
import GHC.Prelude
-- =====================================================================
@@ -28,6 +28,7 @@ parseDirective s =
("#" : "ifdef" : ts) -> Right $ cppIfdef ts
("#" : "else" : ts) -> Right $ cppElse ts
("#" : "endif" : ts) -> Right $ cppEndif ts
+ ("#" : "dumpghccpp" : ts) -> Right $ cppDumpState ts
other -> Left ("unexpected directive: " ++ (combineToks other))
{- | Comply with the CPP requirement to not combine adjacent tokens.
@@ -59,6 +60,9 @@ cppElse _ts = CppElse
cppEndif :: [String] -> CppDirective
cppEndif _ts = CppEndif
+cppDumpState :: [String] -> CppDirective
+cppDumpState _ts = CppDumpState
+
-- ---------------------------------------------------------------------
cppLex :: String -> Either String [Token]
=====================================
compiler/GHC/Parser/PreProcess/Parser.y
=====================================
@@ -4,7 +4,7 @@ module GHC.Parser.PreProcess.Parser (parseExpr) where
import GHC.Parser.PreProcess.Lexer (lex_tok)
import GHC.Parser.PreProcess.ParserM (Token(..), ParserM, run_parser, get_pos, show_pos,
happyError)
-import GHC.Parser.PreProcess.Types
+import GHC.Parser.PreProcess.State
import GHC.Prelude
-- Needed when invoking happy -ad
-- import qualified GHC.Internal.Data.Tuple as Happy_Prelude
=====================================
compiler/GHC/Parser/PreProcess/Types.hs → compiler/GHC/Parser/PreProcess/State.hs
=====================================
@@ -1,4 +1,4 @@
-module GHC.Parser.PreProcess.Types where
+module GHC.Parser.PreProcess.State where
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.List.NonEmpty qualified as NonEmpty
@@ -54,6 +54,7 @@ data CppDirective
| CppIf String
| CppElse
| CppEndif
+ | CppDumpState
deriving (Show, Eq)
-- ---------------------------------------------------------------------
@@ -160,6 +161,9 @@ setAccepting on = do
scope <- getScope
setScope (scope{pp_accepting = on})
+pushAccepting :: Bool -> PP ()
+pushAccepting on = pushScope (PpScope Map.empty on)
+
pushAccepting' :: PpState -> Bool -> PpState
pushAccepting' s on = pushScope' s (PpScope Map.empty on)
=====================================
compiler/ghc.cabal.in
=====================================
@@ -658,7 +658,7 @@ Library
GHC.Parser.PreProcess.ParsePP
GHC.Parser.PreProcess.ParserM
GHC.Parser.PreProcess.Parser
- GHC.Parser.PreProcess.Types
+ GHC.Parser.PreProcess.State
GHC.Parser.String
GHC.Parser.Types
GHC.Parser.Utils
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -138,7 +138,7 @@ GHC.Parser.PreProcess.Macro
GHC.Parser.PreProcess.ParsePP
GHC.Parser.PreProcess.Parser
GHC.Parser.PreProcess.ParserM
-GHC.Parser.PreProcess.Types
+GHC.Parser.PreProcess.State
GHC.Parser.String
GHC.Parser.Types
GHC.Platform
=====================================
utils/check-cpp/Main.hs
=====================================
@@ -25,10 +25,17 @@ import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Utils.Outputable
-import ParsePP
-import ParseSimulate
-import PreProcess
-import Types
+-- import ParsePP
+-- import ParseSimulate
+-- import PreProcess
+-- import Types
+
+import GHC.Parser.PreProcess.ParsePP
+-- import GHC.Parser.ParseSimulate
+import GHC.Parser.PreProcess
+import GHC.Parser.PreProcess as PP
+import GHC.Parser.PreProcess.State
+import GHC.Parser
-- ---------------------------------------------------------------------
@@ -69,9 +76,10 @@ strGetToks includes popts filename str = reverse $ lexAll pstate
buf = stringToStringBuffer str
-- cpp_enabled = Lexer.GhcCppBit `Lexer.xtest` Lexer.pExtsBitmap popts
- lexAll state = case unP (ppLexerDbg True return) state of
+ lexAll state = case unP (PP.lexerDbg True return) state of
-- POk _ t@(L _ ITeof) -> [t]
POk s t@(L _ ITeof) -> trace ("lexall end:s=" ++ show (Lexer.pp s)) [t]
+ -- POk s t@(L _ ITeof) -> trace ("lexall end:s=" ++ showPprUnsafe (Lexer.comment_q s)) [t]
POk state' t -> t : lexAll state'
-- (trace ("lexAll: " ++ show (unLoc t)) state')
PFailed pst -> error $ "failed" ++ showErrorMessages (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)
@@ -86,42 +94,42 @@ showErrorMessages msgs =
getMessages $
msgs
-strParserWrapper ::
- -- | Haskell module source text (full Unicode is supported)
- String ->
- -- | the flags
- DynFlags ->
- -- | the filename (for source locations)
- FilePath ->
- [Located Token]
-strParserWrapper str dflags filename =
- case strParser str dflags filename of
- (_, Left _err) -> error "oops"
- (_, Right toks) -> toks
-
-{- | Parse a file, using the emulated haskell parser, returning the
-resulting tokens only
--}
-strParser ::
- -- | Haskell module source text (full Unicode is supported)
- String ->
- -- | the flags
- DynFlags ->
- -- | the filename (for source locations)
- FilePath ->
- (WarningMessages, Either ErrorMessages [Located Token])
-strParser str dflags filename =
- let
- loc = mkRealSrcLoc (mkFastString filename) 1 1
- buf = stringToStringBuffer str
- in
- case unP parseModuleNoHaddock (Lexer.initParserState initPpState (initParserOpts dflags) buf loc) of
- PFailed pst ->
- let (warns, errs) = Lexer.getPsMessages pst
- in (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)
- POk pst rdr_module ->
- let (warns, _) = Lexer.getPsMessages pst
- in (GhcPsMessage <$> warns, Right rdr_module)
+-- strParserWrapper ::
+-- -- | Haskell module source text (full Unicode is supported)
+-- String ->
+-- -- | the flags
+-- DynFlags ->
+-- -- | the filename (for source locations)
+-- FilePath ->
+-- [Located Token]
+-- strParserWrapper str dflags filename =
+-- case strParser str dflags filename of
+-- (_, Left _err) -> error "oops"
+-- (_, Right toks) -> toks
+
+-- {- | Parse a file, using the emulated haskell parser, returning the
+-- resulting tokens only
+-- -}
+-- strParser ::
+-- -- | Haskell module source text (full Unicode is supported)
+-- String ->
+-- -- | the flags
+-- DynFlags ->
+-- -- | the filename (for source locations)
+-- FilePath ->
+-- (WarningMessages, Either ErrorMessages [Located Token])
+-- strParser str dflags filename =
+-- let
+-- loc = mkRealSrcLoc (mkFastString filename) 1 1
+-- buf = stringToStringBuffer str
+-- in
+-- case unP parseModuleNoHaddock (Lexer.initParserState initPpState (initParserOpts dflags) buf loc) of
+-- PFailed pst ->
+-- let (warns, errs) = Lexer.getPsMessages pst
+-- in (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)
+-- POk pst rdr_module ->
+-- let (warns, _) = Lexer.getPsMessages pst
+-- in (GhcPsMessage <$> warns, Right rdr_module)
initDynFlags :: (GHC.GhcMonad m) => m GHC.DynFlags
initDynFlags = do
@@ -338,3 +346,16 @@ t11 = do
, "#endif"
]
-- x = 1
+
+t12 :: IO ()
+t12 = do
+ doTest
+ [ "#define FOO 4"
+ , "#if FOO > 3"
+ , "#dumpghccpp"
+ , "x = 1"
+ , "#else"
+ , "x = 5"
+ , "#endif"
+ ]
+ -- x = 1
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0137afecab0854cb1cf89bef22940f28191845fc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0137afecab0854cb1cf89bef22940f28191845fc
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/20250205/fc444622/attachment-0001.html>
More information about the ghc-commits
mailing list