patrickaldis/garnet
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use simpler tagged union translation

Browse Source 
Avoids the worst part of the header hack, and makes Haskell wrapper simpler.
This commit is contained in:
George Thomas 2026-02-19 16:17:29 +00:00
parent 5019af701f
commit 9ca4f615d8
8 changed files with 118 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
exe/GarnetRs/Wrapped.hs
View File

@ -29,8 +29,8 @@ data Shape
| Rectangle CDouble CDouble | Rectangle CDouble CDouble
convertShape :: Shape -> Raw.Shape convertShape :: Shape -> Raw.Shape
convertShape = \case convertShape = \case
Circle r -> Raw.Shape (Raw.Shape_Tag 0) $ Raw.set_shape_body_circle $ Raw.Circle_Body r Circle r -> Raw.Shape Raw.Circle $ Raw.set_shape_body_circle $ Raw.Circle_Body r
Rectangle w h -> Raw.Shape (Raw.Shape_Tag 1) $ Raw.set_shape_body_rectangle $ Raw.Rectangle_Body w h Rectangle w h -> Raw.Shape Raw.Rectangle $ Raw.set_shape_body_rectangle $ Raw.Rectangle_Body w h
hello :: ByteString -> IO () hello :: ByteString -> IO ()
hello s = useAsCString s $ Raw.hello . unsafeFromPtr hello s = useAsCString s $ Raw.hello . unsafeFromPtr

47
generate-bindings
View File

@ -36,56 +36,11 @@ echo " Raw header written to $HEADER"
# --- Step 3: Patch the header for hs-bindgen compatibility --- # --- Step 3: Patch the header for hs-bindgen compatibility ---
# #
# Two patches are needed, both due to hs-bindgen limitations with cbindgen's # cbindgen emits: union { ... }; (anonymous)
# output for #[repr(C, u8)] tagged enums:
#
# 1. cbindgen emits: enum Shape_Tag { Circle, Rectangle, };
# typedef uint8_t Shape_Tag;
# hs-bindgen needs: typedef uint8_t Shape_Tag;
# #define Circle 0
# #define Rectangle 1
# See: no upstream issue yet for hs-bindgen
#
# 2. cbindgen emits: union { ... }; (anonymous)
# hs-bindgen needs: union { ... } body; (named) # hs-bindgen needs: union { ... } body; (named)
# See: https://github.com/well-typed/hs-bindgen/issues/1649 # See: https://github.com/well-typed/hs-bindgen/issues/1649
echo "=== Patching header ===" echo "=== Patching header ==="
awk ' awk '
# State machine for enum->typedef+define transformation
/^enum [A-Za-z_][A-Za-z0-9_]* \{$/ {
in_enum = 1
enum_name = $2
variant_count = 0
delete variants
next
}
in_enum && /^\};$/ {
# Next line should be: typedef <type> <enum_name>;
in_enum = 0
pending_enum = 1
next
}
in_enum {
# Collect variant names (strip trailing comma and whitespace)
v = $0
gsub(/^[[:space:]]+/, "", v)
gsub(/,[[:space:]]*$/, "", v)
if (v != "") {
variants[variant_count] = v
variant_count++
}
next
}
pending_enum && /^typedef [A-Za-z0-9_]+ / {
# Emit: typedef <type> <name>; then #define for each variant
print $0
for (i = 0; i < variant_count; i++) {
printf "#define %s %d\n", variants[i], i
}
pending_enum = 0
next
}
# Name anonymous unions: }; at end of union block inside struct -> } body; # Name anonymous unions: }; at end of union block inside struct -> } body;
/^ \};$/ && saw_union { /^ \};$/ && saw_union {
print " } body;" print " } body;"

142
generated/GarnetRs.hs
View File

@ -3,12 +3,12 @@
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-} {-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -19,8 +19,7 @@
module GarnetRs where module GarnetRs where
import qualified Data.Array.Byte import qualified Data.Array.Byte
import qualified Data.Bits as Bits import qualified Data.List.NonEmpty
import qualified Data.Ix as Ix
import qualified Data.Primitive.Types import qualified Data.Primitive.Types
import qualified Data.Proxy import qualified Data.Proxy
import qualified Foreign as F import qualified Foreign as F
@ -28,16 +27,16 @@ import qualified Foreign.C as FC
import qualified GHC.Generics import qualified GHC.Generics
import qualified GHC.Ptr as Ptr import qualified GHC.Ptr as Ptr
import qualified GHC.Records import qualified GHC.Records
import qualified HsBindgen.Runtime.CEnum
import qualified HsBindgen.Runtime.HasCField import qualified HsBindgen.Runtime.HasCField
import qualified HsBindgen.Runtime.Internal.Bitfield
import qualified HsBindgen.Runtime.Internal.ByteArray import qualified HsBindgen.Runtime.Internal.ByteArray
import qualified HsBindgen.Runtime.Internal.HasFFIType import qualified HsBindgen.Runtime.Internal.HasFFIType
import qualified HsBindgen.Runtime.Internal.SizedByteArray import qualified HsBindgen.Runtime.Internal.SizedByteArray
import qualified HsBindgen.Runtime.LibC import qualified HsBindgen.Runtime.LibC
import qualified HsBindgen.Runtime.Marshal import qualified HsBindgen.Runtime.Marshal
import Data.Bits (FiniteBits) import qualified Text.Read
import HsBindgen.Runtime.Internal.TypeEquality (TyEq) import HsBindgen.Runtime.Internal.TypeEquality (TyEq)
import Prelude ((<*>), (>>), Bounded, Enum, Eq, Int, Integral, Num, Ord, Read, Real, Show, pure) import Prelude ((<*>), (>>), Eq, Int, Ord, Read, Show, pure, showsPrec)
{-| __C declaration:__ @struct T@ {-| __C declaration:__ @struct T@
@ -114,34 +113,86 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType T) "b")
getField = getField =
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"b") HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"b")
{-| __C declaration:__ @Shape_Tag@ {-| __C declaration:__ @enum Shape_Tag@
__defined at:__ @garnet_rs.h 11:17@ __defined at:__ @garnet_rs.h 11:14@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
newtype Shape_Tag = Shape_Tag newtype Shape_Tag = Shape_Tag
{ unwrap :: HsBindgen.Runtime.LibC.Word8 { unwrap :: FC.CUInt
} }
deriving stock (GHC.Generics.Generic) deriving stock (GHC.Generics.Generic)
deriving stock (Eq, Ord, Read, Show) deriving stock (Eq, Ord)
deriving newtype deriving newtype (HsBindgen.Runtime.Internal.HasFFIType.HasFFIType)
( HsBindgen.Runtime.Marshal.StaticSize
, HsBindgen.Runtime.Marshal.ReadRaw instance HsBindgen.Runtime.Marshal.StaticSize Shape_Tag where
, HsBindgen.Runtime.Marshal.WriteRaw
, F.Storable staticSizeOf = \_ -> (4 :: Int)
, HsBindgen.Runtime.Internal.HasFFIType.HasFFIType
, Data.Primitive.Types.Prim staticAlignment = \_ -> (4 :: Int)
, HsBindgen.Runtime.Internal.Bitfield.Bitfield
, Bits.Bits instance HsBindgen.Runtime.Marshal.ReadRaw Shape_Tag where
, Bounded
, Enum readRaw =
, FiniteBits \ptr0 ->
, Integral pure Shape_Tag
, Ix.Ix <*> HsBindgen.Runtime.Marshal.readRawByteOff ptr0 (0 :: Int)
, Num
, Real instance HsBindgen.Runtime.Marshal.WriteRaw Shape_Tag where
)
writeRaw =
\ptr0 ->
\s1 ->
case s1 of
Shape_Tag unwrap2 ->
HsBindgen.Runtime.Marshal.writeRawByteOff ptr0 (0 :: Int) unwrap2
deriving via HsBindgen.Runtime.Marshal.EquivStorable Shape_Tag instance F.Storable Shape_Tag
deriving via FC.CUInt instance Data.Primitive.Types.Prim Shape_Tag
instance HsBindgen.Runtime.CEnum.CEnum Shape_Tag where
type CEnumZ Shape_Tag = FC.CUInt
toCEnum = Shape_Tag
fromCEnum = GHC.Records.getField @"unwrap"
declaredValues =
\_ ->
HsBindgen.Runtime.CEnum.declaredValuesFromList [ (0, Data.List.NonEmpty.singleton "Circle")
, (1, Data.List.NonEmpty.singleton "Rectangle")
]
showsUndeclared =
HsBindgen.Runtime.CEnum.showsWrappedUndeclared "Shape_Tag"
readPrecUndeclared =
HsBindgen.Runtime.CEnum.readPrecWrappedUndeclared "Shape_Tag"
isDeclared = HsBindgen.Runtime.CEnum.seqIsDeclared
mkDeclared = HsBindgen.Runtime.CEnum.seqMkDeclared
instance HsBindgen.Runtime.CEnum.SequentialCEnum Shape_Tag where
minDeclaredValue = Circle
maxDeclaredValue = Rectangle
instance Show Shape_Tag where
showsPrec = HsBindgen.Runtime.CEnum.shows
instance Read Shape_Tag where
readPrec = HsBindgen.Runtime.CEnum.readPrec
readList = Text.Read.readListDefault
readListPrec = Text.Read.readListPrecDefault
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_Tag) "unwrap") instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_Tag) "unwrap")
) => GHC.Records.HasField "unwrap" (Ptr.Ptr Shape_Tag) (Ptr.Ptr ty) where ) => GHC.Records.HasField "unwrap" (Ptr.Ptr Shape_Tag) (Ptr.Ptr ty) where
@ -151,32 +202,31 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_Tag) "unwrap")
instance HsBindgen.Runtime.HasCField.HasCField Shape_Tag "unwrap" where instance HsBindgen.Runtime.HasCField.HasCField Shape_Tag "unwrap" where
type CFieldType Shape_Tag "unwrap" = type CFieldType Shape_Tag "unwrap" = FC.CUInt
HsBindgen.Runtime.LibC.Word8
offset# = \_ -> \_ -> 0 offset# = \_ -> \_ -> 0
{-| __C declaration:__ @Circle@ {-| __C declaration:__ @Circle@
__defined at:__ @garnet_rs.h 12:9@ __defined at:__ @garnet_rs.h 12:3@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
circle :: FC.CInt pattern Circle :: Shape_Tag
circle = (0 :: FC.CInt) pattern Circle = Shape_Tag 0
{-| __C declaration:__ @Rectangle@ {-| __C declaration:__ @Rectangle@
__defined at:__ @garnet_rs.h 13:9@ __defined at:__ @garnet_rs.h 13:3@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
rectangle :: FC.CInt pattern Rectangle :: Shape_Tag
rectangle = (1 :: FC.CInt) pattern Rectangle = Shape_Tag 1
{-| __C declaration:__ @struct Circle_Body@ {-| __C declaration:__ @struct Circle_Body@
__defined at:__ @garnet_rs.h 15:16@ __defined at:__ @garnet_rs.h 16:16@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -184,7 +234,7 @@ data Circle_Body = Circle_Body
{ radius :: FC.CDouble { radius :: FC.CDouble
{- ^ __C declaration:__ @radius@ {- ^ __C declaration:__ @radius@
__defined at:__ @garnet_rs.h 16:10@ __defined at:__ @garnet_rs.h 17:10@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -230,7 +280,7 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Circle_Body) "radius
{-| __C declaration:__ @struct Rectangle_Body@ {-| __C declaration:__ @struct Rectangle_Body@
__defined at:__ @garnet_rs.h 19:16@ __defined at:__ @garnet_rs.h 20:16@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -238,14 +288,14 @@ data Rectangle_Body = Rectangle_Body
{ width :: FC.CDouble { width :: FC.CDouble
{- ^ __C declaration:__ @width@ {- ^ __C declaration:__ @width@
__defined at:__ @garnet_rs.h 20:10@ __defined at:__ @garnet_rs.h 21:10@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
, height :: FC.CDouble , height :: FC.CDouble
{- ^ __C declaration:__ @height@ {- ^ __C declaration:__ @height@
__defined at:__ @garnet_rs.h 21:10@ __defined at:__ @garnet_rs.h 22:10@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -305,7 +355,7 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Rectangle_Body) "hei
{-| __C declaration:__ @union \@Shape_body@ {-| __C declaration:__ @union \@Shape_body@
__defined at:__ @garnet_rs.h 26:3@ __defined at:__ @garnet_rs.h 27:3@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -328,7 +378,7 @@ deriving via HsBindgen.Runtime.Marshal.EquivStorable Shape_body instance F.Stora
__C declaration:__ @circle@ __C declaration:__ @circle@
__defined at:__ @garnet_rs.h 27:17@ __defined at:__ @garnet_rs.h 28:17@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -355,7 +405,7 @@ set_shape_body_circle =
__C declaration:__ @rectangle@ __C declaration:__ @rectangle@
__defined at:__ @garnet_rs.h 28:20@ __defined at:__ @garnet_rs.h 29:20@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -403,7 +453,7 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_body) "rectang
{-| __C declaration:__ @struct Shape@ {-| __C declaration:__ @struct Shape@
__defined at:__ @garnet_rs.h 24:16@ __defined at:__ @garnet_rs.h 25:16@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -411,14 +461,14 @@ data Shape = Shape
{ tag :: Shape_Tag { tag :: Shape_Tag
{- ^ __C declaration:__ @tag@ {- ^ __C declaration:__ @tag@
__defined at:__ @garnet_rs.h 25:13@ __defined at:__ @garnet_rs.h 26:13@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
, body :: Shape_body , body :: Shape_body
{- ^ __C declaration:__ @body@ {- ^ __C declaration:__ @body@
__defined at:__ @garnet_rs.h 29:5@ __defined at:__ @garnet_rs.h 30:5@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}

8
generated/GarnetRs/FunPtr.hs
View File

@ -65,7 +65,7 @@ hs_bindgen_faf62265b53521d3 =
{-# NOINLINE hello #-} {-# NOINLINE hello #-}
{-| __C declaration:__ @hello@ {-| __C declaration:__ @hello@
__defined at:__ @garnet_rs.h 32:6@ __defined at:__ @garnet_rs.h 33:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -85,7 +85,7 @@ hs_bindgen_0f8c37ef19b17a6d =
{-# NOINLINE hello_struct #-} {-# NOINLINE hello_struct #-}
{-| __C declaration:__ @hello_struct@ {-| __C declaration:__ @hello_struct@
__defined at:__ @garnet_rs.h 34:6@ __defined at:__ @garnet_rs.h 35:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -105,7 +105,7 @@ hs_bindgen_287ff3ac660f333b =
{-# NOINLINE hello_shape #-} {-# NOINLINE hello_shape #-}
{-| __C declaration:__ @hello_shape@ {-| __C declaration:__ @hello_shape@
__defined at:__ @garnet_rs.h 36:6@ __defined at:__ @garnet_rs.h 37:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -125,7 +125,7 @@ hs_bindgen_bbabdbe61cd1eeb2 =
{-# NOINLINE add #-} {-# NOINLINE add #-}
{-| __C declaration:__ @add@ {-| __C declaration:__ @add@
__defined at:__ @garnet_rs.h 38:32@ __defined at:__ @garnet_rs.h 39:32@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}

8
generated/GarnetRs/Safe.hs
View File

@ -60,7 +60,7 @@ hs_bindgen_433ea2a26af4e593 =
{-| __C declaration:__ @hello@ {-| __C declaration:__ @hello@
__defined at:__ @garnet_rs.h 32:6@ __defined at:__ @garnet_rs.h 33:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -84,7 +84,7 @@ hs_bindgen_51157946af5519c9 =
{-| __C declaration:__ @hello_struct@ {-| __C declaration:__ @hello_struct@
__defined at:__ @garnet_rs.h 34:6@ __defined at:__ @garnet_rs.h 35:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -110,7 +110,7 @@ hs_bindgen_7de06f1fd827ca60 =
{-| __C declaration:__ @hello_shape@ {-| __C declaration:__ @hello_shape@
__defined at:__ @garnet_rs.h 36:6@ __defined at:__ @garnet_rs.h 37:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -142,7 +142,7 @@ hs_bindgen_1c0c71fa74c428a9 =
__C declaration:__ @add@ __C declaration:__ @add@
__defined at:__ @garnet_rs.h 38:32@ __defined at:__ @garnet_rs.h 39:32@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}

8
generated/GarnetRs/Unsafe.hs
View File

@ -60,7 +60,7 @@ hs_bindgen_2dfe97662a4d6377 =
{-| __C declaration:__ @hello@ {-| __C declaration:__ @hello@
__defined at:__ @garnet_rs.h 32:6@ __defined at:__ @garnet_rs.h 33:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -84,7 +84,7 @@ hs_bindgen_29d823ada2bc7302 =
{-| __C declaration:__ @hello_struct@ {-| __C declaration:__ @hello_struct@
__defined at:__ @garnet_rs.h 34:6@ __defined at:__ @garnet_rs.h 35:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -110,7 +110,7 @@ hs_bindgen_b3f40a03f07eaa85 =
{-| __C declaration:__ @hello_shape@ {-| __C declaration:__ @hello_shape@
__defined at:__ @garnet_rs.h 36:6@ __defined at:__ @garnet_rs.h 37:6@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}
@ -142,7 +142,7 @@ hs_bindgen_20eb651f0a8faf48 =
__C declaration:__ @add@ __C declaration:__ @add@
__defined at:__ @garnet_rs.h 38:32@ __defined at:__ @garnet_rs.h 39:32@
__exported by:__ @garnet_rs.h@ __exported by:__ @garnet_rs.h@
-} -}

7
rust/garnet_rs.h
View File

@ -8,9 +8,10 @@ typedef struct T {
uint8_t b; uint8_t b;
} T; } T;
typedef uint8_t Shape_Tag; typedef enum Shape_Tag {
#define Circle 0 Circle,
#define Rectangle 1 Rectangle,
} Shape_Tag;
typedef struct Circle_Body { typedef struct Circle_Body {
double radius; double radius;

2
rust/lib.rs
View File

@ -22,7 +22,7 @@ extern "C" fn hello_struct(t: T) -> () {
say_hello(&format!("{:?}", t)) say_hello(&format!("{:?}", t))
} }
#[repr(C, u8)] #[repr(C)]
#[derive(Debug)] #[derive(Debug)]
enum Shape { enum Shape {
Circle { radius: f64 }, Circle { radius: f64 },