Type inference of macros

This commit implements a simple type-inference pass for macros, see HsBindgen.C.Tc.Macro. It implements a type system with: - variables - function types - type constructors - quantified types Type inference for a macro function definition proceeds in the following stages: 1. constraint generation following Algorithm W, creating new metavariables and carrying a substitution, 2. constraint solving: constraint simplification and defaulting 3. quantification over remaining (undefaulted) type variables and remaining (unsolved) constraints.
well-typed · Oct 21, 2024 · 8463ecb · 8463ecb
1 parent 7ae79a5
commit 8463ecb
Show file tree

Hide file tree

Showing 15 changed files with 1,341 additions and 102 deletions.
diff --git a/.gitignore b/.gitignore
@@ -3,3 +3,4 @@ dist-newstyle/
 unversioned
 cabal.project.local
 .vscode/
+*.dll
diff --git a/hs-bindgen/fixtures/enums.tree-diff.txt b/hs-bindgen/fixtures/enums.tree-diff.txt
@@ -2,7 +2,7 @@ WrapCHeader
   (Header
     [
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {

diff --git a/hs-bindgen/fixtures/macro_functions.tree-diff.txt b/hs-bindgen/fixtures/macro_functions.tree-diff.txt
@@ -2,7 +2,7 @@ WrapCHeader
   (Header
     [
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -16,15 +16,17 @@ WrapCHeader
               multiLocFile = Nothing},
             macroName = CName "INCR",
             macroArgs = [CName "x"],
-            macroBody = MAdd
-              (MTerm (MVar (CName "x") []))
-              (MTerm
-                (MInt
-                  Literal {
-                    literalText = "1",
-                    literalValue = 1}))}),
+            macroBody = MApp
+              MAdd
+              [
+                MTerm (MVar (CName "x") []),
+                MTerm
+                  (MInt
+                    Literal {
+                      literalText = "1",
+                      literalValue = 1})]}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -40,7 +42,8 @@ WrapCHeader
             macroArgs = [
               CName "x",
               CName "y"],
-            macroBody = MAdd
-              (MTerm (MVar (CName "x") []))
-              (MTerm
-                (MVar (CName "y") []))})])
+            macroBody = MApp
+              MAdd
+              [
+                MTerm (MVar (CName "x") []),
+                MTerm (MVar (CName "y") [])]})])
diff --git a/hs-bindgen/fixtures/macros.tree-diff.txt b/hs-bindgen/fixtures/macros.tree-diff.txt
@@ -2,7 +2,7 @@ WrapCHeader
   (Header
     [
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -22,7 +22,7 @@ WrapCHeader
                   literalText = "1",
                   literalValue = 1})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -42,7 +42,7 @@ WrapCHeader
                   literalText = "2",
                   literalValue = 2})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -56,19 +56,21 @@ WrapCHeader
               multiLocFile = Nothing},
             macroName = CName "OBJECTLIKE3",
             macroArgs = [],
-            macroBody = MAdd
-              (MTerm
-                (MInt
-                  Literal {
-                    literalText = "3",
-                    literalValue = 3}))
-              (MTerm
-                (MInt
-                  Literal {
-                    literalText = "3",
-                    literalValue = 3}))}),
+            macroBody = MApp
+              MAdd
+              [
+                MTerm
+                  (MInt
+                    Literal {
+                      literalText = "3",
+                      literalValue = 3}),
+                MTerm
+                  (MInt
+                    Literal {
+                      literalText = "3",
+                      literalValue = 3})]}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -82,19 +84,21 @@ WrapCHeader
               multiLocFile = Nothing},
             macroName = CName "OBJECTLIKE4",
             macroArgs = [],
-            macroBody = MAdd
-              (MTerm
-                (MInt
-                  Literal {
-                    literalText = "4",
-                    literalValue = 4}))
-              (MTerm
-                (MInt
-                  Literal {
-                    literalText = "4",
-                    literalValue = 4}))}),
+            macroBody = MApp
+              MAdd
+              [
+                MTerm
+                  (MInt
+                    Literal {
+                      literalText = "4",
+                      literalValue = 4}),
+                MTerm
+                  (MInt
+                    Literal {
+                      literalText = "4",
+                      literalValue = 4})]}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -115,7 +119,7 @@ WrapCHeader
                   literalText = "42",
                   literalValue = 42})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -136,7 +140,7 @@ WrapCHeader
                   literalText = "052",
                   literalValue = 42})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -157,7 +161,7 @@ WrapCHeader
                   literalText = "0x2a",
                   literalValue = 42})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -178,7 +182,7 @@ WrapCHeader
                   literalText = "0X2A",
                   literalValue = 42})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -199,7 +203,7 @@ WrapCHeader
                   literalText = "0b101010",
                   literalValue = 42})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -222,7 +226,7 @@ WrapCHeader
                   literalValue =
                   18446744073709550592})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -245,7 +249,7 @@ WrapCHeader
                   literalValue =
                   18446744073709550592})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -268,7 +272,7 @@ WrapCHeader
                   literalValue =
                   18446744073709550592})}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {

diff --git a/hs-bindgen/fixtures/typedef_vs_macro.tree-diff.txt b/hs-bindgen/fixtures/typedef_vs_macro.tree-diff.txt
@@ -2,7 +2,7 @@ WrapCHeader
   (Header
     [
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {
@@ -19,7 +19,7 @@ WrapCHeader
             macroBody = MTerm
               (MType (PrimInt Signed))}),
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {

diff --git a/hs-bindgen/fixtures/uses_utf8.tree-diff.txt b/hs-bindgen/fixtures/uses_utf8.tree-diff.txt
@@ -2,7 +2,7 @@ WrapCHeader
   (Header
     [
       DeclMacro
-        (Right
+        (MacroDecl
           Macro {
             macroLoc = MultiLoc {
               multiLocExpansion = SingleLoc {

diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal
@@ -79,6 +79,8 @@ library
       HsBindgen.C.Reparse.Literal
       HsBindgen.C.Reparse.Macro
       HsBindgen.C.Reparse.Type
+      HsBindgen.C.Tc.Macro
+      HsBindgen.Pretty.Orphans
       HsBindgen.Hs.AST.Name
       HsBindgen.Translation.LowLevel
       HsBindgen.Util.Parsec

diff --git a/hs-bindgen/src/HsBindgen/C/AST.hs b/hs-bindgen/src/HsBindgen/C/AST.hs
@@ -27,8 +27,10 @@ module HsBindgen.C.AST (
   , Typedef(..)
     -- * Macros
   , Macro(..)
+  , MacroDecl(..)
     -- ** Expressions
   , MExpr(..)
+  , MFun(..)
   , MTerm(..)
   , Literal(..)
     -- ** Attributes
@@ -37,6 +39,7 @@ module HsBindgen.C.AST (
   , isIncludeGuard
     -- ** Unrecognized
   , ReparseError(..)
+  , TcMacroError(..)
   , Token(..)
   , TokenSpelling(..)
     -- * Source locations
@@ -54,6 +57,8 @@ import HsBindgen.C.AST.Macro
 import HsBindgen.C.AST.Name
 import HsBindgen.C.AST.Type
 import HsBindgen.C.Reparse.Infra (ReparseError(..))
+import HsBindgen.C.Tc.Macro
+  ( TcMacroError(..) )
 import HsBindgen.Clang.HighLevel.Types
 
 {-------------------------------------------------------------------------------
@@ -72,7 +77,13 @@ data Decl =
     DeclStruct Struct
   | DeclTypedef Typedef
   | DeclEnum Enu
-  | DeclMacro (Either ReparseError Macro)
+  | DeclMacro MacroDecl
   deriving stock (Show, Eq, Generic)
   deriving anyclass (PrettyVal)
 
+data MacroDecl
+  = MacroReparseError ReparseError
+  | MacroTcError TcMacroError
+  | MacroDecl Macro
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (PrettyVal)
diff --git a/hs-bindgen/src/HsBindgen/C/AST/Macro.hs b/hs-bindgen/src/HsBindgen/C/AST/Macro.hs
@@ -6,6 +6,7 @@ module HsBindgen.C.AST.Macro (
     Macro(..)
     -- ** Expressions
   , MExpr(..)
+  , MFun(..)
   , MTerm(..)
     -- ** Attributes
   , Attribute(..)
@@ -45,28 +46,34 @@ data Macro = Macro {
 -- | Body of a function-like macro
 data MExpr =
     MTerm MTerm
-  | MUnaryPlus MExpr        -- ^ @+@
-  | MUnaryMinus MExpr       -- ^ @-@
-  | MLogicalNot MExpr       -- ^ @!@
-  | MBitwiseNot MExpr       -- ^ @~@
-  | MMult MExpr MExpr        -- ^ @*@
-  | MDiv MExpr MExpr         -- ^ @/@
-  | MRem MExpr MExpr         -- ^ @%@
-  | MAdd MExpr MExpr         -- ^ @+@
-  | MSub MExpr MExpr         -- ^ @-@
-  | MShiftLeft MExpr MExpr   -- ^ @<<@
-  | MShiftRight MExpr MExpr  -- ^ @>>@
-  | MRelLT MExpr MExpr       -- ^ @<@
-  | MRelLE MExpr MExpr       -- ^ @<=@
-  | MRelGT MExpr MExpr       -- ^ @>@
-  | MRelGE MExpr MExpr       -- ^ @>=@
-  | MRelEQ MExpr MExpr       -- ^ @==@
-  | MRelNE MExpr MExpr       -- ^ @!=@
-  | MBitwiseAnd MExpr MExpr  -- ^ @&@
-  | MBitwiseXor MExpr MExpr  -- ^ @^@
-  | MBitwiseOr MExpr MExpr   -- ^ @|@
-  | MLogicalAnd MExpr MExpr  -- ^ @&&@
-  | MLogicalOr MExpr MExpr   -- ^ @||@
+  -- | Exactly saturated application
+  | MApp MFun [MExpr]
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (PrettyVal)
+
+data MFun
+  = MUnaryPlus  -- ^ @+@
+  | MUnaryMinus -- ^ @-@
+  | MLogicalNot -- ^ @!@
+  | MBitwiseNot -- ^ @~@
+  | MMult       -- ^ @*@
+  | MDiv        -- ^ @/@
+  | MRem        -- ^ @%@
+  | MAdd        -- ^ @+@
+  | MSub        -- ^ @-@
+  | MShiftLeft  -- ^ @<<@
+  | MShiftRight -- ^ @>>@
+  | MRelLT      -- ^ @<@
+  | MRelLE      -- ^ @<=@
+  | MRelGT      -- ^ @>@
+  | MRelGE      -- ^ @>=@
+  | MRelEQ      -- ^ @==@
+  | MRelNE      -- ^ @!=@
+  | MBitwiseAnd -- ^ @&@
+  | MBitwiseXor -- ^ @^@
+  | MBitwiseOr  -- ^ @|@
+  | MLogicalAnd -- ^ @&&@
+  | MLogicalOr  -- ^ @||@
   deriving stock (Show, Eq, Generic)
   deriving anyclass (PrettyVal)