module Data.State.Acid.Core
( Core
, Method(..)
, MethodContainer(..)
, Tagged
, mkCore
, closeCore
, modifyCoreState
, modifyCoreState_
, withCoreState
, lookupHotMethod
, lookupColdMethod
, runHotMethod
, runColdMethod
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.State (State, runState )
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8
import Data.Binary
import Data.Typeable
import Unsafe.Coerce (unsafeCoerce)
class ( Typeable ev, Binary ev
, Typeable (MethodResult ev), Binary (MethodResult ev)) =>
Method ev where
type MethodResult ev
methodTag :: ev -> Tag
methodTag ev = Lazy.Char8.pack (show (typeOf ev))
data Core st
= Core { coreState :: MVar st
, coreMethods :: MethodMap st
}
mkCore :: [MethodContainer st]
-> st
-> IO (Core st)
mkCore methods initialValue
= do mvar <- newMVar initialValue
return Core{ coreState = mvar
, coreMethods = mkMethodMap methods }
closeCore :: Core st -> IO ()
closeCore core
= do swapMVar (coreState core) errorMsg
return ()
where errorMsg = error "Access failure: Core closed."
modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a
modifyCoreState core action
= modifyMVar (coreState core) $ \st -> do (!st, a) <- action st
return (st, a)
modifyCoreState_ :: Core st -> (st -> IO st) -> IO ()
modifyCoreState_ core action
= modifyMVar_ (coreState core) $ \st -> do !st' <- action st
return st'
withCoreState :: Core st -> (st -> IO a) -> IO a
withCoreState core action
= withMVar (coreState core) action
runColdMethod :: Core st -> Tagged Lazy.ByteString -> IO Lazy.ByteString
runColdMethod core taggedMethod
= modifyCoreState core $ \st ->
do let (a, st') = runState (lookupColdMethod core taggedMethod) st
return ( st', a)
lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> (State st Lazy.ByteString)
lookupColdMethod core (methodTag, methodContent)
= case Map.lookup methodTag (coreMethods core) of
Nothing -> error $ "Method tag doesn't exist: " ++ show methodTag
Just (Method method)
-> liftM encode (method (decode methodContent))
runHotMethod :: Method method => Core st -> method -> IO (MethodResult method)
runHotMethod core method
= modifyCoreState core $ \st ->
do let (a, st') = runState (lookupHotMethod core method) st
return ( st', a)
lookupHotMethod :: Method method => Core st -> method -> State st (MethodResult method)
lookupHotMethod core method
= case Map.lookup (methodTag method) (coreMethods core) of
Nothing -> error $ "Method type doesn't exist: " ++ show (typeOf method)
Just (Method methodHandler)
->
unsafeCoerce methodHandler method
type Tag = Lazy.ByteString
type Tagged a = (Tag, a)
data MethodContainer st where
Method :: Method method => (method -> State st (MethodResult method)) -> MethodContainer st
type MethodMap st = Map.Map Tag (MethodContainer st)
mkMethodMap :: [MethodContainer st] -> MethodMap st
mkMethodMap methods
= Map.fromList [ (methodType method, method) | method <- methods ]
where
methodType :: MethodContainer st -> Tag
methodType m = case m of
Method fn -> let ev :: (ev -> State st res) -> ev
ev _ = undefined
in methodTag (ev fn)