Merge pull request #82 from well-typed/edsko/basic-clang-support

Basic `libclang` bindings

.github/workflows/haskell-ci.yml

@@ -146,6 +146,7 @@ jobs:
       - name: initial cabal.project for sdist
         run: |
           touch cabal.project
+          echo "packages: $GITHUB_WORKSPACE/source/hs-bindgen-patterns" >> cabal.project
           echo "packages: $GITHUB_WORKSPACE/source/hs-bindgen" >> cabal.project
           cat cabal.project
       - name: sdist
@@ -158,23 +159,32 @@ jobs:
           find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
       - name: generate cabal.project
         run: |
+          PKGDIR_hs_bindgen_patterns="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hs-bindgen-patterns-[0-9.]*')"
+          echo "PKGDIR_hs_bindgen_patterns=${PKGDIR_hs_bindgen_patterns}" >> "$GITHUB_ENV"
           PKGDIR_hs_bindgen="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hs-bindgen-[0-9.]*')"
           echo "PKGDIR_hs_bindgen=${PKGDIR_hs_bindgen}" >> "$GITHUB_ENV"
           rm -f cabal.project cabal.project.local
           touch cabal.project
           touch cabal.project.local
+          echo "packages: ${PKGDIR_hs_bindgen_patterns}" >> cabal.project
           echo "packages: ${PKGDIR_hs_bindgen}" >> cabal.project
+          echo "package hs-bindgen-patterns" >> cabal.project
+          echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           echo "package hs-bindgen" >> cabal.project
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           cat >> cabal.project <<EOF
           package hs-bindgen
-            extra-lib-dirs:     /usr/lib/llvm-14/lib
-            extra-include-dirs: /usr/lib/llvm-14/include
+            flags:       +build-clang-tutorial
+            ghc-options: -Werror
 
-          package hs-bindgen
+          package hs-bindgen-patterns
             ghc-options: -Werror
+
+          package hs-bindgen
+            extra-lib-dirs:     /usr/lib/llvm-14/lib
+            extra-include-dirs: /usr/lib/llvm-14/include
           EOF
-          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(hs-bindgen)$/; }' >> cabal.project.local
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(hs-bindgen|hs-bindgen-patterns)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local
       - name: dump install plan
@@ -199,6 +209,8 @@ jobs:
           $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
       - name: cabal check
         run: |
+          cd ${PKGDIR_hs_bindgen_patterns} || false
+          ${CABAL} -vnormal check
           cd ${PKGDIR_hs_bindgen} || false
           ${CABAL} -vnormal check
       - name: haddock

.gitignore

@@ -2,3 +2,4 @@
 dist-newstyle/
 unversioned
 cabal.project.local
+.vscode/

cabal.project

@@ -1 +1,4 @@
-packages: hs-bindgen
+packages: hs-bindgen-patterns, hs-bindgen
+
+package hs-bindgen
+  flags: +build-clang-tutorial

cabal.project.ci

@@ -1,4 +1,11 @@
-packages: hs-bindgen
+packages: hs-bindgen-patterns, hs-bindgen
+
+package hs-bindgen
+  flags: +build-clang-tutorial
+  ghc-options: -Werror
+
+package hs-bindgen-patterns
+  ghc-options: -Werror
 
 -- TODO: <https://github.com/well-typed/hs-bindgen/issues/78>
 -- We should instead /discover/ where @libclang@ is.
@@ -8,5 +15,3 @@ package hs-bindgen
   extra-include-dirs:
     /usr/lib/llvm-14/include
 
-package hs-bindgen
-  ghc-options: -Werror

hs-bindgen-patterns/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for hs-bindgen-patterns
+
+## 0.1.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

hs-bindgen-patterns/LICENSE

@@ -0,0 +1,29 @@
+Copyright (c) 2024, Well-Typed LLP and Anduril Industries Inc. 
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hs-bindgen-patterns/hs-bindgen-patterns.cabal

@@ -0,0 +1,42 @@
+cabal-version:      3.0
+name:               hs-bindgen-patterns
+version:            0.1.0
+synopsis:           Design patterns for writing high-level FFI bindings
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Edsko de Vries
+maintainer:         [email protected]
+category:           Development
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+tested-with:      , GHC==9.2.8
+                  , GHC==9.4.8
+                  , GHC==9.6.6
+                  , GHC==9.8.2
+                  , GHC==9.10.1
+
+common lang
+  ghc-options:
+      -Wall
+  build-depends:
+      base >= 4.16 && < 4.21
+  default-language:
+      GHC2021
+  default-extensions:
+      DeriveAnyClass
+      DerivingStrategies
+  other-extensions:
+      CPP
+
+library
+  import:
+      lang
+  exposed-modules:
+      HsBindgen.Patterns
+  other-modules:
+      HsBindgen.Patterns.Enum.Bitfield
+      HsBindgen.Patterns.Enum.Simple
+      HsBindgen.Patterns.SafeForeignPtr
+      HsBindgen.Patterns.Stack
+  hs-source-dirs:
+      src

hs-bindgen-patterns/src/HsBindgen/Patterns.hs

@@ -0,0 +1,41 @@
+-- | Design patterns for writing high-level FFI bindings
+--
+-- This is the only exported module in this library. It is intended to be
+-- imported unqualified.
+--
+-- __NOTE__: This library is little more than an experiment in its current form,
+-- with some patterns to support the FFI bindings that @hs-bindgen@ itself needs
+-- (for the @libclang@ bindings).
+module HsBindgen.Patterns (
+    -- * Enums
+    -- ** Simple
+    SimpleEnum(..)
+  , IsSimpleEnum(..)
+  , simpleEnum
+  , fromSimpleEnum
+  , unsafeFromSimpleEnum
+    -- ** Bitfield
+  , BitfieldEnum(..)
+  , IsSingleFlag(..)
+   -- *** API
+  , bitfieldEnum
+  , fromBitfieldEnum
+  , flagIsSet
+    -- * Foreign pointers
+  , SafeForeignPtr
+  , AccessedFinalizedForeignPtrException
+    -- ** API
+  , newSafeForeignPtr
+  , withSafeForeignPtr
+  , finalizeSafeForeignPtr
+    -- * Backtrace
+  , Stack
+  , getStack
+  , prettyStack
+  , ContainsStack(..)
+  ) where
+
+import HsBindgen.Patterns.Enum.Bitfield
+import HsBindgen.Patterns.Enum.Simple
+import HsBindgen.Patterns.SafeForeignPtr
+import HsBindgen.Patterns.Stack

hs-bindgen-patterns/src/HsBindgen/Patterns/Enum/Bitfield.hs

@@ -0,0 +1,76 @@
+module HsBindgen.Patterns.Enum.Bitfield (
+    BitfieldEnum(..)
+  , IsSingleFlag(..)
+    -- * API
+  , bitfieldEnum
+  , fromBitfieldEnum
+  , flagIsSet
+  ) where
+
+import Foreign.C
+import Data.Foldable qualified as Foldable
+import Data.Bits
+
+{-------------------------------------------------------------------------------
+  Definition
+-------------------------------------------------------------------------------}
+
+-- | Single flags
+--
+-- See 'BitfieldEnum' for discussion.
+class IsSingleFlag flag where
+  flagToC :: flag -> CUInt
+
+-- | Enum that corresponds to a bitfield
+--
+-- Some C enumerations are defined like this:
+--
+-- > enum Flags {
+-- >   Flag1 = 0x00,
+-- >   Flag2 = 0x01,
+-- >   Flag3 = 0x02,
+-- >   Flag4 = 0x04,
+-- >   Flag5 = 0x08,
+-- >   ..
+-- > };
+--
+-- The intention then is that these flags are ORed together to select multiple
+-- flags. We term this a "bitfield enum": the @flag@ type is intended to be an
+-- ADT with a 'IsSingleFlag' instance, mapping ADT constructors to the values from
+-- the enum. Using @hsc2hs@, such an instance might look like
+--
+-- > data Flags = Flag1 | Flag2 | Flag3 | Flag 4 | Flag5
+-- >
+-- > instance IsSingleFlag Flags where
+-- >   flagToC Flag1 = #const Flag1
+-- >   flagToC Flag2 = #const Flag2
+-- >   flagToC Flag3 = #const Flag3
+-- >   flagToC Flag4 = #const Flag4
+-- >   flagToC Flag5 = #const Flag5
+newtype BitfieldEnum flag = BitfieldEnum CUInt
+
+{-------------------------------------------------------------------------------
+  API
+-------------------------------------------------------------------------------}
+
+-- | Construct 'BitfieldEnum'
+bitfieldEnum :: IsSingleFlag flag => [flag] -> BitfieldEnum flag
+bitfieldEnum = BitfieldEnum . Foldable.foldl' (.|.) 0 . map flagToC
+
+-- | Check if the given flag is set
+flagIsSet :: IsSingleFlag flag => BitfieldEnum flag -> flag -> Bool
+flagIsSet (BitfieldEnum i) flag = (i .&. flagToC flag) /= 0
+
+-- | All set flags
+--
+-- This is @O(n)@ in the number of constructs of the @flag@ ADT; while that is
+-- technically speaking a constant, making this function @O(1)@, this is still
+-- a relatively expensive function. Consider using 'flagIsSet' instead.
+--
+-- NOTE: The @Enum@ and @Bounded@ instances are simply used to enumerate all
+-- flags. Their definition has no bearing on the generated C code, and can
+-- simply be derived.
+fromBitfieldEnum ::
+     (IsSingleFlag flag, Enum flag, Bounded flag)
+  => BitfieldEnum flag -> [flag]
+fromBitfieldEnum i = [flag | flag <- [minBound .. maxBound], flagIsSet i flag]

hs-bindgen-patterns/src/HsBindgen/Patterns/Enum/Simple.hs

@@ -0,0 +1,85 @@
+module HsBindgen.Patterns.Enum.Simple (
+    SimpleEnum(..)
+  , IsSimpleEnum(..)
+    -- * API
+  , simpleEnum
+  , fromSimpleEnum
+  , unsafeFromSimpleEnum
+  ) where
+
+import Foreign.C
+import GHC.Stack
+
+{-------------------------------------------------------------------------------
+  Definition
+-------------------------------------------------------------------------------}
+
+-- | ADTs corresponding to simple enums
+--
+-- See 'SimpleEnum' for discussion
+class IsSimpleEnum a where
+  -- | Translate Haskell constructor to C value
+  simpleToC :: a -> CInt
+
+  -- | Translate C value to haskell constructor
+  --
+  -- This returns a 'Maybe' value, because C enums do not restrict the range.
+  -- From Wikipedia (<https://en.wikipedia.org/wiki/C_syntax#Enumerated_type>):
+  --
+  -- > Some compilers warn if an object with enumerated type is assigned a value
+  -- > that is not one of its constants. However, such an object can be assigned
+  -- > any values in the range of their compatible type, and enum constants can
+  -- > be used anywhere an integer is expected. For this reason, enum values are
+  -- > often used in place of preprocessor #define directives to create named
+  -- > constants. Such constants are generally safer to use than macros, since
+  -- > they reside within a specific identifier namespace.
+  --
+  -- This means that a 'Nothing' value is not necessary an error.
+  simpleFromC :: CInt -> Maybe a
+
+-- | Simple C enums
+--
+-- Suppose we have a simple C enum defined like this:
+--
+-- > enum SomeEnum {
+-- >   Value1,
+-- >   Value2,
+-- >   Value3
+-- > };
+--
+-- Then 'SimpleEnum' can link the underlying 'CInt' to a Haskell ADT. Using
+-- @hsc2hs@, this might look like
+--
+-- > data SomeEnum = Value1 | Value2 | Value3
+-- >
+-- > instance IsSimpleEnum SomeEnum where
+-- >   simpleToC Value1 = #const Value1
+-- >   simpleToC Value2 = #const Value2
+-- >   simpleToC Value3 = #const Value3
+-- >
+-- >   simpleFromC (#const Value1) = Just Value1
+-- >   simpleFromC (#const Value2) = Just Value2
+-- >   simpleFromC (#const Value3) = Just Value3
+-- >
+-- >   simpleFromC _otherwise = Nothing
+newtype SimpleEnum a = SimpleEnum CInt
+
+{-------------------------------------------------------------------------------
+  API
+-------------------------------------------------------------------------------}
+
+simpleEnum :: IsSimpleEnum a => a -> SimpleEnum a
+simpleEnum = SimpleEnum . simpleToC
+
+-- | Underlying C value
+--
+-- Returns the raw 'CInt' if is out of the range of @a@
+fromSimpleEnum :: IsSimpleEnum a => SimpleEnum a -> Either CInt a
+fromSimpleEnum (SimpleEnum i) = maybe (Left i) Right $ simpleFromC i
+
+-- | Like 'fromSimpleEnum', but throw an exception if the value is out of range
+unsafeFromSimpleEnum :: (HasCallStack, IsSimpleEnum a) => SimpleEnum a -> a
+unsafeFromSimpleEnum = either (error . err) id . fromSimpleEnum
+  where
+    err :: CInt -> String
+    err i = "SimpleEnum out of range: " ++ show i