Allocator.hsc

module KB.Text.Shape.FFI.Allocator where

import Control.Exception

import Foreign
import Foreign.C

#include "kb_text_shape.h"

{- $doc
@
  typedef void kbts_allocator_function(void *Data, kbts_allocator_op *Op);
    [Data] the custom data pointer you passed in along with your allocator.
    [Op]   the memory request. It is of this type:

      :kbts_allocator_op
      :allocator_op
      typedef struct kbts_allocator_op
      {
        kbts_allocator_op_kind Kind;

        union
        {
          kbts_allocator_op_allocate Allocate;
          kbts_allocator_op_free Free;
        };
      } kbts_allocator_op;
@

And the possible op kinds are:
  KBTS_ALLOCATOR_OP_KIND_ALLOCATE
  KBTS_ALLOCATOR_OP_KIND_FREE

ALLOCATE expects you to fill in Op->Allocate.Pointer.
  The allocation does not need to be aligned.
FREE expects you to free Op->Free.Pointer.
-}

-- | @void kbts_allocator_function(void *Data, kbts_allocator_op *Op);@
type Allocator = Ptr () -> Ptr Op -> IO ()

foreign import ccall "wrapper"
  mkAllocator :: Allocator -> IO (FunPtr Allocator)

freeAllocator :: FunPtr Allocator -> IO ()
freeAllocator = freeHaskellFunPtr

withAllocator :: Allocator -> (FunPtr Allocator -> IO a) -> IO a
withAllocator fun = bracket (mkAllocator fun) freeAllocator

newtype OpKind = OpKind CInt
  deriving (Eq, Ord, Show)
  deriving newtype (Storable)

pattern OP_KIND_NONE :: OpKind
pattern OP_KIND_NONE = OpKind (#const KBTS_ALLOCATOR_OP_KIND_NONE)

pattern OP_KIND_ALLOCATE :: OpKind
pattern OP_KIND_ALLOCATE = OpKind (#const KBTS_ALLOCATOR_OP_KIND_ALLOCATE)

pattern OP_KIND_FREE :: OpKind
pattern OP_KIND_FREE = OpKind (#const KBTS_ALLOCATOR_OP_KIND_FREE)

data Op = Op
  { kind :: OpKind
  , pointer :: Ptr ()
  , size :: Word32 -- ^ only for 'ALLOCATOR_OP_KIND_ALLOCATE'
  } deriving (Eq, Show)

opUnionBase :: Int
opUnionBase = max (sizeOf (undefined :: OpKind)) (alignment (undefined :: Ptr ()))

instance Storable Op where
  alignment ~_ = #alignment kbts_allocator_op
  sizeOf ~_ = #size kbts_allocator_op

  peek ptr = do
    kind <- (#peek kbts_allocator_op, Kind) ptr
    case kind of
      OP_KIND_ALLOCATE -> do
        pointer <- peekByteOff ptr $ opUnionBase + (#offset kbts_allocator_op_allocate, Pointer)
        size <- peekByteOff ptr $ opUnionBase + (#offset kbts_allocator_op_allocate, Size)
        pure $ Op kind pointer size
      OP_KIND_FREE -> do
        pointer <- peekByteOff ptr $ opUnionBase + (#offset kbts_allocator_op_allocate, Pointer)
        pure $ Op kind pointer 0
      _none_etc -> do
        pure $ Op kind nullPtr 0

  poke ptr Op{..} = do
    (#poke kbts_allocator_op, Kind) ptr kind
    case kind of
      OP_KIND_ALLOCATE -> do
        pokeByteOff ptr (opUnionBase + (#offset kbts_allocator_op_allocate, Pointer)) pointer
        pokeByteOff ptr (opUnionBase + (#offset kbts_allocator_op_allocate, Size)) size
      OP_KIND_FREE ->
        pokeByteOff ptr (opUnionBase + (#offset kbts_allocator_op_allocate, Pointer)) pointer
      _ ->
        pure ()