fresco-binding (empty) → 0.1.0
raw patch · 7 files changed
+623/−0 lines, 7 filesdep +Win32dep +basedep +bytestringsetup-changed
Dependencies added: Win32, base, bytestring, cereal, containers, messagepack, text, unix
Files
- Fresco.hs +26/−0
- Fresco/Component.hs +66/−0
- Fresco/Entity.hs +173/−0
- Fresco/System.hs +289/−0
- LICENSE +12/−0
- Setup.hs +13/−0
- fresco-binding.cabal +44/−0
+ Fresco.hs view
@@ -0,0 +1,26 @@+--+-- 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.hs+--+ +-- | Fresco Binding for Haskell+module Fresco++(+ module Fresco.Component,+ module Fresco.System,+ module Fresco.Entity+)++where++import Fresco.Component+import Fresco.System+import Fresco.Entity+
+ Fresco/Component.hs view
@@ -0,0 +1,66 @@+--+-- 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/Component.hs+--+ +{-# LANGUAGE TypeSynonymInstances #-}++-- | Components of the Entity Component System of Fresco binding+module Fresco.Component+(+ ComponentType (..),+ Component,+ ComponentClass (..)+)+where++import Data.Word+import Data.MessagePack+import Data.ByteString+import Data.Text+import Data.Text.Encoding++-- | Components in Entities are indexed by ComponentType+data ComponentType a = ComponentType Word64 deriving (Eq, Show, Ord)++-- | Components are stored as ByteString+type Component = ByteString++-- | ComponentClass is the typeclass of data types, which can be components+class ComponentClass a where+ toObj :: a -> Object+ fromObj :: Object -> a++instance ComponentClass () where+ toObj () = ObjectNil+ fromObj ObjectNil = ()++instance ComponentClass Text where+ toObj text = ObjectString (encodeUtf8 text)+ fromObj (ObjectString bs) = decodeUtf8 bs ++instance ComponentClass (ComponentType a) where+ toObj (ComponentType i) = ObjectInt (fromIntegral i)+ fromObj (ObjectInt i) = ComponentType (fromIntegral i)+ +instance ComponentClass Bool where+ toObj b = ObjectBool b+ fromObj (ObjectBool b) = b+ +instance ComponentClass Int where+ toObj i = ObjectInt (fromIntegral i)+ fromObj (ObjectInt i) = fromIntegral i+ +instance ComponentClass a => ComponentClass (Maybe a) where+ toObj Nothing = ObjectArray [ObjectInt 0]+ toObj (Just v) = ObjectArray [ObjectInt 1, toObj v]+ fromObj (ObjectArray [ObjectInt 0]) = Nothing+ fromObj (ObjectArray [ObjectInt 1, v_o]) = Just (fromObj v_o)++
+ Fresco/Entity.hs view
@@ -0,0 +1,173 @@+--+-- 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/Entity.hs+--++{-# Language ExistentialQuantification, FlexibleInstances #-}++-- | Entity of the Entity ComponentType System for Fresco Haskell Binding+module Fresco.Entity (++-- * EntityData Type+-- Entities are a kind of simplified extensible record system. They are basically a Map from ComponentType (64 bit id) to a data item with +-- ComponentClass Typeclass. Basic entities are non-mutable but their exists the entity reference.++-- EntityData,+ (#:),+-- (#!),+-- (#),++-- * Entity Type+-- The ERef type, which puts an EntityData into+-- an IORef and serves as mutable data structure.+-- In HGamer3D those ERefs are also used as thread-safe communication vehicle towards the C/C++ implementation of multimedia functionality.++ Entity (..),+ newE,+ -- readE,+ readC,+ updateC,+ setC,+ -- _setC',++ CallbackSystem (..),+ createCBS,+ stepCBS,+ registerReceiverCBS,++)+where++import Data.Maybe+import Data.ByteString+import qualified Data.Map as M+import Data.IORef++import Control.Concurrent+import Control.Applicative+import Foreign+import Foreign.C++import Data.MessagePack+import Data.Serialize++import Fresco.System+import Fresco.Component+++-- | EntityData, a simple non-mutable record type, implemented as Map+type EntityData = M.Map Word64 Component++-- | pair builder for nice construction syntax, allows [ ct #: val, ...] syntax+(#:) :: ComponentClass a => ComponentType a -> a -> (Word64, Component)+(ComponentType c) #: val = (c, toMsg val)++-- | Builder for entities, allows newE = entity [ct #: val, ...] syntax+entityData :: [(Word64, Component)] -> EntityData+entityData clist = M.fromList clist++-- | does the entity have the ComponentType+(#?) :: EntityData -> ComponentType a -> Bool+e #? (ComponentType c) = Prelude.elem c $ M.keys e++-- | get the ComponentType, throws exception, if ComponentType not present+(#!) :: ComponentClass a => EntityData -> ComponentType a -> a+e #! (ComponentType c) = fromJust $ M.lookup c e >>= fromMsg++-- | get the ComponentType as an maybe, in case wrong type+(#) :: ComponentClass a => EntityData -> ComponentType a -> Maybe a+e # (ComponentType c) = M.lookup c e >>= fromMsg++-- | modification function, throws exception, if ComponentType not present+updateDataC :: ComponentClass a => EntityData -> ComponentType a -> (a -> a) -> EntityData+updateDataC e c'@(ComponentType c) f = M.insert c ((toMsg . f) (e #! c')) e++-- | modification function, sets entity ComponentType, needed for events+setDataC :: ComponentClass a => EntityData -> ComponentType a -> a -> EntityData+setDataC e (ComponentType c) val = M.insert c (toMsg val) e+++data CallbackSystem = CallbackSystem (Ptr ())++createCBS :: IO CallbackSystem+createCBS = do+ cbs <- callbackSystemCreate+ return $ CallbackSystem cbs++stepCBS :: CallbackSystem -> IO ()+stepCBS (CallbackSystem cbs) = callbackSystemStep cbs+++registerReceiverCBS :: ComponentClass a => CallbackSystem -> Entity -> ComponentType a -> (a -> IO ()) -> IO ()+registerReceiverCBS (CallbackSystem cbs) (Entity ep) (ComponentType ct) f = do+ -- MsgFunction: Ptr () -> CULong -> Ptr CChar -> CInt -> IO CInt+ let f' = \_ _ cdata len -> do+ bs <- packCStringLen (cdata, fromIntegral len)+ let c = fromJust(fromMsg bs)+ f c+ return 0+ mf <- mkMsgFunPtr f'+ callbackSystemRegisterReceiver cbs ep ct mf+ return ()++-- References to Entities++-- besides Entity, we need atomic references to entities, we call them ERef+-- ERefs also have listeners for updates++-- Listener Map, for each k, manages a map of writers, writers geting the old and the new value after a change++-- type Listeners = IORef (M.Map Word64 [EntityData -> EntityData -> IO ()])+type Listeners = ()++-- | ERef, composable objects, referenced Entities with listeners+data Entity = Entity (Ptr ()) deriving (Eq)++msgFromE :: EntityData -> Component+msgFromE ed = let + pairs = (M.toList ed) -- [(Word64, Component)]+ bs = Prelude.concatMap (\(a, b) -> [encode (ObjectUInt (fromIntegral a)), b]) pairs+ in Data.ByteString.concat bs++msgFromC :: ComponentClass a => ComponentType a -> EntityData -> Component+msgFromC (ComponentType u) e = let+ d = fromJust $ M.lookup u e+ in Data.ByteString.concat [encode (ObjectUInt (fromIntegral u)), d]++-- | creates an Entity+newE :: [(Word64, Component)] -> IO Entity+newE inlist = do+ let e = entityData inlist+ ep <- entityCreate (msgFromE e)+ return $ Entity ep++-- | reads one ComponentType, throws exception, if ComponentType not present, or wrong type+readC :: ComponentClass a => Entity -> ComponentType a -> IO a+readC (Entity ep) (ComponentType ct) = do+ edat <- entityGetData ep ct+ bs <- entityDataRead edat+ entityDataRelease edat+ return (fromJust (fromMsg bs))++-- | updates one ComponentType+updateC :: ComponentClass a => Entity -> ComponentType a -> (a -> a) -> IO ()+updateC er@(Entity ep) c f = do+ val <- readC er c+ let val' = f val+ setC er c val'+ return ()++-- | sets one ComponentType+setC :: ComponentClass a => Entity -> ComponentType a -> a -> IO ()+setC er@(Entity ep) (ComponentType ct) val = do+ let d = Data.ByteString.concat [encode (ObjectUInt (fromIntegral ct)), toMsg val]+ entitySet d ep+ return ()++
+ Fresco/System.hs view
@@ -0,0 +1,289 @@+--+-- 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 qualified Data.ByteString.Lazy as BL+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 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 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 {+ efCreate :: EntityCreateFunction,+ efSet :: EntitySetFunction,+ cbsfCreate :: CallbackSystemCreateFunction,+ cbsfRegisterReceiver :: CallbackSystemRegisterReceiverFunction,+ cbsfStep :: CallbackSystemStepFunction,+ edGet :: EntityGetDataFunction,+ edRead :: EntityDataReadFunction,+ edRelease :: EntityDataReleaseFunction+ }++#ifdef UseWinDLLLoading+dynamicEI :: IORef EntityInterface+{-# NOINLINE dynamicEI #-}+dynamicEI = unsafePerformIO (do+ libname <- getEnv "INTONACO"+ dll <- loadLibrary libname++ efc <- getProcAddress dll "entity_create"+ let efc' = mkEntityCreateFunction $ castPtrToFunPtr efc++ efs <- getProcAddress dll "entity_set" + let efs' = mkEntitySetFunction $ castPtrToFunPtr efs++ 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++ edg <- getProcAddress dll "entity_get_data"+ let edg' = mkEntityGetDataFunction $ castPtrToFunPtr edg++ edr <- getProcAddress dll "entity_data_read"+ let edr' = mkEntityDataReadFunction $ castPtrToFunPtr edr++ edd <- getProcAddress dll "entity_data_release"+ let edd' = mkEntityDataReleaseFunction $ castPtrToFunPtr edd++ ref <- newIORef $ EntityInterface efc' efs' cbc' cbr' cbs' edg' edr' edd'+ return ref+ )++ ++#else+dynamicEI :: IORef EntityInterface+{-# NOINLINE dynamicEI #-}+dynamicEI = unsafePerformIO ( + do+ libname <- getEnv "INTONACO"+ dll <- dlopen libname [RTLD_NOW]++ efc <- dlsym dll "entity_create"+ let efc' = mkEntityCreateFunction efc++ efs <- dlsym dll "entity_set" + let efs' = mkEntitySetFunction efs++ 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++ edg <- dlsym dll "entity_get_data"+ let edg' = mkEntityGetDataFunction edg++ edr <- dlsym dll "entity_data_read"+ let edr' = mkEntityDataReadFunction edr++ edd <- dlsym dll "entity_data_release"+ let edd' = mkEntityDataReleaseFunction edd++ ref <- newIORef $ EntityInterface efc' efs' cbc' cbr' cbs' edg' edr' edd'+ 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+ (efCreate dei) a1'1 a1'2 a2') >>+ peek a2' >>= \a2'' -> + return (a2'')+++entitySet :: (ByteString) -> (Ptr ()) -> IO ()+entitySet a1 a2 =+ unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) -> + let {a2' = id a2} in + (do+ dei <- readIORef dynamicEI+ (efSet 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 ()++callbackSystemCreate :: IO ((Ptr ()))+callbackSystemCreate =+ alloca $ \a1' -> + (do+ dei <- readIORef dynamicEI+ (cbsfCreate 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+ (cbsfRegisterReceiver dei) a1' a2' a3' a4') >>+ return ()++callbackSystemStep :: (Ptr ()) -> IO ()+callbackSystemStep a1 =+ let {a1' = id a1} in + (do+ dei <- readIORef dynamicEI+ (cbsfStep dei) a1') >>+ return ()++
+ LICENSE view
@@ -0,0 +1,12 @@+LICENSE+-------++(c) 2015-2016 Peter Althainz++Fresco is licensed under the Apache License, Version 2.0 (the "License"); you may not use this software except in compliance with the License. You may obtain a copy of the License at++http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.++You can obtain the latest version of the source code under http://www.github.com/urs-of-the-backwoods/Fresco.
+ Setup.hs view
@@ -0,0 +1,13 @@+--+-- 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/Setup.hs+--++import Distribution.Simple+main = defaultMain
+ fresco-binding.cabal view
@@ -0,0 +1,44 @@+--+-- 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-binding.cabal+--++Name: fresco-binding+Version: 0.1.0+Synopsis: Fresco binding for Haskell+Description: + Fresco is a framwork for multi-language programming. This is the Haskell binding.+License: OtherLicense+License-file: LICENSE+Author: Peter Althainz+Maintainer: althainz@gmail.com+Build-Type: Simple+Cabal-Version: >=1.4+Category: Development, FFI, Interfaces+Extra-source-files: Setup.hs + +Library+ Build-Depends: base >= 3 && < 5, containers, bytestring, text, messagepack >=0.5 && <0.6, cereal >=0.5 && < 0.6++ Exposed-modules: Fresco.Component, Fresco.System, Fresco.Entity, Fresco++ Other-modules: ++ c-sources: + + ghc-options: + cc-options: -Wno-attributes + hs-source-dirs: .+ Include-dirs: .+ + if os(win32)+ cpp-options: -DUseWinDLLLoading+ build-depends: Win32+ else+ build-depends: unix