Re: [Haskell-cafe] Re: ambiguous partially defined type problem

15 Sep 2006

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