Refactor to use continuation monad
This commit is contained in:
parent
ca063b1dd6
commit
58005ee261
@ -11,7 +11,10 @@ module GarnetRs.Wrapped (
|
|||||||
sumTree,
|
sumTree,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Cont
|
||||||
|
import Control.Monad.Trans
|
||||||
import Data.ByteString
|
import Data.ByteString
|
||||||
|
import Data.Function
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import Foreign
|
import Foreign
|
||||||
import Foreign.C
|
import Foreign.C
|
||||||
@ -38,20 +41,17 @@ data BTree a
|
|||||||
= Leaf a
|
= Leaf a
|
||||||
| Fork (BTree a) (BTree a)
|
| Fork (BTree a) (BTree a)
|
||||||
withBTree :: BTree Int64 -> (Raw.BTreeC -> IO a) -> IO a
|
withBTree :: BTree Int64 -> (Raw.BTreeC -> IO a) -> IO a
|
||||||
withBTree = flip \f -> \case
|
withBTree =
|
||||||
Leaf v ->
|
runContT . fix \f -> \case
|
||||||
f $ Raw.BTreeC Raw.Leaf $ Raw.set_bTreeC_body_leaf $ Raw.Leaf_Body v
|
Leaf v -> pure $ Raw.BTreeC Raw.Leaf $ Raw.set_bTreeC_body_leaf $ Raw.Leaf_Body v
|
||||||
Fork l r ->
|
Fork l r -> do
|
||||||
withBTree l \lRaw ->
|
lRaw <- f l
|
||||||
withBTree r \rRaw ->
|
rRaw <- f r
|
||||||
alloca \lPtr ->
|
lPtr <- ContT alloca
|
||||||
alloca \rPtr -> do
|
rPtr <- ContT alloca
|
||||||
poke lPtr lRaw
|
lift $ poke lPtr lRaw >> poke rPtr rRaw
|
||||||
poke rPtr rRaw
|
pure . Raw.BTreeC Raw.Fork . Raw.set_bTreeC_body_fork $
|
||||||
f
|
Raw.Fork_Body (unsafeFromPtr lPtr) (unsafeFromPtr rPtr)
|
||||||
. Raw.BTreeC Raw.Fork
|
|
||||||
. Raw.set_bTreeC_body_fork
|
|
||||||
$ Raw.Fork_Body (unsafeFromPtr lPtr) (unsafeFromPtr rPtr)
|
|
||||||
|
|
||||||
hello :: ByteString -> IO ()
|
hello :: ByteString -> IO ()
|
||||||
hello s = useAsCString s $ Raw.hello . unsafeFromPtr
|
hello s = useAsCString s $ Raw.hello . unsafeFromPtr
|
||||||
|
|||||||
@ -53,3 +53,4 @@ executable garnet
|
|||||||
bytestring,
|
bytestring,
|
||||||
garnet-generated,
|
garnet-generated,
|
||||||
hs-bindgen-runtime,
|
hs-bindgen-runtime,
|
||||||
|
mtl,
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user