{-# LINE 1 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
module KB.Text.Shape.FFI.Allocator where

import Control.Exception

import Foreign
import Foreign.C



{- $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 :: FunPtr Allocator -> IO ()
freeAllocator = FunPtr Allocator -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

withAllocator :: Allocator -> (FunPtr Allocator -> IO a) -> IO a
withAllocator :: forall a. Allocator -> (FunPtr Allocator -> IO a) -> IO a
withAllocator Allocator
fun = IO (FunPtr Allocator)
-> (FunPtr Allocator -> IO ())
-> (FunPtr Allocator -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Allocator -> IO (FunPtr Allocator)
mkAllocator Allocator
fun) FunPtr Allocator -> IO ()
freeAllocator

newtype OpKind = OpKind CInt
  deriving (OpKind -> OpKind -> Bool
(OpKind -> OpKind -> Bool)
-> (OpKind -> OpKind -> Bool) -> Eq OpKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpKind -> OpKind -> Bool
== :: OpKind -> OpKind -> Bool
$c/= :: OpKind -> OpKind -> Bool
/= :: OpKind -> OpKind -> Bool
Eq, Eq OpKind
Eq OpKind =>
(OpKind -> OpKind -> Ordering)
-> (OpKind -> OpKind -> Bool)
-> (OpKind -> OpKind -> Bool)
-> (OpKind -> OpKind -> Bool)
-> (OpKind -> OpKind -> Bool)
-> (OpKind -> OpKind -> OpKind)
-> (OpKind -> OpKind -> OpKind)
-> Ord OpKind
OpKind -> OpKind -> Bool
OpKind -> OpKind -> Ordering
OpKind -> OpKind -> OpKind
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OpKind -> OpKind -> Ordering
compare :: OpKind -> OpKind -> Ordering
$c< :: OpKind -> OpKind -> Bool
< :: OpKind -> OpKind -> Bool
$c<= :: OpKind -> OpKind -> Bool
<= :: OpKind -> OpKind -> Bool
$c> :: OpKind -> OpKind -> Bool
> :: OpKind -> OpKind -> Bool
$c>= :: OpKind -> OpKind -> Bool
>= :: OpKind -> OpKind -> Bool
$cmax :: OpKind -> OpKind -> OpKind
max :: OpKind -> OpKind -> OpKind
$cmin :: OpKind -> OpKind -> OpKind
min :: OpKind -> OpKind -> OpKind
Ord, Int -> OpKind -> ShowS
[OpKind] -> ShowS
OpKind -> String
(Int -> OpKind -> ShowS)
-> (OpKind -> String) -> ([OpKind] -> ShowS) -> Show OpKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpKind -> ShowS
showsPrec :: Int -> OpKind -> ShowS
$cshow :: OpKind -> String
show :: OpKind -> String
$cshowList :: [OpKind] -> ShowS
showList :: [OpKind] -> ShowS
Show)
  deriving newtype (Ptr OpKind -> IO OpKind
Ptr OpKind -> Int -> IO OpKind
Ptr OpKind -> Int -> OpKind -> IO ()
Ptr OpKind -> OpKind -> IO ()
OpKind -> Int
(OpKind -> Int)
-> (OpKind -> Int)
-> (Ptr OpKind -> Int -> IO OpKind)
-> (Ptr OpKind -> Int -> OpKind -> IO ())
-> (forall b. Ptr b -> Int -> IO OpKind)
-> (forall b. Ptr b -> Int -> OpKind -> IO ())
-> (Ptr OpKind -> IO OpKind)
-> (Ptr OpKind -> OpKind -> IO ())
-> Storable OpKind
forall b. Ptr b -> Int -> IO OpKind
forall b. Ptr b -> Int -> OpKind -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
$csizeOf :: OpKind -> Int
sizeOf :: OpKind -> Int
$calignment :: OpKind -> Int
alignment :: OpKind -> Int
$cpeekElemOff :: Ptr OpKind -> Int -> IO OpKind
peekElemOff :: Ptr OpKind -> Int -> IO OpKind
$cpokeElemOff :: Ptr OpKind -> Int -> OpKind -> IO ()
pokeElemOff :: Ptr OpKind -> Int -> OpKind -> IO ()
$cpeekByteOff :: forall b. Ptr b -> Int -> IO OpKind
peekByteOff :: forall b. Ptr b -> Int -> IO OpKind
$cpokeByteOff :: forall b. Ptr b -> Int -> OpKind -> IO ()
pokeByteOff :: forall b. Ptr b -> Int -> OpKind -> IO ()
$cpeek :: Ptr OpKind -> IO OpKind
peek :: Ptr OpKind -> IO OpKind
$cpoke :: Ptr OpKind -> OpKind -> IO ()
poke :: Ptr OpKind -> OpKind -> IO ()
Storable)

pattern OP_KIND_NONE :: OpKind
pattern $mOP_KIND_NONE :: forall {r}. OpKind -> ((# #) -> r) -> ((# #) -> r) -> r
$bOP_KIND_NONE :: OpKind
OP_KIND_NONE = OpKind (0)
{-# LINE 57 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}

pattern OP_KIND_ALLOCATE :: OpKind
pattern $mOP_KIND_ALLOCATE :: forall {r}. OpKind -> ((# #) -> r) -> ((# #) -> r) -> r
$bOP_KIND_ALLOCATE :: OpKind
OP_KIND_ALLOCATE = OpKind (1)
{-# LINE 60 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}

pattern OP_KIND_FREE :: OpKind
pattern $mOP_KIND_FREE :: forall {r}. OpKind -> ((# #) -> r) -> ((# #) -> r) -> r
$bOP_KIND_FREE :: OpKind
OP_KIND_FREE = OpKind (2)
{-# LINE 63 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}

data Op = Op
  { Op -> OpKind
kind :: OpKind
  , Op -> Ptr ()
pointer :: Ptr ()
  , Op -> Word32
size :: Word32 -- ^ only for 'ALLOCATOR_OP_KIND_ALLOCATE'
  } deriving (Op -> Op -> Bool
(Op -> Op -> Bool) -> (Op -> Op -> Bool) -> Eq Op
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Op -> Op -> Bool
== :: Op -> Op -> Bool
$c/= :: Op -> Op -> Bool
/= :: Op -> Op -> Bool
Eq, Int -> Op -> ShowS
[Op] -> ShowS
Op -> String
(Int -> Op -> ShowS)
-> (Op -> String) -> ([Op] -> ShowS) -> Show Op
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Op -> ShowS
showsPrec :: Int -> Op -> ShowS
$cshow :: Op -> String
show :: Op -> String
$cshowList :: [Op] -> ShowS
showList :: [Op] -> ShowS
Show)

opUnionBase :: Int
opUnionBase :: Int
opUnionBase = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (OpKind -> Int
forall a. Storable a => a -> Int
sizeOf (OpKind
forall a. HasCallStack => a
undefined :: OpKind)) (Ptr () -> Int
forall a. Storable a => a -> Int
alignment (Ptr ()
forall a. HasCallStack => a
undefined :: Ptr ()))

instance Storable Op where
  alignment :: Op -> Int
alignment ~Op
_ = Int
8
{-# LINE 75 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
  sizeOf ~_ = (24)
{-# LINE 76 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}

  peek :: Ptr Op -> IO Op
peek Ptr Op
ptr = do
    kind <- ((\Ptr Op
hsc_ptr -> Ptr Op -> Int -> IO OpKind
forall b. Ptr b -> Int -> IO OpKind
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Op
hsc_ptr Int
0)) Ptr Op
ptr
{-# LINE 79 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
    case kind of
      OP_KIND_ALLOCATE -> do
        pointer <- peekByteOff ptr $ opUnionBase + ((0))
{-# LINE 82 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
        size <- peekByteOff ptr $ opUnionBase + ((8))
{-# LINE 83 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
        pure $ Op kind pointer size
      OP_KIND_FREE -> do
        pointer <- peekByteOff ptr $ opUnionBase + ((0))
{-# LINE 86 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
        pure $ Op kind pointer 0
      _none_etc -> do
        pure $ Op kind nullPtr 0

  poke :: Ptr Op -> Op -> IO ()
poke Ptr Op
ptr Op{Word32
Ptr ()
OpKind
kind :: Op -> OpKind
pointer :: Op -> Ptr ()
size :: Op -> Word32
kind :: OpKind
pointer :: Ptr ()
size :: Word32
..} = do
    ((\Ptr Op
hsc_ptr -> Ptr Op -> Int -> OpKind -> IO ()
forall b. Ptr b -> Int -> OpKind -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Op
hsc_ptr Int
0)) Ptr Op
ptr OpKind
kind
{-# LINE 92 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
    case kind of
      OP_KIND_ALLOCATE -> do
        pokeByteOff ptr (opUnionBase + ((0))) pointer
{-# LINE 95 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
        pokeByteOff ptr (opUnionBase + ((8))) size
{-# LINE 96 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
      OP_KIND_FREE ->
        pokeByteOff ptr (opUnionBase + ((0))) pointer
{-# LINE 98 "src/KB/Text/Shape/FFI/Allocator.hsc" #-}
      _ ->
        pure ()