Tuple.hsc

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module GEGL.FFI.Tuple where

import qualified Language.C.Inline as C
import qualified Language.C.Types as C
import qualified Language.C.Inline.Context as C

import qualified Data.Map as Map

import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import GHC.Ptr as G

import qualified Language.Haskell.TH as TH

#def typedef struct {void * node; char * pad;} producer;
#def typedef struct {int length; void * data; char ** names;} nodeWithPad;
#def typedef struct {int length; float * data;} tupleFloat;
#def typedef struct {int length; double * data;} tupleDouble;

C.include "Tuple.h"

data Producer = Producer
  { prodNode :: Ptr ()
  , prodPad  :: CString
  }

instance Storable Producer where
  sizeOf    (Producer _ _) = (#size producer)
  alignment (Producer _ _) = alignment (undefined :: CDouble)
  peek ptr = do
    node <- (#peek producer, node) ptr
    pad  <- (#peek producer, pad) ptr
    return $ Producer node pad
  poke _ = error "poke undefined for Produer"

data NodeWithPad =
  NodeWithPad
    { nwpLength :: CInt
    , nwpData   :: Ptr (Ptr ())
    , nwpNames  :: Ptr CString
    }

instance Storable NodeWithPad where
  sizeOf    (NodeWithPad _ _ _) = (#size tupleFloat)
  alignment (NodeWithPad _ _ _) = alignment (undefined :: CDouble)
  peek ptr = do
    length <- (#peek nodeWithPad, length) ptr
    tdata  <- (#peek nodeWithPad, data) ptr
    names  <- (#peek nodeWithPad, names) ptr
    return $ NodeWithPad length tdata names
  poke ptr (NodeWithPad{..}) = do
    (#poke nodeWithPad, length) ptr nwpLength
    (#poke nodeWithPad, data)   ptr nwpData
    (#poke nodeWithPad, names)  ptr nwpNames

data TupleFloat =
  TupleFloat
    { tupleFloatLength :: CInt
    , tupleFloatData   :: Ptr CFloat
    }

instance Storable TupleFloat where
  sizeOf    (TupleFloat _ _) = (#size tupleFloat)
  alignment (TupleFloat _ _) = alignment (undefined :: CDouble)
  peek ptr = do
    length <- (#peek tupleFloat, length) ptr
    tdata  <- (#peek tupleFloat, data) ptr
    return $ TupleFloat length tdata
  poke ptr (TupleFloat{..}) = do
    (#poke tupleFloat, length) ptr tupleFloatLength
    (#poke tupleFloat, data)   ptr tupleFloatData

data TupleDouble =
  TupleDouble
    { tupleDoubleLength :: CInt
    , tupleDoubleData   :: Ptr CDouble
    }

instance Storable TupleDouble where
  sizeOf    (TupleDouble _ _) = (#size tupleDouble)
  alignment (TupleDouble _ _) = alignment (undefined :: CDouble)
  peek ptr = do
    length <- (#peek tupleDouble, length) ptr
    tdata  <- (#peek tupleDouble, data) ptr
    return $ TupleDouble length tdata
  poke ptr (TupleDouble{..}) = do
    (#poke tupleDouble, length) ptr tupleDoubleLength
    (#poke tupleDouble, data)   ptr tupleDoubleData

tupleCtx :: C.Context
tupleCtx = mempty
  { C.ctxTypesTable = tupleTypes
  }

tupleTypes :: Map.Map C.TypeSpecifier TH.TypeQ
tupleTypes = Map.fromList
  [ (C.TypeName "tupleFloat",  [t|TupleFloat|])
  , (C.TypeName "tupleDouble", [t|TupleDouble|])
  , (C.TypeName "nodeWithPad",   [t|NodeWithPad|])
  , (C.TypeName "producer",   [t|Producer|])
  ]