--
--  Fresco Framework for Multi-Language Programming
--  Copyright 2015 - 2017 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.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

-- helper functions

-- different callback functions and dynamic wrapper generation

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)
--      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 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

-- Object Lib System Interface

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
   
-- Callback System Interface

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
{-# NOINLINE dynamicEI #-}
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
{-# NOINLINE dynamicEI #-}
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 ()