diff --git a/exe/GarnetRs/Wrapped.hs b/exe/GarnetRs/Wrapped.hs index cb3f372..cb4d44c 100644 --- a/exe/GarnetRs/Wrapped.hs +++ b/exe/GarnetRs/Wrapped.hs @@ -11,7 +11,10 @@ module GarnetRs.Wrapped ( sumTree, ) where +import Control.Monad.Cont +import Control.Monad.Trans import Data.ByteString +import Data.Function import Data.Word import Foreign import Foreign.C @@ -38,20 +41,17 @@ data BTree a = Leaf a | Fork (BTree a) (BTree a) withBTree :: BTree Int64 -> (Raw.BTreeC -> IO a) -> IO a -withBTree = flip \f -> \case - Leaf v -> - f $ Raw.BTreeC Raw.Leaf $ Raw.set_bTreeC_body_leaf $ Raw.Leaf_Body v - Fork l r -> - withBTree l \lRaw -> - withBTree r \rRaw -> - alloca \lPtr -> - alloca \rPtr -> do - poke lPtr lRaw - poke rPtr rRaw - f - . Raw.BTreeC Raw.Fork - . Raw.set_bTreeC_body_fork - $ Raw.Fork_Body (unsafeFromPtr lPtr) (unsafeFromPtr rPtr) +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 diff --git a/garnet.cabal b/garnet.cabal index 37a80aa..a61a44a 100644 --- a/garnet.cabal +++ b/garnet.cabal @@ -53,3 +53,4 @@ executable garnet bytestring, garnet-generated, hs-bindgen-runtime, + mtl,