Use simpler tagged union translation
Avoids the worst part of the header hack, and makes Haskell wrapper simpler.
This commit is contained in:
George Thomas
parent
5019af701f
commit
9ca4f615d8
@ -29,8 +29,8 @@ data Shape
|
||||
| Rectangle CDouble CDouble
|
||||
convertShape :: Shape -> Raw.Shape
|
||||
convertShape = \case
|
||||
Circle r -> Raw.Shape (Raw.Shape_Tag 0) $ 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
|
||||
Circle r -> Raw.Shape Raw.Circle $ Raw.set_shape_body_circle $ Raw.Circle_Body r
|
||||
Rectangle w h -> Raw.Shape Raw.Rectangle $ Raw.set_shape_body_rectangle $ Raw.Rectangle_Body w h
|
||||
|
||||
hello :: ByteString -> IO ()
|
||||
hello s = useAsCString s $ Raw.hello . unsafeFromPtr
|
||||
|
||||
@ -36,56 +36,11 @@ echo " Raw header written to $HEADER"
|
||||
|
||||
# --- Step 3: Patch the header for hs-bindgen compatibility ---
|
||||
#
|
||||
# Two patches are needed, both due to hs-bindgen limitations with cbindgen's
|
||||
# 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)
|
||||
# See: https://github.com/well-typed/hs-bindgen/issues/1649
|
||||
# cbindgen emits: union { ... }; (anonymous)
|
||||
# hs-bindgen needs: union { ... } body; (named)
|
||||
# See: https://github.com/well-typed/hs-bindgen/issues/1649
|
||||
echo "=== Patching header ==="
|
||||
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;
|
||||
/^ \};$/ && saw_union {
|
||||
print " } body;"
|
||||
|
||||
@ -3,12 +3,12 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
@ -19,8 +19,7 @@
|
||||
module GarnetRs where
|
||||
|
||||
import qualified Data.Array.Byte
|
||||
import qualified Data.Bits as Bits
|
||||
import qualified Data.Ix as Ix
|
||||
import qualified Data.List.NonEmpty
|
||||
import qualified Data.Primitive.Types
|
||||
import qualified Data.Proxy
|
||||
import qualified Foreign as F
|
||||
@ -28,16 +27,16 @@ import qualified Foreign.C as FC
|
||||
import qualified GHC.Generics
|
||||
import qualified GHC.Ptr as Ptr
|
||||
import qualified GHC.Records
|
||||
import qualified HsBindgen.Runtime.CEnum
|
||||
import qualified HsBindgen.Runtime.HasCField
|
||||
import qualified HsBindgen.Runtime.Internal.Bitfield
|
||||
import qualified HsBindgen.Runtime.Internal.ByteArray
|
||||
import qualified HsBindgen.Runtime.Internal.HasFFIType
|
||||
import qualified HsBindgen.Runtime.Internal.SizedByteArray
|
||||
import qualified HsBindgen.Runtime.LibC
|
||||
import qualified HsBindgen.Runtime.Marshal
|
||||
import Data.Bits (FiniteBits)
|
||||
import qualified Text.Read
|
||||
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@
|
||||
|
||||
@ -114,34 +113,86 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType T) "b")
|
||||
getField =
|
||||
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@
|
||||
-}
|
||||
newtype Shape_Tag = Shape_Tag
|
||||
{ unwrap :: HsBindgen.Runtime.LibC.Word8
|
||||
{ unwrap :: FC.CUInt
|
||||
}
|
||||
deriving stock (GHC.Generics.Generic)
|
||||
deriving stock (Eq, Ord, Read, Show)
|
||||
deriving newtype
|
||||
( HsBindgen.Runtime.Marshal.StaticSize
|
||||
, HsBindgen.Runtime.Marshal.ReadRaw
|
||||
, HsBindgen.Runtime.Marshal.WriteRaw
|
||||
, F.Storable
|
||||
, HsBindgen.Runtime.Internal.HasFFIType.HasFFIType
|
||||
, Data.Primitive.Types.Prim
|
||||
, HsBindgen.Runtime.Internal.Bitfield.Bitfield
|
||||
, Bits.Bits
|
||||
, Bounded
|
||||
, Enum
|
||||
, FiniteBits
|
||||
, Integral
|
||||
, Ix.Ix
|
||||
, Num
|
||||
, Real
|
||||
)
|
||||
deriving stock (Eq, Ord)
|
||||
deriving newtype (HsBindgen.Runtime.Internal.HasFFIType.HasFFIType)
|
||||
|
||||
instance HsBindgen.Runtime.Marshal.StaticSize Shape_Tag where
|
||||
|
||||
staticSizeOf = \_ -> (4 :: Int)
|
||||
|
||||
staticAlignment = \_ -> (4 :: Int)
|
||||
|
||||
instance HsBindgen.Runtime.Marshal.ReadRaw Shape_Tag where
|
||||
|
||||
readRaw =
|
||||
\ptr0 ->
|
||||
pure Shape_Tag
|
||||
<*> HsBindgen.Runtime.Marshal.readRawByteOff ptr0 (0 :: Int)
|
||||
|
||||
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")
|
||||
) => 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
|
||||
|
||||
type CFieldType Shape_Tag "unwrap" =
|
||||
HsBindgen.Runtime.LibC.Word8
|
||||
type CFieldType Shape_Tag "unwrap" = FC.CUInt
|
||||
|
||||
offset# = \_ -> \_ -> 0
|
||||
|
||||
{-| __C declaration:__ @Circle@
|
||||
|
||||
__defined at:__ @garnet_rs.h 12:9@
|
||||
__defined at:__ @garnet_rs.h 12:3@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
circle :: FC.CInt
|
||||
circle = (0 :: FC.CInt)
|
||||
pattern Circle :: Shape_Tag
|
||||
pattern Circle = Shape_Tag 0
|
||||
|
||||
{-| __C declaration:__ @Rectangle@
|
||||
|
||||
__defined at:__ @garnet_rs.h 13:9@
|
||||
__defined at:__ @garnet_rs.h 13:3@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
rectangle :: FC.CInt
|
||||
rectangle = (1 :: FC.CInt)
|
||||
pattern Rectangle :: Shape_Tag
|
||||
pattern Rectangle = Shape_Tag 1
|
||||
|
||||
{-| __C declaration:__ @struct Circle_Body@
|
||||
|
||||
__defined at:__ @garnet_rs.h 15:16@
|
||||
__defined at:__ @garnet_rs.h 16:16@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -184,7 +234,7 @@ data Circle_Body = Circle_Body
|
||||
{ radius :: FC.CDouble
|
||||
{- ^ __C declaration:__ @radius@
|
||||
|
||||
__defined at:__ @garnet_rs.h 16:10@
|
||||
__defined at:__ @garnet_rs.h 17:10@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -230,7 +280,7 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Circle_Body) "radius
|
||||
|
||||
{-| __C declaration:__ @struct Rectangle_Body@
|
||||
|
||||
__defined at:__ @garnet_rs.h 19:16@
|
||||
__defined at:__ @garnet_rs.h 20:16@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -238,14 +288,14 @@ data Rectangle_Body = Rectangle_Body
|
||||
{ width :: FC.CDouble
|
||||
{- ^ __C declaration:__ @width@
|
||||
|
||||
__defined at:__ @garnet_rs.h 20:10@
|
||||
__defined at:__ @garnet_rs.h 21:10@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
, height :: FC.CDouble
|
||||
{- ^ __C declaration:__ @height@
|
||||
|
||||
__defined at:__ @garnet_rs.h 21:10@
|
||||
__defined at:__ @garnet_rs.h 22:10@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -305,7 +355,7 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Rectangle_Body) "hei
|
||||
|
||||
{-| __C declaration:__ @union \@Shape_body@
|
||||
|
||||
__defined at:__ @garnet_rs.h 26:3@
|
||||
__defined at:__ @garnet_rs.h 27:3@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -328,7 +378,7 @@ deriving via HsBindgen.Runtime.Marshal.EquivStorable Shape_body instance F.Stora
|
||||
|
||||
__C declaration:__ @circle@
|
||||
|
||||
__defined at:__ @garnet_rs.h 27:17@
|
||||
__defined at:__ @garnet_rs.h 28:17@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -355,7 +405,7 @@ set_shape_body_circle =
|
||||
|
||||
__C declaration:__ @rectangle@
|
||||
|
||||
__defined at:__ @garnet_rs.h 28:20@
|
||||
__defined at:__ @garnet_rs.h 29:20@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -403,7 +453,7 @@ instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_body) "rectang
|
||||
|
||||
{-| __C declaration:__ @struct Shape@
|
||||
|
||||
__defined at:__ @garnet_rs.h 24:16@
|
||||
__defined at:__ @garnet_rs.h 25:16@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -411,14 +461,14 @@ data Shape = Shape
|
||||
{ tag :: Shape_Tag
|
||||
{- ^ __C declaration:__ @tag@
|
||||
|
||||
__defined at:__ @garnet_rs.h 25:13@
|
||||
__defined at:__ @garnet_rs.h 26:13@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
, body :: Shape_body
|
||||
{- ^ __C declaration:__ @body@
|
||||
|
||||
__defined at:__ @garnet_rs.h 29:5@
|
||||
__defined at:__ @garnet_rs.h 30:5@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
|
||||
@ -65,7 +65,7 @@ hs_bindgen_faf62265b53521d3 =
|
||||
{-# NOINLINE hello #-}
|
||||
{-| __C declaration:__ @hello@
|
||||
|
||||
__defined at:__ @garnet_rs.h 32:6@
|
||||
__defined at:__ @garnet_rs.h 33:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -85,7 +85,7 @@ hs_bindgen_0f8c37ef19b17a6d =
|
||||
{-# NOINLINE 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@
|
||||
-}
|
||||
@ -105,7 +105,7 @@ hs_bindgen_287ff3ac660f333b =
|
||||
{-# NOINLINE 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@
|
||||
-}
|
||||
@ -125,7 +125,7 @@ hs_bindgen_bbabdbe61cd1eeb2 =
|
||||
{-# NOINLINE add #-}
|
||||
{-| __C declaration:__ @add@
|
||||
|
||||
__defined at:__ @garnet_rs.h 38:32@
|
||||
__defined at:__ @garnet_rs.h 39:32@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
|
||||
@ -60,7 +60,7 @@ hs_bindgen_433ea2a26af4e593 =
|
||||
|
||||
{-| __C declaration:__ @hello@
|
||||
|
||||
__defined at:__ @garnet_rs.h 32:6@
|
||||
__defined at:__ @garnet_rs.h 33:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -84,7 +84,7 @@ hs_bindgen_51157946af5519c9 =
|
||||
|
||||
{-| __C declaration:__ @hello_struct@
|
||||
|
||||
__defined at:__ @garnet_rs.h 34:6@
|
||||
__defined at:__ @garnet_rs.h 35:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -110,7 +110,7 @@ hs_bindgen_7de06f1fd827ca60 =
|
||||
|
||||
{-| __C declaration:__ @hello_shape@
|
||||
|
||||
__defined at:__ @garnet_rs.h 36:6@
|
||||
__defined at:__ @garnet_rs.h 37:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -142,7 +142,7 @@ hs_bindgen_1c0c71fa74c428a9 =
|
||||
|
||||
__C declaration:__ @add@
|
||||
|
||||
__defined at:__ @garnet_rs.h 38:32@
|
||||
__defined at:__ @garnet_rs.h 39:32@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
|
||||
@ -60,7 +60,7 @@ hs_bindgen_2dfe97662a4d6377 =
|
||||
|
||||
{-| __C declaration:__ @hello@
|
||||
|
||||
__defined at:__ @garnet_rs.h 32:6@
|
||||
__defined at:__ @garnet_rs.h 33:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -84,7 +84,7 @@ hs_bindgen_29d823ada2bc7302 =
|
||||
|
||||
{-| __C declaration:__ @hello_struct@
|
||||
|
||||
__defined at:__ @garnet_rs.h 34:6@
|
||||
__defined at:__ @garnet_rs.h 35:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -110,7 +110,7 @@ hs_bindgen_b3f40a03f07eaa85 =
|
||||
|
||||
{-| __C declaration:__ @hello_shape@
|
||||
|
||||
__defined at:__ @garnet_rs.h 36:6@
|
||||
__defined at:__ @garnet_rs.h 37:6@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
@ -142,7 +142,7 @@ hs_bindgen_20eb651f0a8faf48 =
|
||||
|
||||
__C declaration:__ @add@
|
||||
|
||||
__defined at:__ @garnet_rs.h 38:32@
|
||||
__defined at:__ @garnet_rs.h 39:32@
|
||||
|
||||
__exported by:__ @garnet_rs.h@
|
||||
-}
|
||||
|
||||
@ -8,9 +8,10 @@ typedef struct T {
|
||||
uint8_t b;
|
||||
} T;
|
||||
|
||||
typedef uint8_t Shape_Tag;
|
||||
#define Circle 0
|
||||
#define Rectangle 1
|
||||
typedef enum Shape_Tag {
|
||||
Circle,
|
||||
Rectangle,
|
||||
} Shape_Tag;
|
||||
|
||||
typedef struct Circle_Body {
|
||||
double radius;
|
||||
|
||||
@ -22,7 +22,7 @@ extern "C" fn hello_struct(t: T) -> () {
|
||||
say_hello(&format!("{:?}", t))
|
||||
}
|
||||
|
||||
#[repr(C, u8)]
|
||||
#[repr(C)]
|
||||
#[derive(Debug)]
|
||||
enum Shape {
|
||||
Circle { radius: f64 },
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user