Browse files

Remove trivial build warnings

Redundant imports, unused variables etc.
  • Loading branch information...
1 parent 9ae60f8 commit 290adeab93990f8ea1336730774cf1f2dceaacd7 @kfish kfish committed with Sep 23, 2011
Showing with 122 additions and 111 deletions.
  1. +1 −1 Remote.hs
  2. +9 −4 Remote/Call.hs
  3. +1 −1 Remote/Channel.hs
  4. +1 −1 Remote/Closure.hs
  5. +6 −3 Remote/Encoding.hs
  6. +6 −4 Remote/Init.hs
  7. +7 −5 Remote/Peer.hs
  8. +66 −65 Remote/Process.hs
  9. +25 −27 Remote/Task.hs
View
2 Remote.hs
@@ -24,7 +24,7 @@ module Remote ( -- * The process layer
expect, receive, receiveWait, receiveTimeout,
match, matchIf, matchUnknown, matchUnknownThrow, matchProcessDown,
- logS, say, LogSphere(..), LogTarget(..), LogFilter(..), LogConfig(..), LogLevel(..),
+ logS, say, LogSphere, LogTarget(..), LogFilter(..), LogConfig(..), LogLevel(..),
setLogConfig, setNodeLogConfig, getLogConfig, defaultLogConfig, getCfgArgs,
UnknownMessageException(..), ServiceException(..),
View
13 Remote/Call.hs
@@ -14,7 +14,7 @@ import Control.Monad.Trans (liftIO)
import Control.Monad (liftM)
import Remote.Closure (Closure(..))
import Remote.Process (ProcessM)
-import Remote.Reg (Lookup,putReg,RemoteCallMetaData)
+import Remote.Reg (putReg,RemoteCallMetaData)
import Remote.Task (remoteCallRectify,TaskM)
-- TODO this module is the result of months of tiny thoughtless changes and desperately needs a clean-up
@@ -124,7 +124,7 @@ remotable names =
let outnames = concat $ map snd declGen
regs <- sequence $ makeReg loc outnames
return $ decs ++ regs
- where makeReg loc names =
+ where makeReg loc names' =
let
mkentry = [e| putReg |]
regtype = [t| RemoteCallMetaData |]
@@ -135,7 +135,7 @@ remotable names =
applies [] = varE param
applies [h] = appE (app2E mkentry (varE h) (litE $ stringL (reasonableNameModule h++nameBase h))) (varE param)
applies (h:t) = appE (app2E mkentry (varE h) (litE $ stringL (reasonableNameModule h++nameBase h))) (applies t)
- bodyq = normalB (applies names)
+ bodyq = normalB (applies names')
sig = sigD registryName regtype
dec = funD registryName [clause [varP param] bodyq []]
in [sig,dec]
@@ -170,6 +170,7 @@ remotable names =
isarrow _ = False
applyargs f [] = f
applyargs f (l:r) = applyargs (appE f l) r
+ funtype :: Integer
funtype = case last arglist of
(AppT (process) _) | process == ttprocessm -> 0
| process == ttio -> 1
@@ -207,7 +208,7 @@ remotable names =
[]]
implPls = if isarrowful then [implPldec,implPldef] else []
implPldec = case last arglist of
- (AppT ( process) v) | process == tttaskm ->
+ (AppT ( process) _v) | process == tttaskm ->
sigD implPlName (return $ putParams $ [payload,(AppT process payload)])
_ -> sigD implPlName (return $ putParams implarglist)
implPldef = case last arglist of
@@ -222,16 +223,20 @@ remotable names =
in ([closuredec,closuredef,impldec,impldef]++if not isarrowful then [implPldec,implPldef] else [],
[aname,implName]++if not isarrowful then [implPlName] else [])
+getType :: Name -> Q [(Name, Type)]
getType name =
do info <- reify name
case info of
VarI iname itype _ _ -> return [(iname,itype)]
_ -> return []
+putParams :: [Type] -> Type
putParams (afst:lst:[]) = AppT (AppT ArrowT afst) lst
putParams (afst:[]) = afst
putParams (afst:lst) = AppT (AppT ArrowT afst) (putParams lst)
putParams [] = error "Unexpected parameter type in remotable processing"
+
+getParams :: Type -> [Type]
getParams typ = case typ of
AppT (AppT ArrowT b) c -> b : getParams c
b -> [b]
View
2 Remote/Channel.hs
@@ -17,7 +17,7 @@ module Remote.Channel (
terminateChannel) where
import Remote.Process (ProcessM,send,getMessageType,getMessagePayload,setDaemonic,getProcess,prNodeRef,getNewMessageLocal,localFromPid,isPidLocal,TransmitException(..),TransmitStatus(..),spawnLocalAnd,ProcessId,Node,UnknownMessageException(..))
-import Remote.Encoding (getPayloadType,serialDecodePure,Serializable)
+import Remote.Encoding (Serializable)
import Data.List (foldl')
import Data.Binary (Binary,get,put)
View
2 Remote/Closure.hs
@@ -27,7 +27,7 @@ data Closure a = Closure String Payload
instance Show (Closure a) where
show a = case a of
- (Closure fn pl) -> show fn
+ (Closure fn _pl) -> show fn
instance Binary (Closure a) where
get = do s <- get
View
9 Remote/Encoding.hs
@@ -24,6 +24,9 @@ module Remote.Encoding (
genericPut,
genericGet) where
+import Prelude hiding (id)
+import qualified Prelude as Prelude
+
import Data.Binary (Binary,encode,decode,Put,Get,put,get,putWord8,getWord8)
import Control.Monad (liftM)
import Data.ByteString.Lazy (ByteString)
@@ -115,7 +118,7 @@ serialDecodePure a = (\id ->
if (decode $! payloadType a) ==
show (typeOf $ id undefined)
then Just (id $! decode pc)
- else Nothing ) id
+ else Nothing ) Prelude.id
serialDecode :: (Serializable a) => Payload -> IO (Maybe a)
@@ -128,7 +131,7 @@ serialDecode a = (\id ->
case res of
Left _ -> return $ Nothing
Right v -> return $ Just $ id v
- else return Nothing ) id
+ else return Nothing ) Prelude.id
-- | Data types that can be used in messaging must
@@ -164,7 +167,7 @@ genericGet = generic `extR` genericString
g' <- genericGet
return $ n' g')
(return)
- (repConstr (dataTypeOf (id undefined)) constr_rep)) id
+ (repConstr (dataTypeOf (id undefined)) constr_rep)) Prelude.id
genericString :: Get String
genericString = do q <- get
return $ decode q
View
10 Remote/Init.hs
@@ -3,14 +3,16 @@
-- line arguments, and commonly-used system processes.
module Remote.Init (remoteInit) where
+import qualified Prelude as Prelude
+import Prelude hiding (lookup)
+
import Remote.Peer (startDiscoveryService)
import Remote.Task (__remoteCallMetaData)
-import Remote.Process (startProcessRegistryService,suppressTransmitException,pbracket,localRegistryRegisterNode,localRegistryHello,localRegistryUnregisterNode,
+import Remote.Process (startProcessRegistryService,suppressTransmitException,localRegistryRegisterNode,localRegistryHello,localRegistryUnregisterNode,
startProcessMonitorService,startNodeMonitorService,startLoggingService,startSpawnerService,ProcessM,readConfig,initNode,startLocalRegistry,
forkAndListenAndDeliver,waitForThreads,roleDispatch,Node,runLocalProcess,performFinalization,startFinalizerService)
import Remote.Reg (registerCalls,RemoteCallMetaData)
-import System.FilePath (FilePath)
import System.Environment (getEnvironment)
import Control.Concurrent (threadDelay)
import Control.Monad.Trans (liftIO)
@@ -30,7 +32,7 @@ startServices =
dispatchServices :: MVar Node -> IO ()
dispatchServices node = do mv <- newEmptyMVar
- runLocalProcess node (startServices >> liftIO (putMVar mv ()))
+ _ <- runLocalProcess node (startServices >> liftIO (putMVar mv ()))
takeMVar mv
-- | This is the usual way create a single node of distributed program.
@@ -65,6 +67,6 @@ remoteInit defaultConfig metadata f =
(roleDispatch node userFunction >> waitForThreads node) `finally` (performFinalization node)
threadDelay 500000 -- TODO make configurable, or something
where getConfigFileName = do env <- getEnvironment
- return $ maybe defaultConfig Just (lookup "RH_CONFIG" env)
+ return $ maybe defaultConfig Just (Prelude.lookup "RH_CONFIG" env)
userFunction s = localRegistryHello >> localRegistryRegisterNode >> f s
View
12 Remote/Peer.hs
@@ -6,10 +6,12 @@
-- which does it automatically.
module Remote.Peer (PeerInfo,startDiscoveryService,getPeers,getPeersStatic,getPeersDynamic,findPeerByRole) where
+import Prelude hiding (all, pi)
+
import Network.Socket (defaultHints,sendTo,recv,sClose,Socket,getAddrInfo,AddrInfoFlag(..),setSocketOption,addrFlags,addrSocketType,addrFamily,SocketType(..),Family(..),addrProtocol,SocketOption(..),AddrInfo,bindSocket,addrAddress,SockAddr(..),socket)
import Network.BSD (getProtocolNumber)
import Control.Concurrent.MVar (takeMVar, newMVar, modifyMVar_)
-import Remote.Process (PeerInfo,pingNode,makeNodeFromHost,spawnLocalAnd,setDaemonic,TransmitStatus(..),TransmitException(..),PayloadDisposition(..),ptimeout,getSelfNode,sendSimple,cfgRole,cfgKnownHosts,cfgPeerDiscoveryPort,match,receiveWait,getSelfPid,getConfig,NodeId(..),PortId,ProcessM,ptry,localRegistryQueryNodes)
+import Remote.Process (PeerInfo,pingNode,makeNodeFromHost,spawnLocalAnd,setDaemonic,TransmitStatus(..),TransmitException(..),PayloadDisposition(..),ptimeout,getSelfNode,sendSimple,cfgRole,cfgKnownHosts,cfgPeerDiscoveryPort,match,receiveWait,getSelfPid,getConfig,NodeId,PortId,ProcessM,ptry,localRegistryQueryNodes)
import Control.Monad.Trans (liftIO)
import Data.Typeable (Typeable)
import Data.Maybe (catMaybes)
@@ -18,7 +20,7 @@ import Control.Exception (try,bracket,ErrorCall(..),throw)
import Data.List (nub)
import Control.Monad (filterM)
import qualified Data.Traversable as Traversable (mapM)
-import qualified Data.Map as Map (keys,Map,unionsWith,insertWith,empty,lookup)
+import qualified Data.Map as Map (unionsWith,insertWith,empty,lookup)
data DiscoveryInfo = DiscoveryInfo
{
@@ -65,7 +67,7 @@ sendBroadcast port str
(sClose)
(\sock -> do
setSocketOption sock Broadcast 1
- res <- sendTo sock str (SockAddrInet (toEnum port) (-1))
+ _res <- sendTo sock str (SockAddrInet (toEnum port) (-1))
return ()
)
@@ -77,7 +79,7 @@ sendBroadcast port str
getPeers :: ProcessM PeerInfo
getPeers = do a <- getPeersStatic
b <- getPeersDynamic 500000
- verifyPeerInfo $ Map.unionsWith (\a b -> nub $ a ++ b) [a,b]
+ verifyPeerInfo $ Map.unionsWith (\x y -> nub $ x ++ y) [a,b]
verifyPeerInfo :: PeerInfo -> ProcessM PeerInfo
verifyPeerInfo pi = Traversable.mapM verify1 pi
@@ -112,7 +114,7 @@ getPeersDynamic t =
case (cfgPeerDiscoveryPort cfg) of
0 -> return Map.empty
port -> do -- TODO should send broacast multiple times in case of packet loss
- liftIO $ try $ sendBroadcast port (show pid) :: ProcessM (Either IOError ())
+ _ <- liftIO $ try $ sendBroadcast port (show pid) :: ProcessM (Either IOError ())
responses <- liftIO $ newMVar []
_ <- ptimeout t (receiveInfo responses)
res <- liftIO $ takeMVar responses
View
131 Remote/Process.hs
@@ -19,7 +19,7 @@ module Remote.Process (
-- * Logging functions
logS,say,
- LogSphere(..),LogLevel(..),LogTarget(..),LogFilter(..),LogConfig(..),
+ LogSphere,LogLevel(..),LogTarget(..),LogFilter(..),LogConfig(..),
setLogConfig,getLogConfig,setNodeLogConfig,setRemoteNodeLogConfig,defaultLogConfig,
-- * Exception handling
@@ -64,35 +64,36 @@ module Remote.Process (
)
where
+import qualified Prelude as Prelude
+import Prelude hiding (catch, id, init, last, lookup, pi)
+
import Control.Concurrent (forkIO,ThreadId,threadDelay)
-import Control.Concurrent.MVar (MVar,newMVar, newEmptyMVar,isEmptyMVar,takeMVar,putMVar,modifyMVar,modifyMVar_,readMVar)
-import Prelude hiding (catch)
+import Control.Concurrent.MVar (MVar,newMVar, newEmptyMVar,takeMVar,putMVar,modifyMVar,modifyMVar_,readMVar)
import Control.Exception (ErrorCall(..),throwTo,bracket,try,Exception,throw,evaluate,finally,SomeException,catch)
import Control.Monad (foldM,when,liftM,forever)
import Control.Monad.Trans (MonadIO,liftIO)
import Data.Binary (Binary,put,get,putWord8,getWord8)
import Data.Char (isSpace,isDigit)
-import Data.List (isSuffixOf,foldl', isPrefixOf,nub)
+import Data.List (isSuffixOf,foldl', isPrefixOf)
import Data.Maybe (catMaybes,isNothing)
import Data.Typeable (Typeable)
import Data.Data (Data)
import Data.Unique (newUnique,hashUnique)
import System.IO (Handle,hClose,hSetBuffering,hGetChar,hPutChar,BufferMode(..),hFlush)
import System.IO.Error (isEOFError,isDoesNotExistError,isUserError)
-import System.FilePath (FilePath)
-import Network.BSD (HostEntry(..),getHostName)
-import Network (HostName,PortID(..),PortNumber,listenOn,accept,sClose,connectTo,Socket)
-import Network.Socket (PortNumber(..),setSocketOption,SocketOption(..),socketPort,aNY_PORT )
+import Network.BSD (getHostName)
+import Network (HostName,PortID(..),listenOn,accept,sClose,connectTo)
+import Network.Socket (setSocketOption,SocketOption(..),socketPort,aNY_PORT )
import qualified Data.Map as Map (Map,keys,fromList,unionWith,elems,singleton,member,update,empty,adjust,alter,insert,delete,lookup,toList,size,insertWith')
import Remote.Reg (getEntryByIdent,Lookup,empty)
-import Remote.Encoding (serialEncode,serialDecode,serialEncodePure,serialDecodePure,dynamicEncodePure,dynamicDecodePure,DynamicPayload,Payload,Serializable,PayloadLength,genericPut,genericGet,hPutPayload,hGetPayload,payloadLength,getPayloadType,getDynamicPayloadType)
+import Remote.Encoding (serialEncode,serialDecode,serialEncodePure,serialDecodePure,dynamicEncodePure,dynamicDecodePure,DynamicPayload,Payload,Serializable,hPutPayload,hGetPayload,getPayloadType,getDynamicPayloadType)
import System.Environment (getArgs)
import qualified System.Timeout (timeout)
import Data.Time (toModifiedJulianDay,Day(..),picosecondsToDiffTime,getCurrentTime,diffUTCTime,UTCTime(..),utcToLocalZonedTime)
import Remote.Closure (Closure (..))
import Control.Concurrent.STM (STM,atomically,retry,orElse)
import Control.Concurrent.STM.TChan (TChan,isEmptyTChan,readTChan,newTChanIO,writeTChan)
-import Control.Concurrent.Chan (Chan,newChan,readChan,writeChan)
+import Control.Concurrent.Chan (newChan,readChan,writeChan)
import Control.Concurrent.STM.TVar (TVar,newTVarIO,readTVar,writeTVar)
import Control.Concurrent.QSem (QSem,newQSem,waitQSem,signalQSem)
import Data.IORef (IORef,newIORef,readIORef,writeIORef)
@@ -372,20 +373,20 @@ getCurrentMessages p = do
let newq = queueInsertMulti q msgs
writeTVar (prState p) ps {prQueue = newq}
return $ queueToList newq
- where cleanChannel c m = do empty <- isEmptyTChan c
- if empty
+ where cleanChannel c m = do isEmpty <- isEmptyTChan c
+ if isEmpty
then return m
else do item <- readTChan c
cleanChannel c (item:m)
matchMessage :: [MatchM q ()] -> Message -> STM (Maybe (ProcessM q))
-matchMessage matchers msg = do (mb,r) <- (foldl orElse (retry) (map executor matchers)) `orElse` (return (theMatchBlock,Nothing))
+matchMessage matchers msg = do (_mb,r) <- (foldl orElse (retry) (map executor matchers)) `orElse` (return (theMatchBlock,Nothing))
return r
where executor x = do
- (ok@(mb,matchfound),_) <- runMatchM x theMatchBlock
+ (ok@(_mb,matchfound),_) <- runMatchM x theMatchBlock
case matchfound of
Nothing -> retry
- n -> return ok
+ _ -> return ok
theMatchBlock = MatchBlock {mbMessage = msg}
matchMessages :: [MatchM q ()] -> [(Message,STM ())] -> STM (Maybe (ProcessM q))
@@ -522,7 +523,7 @@ matchCond f =
matchIf (not . isNothing . f) run
where run a = case f a of
Nothing -> throw $ TransmitException $ QteOther $ "Indecesive predicate in matchCond"
- Just a -> a
+ Just q -> q
matchCoreHeaderless :: (Serializable a) => (a -> Bool) -> (a -> ProcessM q) -> MatchM q ()
matchCoreHeaderless f g = matchCore (\(a,b) -> b==(Nothing::Maybe ()) && f a)
@@ -665,13 +666,13 @@ roleDispatch mnode func = do cfg <- getConfigI mnode
-- is guaranteed before spawnAnd returns. Thus, the prefix code is useful for
-- initializing the new process synchronously.
spawnLocalAnd :: ProcessM () -> ProcessM () -> ProcessM ProcessId
-spawnLocalAnd fun and =
+spawnLocalAnd fun prefix =
do p <- getProcess
v <- liftIO $ newEmptyMVar
pid <- liftIO $ runLocalProcess (prNodeRef p) (myFun v)
liftIO $ takeMVar v
return pid
- where myFun mv = (and `pfinally` liftIO (putMVar mv ())) >> fun
+ where myFun mv = (prefix `pfinally` liftIO (putMVar mv ())) >> fun
-- | A synonym for 'spawnLocal'
forkProcess :: ProcessM () -> ProcessM ProcessId
@@ -682,7 +683,7 @@ forkProcess = spawnLocal
-- result in a munged message queue.
forkProcessWeak :: ProcessM () -> ProcessM ()
forkProcessWeak f = do p <- getProcess
- res <- liftIO $ forkIO (runProcessM f p >> return ())
+ _res <- liftIO $ forkIO (runProcessM f p >> return ())
return ()
-- | Create a new process on the current node. Returns the new process's identifier.
@@ -712,7 +713,7 @@ runLocalProcess node fun =
let pp = adminGetPid nid ServiceProcessMonitor
let msg = GlProcessDown (prPid p) r
try $ sendBasic node pp (msg) (Nothing::Maybe ()) PldAdmin Nothing :: IO (Either SomeException TransmitStatus)--ignore result ok
- notifyProcessUp p = return ()
+ notifyProcessUp _p = return ()
closePool p = do c <- readIORef (prPool p)
mapM hClose (Map.elems c)
exceptionHandler e p = let shown = show e in
@@ -803,11 +804,11 @@ roundtripQueryMulti pld pids dat = -- TODO timeout
return $ catMaybes (Map.elems m)
generalPid :: ProcessId -> ProcessId
-generalPid (ProcessId n p) = ProcessId n (-1)
+generalPid (ProcessId n _p) = ProcessId n (-1)
roundtripQuery :: (Serializable a, Serializable b) => PayloadDisposition -> ProcessId -> a -> ProcessM (Either TransmitStatus b)
roundtripQuery pld pid dat =
- do res <- ptry $ withMonitor apid $ roundtripQueryImpl 0 pld pid dat id []
+ do res <- ptry $ withMonitor apid $ roundtripQueryImpl 0 pld pid dat Prelude.id []
case res of
Left (ServiceException s) -> return $ Left $ QteOther s
Right (Left a) -> return (Left a)
@@ -817,12 +818,12 @@ roundtripQuery pld pid dat =
_ -> pid
roundtripQueryLocal :: (Serializable a, Serializable b) => PayloadDisposition -> ProcessId -> a -> ProcessM (Either TransmitStatus b)
-roundtripQueryLocal pld pid dat = roundtripQueryImpl 0 pld pid dat id []
+roundtripQueryLocal pld pid dat = roundtripQueryImpl 0 pld pid dat Prelude.id []
roundtripQueryUnsafe :: (Serializable a, Serializable b) => PayloadDisposition -> ProcessId -> a -> ProcessM (Either TransmitStatus b)
roundtripQueryUnsafe pld pid dat =
do cfg <- getConfig
- roundtripQueryImpl (cfgRoundtripTimeout cfg) pld pid dat id []
+ roundtripQueryImpl (cfgRoundtripTimeout cfg) pld pid dat Prelude.id []
roundtripQueryImpl :: (Serializable a, Serializable b) => Int -> PayloadDisposition -> ProcessId -> a -> (b -> c) -> [MatchM (Either TransmitStatus c) ()] -> ProcessM (Either TransmitStatus c)
roundtripQueryImpl time pld pid dat converter additional =
@@ -847,7 +848,7 @@ roundtripQueryImplSub :: (Serializable a, Serializable b) => PayloadDisposition
roundtripQueryImplSub pld pid dat act =
do convId <- liftIO $ newConversationId
sender <- getSelfPid
- res <- mysend pid dat (Just RoundtripHeader {msgheaderConversationId = convId,msgheaderSender = sender,msgheaderDestination = pid}) pld
+ res <- mysend pid dat (Just RoundtripHeader {msgheaderConversationId = convId,msgheaderSender = sender,msgheaderDestination = pid})
case res of
QteOK -> return $ Right $ \c -> (matchCore (\(_,h) ->
case h of
@@ -856,12 +857,12 @@ roundtripQueryImplSub pld pid dat act =
return $ vv))
err -> return (Left err)
where
- mysend p d mh pld = sendTry p d mh pld
+ mysend p d mh = sendTry p d mh pld
roundtripResponse :: (Serializable a, Serializable b) => (a -> ProcessM (b,q)) -> MatchM q ()
roundtripResponse f = roundtripResponseAsync myf False
where myf inp verf = do (resp,ret) <- f inp
- verf resp
+ _ <- verf resp
return ret
roundtripResponseAsync :: (Serializable a, Serializable b) => (a -> (b -> ProcessM ()) -> ProcessM q) -> Bool -> MatchM q ()
@@ -916,7 +917,7 @@ sendSimple :: (Serializable a) => ProcessId -> a -> PayloadDisposition -> Proces
sendSimple pid dat pld = sendTry pid dat (Nothing :: Maybe ()) pld
sendTry :: (Serializable a,Serializable b) => ProcessId -> a -> Maybe b -> PayloadDisposition -> ProcessM TransmitStatus
-sendTry pid msg msghdr pld = getProcess >>= (\p ->
+sendTry pid msg msghdr pld = getProcess >>= (\_p ->
let
timeoutFilter a =
do cfg <- getConfig
@@ -966,7 +967,7 @@ sendBasic mnode pid msg msghdr pld pool = do
(if islocal then sendRawLocal else sendRawRemote) mnode pid nid themsg pool
sendRawLocal :: MVar Node -> ProcessId -> NodeId -> Message -> Maybe (IORef (Map.Map NodeId Handle)) -> IO TransmitStatus
-sendRawLocal noderef thepid nodeid msg _
+sendRawLocal noderef thepid _nodeid msg _
| thepid == nullPid = return QteUnknownPid
| otherwise = do cfg <- getConfigI noderef
messageHandler cfg noderef (getMessageDisposition msg) msg (cfgNetworkMagic cfg) (localFromPid thepid)
@@ -983,7 +984,7 @@ sendRawRemote noderef thepid nodeid msg (Just pool) =
QteOK -> cleanup h ppool
_ -> case finded of
Nothing -> cleanup h ppool
- _ -> do (ret2,newh) <- sendRawRemoteImpl noderef thepid nodeid msg Nothing
+ _ -> do (_ret2,newh) <- sendRawRemoteImpl noderef thepid nodeid msg Nothing
cleanup newh ppool
return ret
where
@@ -1050,7 +1051,7 @@ writeMessage _ _ = throw $ ServiceException "writeMessage went down wrong pipe"
-- | Starts a message-receive loop on the given node. You probably don't want to call this function yourself.
forkAndListenAndDeliver :: MVar Node -> Config -> IO ()
forkAndListenAndDeliver node cfg = do coord <- newEmptyMVar
- forkIO $ listenAndDeliver node cfg (coord)
+ _tid <- forkIO $ listenAndDeliver node cfg (coord)
result <- takeMVar coord
maybe (return ()) throw result
@@ -1127,17 +1128,17 @@ listenAndDeliver node cfg coord =
Left n -> logNetworkError n
Right q -> return ()
handleComm h =
- do (magic,adestp,nodeid,msg) <- readMessage h
+ do (magic,adestp,_nodeid,msg) <- readMessage h
res <- messageHandler cfg node (getMessageDisposition msg) msg magic adestp
writeResult h res
case res of
QteOK -> handleComm h
_ -> return ()
sockBody s =
do hchan <- newChan
- forkIO $ forever $ do h <- readChan hchan
- hSetBuffering h (BlockBuffering Nothing)
- forkIO $ (handleCommSafe h `finally` hClose h)
+ _tid <- forkIO $ forever $ do h <- readChan hchan
+ hSetBuffering h (BlockBuffering Nothing)
+ forkIO $ (handleCommSafe h `finally` hClose h)
forever $ do (newh,_,_) <- accept s
writeChan hchan newh
@@ -1257,7 +1258,7 @@ nullPid = ProcessId (NodeId "0.0.0.0" 0) 0
-- | Returns the node ID of the node that the current process is running on.
getSelfNode :: ProcessM NodeId
-getSelfNode = do (ProcessId n p) <- getSelfPid
+getSelfNode = do (ProcessId n _p) <- getSelfPid
return n
getNodeId :: MVar Node -> IO NodeId
@@ -1281,7 +1282,7 @@ localFromPid :: ProcessId -> LocalProcessId
localFromPid (ProcessId _ lid) = lid
hostFromNid :: NodeId -> HostName
-hostFromNid (NodeId hn p) = hn
+hostFromNid (NodeId hn _p) = hn
buildPidFromNodeId :: NodeId -> LocalProcessId -> ProcessId
buildPidFromNodeId n lp = ProcessId n lp
@@ -1306,7 +1307,7 @@ suppressTransmitException a =
do res <- ptry a
case res of
Left (TransmitException _) -> return Nothing
- Right a -> return $ Just a
+ Right r -> return $ Just r
-- | A 'ProcessM'-flavoured variant of 'Control.Exception.try'
ptry :: (Exception e) => ProcessM a -> ProcessM (Either e a)
@@ -1620,7 +1621,7 @@ setRemoteNodeLogConfig :: NodeId -> LogConfig -> ProcessM ()
setRemoteNodeLogConfig nid lc = do res <- sendSimple (adminGetPid nid ServiceLog) (LogUpdateConfig lc) PldAdmin
case res of
QteOK -> return ()
- n -> throw $ TransmitException $ QteLoggingError
+ _n -> throw $ TransmitException $ QteLoggingError
logI :: MVar Node -> ProcessId -> LogSphere -> LogLevel -> String -> IO ()
logI mnode pid sph ll txt = do node <- readMVar mnode
@@ -1661,7 +1662,7 @@ logS sph ll txt = do lc <- txt `seq` getLogConfig
in sendSimple svc msg PldAdmin
case res of
QteOK -> return ()
- n -> throw $ TransmitException $ QteLoggingError
+ _n -> throw $ TransmitException $ QteLoggingError
startLoggingService :: ProcessM ()
startLoggingService = serviceThread ServiceLog logger
@@ -1682,7 +1683,7 @@ startLoggingService = serviceThread ServiceLog logger
LtForward nid -> do self <- getSelfNode
when (self /= nid)
(sendSimple (adminGetPid nid ServiceLog) (forwardify txt) PldAdmin >> return ()) -- ignore error -- what can we do?
- n -> throw $ ConfigException $ "Invalid message forwarded setting"
+ _n -> throw $ ConfigException $ "Invalid message forwarded setting"
----------------------------------------------
@@ -1763,10 +1764,10 @@ startNodeMonitorService = serviceThread ServiceNodeMonitor (service Map.empty)
sendSimple (adminGetPid mynid ServiceProcessMonitor) (GlNodeDown nid) PldAdmin
handlefailure nid = case Map.lookup nid state of
Just c -> if c >= failurelimit
- then do reportfailure nid
+ then do _ <- reportfailure nid
return (Map.delete nid state)
else do mypid <- getSelfPid
- spawnLocalAnd (liftIO (threadDelay retrytimeout) >> listenaction nid mypid) setDaemonic
+ _ <- spawnLocalAnd (liftIO (threadDelay retrytimeout) >> listenaction nid mypid) setDaemonic
return (Map.adjust succ nid state)
Nothing -> return state
addmonitor nid = case Map.member nid state of
@@ -1775,7 +1776,7 @@ startNodeMonitorService = serviceThread ServiceNodeMonitor (service Map.empty)
mypid <- getSelfPid
if mynid==nid
then return state
- else do spawnLocalAnd (listenaction nid mypid) setDaemonic
+ else do _ <- spawnLocalAnd (listenaction nid mypid) setDaemonic
return $ Map.insert nid (0) state
in receiveWait [roundtripResponse matchCommand,
@@ -1869,8 +1870,8 @@ data ProcessRegistryCommand = ProcessRegistryQuery String (Maybe (Closure (Proce
instance Binary ProcessRegistryCommand where
put (ProcessRegistryQuery a b) = putWord8 0 >> put a >> put b
put (ProcessRegistrySet a b) = putWord8 1 >> put a >> put b
- get = do a <- getWord8
- case a of
+ get = do cmd <- getWord8
+ case cmd of
0 -> do a <- get
b <- get
return $ ProcessRegistryQuery a b
@@ -1893,7 +1894,7 @@ startProcessRegistryService = serviceThread ServiceProcessRegistry (service init
initialState = ProcessRegistryState Map.empty Map.empty
service state@(ProcessRegistryState nameToPid pidToName) =
let
- downs (ProcessMonitorException pid why) =
+ downs (ProcessMonitorException pid _why) =
case Map.lookup pid pidToName of
Just name ->
let newPidToName = Map.delete pid pidToName
@@ -1918,11 +1919,11 @@ startProcessRegistryService = serviceThread ServiceProcessRegistry (service init
False -> return (ProcessRegistryError $ "Refuse to register nonlocal process" ++ show pid,state)
(Nothing,_) -> return (ProcessRegistryError $ "The name "++name++" has already been registered",state)
(_,_) -> return (ProcessRegistryError $ "The process "++show pid++" has already been registered",state)
- ProcessRegistryQuery name clo ->
+ ProcessRegistryQuery name mClo ->
case Map.lookup name nameToPid of
Just pid -> return (ProcessRegistryResponse (Just pid),state)
Nothing ->
- case clo of
+ case mClo of
Nothing -> return (ProcessRegistryResponse Nothing,state)
Just clo -> do mynid <- getSelfNode
mypid <- getSelfPid
@@ -2116,7 +2117,7 @@ gdCombineEntry :: (Map.Map (LocalProcessId,MonitorAction) (Int),
Map.Map NodeId ()) -> (Map.Map (LocalProcessId,MonitorAction) (Int),
Map.Map LocalProcessId (Int),
Map.Map NodeId ())
-gdCombineEntry newval@(newmonitors,newmonitees,newnodes) oldval@(oldmonitors,oldmonitees,oldnodes) =
+gdCombineEntry (newmonitors,newmonitees,newnodes) (oldmonitors,oldmonitees,oldnodes) =
let finalnodes = Map.unionWith const newnodes oldnodes
finalmonitors = Map.unionWith (+) newmonitors oldmonitors
finalmonitees = Map.unionWith (+) newmonitees oldmonitees
@@ -2149,7 +2150,7 @@ glExpungeProcess gl pid myself =
let mine n = buildPidFromNodeId myself n
in case Map.lookup pid gl of
Nothing -> gl
- Just (mons,mots,ns) ->
+ Just (mons,mots,_ns) ->
let s1 = Map.delete pid gl
s2 = foldl' (\g (lp,_)-> Map.delete (mine lp) g) s1 (Map.keys mons)
s3 = foldl' (\g lp -> Map.delete (mine lp) g) s2 (Map.keys mots)
@@ -2325,15 +2326,15 @@ startProcessMonitorService = serviceThread ServiceProcessMonitor (service emptyG
case res of
Nothing -> return (lpid<0)
Just _ -> return True
- removeLocalMonitee gl monitor monitee action =
+ removeLocalMonitee gl monitor monitee _action =
gl {glLinks = gdDelMonitee (glLinks gl) monitor (localFromPid monitee) }
removeLocalMonitor gl monitor monitee action =
gl {glLinks = gdDelMonitor (glLinks gl) monitee action (localFromPid monitor) }
- addLocalMonitee gl monitor monitee action =
+ addLocalMonitee gl monitor monitee _action =
gl {glLinks = gdAddMonitee (glLinks gl) monitor (localFromPid monitee) }
addLocalMonitor gl monitor monitee action =
gl {glLinks = gdAddMonitor (glLinks gl) monitee action (localFromPid monitor) }
- addLocalNode gl monitor monitee action =
+ addLocalNode gl monitor monitee _action =
gl {glLinks = gdAddNode (glLinks gl) monitee (nodeFromPid monitor)}
broadcast nids msg = mapM_ (\p -> forkProcessWeak $ ((ptimeout 5000000 $ sendSimple (adminGetPid p ServiceProcessMonitor) msg PldAdmin) >> return ())) nids
handleProcessDown :: GlLinks -> ProcessId -> SignalReason -> ProcessM GlLinks
@@ -2342,7 +2343,7 @@ startProcessMonitorService = serviceThread ServiceProcessMonitor (service emptyG
mynid <- getSelfNode
case Map.lookup pid global of
Nothing -> return global
- Just (monitors,monitee,nodes) ->
+ Just (monitors,_monitee,nodes) ->
do mapM_ (\(tellwho,how) -> trigger (buildPidFromNodeId mynid tellwho) pid how why) (Map.keys monitors)
when (islocal)
(broadcast (Map.keys nodes) (GlProcessDown pid why))
@@ -2399,7 +2400,7 @@ startProcessMonitorService = serviceThread ServiceProcessMonitor (service emptyG
let newGlobal = myGlobal {glSyncs = Map.delete myId (glSyncs myGlobal)}
in case myMsg of
QteOK -> let s1 = addLocalNode newGlobal monitor monitee action
- in do ans QteOK
+ in do _ <- ans QteOK
return s1
err -> ans err >> return newGlobal
in do mmatch <- roundtripQueryImplSub PldAdmin (getGlobalFor monitor) msg (receiver (glNextId global))
@@ -2413,19 +2414,19 @@ startProcessMonitorService = serviceThread ServiceProcessMonitor (service emptyG
in case myMsg of
QteOK -> let s1 = addLocalMonitor newGlobal monitor monitee action
in do monitorNode (nodeFromPid monitee)
- ans QteOK
+ _ <- ans QteOK
return s1
QteUnknownPid -> do trigger monitor monitee action SrInvalid
- ans QteOK
+ _ <- ans QteOK
return newGlobal
- err -> do ans err
+ err -> do _ <- ans err
return newGlobal
in do mmatch <- roundtripQueryImplSub PldAdmin (getGlobalFor monitee) msg (receiver (glNextId global))
case mmatch of
Left err -> ans err >> return global
Right mymatch -> return global {glNextId=glNextId global+1,
glSyncs=Map.insert (glNextId global) (mymatch) (glSyncs global)}
- (False,False) -> do ans (QteOther "Requesting monitoring by third party node")
+ (False,False) -> do _ <- ans (QteOther "Requesting monitoring by third party node")
return global
GlUnmonitor monitor monitee action ->
do ismoniteelocal <- isPidLocal monitee
@@ -2564,7 +2565,7 @@ startSpawnerService = serviceThread ServiceSpawner spawner
Just q -> q
matchCallRequest = roundtripResponseAsync
(\cmd sender -> case cmd of
- AmCall pid clo -> spawnLocal (callWorker clo sender) >> return ()) False
+ AmCall _pid clo -> spawnLocal (callWorker clo sender) >> return ()) False
matchSpawnRequest = roundtripResponse
(\cmd -> case cmd of
AmSpawn c opt ->
@@ -2581,7 +2582,7 @@ startSpawnerService = serviceThread ServiceSpawner spawner
monitorPostlude = case amsoMonitor opt of
Nothing -> return ()
Just (pid,ma) -> do mypid <- getSelfPid
- monitorProcessQuiet pid mypid ma
+ _ <- monitorProcessQuiet pid mypid ma
return ()
in do newpid <- spawnLocalAnd (pausePrelude >> spawnWorker c) (namePostlude >> linkPostlude >> monitorPostlude)
return (newpid,()))
@@ -2701,7 +2702,7 @@ localRegistryQueryNodes nid =
let regMsg = LocalNodeQuery (cfgNetworkMagic cfg)
res <- roundtripQueryUnsafe PldAdmin lrpid regMsg
case res of
- Left ts -> return Nothing
+ Left _ts -> return Nothing
Right (LocalNodeAnswer pi) -> return $ Just pi
-- TODO since local registries are potentially sticky, there is good reason
@@ -2781,12 +2782,12 @@ makePayloadClosure (Closure name arg) =
invokeClosure :: (Typeable a) => Closure a -> ProcessM (Maybe a)
invokeClosure (Closure name arg) =
- (\id ->
+ (\_id ->
do node <- getLookup
res <- sequence [pureFun node,ioFun node,procFun node]
case catMaybes res of
(a:_) -> return $ Just a
- _ -> return Nothing ) id
+ _ -> return Nothing ) Prelude.id
where pureFun node = case getEntryByIdent node name of
Nothing -> return Nothing
Just x -> return $ Just $ (x arg)
View
52 Remote/Task.hs
@@ -29,23 +29,22 @@ module Remote.Task (
) where
import Remote.Reg (putReg,getEntryByIdent,RemoteCallMetaData)
-import Remote.Encoding (serialEncodePure,hGetPayload,hPutPayload,Payload(..),getPayloadContent,Serializable,serialDecode,serialEncode)
-import Remote.Process (roundtripQuery, roundtripQueryUnsafe, ServiceException(..), spawnAnd, AmSpawnOptions(..), TransmitStatus(..),diffTime,getConfig,Config(..),matchProcessDown,terminate,nullPid,monitorProcess,TransmitException(..),MonitorAction(..),ptry,LogConfig(..),getLogConfig,setNodeLogConfig,setLogConfig,nodeFromPid,LogLevel(..),LogTarget(..),logS,getLookup,say,LogSphere,NodeId,ProcessM,ProcessId,PayloadDisposition(..),getSelfPid,getSelfNode,matchUnknownThrow,receiveWait,receiveTimeout,roundtripResponse,roundtripResponseAsync,roundtripQueryImpl,match,invokeClosure,makePayloadClosure,spawn,spawnLocal,spawnLocalAnd,setDaemonic,send,makeClosure)
+import Remote.Encoding (serialEncodePure,hGetPayload,hPutPayload,Payload,getPayloadContent,Serializable,serialDecode,serialEncode)
+import Remote.Process (roundtripQuery, ServiceException(..), TransmitStatus(..),diffTime,getConfig,Config(..),matchProcessDown,terminate,nullPid,monitorProcess,TransmitException(..),MonitorAction(..),ptry,LogConfig(..),getLogConfig,setNodeLogConfig,nodeFromPid,LogLevel(..),LogTarget(..),logS,getLookup,say,LogSphere,NodeId,ProcessM,ProcessId,PayloadDisposition(..),getSelfPid,getSelfNode,matchUnknownThrow,receiveWait,receiveTimeout,roundtripResponse,roundtripResponseAsync,roundtripQueryImpl,match,makePayloadClosure,spawn,spawnLocal,spawnLocalAnd,setDaemonic,send,makeClosure)
import Remote.Closure (Closure(..))
import Remote.Peer (getPeers)
import Data.Dynamic (Dynamic, toDyn, fromDynamic)
import System.IO (withFile,IOMode(..))
import System.Directory (renameFile)
import Data.Binary (Binary,get,put,putWord8,getWord8)
-import Control.Exception (SomeException,Exception,throw,try)
+import Control.Exception (SomeException,Exception,throw)
import Data.Typeable (Typeable)
import Control.Monad (liftM,when)
import Control.Monad.Trans (liftIO)
import Control.Concurrent.MVar (MVar,modifyMVar,modifyMVar_,newMVar,newEmptyMVar,takeMVar,putMVar,readMVar,withMVar)
-import qualified Data.Map as Map (Map,fromList,insert,lookup,empty,elems,insertWith',toList)
-import Data.List ((\\),union,nub,groupBy,sortBy,delete,intercalate)
-import System.FilePath (FilePath)
+import qualified Data.Map as Map (Map,insert,lookup,empty,insertWith',toList)
+import Data.List ((\\),union,nub,groupBy,sortBy,delete)
import Data.Time (UTCTime,getCurrentTime)
-- imports required for hashClosure; is there a lighter-weight of doing this?
@@ -81,7 +80,7 @@ instance (Serializable a) => Binary (PromiseList a) where
-- a distributed thunk (in the sense of a non-strict unit
-- of evaluation). These are created by 'newPromise' and friends,
-- and the underlying value can be gotten with 'readPromise'.
-data Promise a = PromiseBasic { psRedeemer :: ProcessId, psId :: PromiseId }
+data Promise a = PromiseBasic { _psRedeemer :: ProcessId, _psId :: PromiseId }
| PromiseImmediate a deriving Typeable
-- psRedeemer should maybe be wrapped in an IORef so that it can be updated in case of node failure
@@ -352,7 +351,7 @@ hashClosure :: Closure a -> Hash
hashClosure (Closure s pl) = show $ md5 $ B.concat [fromString s, getPayloadContent pl]
undiskify :: FilePath -> MVar PromiseStorage -> ProcessM (Maybe PromiseData)
-undiskify fp mps =
+undiskify fpIn mps =
do wrap $ liftIO $ modifyMVar mps (\val ->
case val of
PromiseOnDisk fp ->
@@ -363,7 +362,7 @@ undiskify fp mps =
_ -> return (val,Nothing))
where wrap a = do res <- ptry a
case res of
- Left e -> do logS "TSK" LoCritical $ "Error reading promise from file "++fp++": "++show (e::IOError)
+ Left e -> do logS "TSK" LoCritical $ "Error reading promise from file "++fpIn++": "++show (e::IOError)
return Nothing
Right r -> return r
@@ -374,7 +373,7 @@ diskify fp mps reallywrite =
(handler (cfgPromiseFlushDelay cfg))
where
handler delay =
- do receiveTimeout delay []
+ do _ <- receiveTimeout delay []
again <- wrap $ liftIO $ modifyMVar mps (\val ->
case val of
PromiseInMemory payload utc _ ->
@@ -399,7 +398,7 @@ startNodeWorker :: ProcessId -> NodeBossState ->
MVar PromiseStorage -> Closure Payload -> ProcessM ()
startNodeWorker masterpid nbs mps clo@(Closure cloname cloarg) =
do self <- getSelfPid
- spawnLocalAnd (starter self) (prefix self)
+ _ <- spawnLocalAnd (starter self) (prefix self)
return ()
where
prefix nodeboss =
@@ -438,7 +437,7 @@ startNodeManager masterpid =
handler :: NodeBossState -> ProcessM a
handler state =
let promisecache = nsPromiseCache state
- nmStart = roundtripResponse (\(NmStart promise clo queueing) ->
+ nmStart = roundtripResponse (\(NmStart promise clo _queueing) ->
do promisestore <- liftIO $ newEmptyMVar
ret <- liftIO $ modifyMVar promisecache
(\pc -> let newpc = Map.insert promise promisestore pc
@@ -467,7 +466,7 @@ startNodeManager masterpid =
ans (NmRedeemResponse a)
diskify fp v False
PromiseException _ -> ans NmRedeemResponseException
- in do spawnLocal answerer
+ in do _ <- spawnLocal answerer
return state) False
in receiveWait [nmStart, nmRedeem, nmTermination, matchUnknownThrow] >>= handler
in do forwardLogs $ Just masterpid
@@ -563,20 +562,19 @@ runMaster masterproc =
do recentlist <- findPeers -- TODO if a node fails to response to a probe even once, it's gone forever; be more flexible
let newseen = seen `union` recentlist
let topidlist = recentlist \\ seen
- let getnid (_,n,_) = n
let cleanOut n = filter (\(_,nid,_) -> nid `elem` (map snd recentlist)) n
newlypidded <- mapM (\(role,nid) ->
do pid <- runWorkerNode masterpid nid
return (role,nid,pid)) topidlist
- (newlist,totalseen) <- liftIO $ modifyMVar nodes (\oldlist ->
+ (_newlist,totalseen) <- liftIO $ modifyMVar nodes (\oldlist ->
return ((cleanOut oldlist) ++ newlypidded,(recentlist,newseen)))
let newlyadded = totalseen \\ seen
mapM_ (\nid -> sendSilent masterpid (TmNewPeer nid)) (map snd newlyadded)
return totalseen
proberDelay = 10000000 -- how often do we check the network to see what nodes are available?
prober nodes seen masterpid =
do totalseen <- probeOnce nodes seen masterpid
- receiveTimeout proberDelay [matchUnknownThrow]
+ _ <- receiveTimeout proberDelay [matchUnknownThrow]
prober nodes totalseen masterpid
master state =
let
@@ -585,7 +583,7 @@ runMaster masterproc =
case ns of
Nothing -> do logS "TSK" LoCritical "Attempt to allocate a task, but no nodes found"
return Nothing
- Just (loc@(_,nid,nodeboss)) ->
+ Just (_,nid,nodeboss) ->
do res <- roundtripQuery PldUser nodeboss (NmStart promiseid clo queueing) -- roundtripQuery monitors and then unmonitors, which generates a lot of traffic; we probably don't need to do this
case res of
Left e ->
@@ -654,11 +652,11 @@ runMaster masterproc =
let getByNid _ [] = Nothing
getByNid nid ((_,n,nodeboss):xs) = if nid==n then Just nodeboss else getByNid nid xs
res <- liftIO $ withMVar nodes (\n -> return $ getByNid selfnode n)
- case res of
+ _ <- case res of
Nothing -> taskError "Can't find self: make sure cfgKnownHosts includes the master"
Just x -> spawnLocalAnd (masterproc x) (do myself <- getSelfPid
monitorProcess selfpid myself MaLinkError)
- spawnDaemonic (prober nodes seennodes masterpid)
+ _ <- spawnDaemonic (prober nodes seennodes masterpid)
return masterpid
stubborn :: (Monad m) => Int -> m (Maybe a) -> m (Maybe a)
@@ -693,7 +691,7 @@ toPromiseAt locality a = newPromiseAt locality (passthrough__closure a)
toPromiseNear :: (Serializable a,Serializable b) => Promise b -> a -> TaskM (Promise a)
toPromiseNear (PromiseImmediate _) = toPromise
-- TODO should I consult tsRedeemerForwarding here?
-toPromiseNear (PromiseBasic prhost prid) = toPromiseAt (LcByNode [nodeFromPid prhost])
+toPromiseNear (PromiseBasic prhost _prid) = toPromiseAt (LcByNode [nodeFromPid prhost])
-- | Creates an /immediate promise/, which is to say, a promise
-- in name only. Unlike a regular promise (created by 'toPromise'),
@@ -732,7 +730,7 @@ newPromiseHere clo =
-- evaluated.
newPromiseNear :: (Serializable a, Serializable b) => Promise b -> Closure (TaskM a) -> TaskM (Promise a)
newPromiseNear (PromiseImmediate _) = newPromise
-newPromiseNear (PromiseBasic prhost prid) = newPromiseAt (LcByNode [nodeFromPid prhost])
+newPromiseNear (PromiseBasic prhost _prid) = newPromiseAt (LcByNode [nodeFromPid prhost])
-- | A variant of 'newPromise' that prefers to start
-- the computing functions on some set of nodes that
@@ -778,10 +776,10 @@ readPromise thepromise@(PromiseBasic prhost prid) =
res <- roundtrip fprhost (NmRedeem prid)
case res of
Left e -> do tlogS "TSK" LoInformation $ "Complaining about promise " ++ show prid ++" on " ++show fprhost++" because of "++show e
- complain prhost fprhost prid
+ complain fprhost prid
Right NmRedeemResponseUnknown ->
do tlogS "TSK" LoInformation $ "Complaining about promise " ++ show prid ++" on " ++show fprhost++" because allegedly unknown"
- complain prhost fprhost prid
+ complain fprhost prid
Right (NmRedeemResponse thedata) ->
do extracted <- extractFromPayload thedata
promiseinmem <- liftTaskIO $ makePromiseInMemory thedata (Just $ toDyn extracted)
@@ -791,7 +789,7 @@ readPromise thepromise@(PromiseBasic prhost prid) =
taskError "Failed promise redemption" -- don't redeem, this is a terminal failure
Just mv -> do val <- liftTaskIO $ readMVar mv -- possible long wait here
case val of -- TODO this read/write MVars should be combined!
- PromiseInMemory v utc thedyn ->
+ PromiseInMemory v _utc thedyn ->
case thedyn of
Just thedynvalue ->
case fromDynamic thedynvalue of
@@ -806,15 +804,15 @@ readPromise thepromise@(PromiseBasic prhost prid) =
return extracted
PromiseException _ -> taskError $ "Redemption of promise failed"
PromiseOnDisk fp -> do mpd <- liftTask $ undiskify fp mv
- liftTask $ spawnLocal $ diskify fp mv False
+ _ <- liftTask $ spawnLocal $ diskify fp mv False
case mpd of
Just dat -> extractFromPayload dat
_ -> taskError "Promise extraction from disk failed"
where extractFromPayload v = do out <- liftTaskIO $ serialDecode v
case out of
Just r -> return r
Nothing -> taskError "Unexpected payload type"
- complain prhost fprhost prid =
+ complain fprhost prid =
do master <- getMaster
response <- roundtrip master (MmComplain fprhost prid)
case response of
@@ -929,7 +927,7 @@ shuffle q =
chunkify :: Int -> [a] -> [[a]]
chunkify numChunks l
| numChunks <= 0 = taskError "Can't chunkify into less than one chunk"
- | otherwise = splitSize (ceiling $ fromIntegral (length l) / fromIntegral numChunks) l
+ | otherwise = splitSize (ceiling ((fromIntegral (length l) / fromIntegral numChunks) :: Double)) l
where
splitSize _ [] = []
splitSize i v = let (first,second) = splitAt i v

0 comments on commit 290adea

Please sign in to comment.