5821a0b · distributed-process

git.iko.soy/distributed-process

on master help sign in

Improve resolveClosure

5821a0bEdsko de Vries14 years ago

distributed-process/src/Control/Distributed/Process.hs+5−7

compare with master

unifiedsplit

@@ -61,7 +61,6 @@ module Control.Distributed.Process

61 ) where

63import Prelude hiding (catch)

64−import Data.Maybe (fromJust)

65import Data.Binary (decode, encode)

64import Data.Binary (decode, encode)

66import Data.Typeable (Typeable, typeOf)

65import Data.Typeable (Typeable, typeOf)

67import Control.Monad.Reader (ask)

66import Control.Monad.Reader (ask)

@@ -370,13 +369,12 @@ unmonitor = sendCtrlMsg Nothing . Unmonitor

370unClosure :: forall a. Typeable a => Closure a -> Process a

369unClosure :: forall a. Typeable a => Closure a -> Process a

371unClosure (Closure (Static label) env) = do

370unClosure (Closure (Static label) env) = do

372 rtable <- remoteTable <$> lift getLocalNode

371 rtable <- remoteTable <$> lift getLocalNode

373− let dyn = fromJust (resolveClosure rtable label)

372+ let Just dyn = resolveClosure rtable label env

374− dec = fromDyn dyn (throw (typeError dyn))

373+ return $ fromDyn dyn (throw (typeError dyn))

375− return (dec env)

376 where

374 where

377− typeError proc = userError $ "lookupStatic type error: "

375+ typeError dyn = userError $ "lookupStatic type error: "

378− ++ "cannot match " ++ show (dynTypeRep proc)

376+ ++ "cannot match " ++ show (dynTypeRep dyn)

379− ++ "against " ++ show (typeOf (undefined :: a))

377+ ++ " against " ++ show (typeOf (undefined :: a))

380

378

381--------------------------------------------------------------------------------

379--------------------------------------------------------------------------------

382-- Auxiliary API --

380-- Auxiliary API --

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+13−20

@@ -100,10 +100,10 @@ import Control.Distributed.Process.Internal.CQueue (CQueue)

100import Control.Distributed.Process.Internal.Dynamic

101 ( Dynamic

102 , toDyn

103− , fromDynamic

104 , dynTypeRep

103 , dynTypeRep

105 , dynApp

104 , dynApp

106 , dynBind

105 , dynBind

106+ , dynApply

107 )

108

109--------------------------------------------------------------------------------

@@ -251,26 +251,19 @@ registerLabel label dyn = remoteTableLabel label ^= Just dyn

251registerSender :: TypeRep -> Dynamic -> RemoteTable -> RemoteTable

252registerSender typ dyn = remoteTableSender typ ^= Just dyn

253

254−resolveClosure :: RemoteTable -> String -> Maybe Dynamic

254+resolveClosure :: RemoteTable -> String -> ByteString -> Maybe Dynamic

255−resolveClosure rtable "$call" = Just (toDyn aux)

255+resolveClosure rtable "$call" env = do

256+ proc <- resolveClosure rtable label env'

257+ sender <- rtable ^. remoteTableSender (dynTypeRep proc)

258+ proc `bind` (sender `dynApp` toDyn pid)

256 where

259 where

257− -- TODO: error handling

258− aux :: ByteString -> Process ()

259− aux env = do

260− let (label, env', pid) = decode env :: (String, ByteString, ProcessId)

260+ (label, env', pid) = decode env :: (String, ByteString, ProcessId)

261− Just proc = resolveClosure rtable label

262− proc' = dynApp proc (toDyn env')

263− Just enc = rtable ^. remoteTableSender (dynTypeRep proc')

264− enc' = dynApp enc (toDyn pid)

265− Just bound = dynBind tyConProcess bindProcess proc' enc'

261+ bind = dynBind tyConProcess bindProcess

266− Just proc'' = fromDynamic bound

267− proc''

268−resolveClosure rtable "$bind" = Just (toDyn aux)

262+resolveClosure rtable "$bind" env =

269− where

270− -- TODO: error handling

271− aux :: ByteString -> Process ()

272− aux _ = liftIO $ putStrLn "bind not yet supported"

263+ return $ toDyn ((liftIO $ putStrLn "bind not yet supported") :: Process ())

264+resolveClosure rtable label env = do

273−resolveClosure rtable label = rtable ^. remoteTableLabel label

265+ val <- rtable ^. remoteTableLabel label

266+ dynApply val (toDyn env)

274

267

275tyConProcess :: TyCon

268tyConProcess :: TyCon

276tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))

269tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))

distributed-process/src/Control/Distributed/Process/Node.hs+2−4

@@ -493,11 +493,9 @@ isLocal nid pid = processNodeId pid == localNodeId nid

493unClosure :: Typeable a => Closure a -> NC (Maybe a)

494unClosure (Closure (Static label) env) = do

495 rtable <- remoteTable <$> lift getLocalNode

496− case resolveClosure rtable label of

496+ case resolveClosure rtable label env of

497 Nothing -> return Nothing

498− Just dyn -> case fromDynamic dyn of

498+ Just dyn -> return (fromDynamic dyn)

499− Nothing -> return Nothing

500− Just dec -> return (Just $ dec env)

501

499

502--------------------------------------------------------------------------------

500--------------------------------------------------------------------------------

503-- Messages to local processes --

501-- Messages to local processes --