--
-- Fresco Framework for Multi-Language Programming
-- Copyright 2015-2016 Peter Althainz
--
-- Distributed under the Apache License, Version 2.0
-- (See attached file LICENSE or copy at
-- http:--www.apache.org/licenses/LICENSE-2.0)
--
-- file: haskell/Fresco/System.hs
--
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
-- | Helper functions for binding ffi, encoding, decoding via messagepack
module Fresco.System
where
import Data.ByteString
import Data.ByteString.Unsafe
import Data.MessagePack
import Data.Either
import Data.Maybe
import Data.Serialize
import Foreign
import Foreign.C
import Foreign.Ptr
import Fresco.Component
#ifdef UseWinDLLLoading
import System.Win32.DLL
#else
import System.Posix.DynamicLinker
#endif
import System.Environment
import System.IO.Unsafe
import Data.IORef
toMsg :: ComponentClass o => o -> ByteString
toMsg o = encode (toObj o)
fromMsg :: ComponentClass o => ByteString -> Maybe o
fromMsg bs = case decode bs of
Right o -> Just $ fromObj o
_ -> Nothing
-- helper functions
type MsgFunction = Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Word32
foreign import ccall "dynamic"
mkMsgFun :: FunPtr MsgFunction -> MsgFunction
foreign import ccall "wrapper"
mkMsgFunPtr :: MsgFunction -> IO (FunPtr MsgFunction)
callMsgFunction :: FunPtr MsgFunction -> Ptr () -> Word64 -> ByteString -> IO Int
callMsgFunction mf p ct msg = do
let f = mkMsgFun mf
let dat = msg
unsafeUseAsCStringLen' dat $ \(dat'1, dat'2) -> f p ct dat'1 dat'2 >>= \res -> return (fromIntegral res)
-- unsafeUseAsCStringLen' dat $ \(dat'1, dat'2) -> print "msgfun" >> print dat'1 >> print dat'2 >> f p dat'1 dat'2 >>= \res -> return (fromIntegral res)
type InitFunction = Ptr () -> IO Word32
foreign import ccall "dynamic"
mkInitFun :: FunPtr InitFunction -> InitFunction
callInitFunction :: FunPtr InitFunction -> Ptr () -> IO Int
callInitFunction ifp p = do
let f = mkInitFun ifp
res <- f p
return (fromIntegral res)
-- Entity Interface
type EntityCreateFunction = ((Ptr CChar) -> (Word32 -> ((Ptr (Ptr ())) -> (IO ()))))
foreign import ccall "dynamic"
mkEntityCreateFunction :: FunPtr EntityCreateFunction -> EntityCreateFunction
type EntityDestroyFunction = ((Ptr ()) -> IO ())
foreign import ccall "dynamic"
mkEntityDestroyFunction :: FunPtr EntityDestroyFunction -> EntityDestroyFunction
type EntityIdFunction = ((Ptr ()) -> IO (Ptr CChar))
foreign import ccall "dynamic"
mkEntityIdFunction :: FunPtr EntityIdFunction -> EntityIdFunction
type EntityIdFreeFunction = ((Ptr CChar) -> IO ())
foreign import ccall "dynamic"
mkEntityIdFreeFunction :: FunPtr EntityIdFreeFunction -> EntityIdFreeFunction
type EntitySetFunction = ((Ptr CChar) -> (Word32 -> ((Ptr ()) -> (IO ()))))
foreign import ccall "dynamic"
mkEntitySetFunction :: FunPtr EntitySetFunction -> EntitySetFunction
-- pub extern "C" fn entity_get_data(ep: EntityPointer, ct: u64, pp: *mut *mut DataPointer)
type EntityGetDataFunction = ((Ptr ()) -> Word64 -> (Ptr (Ptr ())) -> IO ())
foreign import ccall "dynamic"
mkEntityGetDataFunction :: FunPtr EntityGetDataFunction -> EntityGetDataFunction
-- pub extern "C" fn entity_data_read(dp: *mut DataPointer, p_cp: *mut *const libc::c_char, p_len: *mut libc::c_int)
type EntityDataReadFunction = ((Ptr ()) -> (Ptr (Ptr CChar)) -> (Ptr Word32) -> IO ())
foreign import ccall "dynamic"
mkEntityDataReadFunction :: FunPtr EntityDataReadFunction -> EntityDataReadFunction
-- pub extern "C" fn entity_data_release(dp: *mut DataPointer)
type EntityDataReleaseFunction = ((Ptr ()) -> IO ())
foreign import ccall "dynamic"
mkEntityDataReleaseFunction :: FunPtr EntityDataReleaseFunction -> EntityDataReleaseFunction
-- pub extern "C" fn callback_system_create(pp: *mut *mut CallbackSystem) {
type ObjectLibSystemCreateFunction = ((Ptr (Ptr ())) -> (IO ()))
foreign import ccall "dynamic"
mkObjectLibSystemCreateFunction :: FunPtr ObjectLibSystemCreateFunction -> ObjectLibSystemCreateFunction
-- pub extern "C" fn callback_system_step(cbs: *mut CallbackSystem) {
type ObjectLibSystemAddEntityFunction = ((Ptr ()) -> ((Ptr ()) -> (IO ())))
foreign import ccall "dynamic"
mkObjectLibSystemAddEntityFunction:: FunPtr ObjectLibSystemAddEntityFunction -> ObjectLibSystemAddEntityFunction
-- pub extern "C" fn callback_system_step(cbs: *mut CallbackSystem) {
type ObjectLibSystemStepFunction = ((Ptr ()) -> (IO ()))
foreign import ccall "dynamic"
mkObjectLibSystemStepFunction:: FunPtr ObjectLibSystemStepFunction -> ObjectLibSystemStepFunction
-- pub extern "C" fn callback_system_create(pp: *mut *mut CallbackSystem) {
type CallbackSystemCreateFunction = ((Ptr (Ptr ())) -> (IO ()))
foreign import ccall "dynamic"
mkCallbackSystemCreateFunction :: FunPtr CallbackSystemCreateFunction -> CallbackSystemCreateFunction
-- pub extern "C" fn callback_system_register_receiver (cbs: *mut CallbackSystem, ep: EntityPointer, ct: u64, mfp: MessageFunctionPointer) {
type CallbackSystemRegisterReceiverFunction = ((Ptr ()) -> ((Ptr ()) -> (Word64 -> ((FunPtr ((Ptr ()) -> (Word64 -> ((Ptr CChar) -> (Word32 -> (IO Word32))))) -> (IO ()))))))
foreign import ccall "dynamic"
mkCallbackSystemRegisterReceiverFunction :: FunPtr CallbackSystemRegisterReceiverFunction -> CallbackSystemRegisterReceiverFunction
-- pub extern "C" fn callback_system_step(cbs: *mut CallbackSystem) {
type CallbackSystemStepFunction = ((Ptr ()) -> (IO ()))
foreign import ccall "dynamic"
mkCallbackSystemStepFunction:: FunPtr CallbackSystemStepFunction -> CallbackSystemStepFunction
data EntityInterface = EntityInterface {
eCreate :: EntityCreateFunction,
eDestroy :: EntityDestroyFunction,
eId :: EntityIdFunction,
eIdFree :: EntityIdFreeFunction,
edSet :: EntitySetFunction,
edGet :: EntityGetDataFunction,
edRead :: EntityDataReadFunction,
edRelease :: EntityDataReleaseFunction,
olsCreate :: ObjectLibSystemCreateFunction,
olsAddEntity :: ObjectLibSystemAddEntityFunction,
olsStep :: ObjectLibSystemStepFunction,
cbsCreate :: CallbackSystemCreateFunction,
cbsRegisterReceiver :: CallbackSystemRegisterReceiverFunction,
cbsStep :: CallbackSystemStepFunction
}
#ifdef UseWinDLLLoading
dynamicEI :: IORef EntityInterface
{-# NOINLINE dynamicEI #-}
dynamicEI = unsafePerformIO (do
libname <- getEnv "INTONACO"
dll <- loadLibrary libname
ec <- getProcAddress dll "entity_create"
let ec' = mkEntityCreateFunction $ castPtrToFunPtr ec
ed <- getProcAddress dll "entity_destroy"
let ed' = mkEntityDestroyFunction $ castPtrToFunPtr ed
ei <- getProcAddress dll "entity_id"
let ei' = mkEntityIdFunction $ castPtrToFunPtr ei
eif <- getProcAddress dll "entity_id_free"
let eif' = mkEntityIdFreeFunction $ castPtrToFunPtr eif
eds <- getProcAddress dll "entity_set"
let eds' = mkEntitySetFunction $ castPtrToFunPtr eds
edg <- getProcAddress dll "entity_get_data"
let edg' = mkEntityGetDataFunction $ castPtrToFunPtr edg
edr <- getProcAddress dll "entity_data_read"
let edr' = mkEntityDataReadFunction $ castPtrToFunPtr edr
edrl <- getProcAddress dll "entity_data_release"
let edrl' = mkEntityDataReleaseFunction $ castPtrToFunPtr edrl
olc <- getProcAddress dll "object_lib_system_create"
let olc' = mkObjectLibSystemCreateFunction $ castPtrToFunPtr olc
ola <- getProcAddress dll "object_lib_system_add_entity"
let ola' = mkObjectLibSystemAddEntityFunction $ castPtrToFunPtr ola
ols <- getProcAddress dll "object_lib_system_step"
let ols' = mkObjectLibSystemStepFunction $ castPtrToFunPtr ols
cbc <- getProcAddress dll "callback_system_create"
let cbc' = mkCallbackSystemCreateFunction $ castPtrToFunPtr cbc
cbr <- getProcAddress dll "callback_system_register_receiver"
let cbr' = mkCallbackSystemRegisterReceiverFunction $ castPtrToFunPtr cbr
cbs <- getProcAddress dll "callback_system_step"
let cbs' = mkCallbackSystemStepFunction $ castPtrToFunPtr cbs
ref <- newIORef $ EntityInterface ec' ed' ei' eif' eds' edg' edr' edrl' olc' ola' ols' cbc' cbr' cbs'
return ref
)
#else
dynamicEI :: IORef EntityInterface
{-# NOINLINE dynamicEI #-}
dynamicEI = unsafePerformIO (
do
libname <- getEnv "INTONACO"
dll <- dlopen libname [RTLD_NOW]
ec <- dlsym dll "entity_create"
let ec' = mkEntityCreateFunction ec
ed <- dlsym dll "entity_destroy"
let ed' = mkEntityDestroyFunction ed
ei <- dlsym dll "entity_id"
let ei' = mkEntityIdFunction ei
eif <- dlsym dll "entity_id_free"
let eif' = mkEntityIdFreeFunction eif
eds <- dlsym dll "entity_set"
let eds' = mkEntitySetFunction eds
edg <- dlsym dll "entity_get_data"
let edg' = mkEntityGetDataFunction edg
edr <- dlsym dll "entity_data_read"
let edr' = mkEntityDataReadFunction edr
edrl <- dlsym dll "entity_data_release"
let edrl' = mkEntityDataReleaseFunction edrl
olc <- dlsym dll "object_lib_system_create"
let olc' = mkObjectLibSystemCreateFunction olc
ola <- dlsym dll "object_lib_system_add_entity"
let ola' = mkObjectLibSystemAddEntityFunction ola
ols <- dlsym dll "object_lib_system_step"
let ols' = mkObjectLibSystemStepFunction ols
cbc <- dlsym dll "callback_system_create"
let cbc' = mkCallbackSystemCreateFunction cbc
cbr <- dlsym dll "callback_system_register_receiver"
let cbr' = mkCallbackSystemRegisterReceiverFunction cbr
cbs <- dlsym dll "callback_system_step"
let cbs' = mkCallbackSystemStepFunction cbs
ref <- newIORef $ EntityInterface ec' ed' ei' eif' eds' edg' edr' edrl' olc' ola' ols' cbc' cbr' cbs'
return ref
)
#endif
type CStringCLen i = (CString, i)
unsafeUseAsCStringLen' :: (Integral i) => ByteString -> (CStringCLen i -> IO a) -> IO a
unsafeUseAsCStringLen' str fn =
unsafeUseAsCStringLen str (\(ptr, len) -> fn (ptr, fromIntegral len))
entityCreate :: (ByteString) -> IO ((Ptr ()))
entityCreate a1 =
unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) ->
alloca $ \a2' ->
(do
dei <- readIORef dynamicEI
(eCreate dei) a1'1 a1'2 a2') >>
peek a2' >>= \a2'' ->
return (a2'')
entityDestroy :: Ptr () -> IO ()
entityDestroy a1 =
(do
dei <- readIORef dynamicEI
(eDestroy dei) a1) >>
return ()
entityId :: Ptr () -> IO ByteString
entityId ep = do
dei <- readIORef dynamicEI
p <- ((eId dei) ep)
bs <- packCStringLen (p, 16)
(eIdFree dei) p
return bs
entitySet :: (ByteString) -> (Ptr ()) -> IO ()
entitySet a1 a2 =
unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) ->
let {a2' = id a2} in
(do
dei <- readIORef dynamicEI
(edSet dei) a1'1 a1'2 a2') >>
return ()
entityGetData :: (Ptr ()) -> Word64 -> IO ((Ptr ()))
entityGetData a1 a2 =
alloca $ \a3' ->
(do
dei <- readIORef dynamicEI
(edGet dei) a1 (fromIntegral a2) a3') >>
peek a3' >>= \a3'' ->
return (a3'')
entityDataRead :: Ptr () -> IO ByteString
entityDataRead a1 =
alloca $ \a2' ->
alloca $ \a3' ->
(do
dei <- readIORef dynamicEI
(edRead dei) a1 a2' a3') >>
peek a2' >>= \a2'' ->
peek a3' >>= \a3'' ->
(do
bs <- packCStringLen (a2'', fromIntegral a3'')
return bs
)
entityDataRelease :: Ptr () -> IO ()
entityDataRelease a1 = do
dei <- readIORef dynamicEI
(edRelease dei) a1
return ()
objectLibSystemCreate :: IO ((Ptr ()))
objectLibSystemCreate =
alloca $ \a1' ->
(do
dei <- readIORef dynamicEI
(olsCreate dei) a1') >>
peek a1'>>= \a1'' ->
return (a1'')
objectLibSystemAddEntity :: (Ptr ()) -> (Ptr ()) -> IO ()
objectLibSystemAddEntity a1 a2 =
let {a1' = id a1; a2' = id a2} in
(do
dei <- readIORef dynamicEI
(olsAddEntity dei) a1' a2') >>
return ()
objectLibSystemStep :: (Ptr ()) -> IO ()
objectLibSystemStep a1 =
let {a1' = id a1} in
(do
dei <- readIORef dynamicEI
(olsStep dei) a1') >>
return ()
callbackSystemCreate :: IO ((Ptr ()))
callbackSystemCreate =
alloca $ \a1' ->
(do
dei <- readIORef dynamicEI
(cbsCreate dei) a1') >>
peek a1'>>= \a1'' ->
return (a1'')
callbackSystemRegisterReceiver :: (Ptr ()) -> (Ptr ()) -> (Word64) -> (FunPtr (Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Word32)) -> IO ()
callbackSystemRegisterReceiver a1 a2 a3 a4 =
let {a1' = id a1} in
let {a2' = id a2} in
let {a3' = fromIntegral a3} in
let {a4' = id a4} in
(do
dei <- readIORef dynamicEI
(cbsRegisterReceiver dei) a1' a2' a3' a4') >>
return ()
callbackSystemStep :: (Ptr ()) -> IO ()
callbackSystemStep a1 =
let {a1' = id a1} in
(do
dei <- readIORef dynamicEI
(cbsStep dei) a1') >>
return ()