[Git][ghc/ghc][wip/az/ghc-cpp] 2 commits: Harvest some commonality

22 Jun 2025

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


Commits:
14999739 by Alan Zimmerman at 2025-06-21T17:03:55+01:00
Harvest some commonality

- - - - -
e4491409 by Alan Zimmerman at 2025-06-22T15:14:55+01:00
Use PPM as Maybe inside PP

- - - - -


2 changed files:

- compiler/GHC/Parser/PreProcess/Macro.hs
- compiler/GHC/Parser/PreProcess/State.hs


Changes:

=====================================
compiler/GHC/Parser/PreProcess/Macro.hs
=====================================
@@ -37,104 +37,86 @@ import Data.Map qualified as Map
 import Data.Maybe
 
 import Data.Semigroup qualified as S
-import GHC.Driver.Errors.Types (PsMessage)
-import GHC.Parser.Lexer qualified as Lexer
 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.State
 import GHC.Prelude
-import GHC.Types.Error (MsgEnvelope)
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic (panic)
 
 -- ---------------------------------------------------------------------

---    We evaluate to an Int, which we convert to a bool
+-- We evaluate to an Int, which we convert to a bool
 cppCond :: SrcSpan -> String -> PP Bool
 cppCond loc str = do
-    s <- getPpState
+    r <- runPM $ cppCond' loc str
+    return $ fromMaybe False r
+
+cppCond' :: SrcSpan -> String -> PPM Bool
+cppCond' loc str = do
+    s <- liftPM getPpState
     expanded <- expand loc (pp_defines s) str
-    case expanded of
+    v <- case Parser.parseExpr expanded of
         Left err -> do
-            Lexer.addError err
-            return False
-        Right expanded -> do
-            v <- case Parser.parseExpr expanded of
-                Left err -> do
-                    let detail =
-                            if str == expanded || expanded == ""
-                                then
-                                    [ text str
-                                    ]
-                                else
-                                    [ text expanded
-                                    , text "expanded from:"
-                                    , text str
-                                    ]
-                    addGhcCPPError
-                        loc
-                        ( hang
-                            (text "Error evaluating CPP condition:")
-                            2
-                            ( text err
-                                <+> text "of"
-                                $+$ vcat detail
-                            )
-                        )
-                    return 0
-                Right tree -> return (eval tree)
-            return (toBool v)
+            let detail =
+                    if str == expanded || expanded == ""
+                        then
+                            [text str]
+                        else
+                            [ text expanded
+                            , text "expanded from:"
+                            , text str
+                            ]
+            liftPM $
+                addGhcCPPError'
+                    loc
+                    "Error evaluating CPP condition:"
+                    ( text err
+                        <+> text "of"
+                        $+$ vcat detail
+                    )
+            return 0
+        Right tree -> return (eval tree)
+    return (toBool v)
 
 -- ---------------------------------------------------------------------
 
-expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String)
+expand :: SrcSpan -> MacroDefines -> String -> PPM String
 expand loc s str = do
     case cppLex False str of
         Left err -> do
-            return
-                ( Left $
-                    mkGhcCPPError
-                        loc
-                        ( hang
-                            (text "Error evaluating CPP condition:")
-                            2
-                            (text err <+> text "of" $+$ text str)
-                        )
-                )
+            liftPM $
+                addGhcCPPError'
+                    loc
+                    "Error evaluating CPP condition:"
+                    (text err <+> text "of" $+$ text str)
+            failPM
         Right tks -> do
-            expandedToks <- expandToks loc maxExpansions s tks
-            case expandedToks of
-                Left err -> return (Left err)
-                Right toks -> return $ Right $ combineToks $ map t_str toks
+            toks <- expandToks loc maxExpansions s tks
+            return $ combineToks $ map t_str toks
 
 maxExpansions :: Int
 maxExpansions = 15
 
-expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token])
+expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PPM [Token]
 expandToks loc 0 _ ts = do
-    return $
-        Left $
-            mkGhcCPPError
-                loc
-                ( hang
-                    (text "CPP macro expansion limit hit:")
-                    2
-                    (text (combineToks $ map t_str ts))
-                )
+    liftPM $
+        addGhcCPPError'
+            loc
+            "CPP macro expansion limit hit:"
+            (text (combineToks $ map t_str ts))
+    failPM
 expandToks loc cnt s ts = do
-    expansion <- doExpandToks loc False s ts
-    case expansion of
-        Left err -> return (Left err)
-        Right (!expansionDone, !r) ->
-            if expansionDone
-                then expandToks loc (cnt - 1) s r
-                else return (Right r)
-
-doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token]))
-doExpandToks _loc ed _ [] = return $ Right (ed, [])
+    (!expansionDone, !r) <- doExpandToks loc False s ts
+    if expansionDone
+        then expandToks loc (cnt - 1) s r
+        else return r
+
+doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PPM (Bool, [Token])
+doExpandToks _loc ed _ [] = return (ed, [])
 doExpandToks loc ed s (TIdentifierLParen n : ts) =
     -- TIdentifierLParen has no meaning here (only in a #define), so
     -- restore it to its constituent tokens
@@ -145,32 +127,26 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do
     case expandedArgs of
         (Just [[TIdentifier macro_name]], rest0) ->
             case Map.lookup macro_name s of
-                Nothing -> return $ Right (True, TInteger "0" : rest0)
-                Just _ -> return $ Right (True, TInteger "1" : rest0)
+                Nothing -> return (True, TInteger "0" : rest0)
+                Just _ -> return (True, TInteger "1" : rest0)
         (Nothing, TIdentifier macro_name : ts0) ->
             case Map.lookup macro_name s of
-                Nothing -> return $ Right (True, TInteger "0" : ts0)
-                Just _ -> return $ Right (True, TInteger "1" : ts0)
+                Nothing -> return (True, TInteger "0" : ts0)
+                Just _ -> return (True, TInteger "1" : ts0)
         (Nothing, _) -> do
-            return $
-                Left $
-                    mkGhcCPPError
-                        loc
-                        ( hang
-                            (text "CPP defined: expected an identifier, got:")
-                            2
-                            (text (concatMap t_str ts))
-                        )
+            liftPM $
+                addGhcCPPError'
+                    loc
+                    "CPP defined: expected an identifier, got:"
+                    (text (concatMap t_str ts))
+            failPM -- TODO:AZ make part of addGhcCPPError'?
         (Just args, _) -> do
-            return $
-                Left $
-                    mkGhcCPPError
-                        loc
-                        ( hang
-                            (text "CPP defined: expected a single arg, got:")
-                            2
-                            (text (intercalate "," (map (concatMap t_str) args)))
-                        )
+            liftPM $
+                addGhcCPPError'
+                    loc
+                    "CPP defined: expected a single arg, got:"
+                    (text (intercalate "," (map (concatMap t_str) args)))
+            failPM -- TODO:AZ make part of addGhcCPPError'?
 doExpandToks loc ed s (TIdentifier n : ts) = do
     (args, rest0) <- getExpandArgs loc ts
     let
@@ -183,15 +159,11 @@ doExpandToks loc ed s (TIdentifier n : ts) = do
                 (ed0, r, rest1) = case m_args of
                     Nothing -> (True, rhs, ts)
                     Just _ -> (True, replace_args args m_args rhs, rest0)
-    expansion <- doExpandToks loc ed' s ts'
-    case expansion of
-        Left err -> return $ Left err
-        Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest)
+    (ed'', rest) <- doExpandToks loc ed' s ts'
+    return (ed'', expanded ++ rest)
 doExpandToks loc ed s (t : ts) = do
-    expansion <- doExpandToks loc ed s ts
-    case expansion of
-        Left err -> return (Left err)
-        Right (ed', r) -> return $ Right (ed', t : r)
+    (ed', r) <- doExpandToks loc ed s ts
+    return (ed', t : r)
 
 {-
 Note: ['defined' unary operator]
@@ -263,17 +235,15 @@ inner parentheses do not separate arguments.
 {- | Look for possible arguments to a macro expansion.
 The only thing we look for are commas, open parens, and close parens.
 -}
-getExpandArgs :: SrcSpan -> [Token] -> PP (Maybe [[Token]], [Token])
+getExpandArgs :: SrcSpan -> [Token] -> PPM (Maybe [[Token]], [Token])
 getExpandArgs loc ts =
     case pArgs ts of
         Left err -> do
-            addGhcCPPError
-                loc
-                ( hang
-                    (text "CPP: cannot expand macro arguments:")
-                    2
+            liftPM $
+                addGhcCPPError'
+                    loc
+                    "CPP: cannot expand macro arguments:"
                     (text err <+> text "in" $+$ text (concatMap t_str ts))
-                )
             return (Nothing, ts)
         Right r -> return r
 


=====================================
compiler/GHC/Parser/PreProcess/State.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Parser.PreProcess.State (
     PpState (..),
     initPpState,
     PP,
+    PPM,
     PpScope (..),
     PpGroupState (..),
     MacroDefines,
@@ -32,8 +33,11 @@ module GHC.Parser.PreProcess.State (
     ghcCppEnabled,
     setInLinePragma,
     getInLinePragma,
-    mkGhcCPPError,
-    addGhcCPPError,
+    PM (..),
+    runPM,
+    liftPM,
+    failPM,
+    addGhcCPPError',
 ) where
 
 import Data.List.NonEmpty ((<|))
@@ -51,12 +55,51 @@ import GHC.Types.SrcLoc
 import GHC.Utils.Error
 
 import GHC.Prelude
-import GHC.Utils.Outputable (text, (<+>))
+import GHC.Utils.Outputable (hang, text, (<+>))
 
 -- ---------------------------------------------------------------------
 
+type PPM = PM PpState
 type PP = P PpState
 
+-- ---------------------------------------------------------------------
+
+-- | The parsing monad, isomorphic to @StateT PState Maybe@.
+newtype PM p a = PM {unPM :: PState p -> ParseResult p (Maybe a)}
+
+instance Functor (PM p) where
+    fmap = liftM
+
+instance Applicative (PM p) where
+    pure = returnP
+    (<*>) = ap
+
+instance Monad (PM p) where
+    (>>=) = thenP
+
+returnP :: a -> PM p a
+returnP a = a `seq` (PM $ \s -> POk s (Just a))
+
+failPM :: PM p a
+failPM = PM $ \s -> POk s Nothing
+
+thenP :: PM p a -> (a -> PM p b) -> PM p b
+(PM m) `thenP` k = PM $ \s ->
+    case m s of
+        POk s1 Nothing -> POk s1 Nothing
+        POk s1 (Just a) -> (unPM (k a)) s1
+        PFailed s1 -> PFailed s1
+
+runPM :: PM p a -> P p (Maybe a)
+runPM m = P $ \s -> (unPM m) s
+
+liftPM :: P p a -> PM p a
+liftPM m = PM $ \s -> case (unP m) s of
+    POk s1 a -> POk s1 (Just a)
+    PFailed s1 -> PFailed s1
+
+-- ---------------------------------------------------------------------
+
 data CppState
     = CppIgnoring
     | CppNormal
@@ -238,15 +281,15 @@ acceptingStateChange old new =
 -- Exit a scope group
 popAccepting :: SrcSpan -> PP AcceptingResult
 popAccepting loc = do
-  scopes <- getScopes
-  new_scope <- case scopes of
-      c :| [] -> do
-        addGhcCPPError loc (text "#endif without #if")
-        return (c :| [])
-      _ :| (h : t) -> return (h :| t)
-  setScopes new_scope
-  let current = scopeValue scopes
-  return (acceptingStateChange current (scopeValue new_scope))
+    scopes <- getScopes
+    new_scope <- case scopes of
+        c :| [] -> do
+            addGhcCPPError loc (text "#endif without #if")
+            return (c :| [])
+        _ :| (h : t) -> return (h :| t)
+    setScopes new_scope
+    let current = scopeValue scopes
+    return (acceptingStateChange current (scopeValue new_scope))
 
 scopeValue :: NonEmpty PpScope -> Bool
 scopeValue s = pp_accepting $ NonEmpty.head s
@@ -266,7 +309,7 @@ parentScope =
                 c :| [] -> c -- Perhaps should return enabled instead
                 _ :| (h : _t) -> h
          in
-            POk s new_scope
+            POk s (new_scope)
 
 -- Get the current scope value
 getScope :: PP PpScope
@@ -415,8 +458,21 @@ insertMacroDef (MacroName name args) def md =
 
 -- ---------------------------------------------------------------------
 
+mkGhcCPPError' :: SrcSpan -> String -> SDoc -> MsgEnvelope PsMessage
+mkGhcCPPError' loc title detail =
+    mkGhcCPPError
+        loc
+        ( hang
+            (text title)
+            2
+            detail
+        )
+
+addGhcCPPError' :: SrcSpan -> String -> SDoc -> PP ()
+addGhcCPPError' loc title detail = Lexer.addError $ mkGhcCPPError' loc title detail
+
 mkGhcCPPError :: SrcSpan -> SDoc -> MsgEnvelope PsMessage
 mkGhcCPPError loc err = mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err
 
-addGhcCPPError :: SrcSpan -> SDoc -> P p ()
+addGhcCPPError :: SrcSpan -> SDoc -> PP ()
 addGhcCPPError loc err = Lexer.addError $ mkGhcCPPError loc err



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c6739013d4f997f8292a3f7969ec1c...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c6739013d4f997f8292a3f7969ec1c...
You're receiving this email because of your account on gitlab.haskell.org.

    

Alan Zimmerman (＠alanz)

tags

participants (1)