From 290adeab93990f8ea1336730774cf1f2dceaacd7 Mon Sep 17 00:00:00 2001 From: Conrad Parker Date: Fri, 23 Sep 2011 12:36:42 +0900 Subject: [PATCH] Remove trivial build warnings Redundant imports, unused variables etc. --- Remote.hs | 2 +- Remote/Call.hs | 13 +++-- Remote/Channel.hs | 2 +- Remote/Closure.hs | 2 +- Remote/Encoding.hs | 9 ++-- Remote/Init.hs | 10 ++-- Remote/Peer.hs | 12 +++-- Remote/Process.hs | 131 +++++++++++++++++++++++---------------------- Remote/Task.hs | 52 +++++++++--------- 9 files changed, 122 insertions(+), 111 deletions(-) diff --git a/Remote.hs b/Remote.hs index a41ca8f..07afdee 100644 --- a/Remote.hs +++ b/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(..), diff --git a/Remote/Call.hs b/Remote/Call.hs index 081575d..c84f281 100644 --- a/Remote/Call.hs +++ b/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] diff --git a/Remote/Channel.hs b/Remote/Channel.hs index 0a56a02..172b561 100644 --- a/Remote/Channel.hs +++ b/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) diff --git a/Remote/Closure.hs b/Remote/Closure.hs index b248511..07caad3 100644 --- a/Remote/Closure.hs +++ b/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 diff --git a/Remote/Encoding.hs b/Remote/Encoding.hs index c61fcec..eac3d46 100644 --- a/Remote/Encoding.hs +++ b/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 diff --git a/Remote/Init.hs b/Remote/Init.hs index 7a48429..e604724 100644 --- a/Remote/Init.hs +++ b/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 diff --git a/Remote/Peer.hs b/Remote/Peer.hs index e159348..2a74ee5 100644 --- a/Remote/Peer.hs +++ b/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 diff --git a/Remote/Process.hs b/Remote/Process.hs index 4c5c0e3..7ee6ec3 100644 --- a/Remote/Process.hs +++ b/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,7 +1128,7 @@ 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 @@ -1135,9 +1136,9 @@ listenAndDeliver node cfg coord = _ -> 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) diff --git a/Remote/Task.hs b/Remote/Task.hs index 5335f46..7c09b1e 100644 --- a/Remote/Task.hs +++ b/Remote/Task.hs @@ -29,8 +29,8 @@ 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) @@ -38,14 +38,13 @@ 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,12 +562,11 @@ 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) @@ -576,7 +574,7 @@ runMaster masterproc = 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,7 +804,7 @@ 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" @@ -814,7 +812,7 @@ readPromise thepromise@(PromiseBasic prhost prid) = 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