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

Commits:

2 changed files:

Changes:

  • compiler/GHC/Parser/PreProcess/Macro.hs
    ... ... @@ -37,104 +37,86 @@ import Data.Map qualified as Map
    37 37 
     import Data.Maybe
    38 38
    39 39 
     import Data.Semigroup qualified as S
    40 
    -import GHC.Driver.Errors.Types (PsMessage)
    41 
    -import GHC.Parser.Lexer qualified as Lexer
    42 40 
     import GHC.Parser.PreProcess.Eval
    43 41 
     import GHC.Parser.PreProcess.ParsePP
    44 42 
     import GHC.Parser.PreProcess.Parser qualified as Parser
    45 43 
     import GHC.Parser.PreProcess.ParserM
    46 44 
     import GHC.Parser.PreProcess.State
    47 45 
     import GHC.Prelude
    48 
    -import GHC.Types.Error (MsgEnvelope)
    49 46 
     import GHC.Types.SrcLoc
    50 47 
     import GHC.Utils.Outputable
    51 48 
     import GHC.Utils.Panic (panic)
    52 49
    53 50 
     -- ---------------------------------------------------------------------
    54 51
    55 
    ---    We evaluate to an Int, which we convert to a bool
    52 
    +-- We evaluate to an Int, which we convert to a bool
    56 53 
     cppCond :: SrcSpan -> String -> PP Bool
    57 54 
     cppCond loc str = do
    58 
    -    s <- getPpState
    55 
    +    r <- runPM $ cppCond' loc str
    56 
    +    return $ fromMaybe False r
    57 
    +
    58 
    +cppCond' :: SrcSpan -> String -> PPM Bool
    59 
    +cppCond' loc str = do
    60 
    +    s <- liftPM getPpState
    59 61 
         expanded <- expand loc (pp_defines s) str
    60 
    -    case expanded of
    62 
    +    v <- case Parser.parseExpr expanded of
    61 63 
             Left err -> do
    62 
    -            Lexer.addError err
    63 
    -            return False
    64 
    -        Right expanded -> do
    65 
    -            v <- case Parser.parseExpr expanded of
    66 
    -                Left err -> do
    67 
    -                    let detail =
    68 
    -                            if str == expanded || expanded == ""
    69 
    -                                then
    70 
    -                                    [ text str
    71 
    -                                    ]
    72 
    -                                else
    73 
    -                                    [ text expanded
    74 
    -                                    , text "expanded from:"
    75 
    -                                    , text str
    76 
    -                                    ]
    77 
    -                    addGhcCPPError
    78 
    -                        loc
    79 
    -                        ( hang
    80 
    -                            (text "Error evaluating CPP condition:")
    81 
    -                            2
    82 
    -                            ( text err
    83 
    -                                <+> text "of"
    84 
    -                                $+$ vcat detail
    85 
    -                            )
    86 
    -                        )
    87 
    -                    return 0
    88 
    -                Right tree -> return (eval tree)
    89 
    -            return (toBool v)
    64 
    +            let detail =
    65 
    +                    if str == expanded || expanded == ""
    66 
    +                        then
    67 
    +                            [text str]
    68 
    +                        else
    69 
    +                            [ text expanded
    70 
    +                            , text "expanded from:"
    71 
    +                            , text str
    72 
    +                            ]
    73 
    +            liftPM $
    74 
    +                addGhcCPPError'
    75 
    +                    loc
    76 
    +                    "Error evaluating CPP condition:"
    77 
    +                    ( text err
    78 
    +                        <+> text "of"
    79 
    +                        $+$ vcat detail
    80 
    +                    )
    81 
    +            return 0
    82 
    +        Right tree -> return (eval tree)
    83 
    +    return (toBool v)
    90 84
    91 85 
     -- ---------------------------------------------------------------------
    92 86
    93 
    -expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String)
    87 
    +expand :: SrcSpan -> MacroDefines -> String -> PPM String
    94 88 
     expand loc s str = do
    95 89 
         case cppLex False str of
    96 90 
             Left err -> do
    97 
    -            return
    98 
    -                ( Left $
    99 
    -                    mkGhcCPPError
    100 
    -                        loc
    101 
    -                        ( hang
    102 
    -                            (text "Error evaluating CPP condition:")
    103 
    -                            2
    104 
    -                            (text err <+> text "of" $+$ text str)
    105 
    -                        )
    106 
    -                )
    91 
    +            liftPM $
    92 
    +                addGhcCPPError'
    93 
    +                    loc
    94 
    +                    "Error evaluating CPP condition:"
    95 
    +                    (text err <+> text "of" $+$ text str)
    96 
    +            failPM
    107 97 
             Right tks -> do
    108 
    -            expandedToks <- expandToks loc maxExpansions s tks
    109 
    -            case expandedToks of
    110 
    -                Left err -> return (Left err)
    111 
    -                Right toks -> return $ Right $ combineToks $ map t_str toks
    98 
    +            toks <- expandToks loc maxExpansions s tks
    99 
    +            return $ combineToks $ map t_str toks
    112 100
    113 101 
     maxExpansions :: Int
    114 102 
     maxExpansions = 15
    115 103
    116 
    -expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token])
    104 
    +expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PPM [Token]
    117 105 
     expandToks loc 0 _ ts = do
    118 
    -    return $
    119 
    -        Left $
    120 
    -            mkGhcCPPError
    121 
    -                loc
    122 
    -                ( hang
    123 
    -                    (text "CPP macro expansion limit hit:")
    124 
    -                    2
    125 
    -                    (text (combineToks $ map t_str ts))
    126 
    -                )
    106 
    +    liftPM $
    107 
    +        addGhcCPPError'
    108 
    +            loc
    109 
    +            "CPP macro expansion limit hit:"
    110 
    +            (text (combineToks $ map t_str ts))
    111 
    +    failPM
    127 112 
     expandToks loc cnt s ts = do
    128 
    -    expansion <- doExpandToks loc False s ts
    129 
    -    case expansion of
    130 
    -        Left err -> return (Left err)
    131 
    -        Right (!expansionDone, !r) ->
    132 
    -            if expansionDone
    133 
    -                then expandToks loc (cnt - 1) s r
    134 
    -                else return (Right r)
    135 
    -
    136 
    -doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token]))
    137 
    -doExpandToks _loc ed _ [] = return $ Right (ed, [])
    113 
    +    (!expansionDone, !r) <- doExpandToks loc False s ts
    114 
    +    if expansionDone
    115 
    +        then expandToks loc (cnt - 1) s r
    116 
    +        else return r
    117 
    +
    118 
    +doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PPM (Bool, [Token])
    119 
    +doExpandToks _loc ed _ [] = return (ed, [])
    138 120 
     doExpandToks loc ed s (TIdentifierLParen n : ts) =
    139 121 
         -- TIdentifierLParen has no meaning here (only in a #define), so
    140 122 
         -- restore it to its constituent tokens
    ... ... @@ -145,32 +127,26 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do
    145 127 
         case expandedArgs of
    146 128 
             (Just [[TIdentifier macro_name]], rest0) ->
    147 129 
                 case Map.lookup macro_name s of
    148 
    -                Nothing -> return $ Right (True, TInteger "0" : rest0)
    149 
    -                Just _ -> return $ Right (True, TInteger "1" : rest0)
    130 
    +                Nothing -> return (True, TInteger "0" : rest0)
    131 
    +                Just _ -> return (True, TInteger "1" : rest0)
    150 132 
             (Nothing, TIdentifier macro_name : ts0) ->
    151 133 
                 case Map.lookup macro_name s of
    152 
    -                Nothing -> return $ Right (True, TInteger "0" : ts0)
    153 
    -                Just _ -> return $ Right (True, TInteger "1" : ts0)
    134 
    +                Nothing -> return (True, TInteger "0" : ts0)
    135 
    +                Just _ -> return (True, TInteger "1" : ts0)
    154 136 
             (Nothing, _) -> do
    155 
    -            return $
    156 
    -                Left $
    157 
    -                    mkGhcCPPError
    158 
    -                        loc
    159 
    -                        ( hang
    160 
    -                            (text "CPP defined: expected an identifier, got:")
    161 
    -                            2
    162 
    -                            (text (concatMap t_str ts))
    163 
    -                        )
    137 
    +            liftPM $
    138 
    +                addGhcCPPError'
    139 
    +                    loc
    140 
    +                    "CPP defined: expected an identifier, got:"
    141 
    +                    (text (concatMap t_str ts))
    142 
    +            failPM -- TODO:AZ make part of addGhcCPPError'?
    164 143 
             (Just args, _) -> do
    165 
    -            return $
    166 
    -                Left $
    167 
    -                    mkGhcCPPError
    168 
    -                        loc
    169 
    -                        ( hang
    170 
    -                            (text "CPP defined: expected a single arg, got:")
    171 
    -                            2
    172 
    -                            (text (intercalate "," (map (concatMap t_str) args)))
    173 
    -                        )
    144 
    +            liftPM $
    145 
    +                addGhcCPPError'
    146 
    +                    loc
    147 
    +                    "CPP defined: expected a single arg, got:"
    148 
    +                    (text (intercalate "," (map (concatMap t_str) args)))
    149 
    +            failPM -- TODO:AZ make part of addGhcCPPError'?
    174 150 
     doExpandToks loc ed s (TIdentifier n : ts) = do
    175 151 
         (args, rest0) <- getExpandArgs loc ts
    176 152 
         let
    ... ... @@ -183,15 +159,11 @@ doExpandToks loc ed s (TIdentifier n : ts) = do
    183 159 
                     (ed0, r, rest1) = case m_args of
    184 160 
                         Nothing -> (True, rhs, ts)
    185 161 
                         Just _ -> (True, replace_args args m_args rhs, rest0)
    186 
    -    expansion <- doExpandToks loc ed' s ts'
    187 
    -    case expansion of
    188 
    -        Left err -> return $ Left err
    189 
    -        Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest)
    162 
    +    (ed'', rest) <- doExpandToks loc ed' s ts'
    163 
    +    return (ed'', expanded ++ rest)
    190 164 
     doExpandToks loc ed s (t : ts) = do
    191 
    -    expansion <- doExpandToks loc ed s ts
    192 
    -    case expansion of
    193 
    -        Left err -> return (Left err)
    194 
    -        Right (ed', r) -> return $ Right (ed', t : r)
    165 
    +    (ed', r) <- doExpandToks loc ed s ts
    166 
    +    return (ed', t : r)
    195 167
    196 168 
     {-
    197 169 
     Note: ['defined' unary operator]
    ... ... @@ -263,17 +235,15 @@ inner parentheses do not separate arguments.
    263 235 
     {- | Look for possible arguments to a macro expansion.
    264 236 
     The only thing we look for are commas, open parens, and close parens.
    265 237 
     -}
    266 
    -getExpandArgs :: SrcSpan -> [Token] -> PP (Maybe [[Token]], [Token])
    238 
    +getExpandArgs :: SrcSpan -> [Token] -> PPM (Maybe [[Token]], [Token])
    267 239 
     getExpandArgs loc ts =
    268 240 
         case pArgs ts of
    269 241 
             Left err -> do
    270 
    -            addGhcCPPError
    271 
    -                loc
    272 
    -                ( hang
    273 
    -                    (text "CPP: cannot expand macro arguments:")
    274 
    -                    2
    242 
    +            liftPM $
    243 
    +                addGhcCPPError'
    244 
    +                    loc
    245 
    +                    "CPP: cannot expand macro arguments:"
    275 246 
                         (text err <+> text "in" $+$ text (concatMap t_str ts))
    276 
    -                )
    277 247 
                 return (Nothing, ts)
    278 248 
             Right r -> return r
    279 249

  • compiler/GHC/Parser/PreProcess/State.hs
    ... ... @@ -8,6 +8,7 @@ module GHC.Parser.PreProcess.State (
    8 8 
         PpState (..),
    9 9 
         initPpState,
    10 10 
         PP,
    11 
    +    PPM,
    11 12 
         PpScope (..),
    12 13 
         PpGroupState (..),
    13 14 
         MacroDefines,
    ... ... @@ -32,8 +33,11 @@ module GHC.Parser.PreProcess.State (
    32 33 
         ghcCppEnabled,
    33 34 
         setInLinePragma,
    34 35 
         getInLinePragma,
    35 
    -    mkGhcCPPError,
    36 
    -    addGhcCPPError,
    36 
    +    PM (..),
    37 
    +    runPM,
    38 
    +    liftPM,
    39 
    +    failPM,
    40 
    +    addGhcCPPError',
    37 41 
     ) where
    38 42
    39 43 
     import Data.List.NonEmpty ((<|))
    ... ... @@ -51,12 +55,51 @@ import GHC.Types.SrcLoc
    51 55 
     import GHC.Utils.Error
    52 56
    53 57 
     import GHC.Prelude
    54 
    -import GHC.Utils.Outputable (text, (<+>))
    58 
    +import GHC.Utils.Outputable (hang, text, (<+>))
    55 59
    56 60 
     -- ---------------------------------------------------------------------
    57 61
    62 
    +type PPM = PM PpState
    58 63 
     type PP = P PpState
    59 64
    65 
    +-- ---------------------------------------------------------------------
    66 
    +
    67 
    +-- | The parsing monad, isomorphic to @StateT PState Maybe@.
    68 
    +newtype PM p a = PM {unPM :: PState p -> ParseResult p (Maybe a)}
    69 
    +
    70 
    +instance Functor (PM p) where
    71 
    +    fmap = liftM
    72 
    +
    73 
    +instance Applicative (PM p) where
    74 
    +    pure = returnP
    75 
    +    (<*>) = ap
    76 
    +
    77 
    +instance Monad (PM p) where
    78 
    +    (>>=) = thenP
    79 
    +
    80 
    +returnP :: a -> PM p a
    81 
    +returnP a = a `seq` (PM $ \s -> POk s (Just a))
    82 
    +
    83 
    +failPM :: PM p a
    84 
    +failPM = PM $ \s -> POk s Nothing
    85 
    +
    86 
    +thenP :: PM p a -> (a -> PM p b) -> PM p b
    87 
    +(PM m) `thenP` k = PM $ \s ->
    88 
    +    case m s of
    89 
    +        POk s1 Nothing -> POk s1 Nothing
    90 
    +        POk s1 (Just a) -> (unPM (k a)) s1
    91 
    +        PFailed s1 -> PFailed s1
    92 
    +
    93 
    +runPM :: PM p a -> P p (Maybe a)
    94 
    +runPM m = P $ \s -> (unPM m) s
    95 
    +
    96 
    +liftPM :: P p a -> PM p a
    97 
    +liftPM m = PM $ \s -> case (unP m) s of
    98 
    +    POk s1 a -> POk s1 (Just a)
    99 
    +    PFailed s1 -> PFailed s1
    100 
    +
    101 
    +-- ---------------------------------------------------------------------
    102 
    +
    60 103 
     data CppState
    61 104 
         = CppIgnoring
    62 105 
         | CppNormal
    ... ... @@ -238,15 +281,15 @@ acceptingStateChange old new =
    238 281 
     -- Exit a scope group
    239 282 
     popAccepting :: SrcSpan -> PP AcceptingResult
    240 283 
     popAccepting loc = do
    241 
    -  scopes <- getScopes
    242 
    -  new_scope <- case scopes of
    243 
    -      c :| [] -> do
    244 
    -        addGhcCPPError loc (text "#endif without #if")
    245 
    -        return (c :| [])
    246 
    -      _ :| (h : t) -> return (h :| t)
    247 
    -  setScopes new_scope
    248 
    -  let current = scopeValue scopes
    249 
    -  return (acceptingStateChange current (scopeValue new_scope))
    284 
    +    scopes <- getScopes
    285 
    +    new_scope <- case scopes of
    286 
    +        c :| [] -> do
    287 
    +            addGhcCPPError loc (text "#endif without #if")
    288 
    +            return (c :| [])
    289 
    +        _ :| (h : t) -> return (h :| t)
    290 
    +    setScopes new_scope
    291 
    +    let current = scopeValue scopes
    292 
    +    return (acceptingStateChange current (scopeValue new_scope))
    250 293
    251 294 
     scopeValue :: NonEmpty PpScope -> Bool
    252 295 
     scopeValue s = pp_accepting $ NonEmpty.head s
    ... ... @@ -266,7 +309,7 @@ parentScope =
    266 309 
                     c :| [] -> c -- Perhaps should return enabled instead
    267 310 
                     _ :| (h : _t) -> h
    268 311 
              in
    269 
    -            POk s new_scope
    312 
    +            POk s (new_scope)
    270 313
    271 314 
     -- Get the current scope value
    272 315 
     getScope :: PP PpScope
    ... ... @@ -415,8 +458,21 @@ insertMacroDef (MacroName name args) def md =
    415 458
    416 459 
     -- ---------------------------------------------------------------------
    417 460
    461 
    +mkGhcCPPError' :: SrcSpan -> String -> SDoc -> MsgEnvelope PsMessage
    462 
    +mkGhcCPPError' loc title detail =
    463 
    +    mkGhcCPPError
    464 
    +        loc
    465 
    +        ( hang
    466 
    +            (text title)
    467 
    +            2
    468 
    +            detail
    469 
    +        )
    470 
    +
    471 
    +addGhcCPPError' :: SrcSpan -> String -> SDoc -> PP ()
    472 
    +addGhcCPPError' loc title detail = Lexer.addError $ mkGhcCPPError' loc title detail
    473 
    +
    418 474 
     mkGhcCPPError :: SrcSpan -> SDoc -> MsgEnvelope PsMessage
    419 475 
     mkGhcCPPError loc err = mkPlainErrorMsgEnvelope loc $ PsErrGhcCpp err
    420 476
    421 
    -addGhcCPPError :: SrcSpan -> SDoc -> P p ()
    477 
    +addGhcCPPError :: SrcSpan -> SDoc -> PP ()
    422 478 
     addGhcCPPError loc err = Lexer.addError $ mkGhcCPPError loc err

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help