module Fresco.System
where
import Data.ByteString.Lazy
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.ByteString (packCStringLen)
import Data.Binary.Serialise.CBOR
import Data.Either
import Data.Maybe
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 :: Serialise o => o -> ByteString
toMsg o = serialise o
fromMsg :: Serialise o => ByteString -> o
fromMsg bs = deserialise bs
type MsgFn = Ptr () -> Ptr CChar -> Word32 -> IO ()
foreign import ccall "dynamic"
mkMsgFn :: FunPtr MsgFn -> MsgFn
foreign import ccall "wrapper"
mkMsgFnPtr :: MsgFn -> IO (FunPtr MsgFn)
type MsgEntityFn = Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Int32
foreign import ccall "dynamic"
mkMsgEntityFn :: FunPtr MsgEntityFn -> MsgEntityFn
foreign import ccall "wrapper"
mkMsgEntityFnPtr :: MsgEntityFn -> IO (FunPtr MsgEntityFn)
callMsgEntityFn :: FunPtr MsgEntityFn -> Ptr () -> Word64 -> ByteString -> IO Int
callMsgEntityFn mf p ct msg = do
let f = mkMsgEntityFn mf
let dat = msg
unsafeUseAsCStringLen' dat $ \(dat'1, dat'2) -> f p ct 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)
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 EntityReadComponentFunction = Ptr () -> Word64 -> Ptr () -> FunPtr MsgFn -> IO ()
foreign import ccall "dynamic"
mkEntityReadComponentFunction :: FunPtr EntityReadComponentFunction -> EntityReadComponentFunction
type EntityWriteComponentFunction = Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO ()
foreign import ccall "dynamic"
mkEntityWriteComponentFunction :: FunPtr EntityWriteComponentFunction -> EntityWriteComponentFunction
type EntityReadIdFunction = Ptr () -> Ptr () -> FunPtr MsgFn -> IO ()
foreign import ccall "dynamic"
mkEntityReadIdFunction :: FunPtr EntityReadIdFunction -> EntityReadIdFunction
type ObjectLibSystemInitFunction = Ptr CChar -> Ptr (Ptr ()) -> IO ()
foreign import ccall "dynamic"
mkObjectLibSystemInitFunction :: FunPtr ObjectLibSystemInitFunction -> ObjectLibSystemInitFunction
type ObjectLibSystemAddEntityFunction = Ptr () -> Ptr () -> IO ()
foreign import ccall "dynamic"
mkObjectLibSystemAddEntityFunction:: FunPtr ObjectLibSystemAddEntityFunction -> ObjectLibSystemAddEntityFunction
type ObjectLibSystemRemoveEntityFunction = Ptr () -> Ptr () -> IO ()
foreign import ccall "dynamic"
mkObjectLibSystemRemoveEntityFunction:: FunPtr ObjectLibSystemRemoveEntityFunction -> ObjectLibSystemRemoveEntityFunction
type ObjectLibSystemShutdownFunction = Ptr () -> IO ()
foreign import ccall "dynamic"
mkObjectLibSystemShutdownFunction:: FunPtr ObjectLibSystemShutdownFunction -> ObjectLibSystemShutdownFunction
type ObjectLibSystemStepFunction = Ptr () -> IO ()
foreign import ccall "dynamic"
mkObjectLibSystemStepFunction:: FunPtr ObjectLibSystemStepFunction -> ObjectLibSystemStepFunction
type CallbackSystemInitFunction = Ptr (Ptr ()) -> IO ()
foreign import ccall "dynamic"
mkCallbackSystemInitFunction :: FunPtr CallbackSystemInitFunction -> CallbackSystemInitFunction
type CallbackSystemRegisterReceiverFunction = Ptr () -> Ptr () -> Word64 -> FunPtr MsgEntityFn -> IO ()
foreign import ccall "dynamic"
mkCallbackSystemRegisterReceiverFunction :: FunPtr CallbackSystemRegisterReceiverFunction -> CallbackSystemRegisterReceiverFunction
type CallbackSystemShutdownFunction = Ptr () -> IO ()
foreign import ccall "dynamic"
mkCallbackSystemShutdownFunction:: FunPtr CallbackSystemShutdownFunction -> CallbackSystemShutdownFunction
type CallbackSystemStepFunction = Ptr () -> IO ()
foreign import ccall "dynamic"
mkCallbackSystemStepFunction:: FunPtr CallbackSystemStepFunction -> CallbackSystemStepFunction
data EntityInterface = EntityInterface {
eCreate :: EntityCreateFunction,
eRead :: EntityReadComponentFunction,
eWrite :: EntityWriteComponentFunction,
eId :: EntityReadIdFunction,
eDestroy :: EntityDestroyFunction,
olsInit :: ObjectLibSystemInitFunction,
olsAddEntity :: ObjectLibSystemAddEntityFunction,
olsRemoveEntity :: ObjectLibSystemRemoveEntityFunction,
olsShutdown :: ObjectLibSystemShutdownFunction,
olsStep :: ObjectLibSystemStepFunction,
cbsInit :: CallbackSystemInitFunction,
cbsRegisterReceiver :: CallbackSystemRegisterReceiverFunction,
cbsShutdown :: CallbackSystemShutdownFunction,
cbsStep :: CallbackSystemStepFunction
}
#ifdef UseWinDLLLoading
dynamicEI :: IORef EntityInterface
dynamicEI = unsafePerformIO (do
libname <- getEnv "INTONACO"
dll <- loadLibrary libname
ec <- getProcAddress dll "inEntityCreate"
let ec' = mkEntityCreateFunction $ castPtrToFunPtr ec
er <- getProcAddress dll "inEntityReadComponent"
let er' = mkEntityReadComponentFunction $ castPtrToFunPtr er
ew <- getProcAddress dll "inEntityWriteComponent"
let ew' = mkEntityWriteComponentFunction $ castPtrToFunPtr ew
ei <- getProcAddress dll "inEntityId"
let ei' = mkEntityReadIdFunction $ castPtrToFunPtr ei
ed <- getProcAddress dll "inEntityDestroy"
let ed' = mkEntityDestroyFunction $ castPtrToFunPtr ed
oli <- getProcAddress dll "inObjectLibSystemInit"
let oli' = mkObjectLibSystemInitFunction $ castPtrToFunPtr oli
ola <- getProcAddress dll "inObjectLibSystemAddEntity"
let ola' = mkObjectLibSystemAddEntityFunction $ castPtrToFunPtr ola
olr <- getProcAddress dll "inObjectLibSystemRemoveEntity"
let olr' = mkObjectLibSystemRemoveEntityFunction $ castPtrToFunPtr olr
olu <- getProcAddress dll "inObjectLibSystemShutdown"
let olu' = mkObjectLibSystemShutdownFunction $ castPtrToFunPtr olu
ols <- getProcAddress dll "inObjectLibSystemStep"
let ols' = mkObjectLibSystemStepFunction $ castPtrToFunPtr ols
cbi <- getProcAddress dll "inCallbackSystemInit"
let cbi' = mkCallbackSystemInitFunction $ castPtrToFunPtr cbi
cbr <- getProcAddress dll "inCallbackSystemRegisterReceiver"
let cbr' = mkCallbackSystemRegisterReceiverFunction $ castPtrToFunPtr cbr
cbu <- getProcAddress dll "inCallbackSystemShutdown"
let cbu' = mkCallbackSystemShutdownFunction $ castPtrToFunPtr cbu
cbs <- getProcAddress dll "inCallbackSystemStep"
let cbs' = mkCallbackSystemStepFunction $ castPtrToFunPtr cbs
ref <- newIORef $ EntityInterface ec' er' ew' ei' ed' oli' ola' olr' olu' ols' cbi' cbr' cbu' cbs'
return ref
)
#else
dynamicEI :: IORef EntityInterface
dynamicEI = unsafePerformIO (
do
libname <- getEnv "INTONACO"
dll <- dlopen libname [RTLD_NOW]
ec <- dlsym dll "inEntityCreate"
let ec' = mkEntityCreateFunction ec
er <- dlsym dll "inEntityReadComponent"
let er' = mkEntityReadComponentFunction er
ew <- dlsym dll "inEntityWriteComponent"
let ew' = mkEntityWriteComponentFunction ew
ei <- dlsym dll "inEntityId"
let ei' = mkEntityReadIdFunction ei
ed <- dlsym dll "inEntityDestroy"
let ed' = mkEntityDestroyFunction ed
oli <- dlsym dll "inObjectLibSystemInit"
let oli' = mkObjectLibSystemInitFunction oli
ola <- dlsym dll "inObjectLibSystemAddEntity"
let ola' = mkObjectLibSystemAddEntityFunction ola
olr <- dlsym dll "inObjectLibSystemRemoveEntity"
let olr' = mkObjectLibSystemRemoveEntityFunction olr
olu <- dlsym dll "inObjectLibSystemShutdown"
let olu' = mkObjectLibSystemShutdownFunction olu
ols <- dlsym dll "inObjectLibSystemStep"
let ols' = mkObjectLibSystemStepFunction ols
cbi <- dlsym dll "inCallbackSystemInit"
let cbi' = mkCallbackSystemInitFunction cbi
cbr <- dlsym dll "inCallbackSystemRegisterReceiver"
let cbr' = mkCallbackSystemRegisterReceiverFunction cbr
cbu <- dlsym dll "inCallbackSystemShutdown"
let cbu' = mkCallbackSystemShutdownFunction cbu
cbs <- dlsym dll "inCallbackSystemStep"
let cbs' = mkCallbackSystemStepFunction cbs
ref <- newIORef $ EntityInterface ec' er' ew' ei' ed' oli' ola' olr' olu' ols' cbi' cbr' cbu' cbs'
return ref
)
#endif
type CStringCLen i = (CString, i)
unsafeUseAsCStringLen' :: (Integral i) => ByteString -> (CStringCLen i -> IO a) -> IO a
unsafeUseAsCStringLen' str fn =
unsafeUseAsCStringLen (toStrict 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
pbs <- newIORef undefined
fp <- (mkMsgFnPtr (\_ p len -> do
bs <- packCStringLen (p, fromIntegral len)
writeIORef pbs bs
return ()
))
(eId dei) ep nullPtr fp
bs <- readIORef pbs
return (fromStrict bs)
entityWrite :: (Ptr ()) -> Word64 -> ByteString -> IO ()
entityWrite a1 a2 a3 =
unsafeUseAsCStringLen' a3 $ \(a3'1, a3'2) ->
(do
dei <- readIORef dynamicEI
(eWrite dei) a1 a2 a3'1 a3'2) >>
return ()
entityRead :: Ptr () -> Word64 -> IO ByteString
entityRead ep ct = do
dei <- readIORef dynamicEI
pbs <- newIORef undefined
fp <- (mkMsgFnPtr (\_ p len -> do
bs <- packCStringLen (p, fromIntegral len)
writeIORef pbs bs
return ()
))
(eRead dei) ep ct (nullPtr) fp
bs <- readIORef pbs
return (fromStrict bs)
objectLibSystemCreate :: ByteString -> IO (Ptr ())
objectLibSystemCreate a1 =
unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) ->
alloca $ \a2' ->
(do
dei <- readIORef dynamicEI
(olsInit dei) a1'1 a2') >>
peek a2'>>= \a2'' ->
return (a2'')
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 ()
objectLibSystemShutdown :: (Ptr ()) -> IO ()
objectLibSystemShutdown a1 =
let {a1' = id a1} in
(do
dei <- readIORef dynamicEI
(olsShutdown dei) a1') >>
return ()
callbackSystemCreate :: IO ((Ptr ()))
callbackSystemCreate =
alloca $ \a1' ->
(do
dei <- readIORef dynamicEI
(cbsInit dei) a1') >>
peek a1'>>= \a1'' ->
return (a1'')
callbackSystemRegisterReceiver :: (Ptr ()) -> (Ptr ()) -> (Word64) -> (FunPtr (Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Int32)) -> 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 ()
callbackSystemShutdown :: (Ptr ()) -> IO ()
callbackSystemShutdown a1 =
let {a1' = id a1} in
(do
dei <- readIORef dynamicEI
(cbsShutdown dei) a1') >>
return ()