garnet/exe/GarnetRs/Wrapped.hs

-- TODO automate this sort of high level wrapper boilerplate
-- or look at upstream plans: https://github.com/well-typed/hs-bindgen/issues?q=state%3Aopen%20label%3A%22highlevel%22
module GarnetRs.Wrapped (
    T (..),
    Shape (..),
    BTree (..),
    hello,
    helloStruct,
    helloShape,
    add,
    sumTree,
) where

import Control.Monad.Cont
import Control.Monad.Trans
import Data.ByteString
import Data.Function
import Data.Word
import Foreign
import Foreign.C
import GarnetRs qualified as Raw
import GarnetRs.Safe qualified as Raw
import HsBindgen.Runtime.PtrConst

data T = T
    { a :: Bool
    , b :: Word8
    }
convertT :: T -> Raw.T
convertT T{a, b} = Raw.T{a = fromBool a, b}

data Shape
    = Circle CDouble
    | Rectangle CDouble CDouble
convertShape :: Shape -> Raw.Shape
convertShape = \case
    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

data BTree a
    = Leaf a
    | Fork (BTree a) (BTree a)
withBTree :: BTree Int64 -> (Raw.BTreeC -> IO a) -> IO a
withBTree =
    runContT . fix \f -> \case
        Leaf v -> pure $ Raw.BTreeC Raw.Leaf $ Raw.set_bTreeC_body_leaf $ Raw.Leaf_Body v
        Fork l r -> do
            lRaw <- f l
            rRaw <- f r
            lPtr <- ContT alloca
            rPtr <- ContT alloca
            lift $ poke lPtr lRaw >> poke rPtr rRaw
            pure . Raw.BTreeC Raw.Fork . Raw.set_bTreeC_body_fork $
                Raw.Fork_Body (unsafeFromPtr lPtr) (unsafeFromPtr rPtr)

hello :: ByteString -> IO ()
hello s = useAsCString s $ Raw.hello . unsafeFromPtr

helloStruct :: T -> IO ()
helloStruct = Raw.hello_struct . convertT

helloShape :: Shape -> IO ()
helloShape = Raw.hello_shape . convertShape

add :: Int64 -> Int64 -> Int64
add = Raw.add

sumTree :: BTree Int64 -> IO Int64
sumTree = flip withBTree Raw.sum_tree