c-expr-dsl 0.1.0.1 → 0.2.0.0

raw patch · 18 files changed

+725/−371 lines, 18 filesdep ~libclang-bindingsnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: libclang-bindings

API changes (from Hackage documentation)

Files

• CHANGELOG.md +41/−0
• c-expr-dsl.cabal +4/−4
• src/C/Expr/Parse.hs +3/−3
• src/C/Expr/Parse/Expr.hs +160/−131
• src/C/Expr/Parse/Identifier.hs +1/−19
• src/C/Expr/Parse/Infra.hs +12/−23
• src/C/Expr/Syntax.hs +2/−1
• test/Test/CExpr/Parse/Golden.hs +114/−22
• test/Test/CExpr/Parse/Infra.hs +16/−27
• test/Test/CExpr/Parse/Literal.hs +28/−23
• test/Test/CExpr/Parse/Macro.hs +177/−105
• test/Test/CExpr/Parse/Type.hs +4/−2
• test/Test/CExpr/Typecheck/Classify.hs +33/−3
• test/Test/CExpr/Typecheck/Infra.hs +32/−0
• test/Test/CExpr/Util.hs +1/−1
• test/fixtures/macros.C17.golden +17/−1
• test/fixtures/macros.C23.golden +17/−1
• test/fixtures/macros.h +63/−5

@@ -1,5 +1,46 @@ # Revision history for `c-expr-dsl` +## 0.2.0.0 -- 2026-10-06++### Breaking changes++* `parseMacro` is replaced by `parseMacroBody`, which parses a macro *body*.+  Splitting a `#define` into its name, formal parameter list and body is now+  the caller's responsibility. The formal parameters are passed in source+  order, and references to them in the body become `LocalParam`s.+  `parseMacroBody` consumes the entire token stream (it ends with `eof`).+  See [issue #2243][issue-2243].+* `parseMacroType` likewise takes its formal parameters in source order.+* `Token`, `MultiLoc`, and `SingleLoc` from `libclang-bindings` are now+  parameterized by a path type. All uses in `c-expr-dsl` apply `SourcePath`,+  e.g. `Token SourcePath TokenSpelling` where `Token TokenSpelling` appeared+  before. This follows the upstream `libclang-bindings` change that distinguishes+  raw clang paths (`SourcePath`) from canonical on-disk paths (`RealPath`).+* Require `libclang-bindings` `>=0.2 && <0.3`, the release that contains the+  path-parameterized types above.++### Bug fixes++* `runParser` no longer panics when given an empty token list; it returns a+  `MacroParseError` instead. An empty macro body (`#define FOO`) is legal C and+  may reach the parser. See [issue #2246][issue-2246].+* A formal parameter spelled like a keyword is now recognized as the parameter.+  The preprocessor works on pp-tokens, which have no keywords. That is,+  `#define F(bool) bool` is valid C and its body is the parameter. The parse no+  longer depends on how libclang classifies the spelling, which varies with the+  C standard: `#define F(bool) bool` used to yield the type `bool` under C23,+  and a parameter named `const` or `sizeof` used to fail to parse.+* The shadowing above now also holds in qualifier, specifier and tag position,+  where a token is matched by its spelling rather than looked up in the+  parameter scope. `#define F(const) const x` used to parse as the type+  `const x`, dropping the parameter; it is now rejected, since a qualifier+  applied to a parameter has no representation. Likewise+  `#define F(int) unsigned int` and `#define F(Foo) struct Foo`. Conversely+  `#define F(const) const *` is now accepted as a pointer to the parameter.++[issue-2243]: https://github.com/well-typed/hs-bindgen/issues/2243+[issue-2246]: https://github.com/well-typed/hs-bindgen/issues/2246+ ## 0.1.0.1 -- 2026-07-22  ### Bug fixes

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            c-expr-dsl-version:         0.1.0.1+version:         0.2.0.0 license:         BSD-3-Clause license-file:    LICENSE author:          Well-Typed LLP@@ -42,7 +42,7 @@   type:     git   location: https://github.com/well-typed/c-expr.git   subdir:   c-expr-dsl-  tag:      release-0.1.0.1+  tag:      release-0.2.0.0  common lang   build-depends:      base >=4.16 && <4.23@@ -106,7 +106,7 @@     , debruijn             >=0.3.1 && <0.4     , fin                  >=0.3.2 && <0.4     , indexed-traversable  >=0.1.4 && <0.2-    , libclang-bindings    >=0.1   && <0.2+    , libclang-bindings    >=0.2   && <0.3     , mtl                  >=2.2   && <2.4     , parsec               >=3.1   && <3.2     , scientific           >=0.3.7 && <0.4@@ -146,7 +146,7 @@     , debruijn           >=0.3.1 && <0.4     , filepath           >=1.4   && <1.6     , fin                >=0.3.2 && <0.4-    , libclang-bindings  >=0.1   && <0.2+    , libclang-bindings  >=0.2   && <0.3     , parsec             >=3.1   && <3.2     , tasty              >=1.4   && <1.6     , tasty-golden       >=2.3   && <2.4

@@ -1,6 +1,6 @@ module C.Expr.Parse (-    -- * Parsing macros-    parseMacro+    -- * Parsing macro bodies+    parseMacroBody   , parseMacroType     -- * Parser infrastructure   , Parser@@ -8,5 +8,5 @@   , MacroParseError(..)   ) where -import C.Expr.Parse.Expr (parseMacro, parseMacroType)+import C.Expr.Parse.Expr (parseMacroBody, parseMacroType) import C.Expr.Parse.Infra (MacroParseError (..), Parser, runParser)

@@ -1,10 +1,9 @@-{-# LANGUAGE OverloadedRecordDot #-}--module C.Expr.Parse.Expr (parseMacro, parseMacroType) where+module C.Expr.Parse.Expr (parseMacroBody, parseMacroType) where  import Control.Monad import Data.Foldable qualified as Foldable import Data.Functor.Identity+import Data.Maybe (isJust) import Data.Text (Text) import Data.Type.Nat import Data.Vec.Lazy (Vec (..))@@ -36,43 +35,32 @@     <https://en.cppreference.com/w/c/language/operator_precedence> -------------------------------------------------------------------------------} --- | Parse a macro definition (type or value expression)+-- | Parse a macro body (type or value expression) --+-- The formal parameters are given in source order, and references to them in+-- the body become 'LocalParam's.+--+-- The entire token stream must be the body: 'parseMacroBody' ends with 'eof'.+-- -- Tries to parse the body as a type expression first. A valid type token -- sequence always produces @'Term' ('Type' …)@; everything else parses as an -- expression. Only when typechecking macros, we can fully discriminate type and -- value expressions.-parseMacro :: ClangCStandard -> Parser (Macro ())-parseMacro cStd = do-    (macroLocRange, macroName) <- parseLocIdentifier-    let-        macroLoc :: MultiLoc-        macroLoc = macroLocRange.rangeStart--        functionLike :: Parser (Macro ())-        functionLike = do-          noWhitespace macroLocRange-          paramNames <- formalParams-          Vec.reifyList (reverse paramNames) $ \macroParams -> do-            macroExpr <- bodyExpr macroParams-            pure $ Macro macroLoc macroName (Vec.reverse macroParams) macroExpr--        objectLike :: Parser (Macro ())-        objectLike = do-          macroExpr <- bodyExpr VNil-          pure $ Macro macroLoc macroName VNil macroExpr-    m <- choice [try functionLike, objectLike]-    eof-    return m+parseMacroBody ::+     forall ctx.+     ClangCStandard+  -> Vec ctx Identifier  -- ^ Formal parameters, in source order+  -> Parser (Expr ctx (Ps ()))+parseMacroBody cStd params = do+    rejectPragma+    -- The 'eof' inside the 'try' is essential: if 'macroType' succeeds on a+    -- prefix (e.g. the bare identifier in @size_t + 1@) but leaves tokens+    -- unconsumed, the whole attempt is abandoned and we fall back to the+    -- expression parser.+    try (macroType cStd scope <* eof) <|> (exprTuple cStd scope <* eof)   where-    -- Try the body as a type expression first. The @'eof'@ inside the @'try'@-    -- is essential: if @'parseMacroType'@ succeeds on a prefix (e.g. the bare-    -- identifier in @size_t + 1@) but leaves tokens unconsumed, the whole-    -- attempt is abandoned and we fall back to the expression parser.-    bodyExpr :: Vec ctx Identifier -> Parser (Expr ctx (Ps ()))-    bodyExpr macroParams = do-      rejectPragma-      try (parseMacroType cStd macroParams <* eof) <|> exprTuple cStd macroParams+    scope :: Scope ctx+    scope = mkScope params  -- | Reject macro bodies that begin with the @_Pragma@ operator --@@ -89,41 +77,61 @@ rejectPragma =     notFollowedBy (token isPragma) <?> "C expression (not a _Pragma operator)"   where-    isPragma :: Token TokenSpelling -> Maybe ()+    isPragma :: Token SourcePath TokenSpelling -> Maybe ()     isPragma t       | getTokenSpelling (tokenSpelling t) == "_Pragma" = Just ()       | otherwise                                       = Nothing -formalParams :: Parser [Identifier]-formalParams = parens $ parseIdentifier `sepBy` comma+{-------------------------------------------------------------------------------+  Macro parameters in scope+-------------------------------------------------------------------------------} -lookupParam :: Identifier -> Vec ctx Identifier -> Maybe (Idx ctx)-lookupParam _ VNil    = Nothing-lookupParam n (m ::: vec)-  | n == m    = Just IZ-  | otherwise = IS <$> lookupParam n vec+-- | The formal parameters of a macro, ordered for de Bruijn lookup+--+-- The innermost binder comes first, so @FOO(x, y)@ binds @y@ to 'IZ' and @x@ to+-- @'IS' 'IZ'@. This is the reverse of the source order used wherever the+-- parameters are visible from the outside ('parseMacroBody', 'macroParams'),+-- which is why this type exists: the two orders are otherwise indistinguishable.+newtype Scope ctx = Scope (Vec ctx Identifier) --- | Check that there is no whitespace between the previous token and the current--- token+-- | Build a 'Scope' from the formal parameters in source order+mkScope :: Vec ctx Identifier -> Scope ctx+mkScope params = Scope (Vec.reverse params)++lookupParam :: forall ctx. Identifier -> Scope ctx -> Maybe (Idx ctx)+lookupParam n (Scope params) = go params+  where+    go :: forall ctx'. Vec ctx' Identifier -> Maybe (Idx ctx')+    go VNil = Nothing+    go (m ::: vec)+      | n == m    = Just IZ+      | otherwise = IS <$> go vec++-- | Is this spelling a formal parameter?+isParam :: Identifier -> Scope ctx -> Bool+isParam n = isJust . lookupParam n++-- | Match a reference to a formal parameter ----- Function-like macros are only function-like if there is /no/ whitespace--- between the macro name and the opening parenthesis of the parameter list.+-- Only the spelling decides, not the token kind. The preprocessor works on+-- pp-tokens, which have no keywords, so @#define F(bool) bool@ is valid C in+-- every standard, and inside the replacement list a parameter shadows every+-- other meaning of its spelling. ----- We used to not check whitespace, which was the source of a bug. See issue--- #1903: <https://github.com/well-typed/hs-bindgen/issues/1903>-noWhitespace ::-     -- | Source range for the previous token-     Range MultiLoc-  -> Parser ()-noWhitespace prevRange = lookAhead $ do-    tok <- anyToken-    let prev    = prevRange.rangeEnd.multiLocExpansion-        current = tok.tokenExtent.rangeStart.multiLocExpansion-        p       = prev.singleLocPath   == current.singleLocPath &&-                  prev.singleLocLine   == current.singleLocLine &&-                  prev.singleLocColumn == current.singleLocColumn-    unless p $-      parserFail "unexpected whitespace"+-- What @libclang@ reports is instead a property of the translation unit's+-- language options: the same @bool@ is 'CXToken_Identifier' under @-std=c17@+-- and 'CXToken_Keyword' under @-std=c2x@. Letting that classification reach+-- the grammar would make the parse depend on the C standard in force.+--+-- The shadowing is total: a spelling in scope has no meaning other than the+-- parameter. Wherever a token is matched by kind rather than offered to this+-- parser first -- 'keyword', and the tag name in 'taggedTypeLit' -- that parser+-- must consult the scope itself and fail on a parameter spelling.+paramRef :: Scope ctx -> Parser (Idx ctx)+paramRef scope = token $ \t -> do+    guard $ fromSimpleEnum (tokenKind t) `elem`+      [Right CXToken_Identifier, Right CXToken_Keyword]+    lookupParam (Identifier (getTokenSpelling (tokenSpelling t))) scope  {-------------------------------------------------------------------------------   Types@@ -150,20 +158,27 @@ -- -- Returns an @'Expr' ctx ('Ps' ())@ where: --+-- * A spelling that is a formal parameter becomes @'Term' ('LocalParam' …)@,+--   whatever @libclang@ classifies it as; see 'paramRef'. -- * A keyword base type becomes @'Term' ('Literal' ('TypeLit' …))@. -- * A tagged base type (e.g. @struct Foo@) becomes @'Term' ('Var' …)@ with a --   'NameTagged' name; the typechecker resolves it.--- * A bare identifier that is a local macro parameter becomes @'Term' ('LocalParam' …)@.--- * A bare identifier that is a free variable becomes @'Term' ('Var' …)@;---   the typechecker decides whether it names a type or a value.+-- * Any other bare identifier becomes @'Term' ('Var' …)@; the typechecker+--   decides whether it names a type or a value. -- * Each @const@ qualifier wraps the expression in @'TyApp' 'Const'@. -- * Each @*@ pointer layer wraps the expression in @'TyApp' 'Pointer'@.-parseMacroType :: ClangCStandard -> Vec ctx Identifier -> Parser (Expr ctx (Ps ()))-parseMacroType cStd macroParams = do-    constBefore <- option False (True <$ keyword "const")-    base        <- typeBase cStd macroParams-    constAfter  <- option False (True <$ keyword "const")-    ptrs        <- pointerLayers+parseMacroType ::+     ClangCStandard+  -> Vec ctx Identifier  -- ^ Formal parameters, in source order+  -> Parser (Expr ctx (Ps ()))+parseMacroType cStd params = macroType cStd (mkScope params)++macroType :: ClangCStandard -> Scope ctx -> Parser (Expr ctx (Ps ()))+macroType cStd scope = do+    constBefore <- option False (True <$ keyword scope "const")+    base        <- typeBase cStd scope+    constAfter  <- option False (True <$ keyword scope "const")+    ptrs        <- pointerLayers scope     -- In C, @const@ is idempotent: @const int const@ is valid but equivalent     -- to @const int@. We therefore wrap with at most one 'Const' layer,     -- regardless of whether the qualifier appeared before or after the base.@@ -180,18 +195,22 @@ -- -- Returns: --+-- * @'Term' ('LocalParam' …)@ for a spelling that is a local macro parameter. -- * @'Term' ('Literal' ('TypeLit' …))@ for keyword base types. -- * @'Term' ('Var' …)@ with a 'NameTagged' name for a tagged base type (e.g. @struct Foo@).--- * @'Term' ('LocalParam' …)@ for a bare identifier that is a local macro parameter. -- * @'Term' ('Var' …)@ for any other bare identifier; the typechecker decides --   whether it names a type or a value.-typeBase :: forall ctx. ClangCStandard -> Vec ctx Identifier -> Parser (Expr ctx (Ps ()))-typeBase cStd macroParams =+typeBase :: forall ctx. ClangCStandard -> Scope ctx -> Parser (Expr ctx (Ps ()))+typeBase cStd scope =     choice [+        -- Macro parameter. Comes first: within the replacement list a parameter+        -- shadows the keyword of the same spelling, so @#define F(bool) bool@+        -- is the parameter and not the type.+        Term . LocalParam <$> paramRef scope         -- Type literal.-        Term . Literal . TypeLit <$> typeLiteral cStd+      , Term . Literal . TypeLit <$> typeLiteral cStd scope         -- Tagged type (e.g., @struct Foo@)-      , Term . mkTagged <$> taggedTypeLit+      , Term . mkTagged <$> taggedTypeLit scope         -- The bare identifier (typedef name, type macro, or expression         -- variable) is needed to parse pointer-qualified typedef references         -- such as @size_t *@: without it, @parseMacroType@ would reject the@@ -207,9 +226,7 @@     mkTagged (tag, ident) = Var (XVarPs ()) (NameTagged ident tag) []      mkVar :: Identifier -> Term ctx (Ps ())-    mkVar n = case lookupParam n macroParams of-      Just i  -> LocalParam i-      Nothing -> Var (XVarPs ()) (NameOrdinary n) []+    mkVar n = Var (XVarPs ()) (NameOrdinary n) []  -- | Parse a sequence of type-literal keywords and combine them --@@ -222,9 +239,9 @@ -- @ -- -- are all the same type.-typeLiteral :: ClangCStandard -> Parser TypeLit-typeLiteral cStd = do-    kws <- many1 (typeKeyword cStd)+typeLiteral :: ClangCStandard -> Scope ctx -> Parser TypeLit+typeLiteral cStd scope = do+    kws <- many1 (typeKeyword cStd scope)     case interpretKeywords kws of       Just lit -> return lit       Nothing  -> fail "unrecognised type literal"@@ -236,14 +253,18 @@ --   union  tag --   enum   tag -- @-taggedTypeLit :: Parser (TagKind, Identifier)-taggedTypeLit = do-    tag <- choice [-        TagStruct <$ keyword "struct"-      , TagUnion  <$ keyword "union"-      , TagEnum   <$ keyword "enum"+--+-- A formal parameter as the tag name is rejected: 'NameTagged' has no room for+-- a de Bruijn index, so @#define F(Foo) struct Foo@ has no representation.+taggedTypeLit :: Scope ctx -> Parser (TagKind, Identifier)+taggedTypeLit scope = do+    tag  <- choice [+        TagStruct <$ keyword scope "struct"+      , TagUnion  <$ keyword scope "union"+      , TagEnum   <$ keyword scope "enum"       ]     name <- parseIdentifier+    guard $ not (isParam name scope)     return (tag, name)  data TypeKeyword =@@ -253,18 +274,18 @@   | KwVoid | KwBool   deriving stock (Eq) -typeKeyword :: ClangCStandard -> Parser TypeKeyword-typeKeyword cStd = choice $-      [ KwSigned   <$ keyword "signed"-      , KwUnsigned <$ keyword "unsigned"-      , KwShort    <$ keyword "short"-      , KwInt      <$ keyword "int"-      , KwLong     <$ keyword "long"-      , KwChar     <$ keyword "char"-      , KwFloat    <$ keyword "float"-      , KwDouble   <$ keyword "double"-      , KwVoid     <$ keyword "void"-      , KwBool     <$ keyword "_Bool"+typeKeyword :: ClangCStandard -> Scope ctx -> Parser TypeKeyword+typeKeyword cStd scope = choice $+      [ KwSigned   <$ keyword scope "signed"+      , KwUnsigned <$ keyword scope "unsigned"+      , KwShort    <$ keyword scope "short"+      , KwInt      <$ keyword scope "int"+      , KwLong     <$ keyword scope "long"+      , KwChar     <$ keyword scope "char"+      , KwFloat    <$ keyword scope "float"+      , KwDouble   <$ keyword scope "double"+      , KwVoid     <$ keyword scope "void"+      , KwBool     <$ keyword scope "_Bool"       ]       ++       -- @bool@ is a keyword in C23 and later.@@ -272,7 +293,7 @@         ClangCStandard std _ | std >= C23 -> [bool]         _                                 -> []   where-    bool = KwBool <$ keyword "bool"+    bool = KwBool <$ keyword scope "bool"  -- | Combine a list of type keywords into a type literal --@@ -329,29 +350,37 @@   -- We return Nothing here; the caller interprets (Just sign, Nothing) as int.  -- | Parse zero or more pointer indirections, optionally followed by @const@-pointerLayers :: Parser [Bool]-pointerLayers = many pointerLayer+pointerLayers :: Scope ctx -> Parser [Bool]+pointerLayers scope = many (pointerLayer scope)  -- | Parse a pointer indirection, optionally followed by @const@-pointerLayer :: Parser Bool-pointerLayer = do+pointerLayer :: Scope ctx -> Parser Bool+pointerLayer scope = do     punctuation "*"-    option False (True <$ keyword "const")+    option False (True <$ keyword scope "const")  -- | Match a keyword token with the given spelling-keyword :: Text -> Parser ()-keyword expected = token $ \t ->-    if fromSimpleEnum (tokenKind t) == Right CXToken_Keyword-       && getTokenSpelling (tokenSpelling t) == expected-      then Just ()-      else Nothing+--+-- Fails when the spelling is a formal parameter. A keyword in qualifier or+-- specifier position is never offered to 'paramRef', so the shadowing has to+-- be enforced here.+keyword :: Scope ctx -> Text -> Parser ()+keyword scope expected+  | isParam (Identifier expected) scope = parserZero+  | otherwise                                         = token $ \case+      (Token k s _ _)+        | fromSimpleEnum k == Right CXToken_Keyword+          && getTokenSpelling s == expected ->+            Just ()+        | otherwise ->+            Nothing  {-------------------------------------------------------------------------------   Simple expressions -------------------------------------------------------------------------------} -term :: forall ctx. ClangCStandard -> Vec ctx Identifier -> Parser (Term ctx (Ps ()))-term cStd macroParams =+term :: forall ctx. ClangCStandard -> Scope ctx -> Parser (Term ctx (Ps ()))+term cStd scope =     buildExpressionParser ops trm <?> "simple expression"   where     trm :: Parser (Term ctx (Ps ()))@@ -360,15 +389,15 @@       , localParamOrVar       ] +    -- As in 'typeBase', the parameter scope is consulted before the token is+    -- interpreted as a keyword or as a free variable.     localParamOrVar :: Parser (Term ctx (Ps ()))-    localParamOrVar = do-      varName <- parseIdentifier-      case lookupParam varName macroParams of-        Just i ->-          pure $ LocalParam i-        Nothing ->-          Var (XVarPs ()) (NameOrdinary varName) <$>-            option [] (actualArgs cStd macroParams)+    localParamOrVar = choice [+          LocalParam <$> paramRef scope+        , do varName <- parseIdentifier+             Var (XVarPs ()) (NameOrdinary varName) <$>+               option [] (actualArgs cStd scope)+        ]      lit :: Parser Literal     lit = ValueLit <$> choice [@@ -378,7 +407,7 @@       , ValueString <$> literalString       ] -    ops :: OperatorTable [Token TokenSpelling] () Identity (Term ctx (Ps ()))+    ops :: OperatorTable [Token SourcePath TokenSpelling] () Identity (Term ctx (Ps ()))     ops = []  @@ -415,8 +444,8 @@   val <- parseTokenOfKind CXToken_Literal parseLiteralString   return $ StringLiteral val -actualArgs :: ClangCStandard -> Vec ctx Identifier -> Parser [Expr ctx (Ps ())]-actualArgs cStd macroParams = parens $ expr cStd macroParams `sepBy` comma+actualArgs :: ClangCStandard -> Scope ctx -> Parser [Expr ctx (Ps ())]+actualArgs cStd scope = parens $ expr cStd scope `sepBy` comma  {-------------------------------------------------------------------------------   Expressions@@ -426,12 +455,12 @@   follow the same structure. -------------------------------------------------------------------------------} -exprTuple :: ClangCStandard -> Vec ctx Identifier -> Parser (Expr ctx (Ps ()))-exprTuple cStd macroParams = try tuple <|> expr cStd macroParams+exprTuple :: ClangCStandard -> Scope ctx -> Parser (Expr ctx (Ps ()))+exprTuple cStd scope = try tuple <|> expr cStd scope   where     tuple = do       openParen <- optionMaybe $ punctuation "("-      (e1, e2, es) <- expr cStd macroParams `sepBy2` comma+      (e1, e2, es) <- expr cStd scope `sepBy2` comma       case openParen of         Nothing -> return ()         Just {} -> punctuation ")"@@ -439,14 +468,14 @@         Vec.reifyList es $ \es' ->            VaApp NoXApp MTuple ( e1 ::: e2 ::: es' ) -expr :: forall ctx. ClangCStandard -> Vec ctx Identifier -> Parser (Expr ctx (Ps ()))-expr cStd macroParams = buildExpressionParser ops trm <?> "expression"+expr :: forall ctx. ClangCStandard -> Scope ctx -> Parser (Expr ctx (Ps ()))+expr cStd scope = buildExpressionParser ops trm <?> "expression"   where      trm :: Parser (Expr ctx (Ps ()))     trm = choice [-          parens (expr cStd macroParams)-        , Term <$> term cStd macroParams+          parens (expr cStd scope)+        , Term <$> term cStd scope         ]      -- 'OperatorTable' expects the list in descending precedence

@@ -1,7 +1,6 @@ -- | Parsing C identifiers module C.Expr.Parse.Identifier (     parseIdentifier-  , parseLocIdentifier   ) where  import Control.Monad@@ -19,27 +18,10 @@  -- | Parse an identifier ----- Does not accept C keywords. Use 'parseLocIdentifier' when the token may be a--- keyword (e.g. for macro names, where @#define bool int@ is valid C).+-- Does not accept C keywords. parseIdentifier :: Parser Identifier parseIdentifier = token $ \t -> do     let spelling = getTokenSpelling (tokenSpelling t)     let ki = fromSimpleEnum (tokenKind t)     guard $ ki == Right CXToken_Identifier     return $ Identifier spelling---- | Parse an identifier together with its source location------ Accepts both identifiers and keywords. In later LLVMs (not in 14, surely in--- 16), @bool@ is classified as a keyword rather than an identifier. We accept--- keywords here so that macros such as @#define bool int@ can be parsed. Even--- in C23 the meaning of @bool@ can be overwritten (the macro takes precedence).-parseLocIdentifier :: Parser (Range MultiLoc, Identifier)-parseLocIdentifier = token $ \t -> do-    let spelling = getTokenSpelling (tokenSpelling t)-    let ki = fromSimpleEnum (tokenKind t)-    guard $ ki == Right CXToken_Identifier || ki == Right CXToken_Keyword-    return (-        tokenExtent t-      , Identifier spelling-      )

@@ -22,41 +22,30 @@ import Data.Text (Text) import Data.Text qualified as Text import GHC.Generics-import GHC.Stack import Text.Parsec hiding (runParser, token, tokens) import Text.Parsec qualified as Parsec import Text.Parsec.Pos -import C.Expr.Util.Panic- import Clang.Enum.Simple import Clang.HighLevel.Types import Clang.LowLevel.Core-import Clang.Paths+import Clang.Paths (getSourcePath)  {-------------------------------------------------------------------------------   Parser type -------------------------------------------------------------------------------} -type Parser = Parsec [Token TokenSpelling] ()+type Parser = Parsec [Token SourcePath TokenSpelling] () +-- | Run a parser on a stream of tokens runParser ::-     HasCallStack-  => Parser a-  -> [Token TokenSpelling]+     FilePath+  -> Parser a+  -> [Token SourcePath TokenSpelling]   -> Either MacroParseError a-runParser p tokens =+runParser sourcePath p tokens =     first unrecognized $ Parsec.runParser p () sourcePath tokens   where-    sourcePath :: FilePath-    sourcePath =-        case tokens of-          []  -> panicPure "runParser: empty list"-          t:_ -> getSourcePath $ singleLocPath start-            where-              start :: SingleLoc-              start = rangeStart $ multiLocExpansion <$> tokenExtent t-     unrecognized :: ParseError -> MacroParseError     unrecognized err = MacroParseError{           parseError       = show err@@ -69,7 +58,7 @@  data MacroParseError = MacroParseError {       parseError       :: String-    , parseErrorTokens :: [Token TokenSpelling]+    , parseErrorTokens :: [Token SourcePath TokenSpelling]     }   deriving stock (Show, Eq, Generic)   deriving anyclass (Exception)@@ -78,10 +67,10 @@   Dealing with individual tokens -------------------------------------------------------------------------------} -token :: (Token TokenSpelling -> Maybe a) -> Parser a+token :: (Token SourcePath TokenSpelling -> Maybe a) -> Parser a token = Parsec.token tokenPretty tokenSourcePos   where-    tokenPretty :: Token TokenSpelling -> String+    tokenPretty :: Token SourcePath TokenSpelling -> String     tokenPretty Token{tokenKind, tokenSpelling} = concat [           show $ Text.unpack (getTokenSpelling tokenSpelling)         , " ("@@ -89,14 +78,14 @@         ,  ")"         ] -    tokenSourcePos :: Token a -> SourcePos+    tokenSourcePos :: Token SourcePath a -> SourcePos     tokenSourcePos t =         newPos           (getSourcePath $ singleLocPath start)           (singleLocLine start)           (singleLocColumn start)       where-        start :: SingleLoc+        start :: SingleLoc SourcePath         start = rangeStart $ multiLocExpansion <$> tokenExtent t  tokenOfKind :: CXTokenKind -> (Text -> Maybe a) -> Parser a

@@ -60,9 +60,10 @@  type Macro :: Hs.Type -> Hs.Type data Macro ann = forall (ctx :: Ctx). Macro {-      macroLoc    :: MultiLoc+      macroLoc    :: MultiLoc SourcePath     , macroName   :: Identifier     , macroParams :: Vec ctx Identifier+      -- ^ Formal parameters, in source order     , macroExpr   :: Expr ctx (Ps ann)     } 

@@ -1,16 +1,17 @@--- | Golden integration tests for 'C.Expr.Parse.Expr.parseMacro'+-- | Golden integration tests for 'C.Expr.Parse.parseMacroBody' -- -- These tests use @libclang@ to tokenise the macros defined in--- @test/fixtures/macros.h@, feed the token streams to 'parseMacro', and--- compare the results against the golden file @test/fixtures/macros.golden@.+-- @test/fixtures/macros.h@, split each definition into its formal parameters+-- and its body, feed the bodies to 'parseMacroBody', and compare the results+-- against the golden file @test/fixtures/macros.golden@. -- -- Golden file can be regenerated using the @--accept@ CLI option. module Test.CExpr.Parse.Golden (tests) where -import Data.Bifunctor (Bifunctor (..)) import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Text (Text) import Data.Text qualified as Text+import Data.Vec.Lazy qualified as Vec import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO) import Test.Tasty (TestName, TestTree, testGroup)@@ -26,7 +27,6 @@ import Clang.HighLevel qualified as HighLevel import Clang.HighLevel.Types import Clang.LowLevel.Core-import Clang.Paths import Clang.Version  import Paths_c_expr_dsl (getDataDir)@@ -48,7 +48,7 @@     CExprC23 -> "-std=c2x"  tests :: TestTree-tests = testGroup "Parse.Golden" $ [goldenWith CExprC17] ++ mbC23+tests = testGroup "Parse.Golden" $ goldenWith CExprC17 : mbC23   where     mbC23 =       case runtimeClangVersion of@@ -78,7 +78,7 @@   -> FilePath           -- ^ path to the golden file   -> IO LBS.ByteString  -- ^ action producing the actual output   -> TestTree-goldenDynamic name goldenPath getActual = goldenVsString name goldenPath getActual+goldenDynamic = goldenVsString  {-------------------------------------------------------------------------------   Run the parser on all macros in the fixture file@@ -87,23 +87,116 @@ parseMacrosFixture :: TestCStandard -> FilePath -> IO LBS.ByteString parseMacrosFixture testCStd fixturePath = do     macroTokens <- collectMacroTokens testCStd fixturePath-    return $ LBS.pack $ unlines $-      map (formatEntry . second (runParser $ parseMacro cStd)) macroTokens+    return $ LBS.pack $ unlines $ map formatEntry macroTokens   where     cStd :: ClangCStandard     cStd = ClangCStandard (testCStandardToCStandard testCStd) DisableGnu -    formatEntry ::-         Show ann-      => (Text, Either MacroParseError (Macro ann))-      -> String-    formatEntry (name, result) =-        Text.unpack name ++ ": " ++ formatResult result+    -- A split failure is reported separately from a parse failure: the splitter+    -- is test-local, so a regression in it must not masquerade as a parser+    -- result.+    formatEntry :: (Text, [Token SourcePath TokenSpelling]) -> String+    formatEntry (name, tokens) =+        Text.unpack name ++ ": " +++          case splitMacro tokens of+            Nothing              -> "Left <split error>"+            Just (params, body)  ->+              Vec.reifyList params $ \params' ->+                case runParser "<parseMacrosFixture" (parseMacroBody cStd params') body of+                  Right expr -> "Right " ++ show expr+                  Left _     -> "Left <parse error>" -    formatResult :: Show ann => Either MacroParseError (Macro ann) -> String-    formatResult (Right (Macro{macroExpr})) = "Right " ++ show macroExpr-    formatResult (Left _)                   = "Left <parse error>"+{-------------------------------------------------------------------------------+  Splitting macro definitions +  Test-local and deliberately minimal: @hs-bindgen@ owns the real splitter+  (@HsBindgen.Macro.Syntax.splitMacro@), which reports errors and handles+  variadic macros. This one exists only so that these golden tests can keep+  driving real @#define@s through libclang. Do not promote it into the library.+-------------------------------------------------------------------------------}++-- | Split a macro definition into its formal parameters and its body+--+-- The parameters are returned in source order. 'Nothing' means the definition+-- is not one we can represent: a name that is neither an identifier nor a+-- keyword, a malformed parameter list, or a variadic macro.+splitMacro ::+     [Token SourcePath TokenSpelling]+  -> Maybe ([Identifier], [Token SourcePath TokenSpelling])+splitMacro []            = Nothing+splitMacro (name:tokens)+    | not (isMacroName name) = Nothing+    | otherwise              =+        case tokens of+          -- A macro is function-like only when the opening parenthesis follows+          -- the name with no whitespace in between. See issue #1903:+          -- <https://github.com/well-typed/hs-bindgen/issues/1903>+          t:ts | adjacent name t, isPunctuation "(" t -> paramList ts+          _otherwise                                  -> Just ([], tokens)+  where+    paramList ::+         [Token SourcePath TokenSpelling]+      -> Maybe ([Identifier], [Token SourcePath TokenSpelling])+    paramList (t:ts) | isPunctuation ")" t = Just ([], ts)+    paramList ts                           = go [] ts++    go ::+         [Identifier]+      -> [Token SourcePath TokenSpelling]+      -> Maybe ([Identifier], [Token SourcePath TokenSpelling])+    go acc (t:u:us)+      | Just param <- macroParam t+      = if | isPunctuation "," u -> go (param:acc) us+           | isPunctuation ")" u -> Just (reverse (param:acc), us)+           | otherwise           -> Nothing+    go _ _+      = Nothing++-- | Macro names may be keywords (@#define bool int@ is valid C)+isMacroName :: Token SourcePath TokenSpelling -> Bool+isMacroName t = case fromSimpleEnum (tokenKind t) of+    Right CXToken_Identifier -> True+    Right CXToken_Keyword    -> True+    _otherwise               -> False++-- | Parameter names may be keywords, too (@#define F(bool) bool@)+--+-- Which spellings @libclang@ classifies as 'CXToken_Keyword' depends on the C+-- standard in force, so the kind must not decide what counts as a parameter.+macroParam :: Token SourcePath TokenSpelling -> Maybe Identifier+macroParam t = case fromSimpleEnum (tokenKind t) of+    Right CXToken_Identifier -> Just name+    Right CXToken_Keyword    -> Just name+    _otherwise               -> Nothing+  where+    name = Identifier (getTokenSpelling (tokenSpelling t))++isPunctuation :: String -> Token SourcePath TokenSpelling -> Bool+isPunctuation expected t =+       fromSimpleEnum (tokenKind t) == Right CXToken_Punctuation+    && removeMultilines (Text.unpack (getTokenSpelling (tokenSpelling t))) == expected++-- | Are the two tokens adjacent in the source, with no whitespace in between?+adjacent ::+     Token SourcePath TokenSpelling+  -> Token SourcePath TokenSpelling+  -> Bool+adjacent prev next =+       singleLocPath   end == singleLocPath   start+    && singleLocLine   end == singleLocLine   start+    && singleLocColumn end == singleLocColumn start+  where+    end   = rangeEnd   $ multiLocExpansion <$> tokenExtent prev+    start = rangeStart $ multiLocExpansion <$> tokenExtent next++-- | Drop line continuations, which libclang sometimes leaves inside a token+-- spelling+removeMultilines :: String -> String+removeMultilines = \case+    '\\':'\n':cs -> removeMultilines cs+    c:cs         -> c : removeMultilines cs+    []           -> []+ {-------------------------------------------------------------------------------   Collect macro definitions from a C header file via libclang -------------------------------------------------------------------------------}@@ -111,7 +204,7 @@ collectMacroTokens ::      TestCStandard   -> FilePath-  -> IO [(Text, [Token TokenSpelling])]+  -> IO [(Text, [Token SourcePath TokenSpelling])] collectMacroTokens testCStd path =     HighLevel.withIndex DontDisplayDiagnostics $ \index ->       HighLevel.withTranslationUnit index src noArgs [] flags $ \unit -> do@@ -129,7 +222,7 @@  macroFold ::      CXTranslationUnit-  -> Fold IO (Text, [Token TokenSpelling])+  -> Fold IO (Text, [Token SourcePath TokenSpelling]) macroFold unit = simpleFold $ \cursor -> do     loc    <- clang_getCursorLocation cursor     inMain <- clang_Location_isFromMainFile loc@@ -140,8 +233,7 @@         case kind of           Right CXCursor_MacroDefinition -> do               name   <- clang_getCursorSpelling cursor-              range  <- HighLevel.clang_getCursorExtent cursor-              tokens <- HighLevel.clang_tokenize unit (multiLocExpansion <$> range)+              tokens <- HighLevel.clang_tokenize unit =<< clang_getCursorExtent cursor               foldContinueWith (name, tokens)           _ ->               foldContinue

@@ -7,8 +7,7 @@   , lit     -- * Running parsers   , checkType-  , checkMacro-  , parseTestWith+  , checkBody     -- * Results   , tyLit   ) where@@ -33,22 +32,22 @@ -------------------------------------------------------------------------------}  -- | Construct a keyword token-kw :: Text -> Token TokenSpelling+kw :: Text -> Token SourcePath TokenSpelling kw = mkToken CXToken_Keyword  -- | Construct an identifier token-ident :: Text -> Token TokenSpelling+ident :: Text -> Token SourcePath TokenSpelling ident = mkToken CXToken_Identifier  -- | Construct a punctuation token-punc :: Text -> Token TokenSpelling+punc :: Text -> Token SourcePath TokenSpelling punc = mkToken CXToken_Punctuation  -- | Construct a literal token-lit :: Text -> Token TokenSpelling+lit :: Text -> Token SourcePath TokenSpelling lit = mkToken CXToken_Literal -mkToken :: CXTokenKind -> Text -> Token TokenSpelling+mkToken :: CXTokenKind -> Text -> Token SourcePath TokenSpelling mkToken kind spelling = Token{       tokenKind       = simpleEnum kind     , tokenSpelling   = TokenSpelling spelling@@ -65,31 +64,21 @@ -- Adds 'eof' so that trailing tokens are rejected as parse failures. checkType ::      ClangCStandard-  -> [Token TokenSpelling]+  -> [Token SourcePath TokenSpelling]   -> Either MacroParseError (Expr Z (Ps ()))-checkType cStd = runParser (parseMacroType cStd VNil <* eof)+checkType cStd = runParser "<checkType>" (parseMacroType cStd VNil <* eof) --- | Run the macro parser on a complete token sequence+-- | Run the macro body parser on a sequence of tokens ----- The first token must be the macro name (an identifier).  'parseMacro'+-- The tokens are the macro body only, without the name or the parameter list;+-- the formal parameters are given separately, in source order. 'parseMacroBody' -- itself calls 'eof', so no trailing tokens are allowed.-checkMacro ::+checkBody ::      ClangCStandard-  -> [Token TokenSpelling]-  -> Either MacroParseError (Macro ())-checkMacro cStd = runParser (parseMacro cStd)---- | Run a parser on a list of (kind, spelling) pairs and print the result.------ Useful for interactive debugging in GHCi:------ > parseTestWith (parseMacro C17) [(CXToken_Identifier, "M"), (CXToken_Literal, "1")]-parseTestWith ::-     Show a-  => Parser a-  -> [(CXTokenKind, Text)]-  -> IO ()-parseTestWith p pairs = print $ runParser p (map (uncurry mkToken) pairs)+  -> Vec ctx Identifier+  -> [Token SourcePath TokenSpelling]+  -> Either MacroParseError (Expr ctx (Ps ()))+checkBody cStd params = runParser "<checkBody>" (parseMacroBody cStd params)  {-------------------------------------------------------------------------------   Results

@@ -1,9 +1,9 @@ -- | Unit tests for character and string literal parsing -- -- These exercise 'C.Expr.Parse.Literal.parseLiteralChar' and--- 'C.Expr.Parse.Literal.parseLiteralString' through the public macro parser--- ('C.Expr.Parse.parseMacro'): a @CXToken_Literal@ token whose spelling is the--- full literal (quotes included) is fed to the parser, and the resulting+-- 'C.Expr.Parse.Literal.parseLiteralString' through the public macro body parser+-- ('C.Expr.Parse.parseMacroBody'): a @CXToken_Literal@ token whose spelling is+-- the full literal (quotes included) is fed to the parser, and the resulting -- 'CharLiteral' / 'StringLiteral' is inspected. -- -- The aim is to cover every kind of character and string literal we accept (and@@ -18,16 +18,18 @@  import Data.ByteString (ByteString) import Data.Either (isLeft)+import Data.Nat (Nat (..)) import Data.Text (Text) import Data.Text qualified as Text+import Data.Vec.Lazy (Vec (..)) import Foreign.C (CChar) import Test.Tasty import Test.Tasty.HUnit +import C.Expr.Parse import C.Expr.Syntax  import Clang.CStandard-import Clang.HighLevel.Types  import Test.CExpr.Parse.Infra @@ -63,29 +65,32 @@   Helpers -------------------------------------------------------------------------------} --- | A fixed macro name token used in all tests.-macroNameTok :: Token TokenSpelling-macroNameTok = ident "FOO"+-- | Parse a single literal token as an object-like macro body.+checkLit ::+     ClangCStandard+  -> Text+  -> Either MacroParseError (Expr Z (Ps ()))+checkLit cStd spelling = checkBody cStd VNil [lit spelling] --- | Extract a character literal from a parsed object-like macro body.-getCharLit :: Either e (Macro ann) -> Maybe CharLiteral-getCharLit (Right Macro{macroExpr}) = case macroExpr of+-- | Extract a character literal from a parsed macro body.+getCharLit :: Either e (Expr ctx (Ps ann)) -> Maybe CharLiteral+getCharLit (Right body) = case body of     Term (Literal (ValueLit (ValueChar c))) -> Just c-    _                                        -> Nothing+    _                                       -> Nothing getCharLit _ = Nothing --- | Extract a string literal from a parsed object-like macro body.-getStrLit :: Either e (Macro ann) -> Maybe StringLiteral-getStrLit (Right Macro{macroExpr}) = case macroExpr of+-- | Extract a string literal from a parsed macro body.+getStrLit :: Either e (Expr ctx (Ps ann)) -> Maybe StringLiteral+getStrLit (Right body) = case body of     Term (Literal (ValueLit (ValueString s))) -> Just s-    _                                          -> Nothing+    _                                         -> Nothing getStrLit _ = Nothing --- | Extract an integer value from a parsed object-like macro body.-getIntVal :: Either e (Macro ann) -> Maybe Integer-getIntVal (Right Macro{macroExpr}) = case macroExpr of+-- | Extract an integer value from a parsed macro body.+getIntVal :: Either e (Expr ctx (Ps ann)) -> Maybe Integer+getIntVal (Right body) = case body of     Term (Literal (ValueLit (ValueInt i))) -> Just (integerLiteralValue i)-    _                                       -> Nothing+    _                                      -> Nothing getIntVal _ = Nothing  -- | A successful character literal: the spelling parses to the given value,@@ -93,7 +98,7 @@ charCase :: ClangCStandard -> Text -> CChar -> TestTree charCase cStd spelling val =     testCase (Text.unpack spelling) $-      getCharLit (checkMacro cStd [macroNameTok, lit spelling])+      getCharLit (checkLit cStd spelling)         @?= Just (CharLiteral val)  -- | A successful string literal: the spelling parses to the given decoded@@ -101,7 +106,7 @@ strCase :: ClangCStandard -> Text -> ByteString -> TestTree strCase cStd spelling val =     testCase (Text.unpack spelling) $-      getStrLit (checkMacro cStd [macroNameTok, lit spelling])+      getStrLit (checkLit cStd spelling)         @?= Just (StringLiteral val)  -- | A literal spelling we reject (the whole macro fails to parse).@@ -109,7 +114,7 @@ failCase cStd spelling =     testCase (Text.unpack spelling) $       assertBool "expected parse failure" $-        isLeft (checkMacro cStd [macroNameTok, lit spelling])+        isLeft (checkLit cStd spelling)  {-------------------------------------------------------------------------------   Characters: ordinary (unescaped) source characters@@ -261,7 +266,7 @@     quirk :: Text -> Integer -> TestTree     quirk spelling val =       testCase (Text.unpack spelling) $-        getIntVal (checkMacro cStd [macroNameTok, lit spelling]) @?= Just val+        getIntVal (checkLit cStd spelling) @?= Just val  {-------------------------------------------------------------------------------   Strings: ordinary (unescaped) source characters

@@ -1,34 +1,27 @@-{-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >=908-{-# LANGUAGE TypeAbstractions #-}-#endif---- | Unit tests for 'C.Expr.Parse.Expr.parseMacro'+-- | Unit tests for 'C.Expr.Parse.parseMacroBody' ----- Tests the full macro parser, focusing on:+-- Tests the macro body parser, focusing on: -- -- * Type bodies vs expression bodies (disambiguation)--- * Object-like and function-like expression macros+-- * Bodies of object-like and function-like macros+--+-- Splitting a definition into name, formal parameters and body is the+-- embedder's job, so the parameters are an input here rather than something+-- the parser recovers from the token stream. module Test.CExpr.Parse.Macro (tests) where  import Data.Either (isLeft, isRight)-import Data.Nat (Nat (..))-import Data.Type.Equality ((:~:) (..))-import Data.Type.Nat qualified as Nat import Data.Vec.Lazy (Vec (..))-import Data.Vec.Lazy qualified as Vec-import DeBruijn (Idx (..))+import DeBruijn (Idx (..), pattern I1) import Test.Tasty import Test.Tasty.HUnit  import C.Expr.Syntax  import Clang.CStandard-import Clang.HighLevel.Types  import Test.CExpr.Parse.Infra-import Test.CExpr.Typecheck.Infra (mtagged, mvar)+import Test.CExpr.Typecheck.Infra (add, intLit, mtagged, mtuple, mvar)  {-------------------------------------------------------------------------------   Top-level@@ -43,7 +36,9 @@ testsWithCStd cStd = testGroup (show cStd) [       testGroup "type bodies"               $ tests_typeBody         std     , testGroup "function-like type bodies" $ tests_funcLikeTypeBody std+    , testGroup "keyword parameters"        $ tests_keywordParam     std     , testGroup "expression bodies"         $ tests_exprBody         std+    , testGroup "comma bodies"              $ tests_commaBody        std     , testGroup "disambiguation"            $ tests_disambiguation   std     ]   where@@ -53,53 +48,29 @@   Helpers -------------------------------------------------------------------------------} --- | A fixed macro name token used in all tests-macroNameTok :: Token TokenSpelling-macroNameTok = ident "FOO"- -- | True when the macro expression looks like a type: it has an 'Type' or -- 'TyApp' at its core (bare identifier cases are intentionally excluded -- because a bare name is structurally identical in both type and expression -- position after the refactor).-isTypeBody :: Either e (Macro ann) -> Bool-isTypeBody (Right Macro{macroExpr}) = case macroExpr of+isTypeBody :: Either e (Expr ctx (Ps ann)) -> Bool+isTypeBody (Right body) = case body of     Term (Literal (TypeLit _)) -> True-    TyApp {}       -> True-    _               -> False+    TyApp {}                   -> True+    _                          -> False isTypeBody _ = False  -- | True when the macro expression is unambiguously an expression (a literal -- or an operator application), not a type.-isExprBody :: Either e (Macro ann) -> Bool-isExprBody (Right Macro{macroExpr}) = case macroExpr of+isExprBody :: Either e (Expr ctx (Ps ann)) -> Bool+isExprBody (Right body) = case body of     Term (Literal (ValueLit (ValueInt _)))    -> True     Term (Literal (ValueLit (ValueFloat _)))  -> True     Term (Literal (ValueLit (ValueChar _)))   -> True     Term (Literal (ValueLit (ValueString _))) -> True-    VaApp {}         -> True-    _                 -> False+    VaApp {}                                  -> True+    _                                         -> False isExprBody _ = False -getMacroExpr ::-     forall e ctx ann. Nat.SNatI ctx-  => Either e (Macro ann)-  -> Maybe (Expr ctx (Ps ann))-getMacroExpr (Right (Macro @_ @ctx1 _ _ macroParams macroExpr)) =-    Vec.withDict macroParams $-      case Nat.eqNat @ctx @ctx1 of-        Just Refl -> Just macroExpr-        Nothing   -> Nothing-getMacroExpr _ =-    Nothing---- | Extract the expression body from an object-like (0-arg) macro.-getObjExpr :: forall e ann. Either e (Macro ann) -> Maybe (Expr Z (Ps ann))-getObjExpr = getMacroExpr---- | Extract the expression body from a function-like macro with one parameter.-getFn1Expr :: forall e ann. Either e (Macro ann) -> Maybe (Expr (S Z) (Ps ann))-getFn1Expr = getMacroExpr- {-------------------------------------------------------------------------------   Type bodies -------------------------------------------------------------------------------}@@ -108,36 +79,36 @@ tests_typeBody cStd = [       testCase "int" $         -- #define FOO int-        getObjExpr (checkMacro cStd [macroNameTok, kw "int"])-          @?= Just (tyLit (TypeInt Nothing (Just SizeInt)))+        checkBody cStd VNil [kw "int"]+          @?= Right (tyLit (TypeInt Nothing (Just SizeInt)))     , testCase "unsigned long" $         -- #define FOO unsigned long-        getObjExpr (checkMacro cStd [macroNameTok, kw "unsigned", kw "long"])-          @?= Just (tyLit (TypeInt (Just Unsigned) (Just SizeLong)))+        checkBody cStd VNil [kw "unsigned", kw "long"]+          @?= Right (tyLit (TypeInt (Just Unsigned) (Just SizeLong)))     , testCase "const int*" $         -- #define FOO const int *-        getObjExpr (checkMacro cStd [macroNameTok, kw "const", kw "int", punc "*"])-          @?= Just (TyApp Pointer (TyApp Const (tyLit (TypeInt Nothing (Just SizeInt)) ::: VNil) ::: VNil))+        checkBody cStd VNil [kw "const", kw "int", punc "*"]+          @?= Right (TyApp Pointer (TyApp Const (tyLit (TypeInt Nothing (Just SizeInt)) ::: VNil) ::: VNil))     , testCase "void*" $         -- #define FOO void *-        getObjExpr (checkMacro cStd [macroNameTok, kw "void", punc "*"])-          @?= Just (TyApp Pointer (tyLit TypeVoid ::: VNil))+        checkBody cStd VNil [kw "void", punc "*"]+          @?= Right (TyApp Pointer (tyLit TypeVoid ::: VNil))     , testCase "struct Foo" $         -- #define FOO struct Foo-        getObjExpr (checkMacro cStd [macroNameTok, kw "struct", ident "Foo"])-          @?= Just (mtagged "Foo" TagStruct)+        checkBody cStd VNil [kw "struct", ident "Foo"]+          @?= Right (mtagged "Foo" TagStruct)     , testCase "size_t" $         -- #define FOO size_t (bare identifier; typechecker decides it's a type)-        getObjExpr (checkMacro cStd [macroNameTok, ident "size_t"])-          @?= Just (mvar "size_t")+        checkBody cStd VNil [ident "size_t"]+          @?= Right (mvar "size_t")     , testCase "_Bool" $         -- #define FOO _Bool-        getObjExpr (checkMacro cStd [macroNameTok, kw "_Bool"])-          @?= Just (tyLit TypeBool)-    , testCase "_Bool" $+        checkBody cStd VNil [kw "_Bool"]+          @?= Right (tyLit TypeBool)+    , testCase "size_t const * const" $         -- #define FOO size_t const * const-        getObjExpr (checkMacro cStd [macroNameTok, ident "size_t", kw "const", punc "*", kw "const" ])-          @?= Just (TyApp Const (TyApp Pointer (TyApp Const (mvar "size_t" ::: VNil) ::: VNil) ::: VNil))+        checkBody cStd VNil [ident "size_t", kw "const", punc "*", kw "const"]+          @?= Right (TyApp Const (TyApp Pointer (TyApp Const (mvar "size_t" ::: VNil) ::: VNil) ::: VNil))     ]  {-------------------------------------------------------------------------------@@ -149,29 +120,95 @@       testCase "PTR(T) = T*" $         -- #define PTR(T) T*         -- T is a local arg; the body is a pointer type parameterised by T.-        getFn1Expr (checkMacro cStd-            [ macroNameTok, punc "(", ident "T", punc ")"-            , ident "T", punc "*"-            ])-          @?= Just (TyApp Pointer (Term (LocalParam IZ) ::: VNil))+        checkBody cStd (Identifier "T" ::: VNil) [ident "T", punc "*"]+          @?= Right (TyApp Pointer (Term (LocalParam IZ) ::: VNil))     , testCase "CONST_PTR(T) = const T*" $         -- #define CONST_PTR(T) const T*-        getFn1Expr (checkMacro cStd-            [ macroNameTok, punc "(", ident "T", punc ")"-            , kw "const", ident "T", punc "*"-            ])-          @?= Just (TyApp Pointer (TyApp Const (Term (LocalParam IZ) ::: VNil) ::: VNil))+        checkBody cStd (Identifier "T" ::: VNil) [kw "const", ident "T", punc "*"]+          @?= Right (TyApp Pointer (TyApp Const (Term (LocalParam IZ) ::: VNil) ::: VNil))     , testCase "free var is not a local arg" $         -- #define PTR(T) size_t*         -- size_t is not a formal parameter, so it stays as Var, not LocalParam.-        getFn1Expr (checkMacro cStd-            [ macroNameTok, punc "(", ident "T", punc ")"-            , ident "size_t", punc "*"-            ])-          @?= Just (TyApp Pointer (mvar "size_t" ::: VNil))+        checkBody cStd (Identifier "T" ::: VNil) [ident "size_t", punc "*"]+          @?= Right (TyApp Pointer (mvar "size_t" ::: VNil))     ]  {-------------------------------------------------------------------------------+  Parameters spelled like keywords++  The preprocessor works on pp-tokens, which have no keywords, so+  @#define F(bool) bool@ is valid C in every standard and the body's @bool@ is+  the parameter. libclang classifies the spelling according to the translation+  unit's language options, so the same body arrives as 'kw' under C23 and as+  'ident' under C17; both must parse the same way.+-------------------------------------------------------------------------------}++tests_keywordParam :: ClangCStandard -> [TestTree]+tests_keywordParam cStd = [+      testCase "F(bool) = bool (keyword token)" $+        -- #define F(bool) bool+        checkBody cStd (Identifier "bool" ::: VNil) [kw "bool"]+          @?= Right (Term (LocalParam IZ))+    , testCase "F(bool) = bool (identifier token)" $+        -- #define F(bool) bool+        checkBody cStd (Identifier "bool" ::: VNil) [ident "bool"]+          @?= Right (Term (LocalParam IZ))+    , testCase "F(bool) = bool*" $+        -- #define F(bool) bool *+        checkBody cStd (Identifier "bool" ::: VNil) [kw "bool", punc "*"]+          @?= Right (TyApp Pointer (Term (LocalParam IZ) ::: VNil))+    , testCase "F(int) = int" $+        -- #define F(int) int+        checkBody cStd (Identifier "int" ::: VNil) [kw "int"]+          @?= Right (Term (LocalParam IZ))+    , testCase "F(const) = const" $+        -- #define F(const) const+        checkBody cStd (Identifier "const" ::: VNil) [kw "const"]+          @?= Right (Term (LocalParam IZ))+    , testCase "F(sizeof) = sizeof + 1" $+        -- #define F(sizeof) sizeof + 1+        checkBody cStd (Identifier "sizeof" ::: VNil)+            [kw "sizeof", punc "+", lit "1"]+          @?= Right (add (Term (LocalParam IZ)) (intLit 1))+      -- The shadowing also holds in qualifier and specifier position, where the+      -- token is matched by spelling and kind rather than looked up in scope.+    , testCase "F(const) = const *" $+        -- #define F(const) const *+        checkBody cStd (Identifier "const" ::: VNil) [kw "const", punc "*"]+          @?= Right (TyApp Pointer (Term (LocalParam IZ) ::: VNil))+    , testCase "F(const) = const x is not a qualified type" $+        -- #define F(const) const x+        -- The parameter is not the 'const' qualifier, and a qualifier applied+        -- to a parameter is not representable, so this must fail rather than+        -- silently yield @const x@ with the parameter dropped.+        assertBool "expected failure" $+          isLeft (checkBody cStd (Identifier "const" ::: VNil)+                    [kw "const", ident "x"])+    , testCase "F(int) = unsigned int is not a type literal" $+        -- #define F(int) unsigned int+        assertBool "expected failure" $+          isLeft (checkBody cStd (Identifier "int" ::: VNil)+                    [kw "unsigned", kw "int"])+    , testCase "F(Foo) = struct Foo is not a tagged type" $+        -- #define F(Foo) struct Foo+        -- A parameter as the tag name is not representable either.+        assertBool "expected failure" $+          isLeft (checkBody cStd (Identifier "Foo" ::: VNil)+                    [kw "struct", ident "Foo"])+      -- The complement: a keyword that is /not/ a parameter keeps its keyword+      -- meaning. An over-broad fix (accepting keywords as identifiers) would+      -- turn this into a variable reference.+    , testCase "F(x) = bool is still the type bool" $+        -- #define F(x) bool+        let res = checkBody cStd (Identifier "x" ::: VNil) [kw "bool"]+        in  case cStd of+              ClangCStandard std _ | std >= C23 ->+                res @?= Right (tyLit TypeBool)+              _ ->+                assertBool "bool not a kw" $ isLeft res+    ]++{-------------------------------------------------------------------------------   Expression bodies -------------------------------------------------------------------------------} @@ -181,41 +218,77 @@       testCase "integer literal" $         -- #define FOO 42         assertBool "expected expression body" $-          isExprBody (checkMacro cStd [macroNameTok, lit "42"])+          isExprBody (checkBody cStd VNil [lit "42"])     , testCase "negative literal" $         -- #define FOO -1         assertBool "expected expression body" $-          isExprBody (checkMacro cStd [macroNameTok, punc "-", lit "1"])+          isExprBody (checkBody cStd VNil [punc "-", lit "1"])     , testCase "arithmetic expression" $         -- #define FOO 1 + 2         assertBool "expected expression body" $-          isExprBody (checkMacro cStd [macroNameTok, lit "1", punc "+", lit "2"])+          isExprBody (checkBody cStd VNil [lit "1", punc "+", lit "2"])       -- Function-like macros       -- A bare identifier body (e.g. x) is structurally identical for type and       -- expression positions after the Expr unification; we just check it parses.     , testCase "identity function" $         -- #define FOO(x) x         assertBool "expected parse success" $-          isRight $-            checkMacro cStd [-                macroNameTok, punc "(", ident "x", punc ")"-              , ident "x"-              ]+          isRight $ checkBody cStd (Identifier "x" ::: VNil) [ident "x"]     , testCase "two-argument function" $         -- #define FOO(a, b) a + b+        -- Parameters are given in source order; the /last/ one is the innermost+        -- binder, so a is I1 and b is IZ.+        checkBody cStd (Identifier "a" ::: Identifier "b" ::: VNil)+            [ident "a", punc "+", ident "b"]+          @?= Right (add (Term (LocalParam I1)) (Term (LocalParam IZ)))+    , testCase "zero-argument function" $+        -- #define FOO() 0         assertBool "expected expression body" $-          isExprBody $-            checkMacro cStd [-                macroNameTok-              , punc "(", ident "a", punc ",", ident "b", punc ")"-              , ident "a", punc "+", ident "b"-              ]-      -- Zero-argument function-like macro (#define FOO() 0) is-      -- parsed as objectLike since empty parens are not valid formalArgs;-      -- the result is still an expression body+          isExprBody (checkBody cStd VNil [lit "0"])     ]  {-------------------------------------------------------------------------------+  Comma bodies++  A comma in a macro body denotes a tuple, not the C comma operator; see+  <https://github.com/well-typed/hs-bindgen/issues/2182>.+-------------------------------------------------------------------------------}++tests_commaBody :: ClangCStandard -> [TestTree]+tests_commaBody cStd = [+      testCase "(1, 2)" $+        -- #define FOO (1, 2)+        checkBody cStd VNil [punc "(", lit "1", punc ",", lit "2", punc ")"]+          @?= Right (mtuple (intLit 1 ::: intLit 2 ::: VNil))+    , testCase "1, 2 (without parentheses)" $+        -- #define FOO 1, 2+        checkBody cStd VNil [lit "1", punc ",", lit "2"]+          @?= Right (mtuple (intLit 1 ::: intLit 2 ::: VNil))+    , testCase "(1, 2, 3)" $+        -- #define FOO (1, 2, 3)+        checkBody cStd VNil+            [punc "(", lit "1", punc ",", lit "2", punc ",", lit "3", punc ")"]+          @?= Right (mtuple (intLit 1 ::: intLit 2 ::: intLit 3 ::: VNil))+    , testCase "components are full expressions" $+        -- #define FOO (1 + 2, 3)+        checkBody cStd VNil+            [punc "(", lit "1", punc "+", lit "2", punc ",", lit "3", punc ")"]+          @?= Right (mtuple (add (intLit 1) (intLit 2) ::: intLit 3 ::: VNil))+    , testCase "FOO(x, y) = (x, y)" $+        -- #define FOO(x, y) (x, y)+        checkBody cStd (Identifier "x" ::: Identifier "y" ::: VNil)+            [punc "(", ident "x", punc ",", ident "y", punc ")"]+          @?= Right (mtuple (Term (LocalParam I1) ::: Term (LocalParam IZ) ::: VNil))+    , testCase "FOO(x, y) = ((x), (y))" $+        -- #define FOO(x, y) ((x), (y))+        checkBody cStd (Identifier "x" ::: Identifier "y" ::: VNil)+            [ punc "(", punc "(", ident "x", punc ")", punc ","+            ,           punc "(", ident "y", punc ")", punc ")"+            ]+          @?= Right (mtuple (Term (LocalParam I1) ::: Term (LocalParam IZ) ::: VNil))+    ]++{-------------------------------------------------------------------------------   Disambiguation: types vs. expressions -------------------------------------------------------------------------------} @@ -227,29 +300,28 @@       testCase "bare name parses successfully" $         -- #define FOO size_t         assertBool "expected parse success" $-          isRight (checkMacro cStd [macroNameTok, ident "size_t"])+          isRight (checkBody cStd VNil [ident "size_t"])     , testCase "void is a type body, not an identifier expression" $         -- #define FOO void         assertBool "expected type body" $-          isTypeBody (checkMacro cStd [macroNameTok, kw "void"])+          isTypeBody (checkBody cStd VNil [kw "void"])       -- An integer literal cannot be a type, so it falls through to expression.     , testCase "literal falls through to expression" $         -- #define FOO 0         assertBool "expected expression body" $-          isExprBody (checkMacro cStd [macroNameTok, lit "0"])-      -- An expression that starts with parenthesised identifiers could look-      -- like formal arguments.+          isExprBody (checkBody cStd VNil [lit "0"])+      -- A parenthesised literal is not a type either.     , testCase "parenthesised expression is not a type" $         -- #define FOO (1)         assertBool "expected expression body" $-          isExprBody (checkMacro cStd [macroNameTok, punc "(", lit "1", punc ")"])+          isExprBody (checkBody cStd VNil [punc "(", lit "1", punc ")"])       -- Completely unparseable input     , testCase "bare comma fails" $         -- #define FOO ,         assertBool "expected failure" $-          isLeft (checkMacro cStd [macroNameTok, punc ","])+          isLeft (checkBody cStd VNil [punc ","])     , testCase "empty body fails" $         -- #define FOO         assertBool "expected failure" $-          isLeft (checkMacro cStd [macroNameTok])+          isLeft (checkBody cStd VNil [])     ]

@@ -53,7 +53,8 @@         -- _Bool         checkType cStd [kw "_Bool"]           @?= Right (tyLit TypeBool)-      -- 'bool' as CXToken_Keyword (Clang >= 16)+      -- 'bool' as CXToken_Keyword, which is how libclang classifies it under+      -- C23 and later     , testCase "bool (keyword)" $         -- bool         let res = checkType cStd [kw "bool"]@@ -62,7 +63,8 @@                 res @?= Right (tyLit TypeBool)               _ ->                 assertBool "bool not a kw" $ isLeft res-      -- 'bool' as CXToken_Identifier (older Clang): treated as a named type+      -- 'bool' as CXToken_Identifier, which is how libclang classifies it+      -- before C23: treated as a named type     , testCase "bool (identifier)" $         -- bool         checkType cStd [ident "bool"]

@@ -20,6 +20,7 @@     , tests_typeApp     , tests_intLiterals     , tests_arithmetic+    , tests_commas     , tests_functionLike     , tests_typeEnvChain     , tests_errors@@ -79,9 +80,38 @@     ]  {--------------------------------------------------------------------------------  Group 5: function-like macro bodies (with formal parameters)+  Group 5: comma expression bodies++  A comma in a macro body denotes a tuple, not the C comma operator; see+  <https://github.com/well-typed/hs-bindgen/issues/2182>. -------------------------------------------------------------------------------} +tests_commas :: TestTree+tests_commas = testGroup "comma expression bodies" [+      testCase "1, 2" $+        assertTupleMacro 2 $+          classifyOne "M" VNil (mtuple (intLit 1 ::: intLit 2 ::: VNil))+    , testCase "1, 2, 3" $+        assertTupleMacro 3 $+          classifyOne "M" VNil+            (mtuple (intLit 1 ::: intLit 2 ::: intLit 3 ::: VNil))+    , testCase "mixed: 1 + 2, 3" $+        assertTupleMacro 2 $+          classifyOne "M" VNil+            (mtuple (add (intLit 1) (intLit 2) ::: intLit 3 ::: VNil))+    , testCase "TUPLE(x, y) = x, y" $+        -- The components are independently polymorphic: the macro's type is+        -- @forall a b. a -> b -> (a, b)@, not @b@ as the comma operator would+        -- give.+        assertTupleMacro 2 $+          classifyOne "TUPLE" ("x" ::: "y" ::: VNil)+            (mtuple (mlocal I1 ::: mlocal IZ ::: VNil))+    ]++{-------------------------------------------------------------------------------+  Group 6: function-like macro bodies (with formal parameters)+-------------------------------------------------------------------------------}+ tests_functionLike :: TestTree tests_functionLike = testGroup "function-like macro bodies" [       testCase "identity: \\x -> x" $@@ -93,7 +123,7 @@     ]  {--------------------------------------------------------------------------------  Group 6: TypeEnv chain — value macro references+  Group 7: TypeEnv chain — value macro references -------------------------------------------------------------------------------}  tests_typeEnvChain :: TestTree@@ -115,7 +145,7 @@     ]  {--------------------------------------------------------------------------------  Group 7: error cases+  Group 8: error cases -------------------------------------------------------------------------------}  tests_errors :: TestTree

@@ -9,6 +9,7 @@     -- * Assertion helpers   , assertTypeMacro   , assertValueMacro+  , assertTupleMacro     -- * Expression helpers   , tyLit   , constOf@@ -19,20 +20,26 @@   , mlocal   , mvar   , mtagged+  , mtuple   ) where  import Data.Functor.Identity (Identity (runIdentity)) import Data.Map (Map) import Data.Map qualified as Map import Data.Nat (Nat (..))+import Data.Type.Nat (SNatI)+import Data.Type.Nat qualified as Nat import Data.Vec.Lazy (Vec (..)) import DeBruijn (Idx (..))+import Numeric.Natural (Natural) import Test.Tasty.HUnit  import C.Type qualified as Runtime  import C.Expr.Syntax import C.Expr.Typecheck+import C.Expr.Typecheck.Type (Kind (Ty), QuantTyBody (..), Type (..),+                              mkQuantTyBody, pattern Tuple) import C.Expr.Util.Panic  import Test.CExpr.Util@@ -84,6 +91,27 @@ assertValueMacro r =     assertBool ("expected MacroTcValueExpr, got: " ++ show r) (isValueMacro r) +-- | Assert that the macro is a value macro whose result type is a tuple of the+-- given arity.+assertTupleMacro :: (Show a) => Natural -> MacroTcResult a -> Assertion+assertTupleMacro arity r =+    case r of+      MacroTcValueExpr TypecheckedMacroValueExpr{macroValueType}+        | Tuple n _ <- resultTy (snd (quantTyBody (mkQuantTyBody macroValueType)))+        , Nat.snatToNatural n == arity+        -> pure ()+      _otherwise+        -> assertFailure $+             "expected a value macro of tuple type with arity "+               ++ show arity ++ ", got: " ++ show r+  where+    -- Drop the parameters of a function-like macro; we are only interested in+    -- what its body evaluates to.+    resultTy :: Type Ty -> Type Ty+    resultTy = \case+      FunTy _params res -> res+      ty                -> ty+ tyLit :: TypeLit -> Expr ctx (Ps ()) tyLit = Term . Literal . TypeLit @@ -116,6 +144,10 @@  mtagged :: Identifier -> TagKind -> Expr ctx (Ps ()) mtagged n t = Term $ Var (XVarPs ()) (NameTagged n t) []++-- | A comma expression: at least two components, interpreted as a tuple.+mtuple :: SNatI n => Vec (S (S n)) (Expr ctx (Ps ())) -> Expr ctx (Ps ())+mtuple = VaApp NoXApp MTuple  {-------------------------------------------------------------------------------   Auxiliary

@@ -8,7 +8,7 @@ -- | A synthetic source location used to satisfy constructors that carry a -- 'MultiLoc' (notably 'C.Expr.Syntax.Macro' and 'Token') in tests where the -- actual location is irrelevant.-fakeLoc :: MultiLoc+fakeLoc :: MultiLoc SourcePath fakeLoc = MultiLoc{       multiLocExpansion = SingleLoc{           singleLocPath   = "<test>"

@@ -62,21 +62,37 @@ EXPR_BITWISE_OR: Right VaApp NoXApp MBitwiseOr (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 15})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 240})))) ::: VNil) EXPR_PARENS: Right Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 42})))) EXPR_COMPOUND: Right VaApp NoXApp MMult (VaApp NoXApp MAdd (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: VNil) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 3})))) ::: VNil)+EXPR_TUPLE: Right VaApp NoXApp MTuple (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: VNil)+EXPR_TUPLE_NO_PARENS: Right VaApp NoXApp MTuple (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: VNil)+EXPR_TUPLE_THREE: Right VaApp NoXApp MTuple (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 3})))) ::: VNil) FUNC_IDENTITY: Right Term (LocalParam 0) FUNC_ADD: Right VaApp NoXApp MAdd (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) FUNC_NEG: Right VaApp NoXApp MUnaryMinus (Term (LocalParam 0) ::: VNil) FUNC_MULTIPLE_LOCAL_PARAMS: Right VaApp NoXApp MAdd (Term (LocalParam 3) ::: VaApp NoXApp MSub (Term (LocalParam 2) ::: VaApp NoXApp MAdd (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) ::: VNil) ::: VNil)+FUNC_TUPLE: Right VaApp NoXApp MTuple (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil)+FUNC_TUPLE_THREE: Right VaApp NoXApp MTuple (Term (LocalParam 2) ::: Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) FUNC_SINGLELINE: Right VaApp NoXApp MMult (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) FUNC_MULTILINE: Right VaApp NoXApp MMult (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil)+KWPARAM_BOOL: Right Term (LocalParam 0)+KWPARAM_BOOL_PTR: Right TyApp Pointer (Term (LocalParam 0) ::: VNil)+KWPARAM_INT: Right Term (LocalParam 0)+KWPARAM_CONST: Right Term (LocalParam 0)+KWPARAM_SIZEOF: Right VaApp NoXApp MAdd (Term (LocalParam 0) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: VNil)+KWPARAM_CONST_PTR: Right TyApp Pointer (Term (LocalParam 0) ::: VNil)+KWPARAM_UNUSED: Right Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "x") [])+KWPARAM_QUALIFIER: Left <parse error>+KWPARAM_SPECIFIER: Left <parse error>+KWPARAM_TAG: Left <parse error>+KWPARAM_SHADOWS_NOTHING: Right Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "bool") []) EXPR_REF_ADD: Right VaApp NoXApp MAdd (Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_ONE") []) ::: Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_FORTY_TWO") []) ::: VNil) EXPR_CALL_ADD: Right Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "FUNC_ADD") [Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))),Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2}))))]) EXPR_CALL_NESTED: Right VaApp NoXApp MAdd (Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "FUNC_ADD") [Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_ONE") []),Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_FORTY_TWO") [])]) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: VNil) CAST_SINGLE_NOKW: Left <parse error> CAST_SINGLE_KW: Left <parse error> CAST_MULTI_KW: Left <parse error>-BAD_KEYWORD_AS_PARAM: Left <parse error> TYPE_FUN_WITH_PARAM: Right Term (Literal (TypeLit (TypeInt Nothing (Just SizeInt)))) BAD_TERNARY: Left <parse error> BAD_LONG_DOUBLE: Left <parse error> PACK_START: Left <parse error> PACK_FINISH: Left <parse error>+bool: Right Term (Literal (TypeLit (TypeInt Nothing (Just SizeInt))))

@@ -62,21 +62,37 @@ EXPR_BITWISE_OR: Right VaApp NoXApp MBitwiseOr (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 15})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 240})))) ::: VNil) EXPR_PARENS: Right Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 42})))) EXPR_COMPOUND: Right VaApp NoXApp MMult (VaApp NoXApp MAdd (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: VNil) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 3})))) ::: VNil)+EXPR_TUPLE: Right VaApp NoXApp MTuple (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: VNil)+EXPR_TUPLE_NO_PARENS: Right VaApp NoXApp MTuple (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: VNil)+EXPR_TUPLE_THREE: Right VaApp NoXApp MTuple (Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2})))) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 3})))) ::: VNil) FUNC_IDENTITY: Right Term (LocalParam 0) FUNC_ADD: Right VaApp NoXApp MAdd (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) FUNC_NEG: Right VaApp NoXApp MUnaryMinus (Term (LocalParam 0) ::: VNil) FUNC_MULTIPLE_LOCAL_PARAMS: Right VaApp NoXApp MAdd (Term (LocalParam 3) ::: VaApp NoXApp MSub (Term (LocalParam 2) ::: VaApp NoXApp MAdd (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) ::: VNil) ::: VNil)+FUNC_TUPLE: Right VaApp NoXApp MTuple (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil)+FUNC_TUPLE_THREE: Right VaApp NoXApp MTuple (Term (LocalParam 2) ::: Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) FUNC_SINGLELINE: Right VaApp NoXApp MMult (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil) FUNC_MULTILINE: Right VaApp NoXApp MMult (Term (LocalParam 1) ::: Term (LocalParam 0) ::: VNil)+KWPARAM_BOOL: Right Term (LocalParam 0)+KWPARAM_BOOL_PTR: Right TyApp Pointer (Term (LocalParam 0) ::: VNil)+KWPARAM_INT: Right Term (LocalParam 0)+KWPARAM_CONST: Right Term (LocalParam 0)+KWPARAM_SIZEOF: Right VaApp NoXApp MAdd (Term (LocalParam 0) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: VNil)+KWPARAM_CONST_PTR: Right TyApp Pointer (Term (LocalParam 0) ::: VNil)+KWPARAM_UNUSED: Right Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "x") [])+KWPARAM_QUALIFIER: Left <parse error>+KWPARAM_SPECIFIER: Left <parse error>+KWPARAM_TAG: Left <parse error>+KWPARAM_SHADOWS_NOTHING: Right Term (Literal (TypeLit TypeBool)) EXPR_REF_ADD: Right VaApp NoXApp MAdd (Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_ONE") []) ::: Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_FORTY_TWO") []) ::: VNil) EXPR_CALL_ADD: Right Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "FUNC_ADD") [Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))),Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 2}))))]) EXPR_CALL_NESTED: Right VaApp NoXApp MAdd (Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "FUNC_ADD") [Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_ONE") []),Term (Var (XVarPs {psAnn = ()}) (NameOrdinary "EXPR_FORTY_TWO") [])]) ::: Term (Literal (ValueLit (ValueInt (IntegerLiteral {integerLiteralType = Int Signed, integerLiteralValue = 1})))) ::: VNil) CAST_SINGLE_NOKW: Left <parse error> CAST_SINGLE_KW: Left <parse error> CAST_MULTI_KW: Left <parse error>-BAD_KEYWORD_AS_PARAM: Left <parse error> TYPE_FUN_WITH_PARAM: Right Term (Literal (TypeLit (TypeInt Nothing (Just SizeInt)))) BAD_TERNARY: Left <parse error> BAD_LONG_DOUBLE: Left <parse error> PACK_START: Left <parse error> PACK_FINISH: Left <parse error>+bool: Right Term (Literal (TypeLit (TypeInt Nothing (Just SizeInt))))

@@ -1,7 +1,8 @@ // Fixture for c-expr-dsl golden tests. //-// Each macro is parsed using libclang and then fed to 'parseMacro'. The-// results are compared against the golden file macros.golden.+// Each macro is tokenised using libclang, split into its formal parameters and+// its body, and then fed to 'parseMacroBody'. The results are compared against+// the golden file macros.golden.  // --------------------------------------------------------------------------- // Type macros: void and bool@@ -139,6 +140,25 @@ #define EXPR_COMPOUND (1 + 2) * 3  // ---------------------------------------------------------------------------+// Expression macros: comma+//+// A comma in a macro body denotes a tuple, not the C comma operator.+//+// C assigns no meaning to macro bodies, so we are free to pick the most useful+// interpretation. Tuples support the argument-list idiom (`#define ARGS 1, 2`+// used as `f(ARGS)`).+//+// The comma operator resembles side effects, which we cannot express in Haskell+// in a meaningful way anyways.+//+// See <https://github.com/well-typed/hs-bindgen/issues/2182>.+// ---------------------------------------------------------------------------++#define EXPR_TUPLE (1, 2)+#define EXPR_TUPLE_NO_PARENS 1, 2+#define EXPR_TUPLE_THREE (1, 2, 3)++// --------------------------------------------------------------------------- // Function-like macros // --------------------------------------------------------------------------- @@ -146,6 +166,9 @@ #define FUNC_ADD(a, b) a + b #define FUNC_NEG(x) (-x) #define FUNC_MULTIPLE_LOCAL_PARAMS(a, b, c, d) a + (b - (c + d))+// Comma is a tuple here, too (see EXPR_TUPLE above)+#define FUNC_TUPLE(x, y) (x, y)+#define FUNC_TUPLE_THREE(x, y, z) ((x), (y), (z)) // TODO <https://github.com/well-typed/c-expr/issues/1> // // Ternary operator is not yet in the expression grammar (see below).@@ -170,6 +193,36 @@ y  // ---------------------------------------------------------------------------+// Function-like macros: parameters spelled like keywords+//+// The preprocessor works on pp-tokens, which have no keywords, so these are+// valid C in every standard, and inside the replacement list the parameter+// shadows the keyword. libclang classifies the spelling according to the+// language options of the translation unit ('bool' is CXToken_Identifier under+// -std=c17 and CXToken_Keyword under -std=c2x), so every parameter reference+// below must come out identical in both golden files.+// ---------------------------------------------------------------------------++#define KWPARAM_BOOL(bool) bool+#define KWPARAM_BOOL_PTR(bool) bool *+#define KWPARAM_INT(int) int+#define KWPARAM_CONST(const) const+#define KWPARAM_SIZEOF(sizeof) sizeof + 1+#define KWPARAM_CONST_PTR(const) const *+// The parameter is unused, so the body is an ordinary free variable+#define KWPARAM_UNUSED(int) x+// The shadowing also holds in qualifier, specifier and tag position. None of+// these bodies is representable (a qualifier or specifier applied to a+// parameter has no syntax tree), so all must be rejected rather than parsed+// with the parameter silently dropped.+#define KWPARAM_QUALIFIER(const) const x+#define KWPARAM_SPECIFIER(int) unsigned int+#define KWPARAM_TAG(Foo) struct Foo+// 'bool' is not a parameter here, so it keeps its keyword meaning: the type+// bool under C23, a named type under C17+#define KWPARAM_SHADOWS_NOTHING(x) bool++// --------------------------------------------------------------------------- // Expression macros: references to other macros / typedefs // // Macro names and typedef names are tokenised as CXToken_Identifier, so@@ -199,9 +252,6 @@ #define CAST_SINGLE_KW (int)x #define CAST_MULTI_KW (unsigned int)x -// This is genuine erroneous function; keywords must not be parameter names.-#define BAD_KEYWORD_AS_PARAM(int) x- // We can parse this macro, but typecheck will fail. #define TYPE_FUN_WITH_PARAM(X) int @@ -217,3 +267,11 @@ // expands to a preprocessing directive, not a C expression, so we reject it. #define PACK_START _Pragma("pack(1)") #define PACK_FINISH _Pragma("pack()")++// ---------------------------------------------------------------------------+// A macro name spelled like a keyword+//+// Also valid C. Defined last, because from here on the spelling is a macro.+// ---------------------------------------------------------------------------++#define bool int