Dear Brian,
Maarten wrote:
Brian Hulley wrote:
Alternatively, you could wrap the custom part within the node as in:
data Node = forall cust. ICustom cust = Node cust Common
getCommon :: Node - Common
getCommon (Node cust com) = com
Thanks. This really helped. The main thing (I think) that you put the
custom part behind an interface. After this I separated the custom and
common part of two 'piggy bagged' state transformers, so one can access
the functionality separately. The state transformers made into active
object by putting them behind a channel in a separate thread and one can
invoke actions by writing to the channel. The common functionality
provides the connections between the active objects. In this way I would
like to create some sort of 'agent' structure, that receive message and
process them in their own thread. So far this works quite neat. Wonder
if this is they way to go though...
Only update (see code below) is a bit ugly (I have no idea why I need
fixCastUpdate) and Node itself is probably not necessary, so one level
of indirection could be removed. Rest is quite straight forward.
Thanks again.
Maarten
... (imports)
data Node = forall cust. (ICustom cust) = Node cust
deriving (Typeable)
instance Show Node where-- just for debugging
show (Node a) = Node ( ++ show a ++ )
class (Show a, Typeable a) = ICustom a where
getVal :: forall b cust. (Typeable b, ICustom cust) = a - (cust -
b) - Maybe b
getVal a f = case cast a of
Nothing - Nothing
Just cust - Just (f cust)
--update :: oif - (forall a. (ObjectIFace a) = a - a) - IO oif
update :: a - (forall b. (ICustom b) = b - b) - a
update a f = f a
instance ICustom Node where
getVal (Node n) f = getVal n f
update (Node n) f = Node (update n f)
type NodeState a = StateT Node (StateT Common IO) a
type Connection = Chan (NodeState ())
type Connections = [Connection]
instance Show Connection where
show o = Chan (StateT Node (StateT Common IO) ())
-- common part
data Common = Common { uid::Integer, connections::Connections }
deriving (Show,Typeable)
-- custom data
data Custom = Custom { val::Integer }
deriving (Show,Typeable)
instance ICustom Custom where
data Custom2 = Custom2 { val2::Integer }
deriving (Show,Typeable)
instance ICustom Custom2 where
-- some function to use common functionality
uidM :: NodeState Integer
uidM = lift $ gets uid
addNodeM :: Connection - NodeState ()
addNodeM n = lift $ modify (\s - addNode s n)
where
addNode (Common i ns) nn = (Common i (nn:ns))
getNodeM :: Integer - NodeState Connection
getNodeM i = do
s - lift $ get
return (getNode s i)
where
getNode (Common _ ns) i = (ns!!(fromInteger i))
getValM f = do
s - get
return (getVal s f)
updateM :: forall a b. (ICustom a, ICustom b) = (a - b) - NodeState ()
updateM f = do
s - get
let s' = update s (fixCastUpdate f)
put s'
fixCastUpdate f st =
case (cast st) of
Nothing - st
Just es - case cast (f es) of
Nothing - st
Just g - g
getStateM = get
-- function to create active node functionality
action [] = return ()
action (e:es) = do
e
s - get-- just for debugging
lift $ lift $ putStrLn $ show s
action es
newBaseState = do
uid - newUnique
return (Common ((toInteger .hashUnique) uid) [])
initAction list state = do
bs - newBaseState
execStateT (execStateT (action list) state) bs
return ()
send chan action = writeChan chan action
sync chan f = do
mv - newEmptyMVar
send chan (f' mv)
a - takeMVar mv
return a
where
f' mv = do
a - f
lift $ lift $ putMVar mv a
newActiveObject action state = do
chan - newChan
cs - getChanContents chan
forkIO (action cs state)
return chan
-- example
main = do
let n1 = Node (Custom 5)
let n2 = Node (Custom2 6)
let n3 = Node (Custom2 7)
chan - newActiveObject initAction n1
chan2 - newActiveObject initAction n3
let l = [chan, chan2]
mapM_ (\ch - send ch (addNodeM chan)) l
mapM_ (\ch - send ch (addNodeM chan2)) l
r - mapM (\ch - sync ch (getNodeM 0)) l
putStrLn $ r: ++ show r
r2 - mapM (\ch - sync ch (uidM)) l
putStrLn $ r2: ++ show r2
r3 - mapM (\ch - sync ch (getValM val)) l
putStrLn $ r3: ++ show r3
mapM_ (\ch - send ch (updateM (\s - s { val2 = 100 }))) l
r5 - mapM (\ch - sync ch (getStateM)) l
putStrLn $ r5: ++ show r5
getChar
return ()
___
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
