0a1911862f
We drop the tools specifically designed for Haskell and Rust together, in favour of general tools for using each with C. Namely, we use Mozilla's `cbindgen` for generating header files from the Rust source, and Well-Typed's new `hs-bindgen` tool for generating Haskell from those header files. The Rust code here is essentially the result of expanding the old macro, then inlining and renaming internals. The most important thing here is that we're now relying solely on robust well-maintained tools.
477 lines
13 KiB
Haskell
477 lines
13 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE ExplicitForAll #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MagicHash #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE UnboxedTuples #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module GarnetRs where
|
|
|
|
import qualified Data.Array.Byte
|
|
import qualified Data.Bits as Bits
|
|
import qualified Data.Ix as Ix
|
|
import qualified Data.Primitive.Types
|
|
import qualified Data.Proxy
|
|
import qualified Foreign as F
|
|
import qualified Foreign.C as FC
|
|
import qualified GHC.Generics
|
|
import qualified GHC.Ptr as Ptr
|
|
import qualified GHC.Records
|
|
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 HsBindgen.Runtime.Internal.TypeEquality (TyEq)
|
|
import Prelude ((<*>), (>>), Bounded, Enum, Eq, Int, Integral, Num, Ord, Read, Real, Show, pure)
|
|
|
|
{-| __C declaration:__ @struct T@
|
|
|
|
__defined at:__ @garnet_rs.h 6:16@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
data T = T
|
|
{ a :: FC.CBool
|
|
{- ^ __C declaration:__ @a@
|
|
|
|
__defined at:__ @garnet_rs.h 7:8@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
, b :: HsBindgen.Runtime.LibC.Word8
|
|
{- ^ __C declaration:__ @b@
|
|
|
|
__defined at:__ @garnet_rs.h 8:11@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
}
|
|
deriving stock (GHC.Generics.Generic)
|
|
deriving stock (Eq, Show)
|
|
|
|
instance HsBindgen.Runtime.Marshal.StaticSize T where
|
|
|
|
staticSizeOf = \_ -> (2 :: Int)
|
|
|
|
staticAlignment = \_ -> (1 :: Int)
|
|
|
|
instance HsBindgen.Runtime.Marshal.ReadRaw T where
|
|
|
|
readRaw =
|
|
\ptr0 ->
|
|
pure T
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"a") ptr0
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"b") ptr0
|
|
|
|
instance HsBindgen.Runtime.Marshal.WriteRaw T where
|
|
|
|
writeRaw =
|
|
\ptr0 ->
|
|
\s1 ->
|
|
case s1 of
|
|
T a2 b3 ->
|
|
HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"a") ptr0 a2
|
|
>> HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"b") ptr0 b3
|
|
|
|
deriving via HsBindgen.Runtime.Marshal.EquivStorable T instance F.Storable T
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField T "a" where
|
|
|
|
type CFieldType T "a" = FC.CBool
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType T) "a")
|
|
) => GHC.Records.HasField "a" (Ptr.Ptr T) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"a")
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField T "b" where
|
|
|
|
type CFieldType T "b" = HsBindgen.Runtime.LibC.Word8
|
|
|
|
offset# = \_ -> \_ -> 1
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType T) "b")
|
|
) => GHC.Records.HasField "b" (Ptr.Ptr T) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"b")
|
|
|
|
{-| __C declaration:__ @Shape_Tag@
|
|
|
|
__defined at:__ @garnet_rs.h 11:17@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
newtype Shape_Tag = Shape_Tag
|
|
{ unwrap :: HsBindgen.Runtime.LibC.Word8
|
|
}
|
|
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
|
|
)
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_Tag) "unwrap")
|
|
) => GHC.Records.HasField "unwrap" (Ptr.Ptr Shape_Tag) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"unwrap")
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Shape_Tag "unwrap" where
|
|
|
|
type CFieldType Shape_Tag "unwrap" =
|
|
HsBindgen.Runtime.LibC.Word8
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
{-| __C declaration:__ @Circle@
|
|
|
|
__defined at:__ @garnet_rs.h 12:9@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
circle :: FC.CInt
|
|
circle = (0 :: FC.CInt)
|
|
|
|
{-| __C declaration:__ @Rectangle@
|
|
|
|
__defined at:__ @garnet_rs.h 13:9@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
rectangle :: FC.CInt
|
|
rectangle = (1 :: FC.CInt)
|
|
|
|
{-| __C declaration:__ @struct Circle_Body@
|
|
|
|
__defined at:__ @garnet_rs.h 15:16@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
data Circle_Body = Circle_Body
|
|
{ radius :: FC.CDouble
|
|
{- ^ __C declaration:__ @radius@
|
|
|
|
__defined at:__ @garnet_rs.h 16:10@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
}
|
|
deriving stock (GHC.Generics.Generic)
|
|
deriving stock (Eq, Show)
|
|
|
|
instance HsBindgen.Runtime.Marshal.StaticSize Circle_Body where
|
|
|
|
staticSizeOf = \_ -> (8 :: Int)
|
|
|
|
staticAlignment = \_ -> (8 :: Int)
|
|
|
|
instance HsBindgen.Runtime.Marshal.ReadRaw Circle_Body where
|
|
|
|
readRaw =
|
|
\ptr0 ->
|
|
pure Circle_Body
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"radius") ptr0
|
|
|
|
instance HsBindgen.Runtime.Marshal.WriteRaw Circle_Body where
|
|
|
|
writeRaw =
|
|
\ptr0 ->
|
|
\s1 ->
|
|
case s1 of
|
|
Circle_Body radius2 ->
|
|
HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"radius") ptr0 radius2
|
|
|
|
deriving via HsBindgen.Runtime.Marshal.EquivStorable Circle_Body instance F.Storable Circle_Body
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Circle_Body "radius" where
|
|
|
|
type CFieldType Circle_Body "radius" = FC.CDouble
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Circle_Body) "radius")
|
|
) => GHC.Records.HasField "radius" (Ptr.Ptr Circle_Body) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"radius")
|
|
|
|
{-| __C declaration:__ @struct Rectangle_Body@
|
|
|
|
__defined at:__ @garnet_rs.h 19:16@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
data Rectangle_Body = Rectangle_Body
|
|
{ width :: FC.CDouble
|
|
{- ^ __C declaration:__ @width@
|
|
|
|
__defined at:__ @garnet_rs.h 20:10@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
, height :: FC.CDouble
|
|
{- ^ __C declaration:__ @height@
|
|
|
|
__defined at:__ @garnet_rs.h 21:10@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
}
|
|
deriving stock (GHC.Generics.Generic)
|
|
deriving stock (Eq, Show)
|
|
|
|
instance HsBindgen.Runtime.Marshal.StaticSize Rectangle_Body where
|
|
|
|
staticSizeOf = \_ -> (16 :: Int)
|
|
|
|
staticAlignment = \_ -> (8 :: Int)
|
|
|
|
instance HsBindgen.Runtime.Marshal.ReadRaw Rectangle_Body where
|
|
|
|
readRaw =
|
|
\ptr0 ->
|
|
pure Rectangle_Body
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"width") ptr0
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"height") ptr0
|
|
|
|
instance HsBindgen.Runtime.Marshal.WriteRaw Rectangle_Body where
|
|
|
|
writeRaw =
|
|
\ptr0 ->
|
|
\s1 ->
|
|
case s1 of
|
|
Rectangle_Body width2 height3 ->
|
|
HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"width") ptr0 width2
|
|
>> HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"height") ptr0 height3
|
|
|
|
deriving via HsBindgen.Runtime.Marshal.EquivStorable Rectangle_Body instance F.Storable Rectangle_Body
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Rectangle_Body "width" where
|
|
|
|
type CFieldType Rectangle_Body "width" = FC.CDouble
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Rectangle_Body) "width")
|
|
) => GHC.Records.HasField "width" (Ptr.Ptr Rectangle_Body) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"width")
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Rectangle_Body "height" where
|
|
|
|
type CFieldType Rectangle_Body "height" = FC.CDouble
|
|
|
|
offset# = \_ -> \_ -> 8
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Rectangle_Body) "height")
|
|
) => GHC.Records.HasField "height" (Ptr.Ptr Rectangle_Body) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"height")
|
|
|
|
{-| __C declaration:__ @union \@Shape_body@
|
|
|
|
__defined at:__ @garnet_rs.h 26:3@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
newtype Shape_body = Shape_body
|
|
{ unwrap :: Data.Array.Byte.ByteArray
|
|
}
|
|
deriving stock (GHC.Generics.Generic)
|
|
|
|
deriving via (HsBindgen.Runtime.Internal.SizedByteArray.SizedByteArray 16) 8 instance HsBindgen.Runtime.Marshal.StaticSize Shape_body
|
|
|
|
deriving via (HsBindgen.Runtime.Internal.SizedByteArray.SizedByteArray 16) 8 instance HsBindgen.Runtime.Marshal.ReadRaw Shape_body
|
|
|
|
deriving via (HsBindgen.Runtime.Internal.SizedByteArray.SizedByteArray 16) 8 instance HsBindgen.Runtime.Marshal.WriteRaw Shape_body
|
|
|
|
deriving via HsBindgen.Runtime.Marshal.EquivStorable Shape_body instance F.Storable Shape_body
|
|
|
|
{-|
|
|
|
|
__See:__ 'set_shape_body_circle'
|
|
|
|
__C declaration:__ @circle@
|
|
|
|
__defined at:__ @garnet_rs.h 27:17@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
get_shape_body_circle ::
|
|
Shape_body
|
|
-> Circle_Body
|
|
get_shape_body_circle =
|
|
HsBindgen.Runtime.Internal.ByteArray.getUnionPayload
|
|
|
|
{-|
|
|
|
|
__See:__ 'get_shape_body_circle'
|
|
|
|
-}
|
|
set_shape_body_circle ::
|
|
Circle_Body
|
|
-> Shape_body
|
|
set_shape_body_circle =
|
|
HsBindgen.Runtime.Internal.ByteArray.setUnionPayload
|
|
|
|
{-|
|
|
|
|
__See:__ 'set_shape_body_rectangle'
|
|
|
|
__C declaration:__ @rectangle@
|
|
|
|
__defined at:__ @garnet_rs.h 28:20@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
get_shape_body_rectangle ::
|
|
Shape_body
|
|
-> Rectangle_Body
|
|
get_shape_body_rectangle =
|
|
HsBindgen.Runtime.Internal.ByteArray.getUnionPayload
|
|
|
|
{-|
|
|
|
|
__See:__ 'get_shape_body_rectangle'
|
|
|
|
-}
|
|
set_shape_body_rectangle ::
|
|
Rectangle_Body
|
|
-> Shape_body
|
|
set_shape_body_rectangle =
|
|
HsBindgen.Runtime.Internal.ByteArray.setUnionPayload
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Shape_body "circle" where
|
|
|
|
type CFieldType Shape_body "circle" = Circle_Body
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_body) "circle")
|
|
) => GHC.Records.HasField "circle" (Ptr.Ptr Shape_body) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"circle")
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Shape_body "rectangle" where
|
|
|
|
type CFieldType Shape_body "rectangle" =
|
|
Rectangle_Body
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape_body) "rectangle")
|
|
) => GHC.Records.HasField "rectangle" (Ptr.Ptr Shape_body) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"rectangle")
|
|
|
|
{-| __C declaration:__ @struct Shape@
|
|
|
|
__defined at:__ @garnet_rs.h 24:16@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
data Shape = Shape
|
|
{ tag :: Shape_Tag
|
|
{- ^ __C declaration:__ @tag@
|
|
|
|
__defined at:__ @garnet_rs.h 25:13@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
, body :: Shape_body
|
|
{- ^ __C declaration:__ @body@
|
|
|
|
__defined at:__ @garnet_rs.h 29:5@
|
|
|
|
__exported by:__ @garnet_rs.h@
|
|
-}
|
|
}
|
|
deriving stock (GHC.Generics.Generic)
|
|
|
|
instance HsBindgen.Runtime.Marshal.StaticSize Shape where
|
|
|
|
staticSizeOf = \_ -> (24 :: Int)
|
|
|
|
staticAlignment = \_ -> (8 :: Int)
|
|
|
|
instance HsBindgen.Runtime.Marshal.ReadRaw Shape where
|
|
|
|
readRaw =
|
|
\ptr0 ->
|
|
pure Shape
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"tag") ptr0
|
|
<*> HsBindgen.Runtime.HasCField.readRaw (Data.Proxy.Proxy @"body") ptr0
|
|
|
|
instance HsBindgen.Runtime.Marshal.WriteRaw Shape where
|
|
|
|
writeRaw =
|
|
\ptr0 ->
|
|
\s1 ->
|
|
case s1 of
|
|
Shape tag2 body3 ->
|
|
HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"tag") ptr0 tag2
|
|
>> HsBindgen.Runtime.HasCField.writeRaw (Data.Proxy.Proxy @"body") ptr0 body3
|
|
|
|
deriving via HsBindgen.Runtime.Marshal.EquivStorable Shape instance F.Storable Shape
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Shape "tag" where
|
|
|
|
type CFieldType Shape "tag" = Shape_Tag
|
|
|
|
offset# = \_ -> \_ -> 0
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape) "tag")
|
|
) => GHC.Records.HasField "tag" (Ptr.Ptr Shape) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"tag")
|
|
|
|
instance HsBindgen.Runtime.HasCField.HasCField Shape "body" where
|
|
|
|
type CFieldType Shape "body" = Shape_body
|
|
|
|
offset# = \_ -> \_ -> 8
|
|
|
|
instance ( TyEq ty ((HsBindgen.Runtime.HasCField.CFieldType Shape) "body")
|
|
) => GHC.Records.HasField "body" (Ptr.Ptr Shape) (Ptr.Ptr ty) where
|
|
|
|
getField =
|
|
HsBindgen.Runtime.HasCField.fromPtr (Data.Proxy.Proxy @"body")
|