module HAppS.State.ComponentSystem where
import HAppS.Data.Serialize
import HAppS.Data.Proxy
import HAppS.State.Types
import Data.Typeable
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Monad.State.Strict
#ifndef __HADDOCK__
data End = End
data h :+: t = h :+: t
infixr 6 :+:
#endif
class (Serialize ev, Serialize res) => UpdateEvent ev res | ev -> res
class (Serialize ev, Serialize res) => QueryEvent ev res | ev -> res
#ifndef __HADDOCK__
data Method st where
Update :: (UpdateEvent ev res) => (ev -> Update st res) -> Method st
Query :: (QueryEvent ev res) => (ev -> Query st res) -> Method st
#endif
instance Show (Method st) where
show method = "Method: " ++ methodType method
methodType m = case m of
Update fn -> let ev :: (ev -> Update st res) -> ev
ev _ = undefined
in show (typeOf (ev fn))
Query fn -> let ev :: (ev -> Query st res) -> ev
ev _ = undefined
in show (typeOf (ev fn))
class Methods a where
methods :: Proxy a -> [Method a]
#ifndef __HADDOCK__
data MethodMap where
MethodMap :: (Component st) => Map String (Method st) -> MethodMap
#endif
instance Show MethodMap where
show (MethodMap m) = show m
type ComponentTree = Map String MethodMap
#ifndef __HADDOCK__
class (SubHandlers (Dependencies a),Serialize a) => Component a where
type Dependencies a
initialValue :: a
onLoad :: Proxy a -> IO ()
onLoad _ = return ()
#endif
class SubHandlers a where
subHandlers :: a -> Collect ()
#ifndef __HADDOCK__
instance SubHandlers End where
subHandlers ~End = return ()
instance (Methods a, Component a, SubHandlers b) => SubHandlers (a :+: b) where
subHandlers ~(a :+: b) = do collectHandlers' (proxy a)
subHandlers b
#endif
data Collection = Collection ComponentTree [IO ()]
addItem key item ioAction
= do Collection tree ioActions <- get
case Map.member key tree of
False -> put $ Collection (Map.insert key item tree) (ioAction:ioActions)
True -> dup key
type Collect = State Collection
collectHandlers :: (Methods a, Component a) => Proxy a -> (ComponentTree, [IO ()])
collectHandlers proxy
= case execState (collectHandlers' proxy) (Collection Map.empty []) of
Collection tree ioActions -> (tree, ioActions)
collectHandlers' :: (Methods a, Component a) => Proxy a -> Collect ()
collectHandlers' proxy
= let key = show (typeOf (unProxy proxy))
item = MethodMap $ Map.fromList [ (methodType m, m) | m <- methods proxy ]
in do addItem key item (onLoad proxy)
subHandlers (sub proxy)
where sub :: Component a => Proxy a -> Dependencies a
sub _ = undefined
dup key = error $ "Duplicate component: " ++ key