creatur 5.6.6 → 5.6.7

raw patch · 3 files changed

+41/−46 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• creatur.cabal +2/−2
• src/ALife/Creatur/Daemon.hs +12/−11
• src/ALife/Creatur/Task.hs +27/−33

@@ -1,5 +1,5 @@ Name:              creatur-Version:           5.6.6+Version:           5.6.7 Stability:         experimental Synopsis:          Framework for artificial life experiments. Description:       A software framework for automating experiments@@ -36,7 +36,7 @@ source-repository this   type:     git   location: https://github.com/mhwombat/creatur.git-  tag:      5.6.6+  tag:      5.6.7  library   GHC-Options:      -Wall -fno-warn-orphans

@@ -16,14 +16,15 @@ module ALife.Creatur.Daemon   (     Daemon(..),-    launch+    launch,+    requestShutdown   ) where  import Control.Concurrent (MVar, newMVar, readMVar, swapMVar,    threadDelay) import Control.Exception (SomeException, handle, catch) import Control.Monad (when)-import Control.Monad.State (StateT, runStateT)+import Control.Monad.State (StateT, execStateT) import System.IO (hPutStr, stderr) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Daemonize (CreateDaemon(..), serviced, simpleDaemon)@@ -40,9 +41,9 @@   {     onStartup :: s -> IO s,     onShutdown :: s -> IO (),-    onException :: s -> SomeException -> IO (Bool, s),+    onException :: s -> SomeException -> IO s,     -- | The agent task.-    task :: StateT s IO Bool,+    task :: StateT s IO (),     username :: String,     -- | Number of microseconds to sleep between agent tasks.     sleepTime :: Int@@ -70,7 +71,7 @@ daemonMain :: Daemon s -> s -> () -> IO () daemonMain d s _ = do   s' <- onStartup d s-  _ <- installHandler sigTERM (Catch handleTERM) (Just fullSignalSet)+  _ <- installHandler sigTERM (Catch requestShutdown) (Just fullSignalSet)   _ <- wrap (daemonMainLoop d s')   return () @@ -78,10 +79,9 @@ daemonMainLoop d s = do   stopRequested <- readMVar termReceived   when (not stopRequested) $ do-    (continue, s') <- handle (onException d s) $ runStateT (task d) s-    when continue $ do-      threadDelay $ sleepTime d-      daemonMainLoop d s'+    s' <- handle (onException d s) $ execStateT (task d) s+    when (sleepTime d > 0) $ threadDelay $ sleepTime d+    daemonMainLoop d s'   onShutdown d s  wrap :: IO () -> IO ()@@ -91,8 +91,9 @@      hPutStr stderr ("Unhandled exception: " ++ err)      return ()) -handleTERM :: IO ()-handleTERM = do+requestShutdown :: IO ()+requestShutdown = do   _ <- swapMVar termReceived True   return ()+ 

@@ -32,12 +32,15 @@  ) where  import ALife.Creatur.Daemon (Daemon(..))+import qualified ALife.Creatur.Daemon as D import ALife.Creatur.Universe (Universe, Agent, AgentProgram,   AgentsProgram, writeToLog, lineup, refreshLineup, markDone, endOfRound,   withAgent, withAgents, incTime, popSize) import Control.Conditional (whenM) import Control.Exception (SomeException)-import Control.Monad.State (StateT, execStateT)+import Control.Monad (when)+import Control.Monad.State (StateT, execStateT, evalStateT)+import Control.Monad.Trans.Class (lift) import Data.Serialize (Serialize)  simpleDaemon :: Universe u => Daemon u@@ -55,32 +58,26 @@ startupHandler = execStateT (writeToLog $ "Starting")  shutdownHandler :: Universe u => u -> IO ()-shutdownHandler u = do-  _ <- execStateT (writeToLog "Shutdown requested") u-  return ()+shutdownHandler u = evalStateT (writeToLog "Shutdown requested") u -exceptionHandler :: Universe u => u -> SomeException -> IO (Bool, u)-exceptionHandler u x = do-  u' <- execStateT (writeToLog ("WARNING: " ++ show x)) u-  return (True, u')+exceptionHandler :: Universe u => u -> SomeException -> IO u+exceptionHandler u x = execStateT (writeToLog ("WARNING: " ++ show x)) u  runNoninteractingAgents   :: (Universe u, Serialize (Agent u))     => AgentProgram u -> (Int, Int) -> StateT u IO () -> StateT u IO ()-      -> StateT u IO Bool+      -> StateT u IO () runNoninteractingAgents agentProgram popRange startRoundProgram     endRoundProgram = do   atStartOfRound startRoundProgram   as <- lineup-  if null as-    then return False-    else do-      let a = head as-      markDone a-      -- do that first in case the next line triggers an exception-      withAgent agentProgram a-      atEndOfRound endRoundProgram-      popSizeInBounds popRange+  when (not . null $ as) $ do+    let a = head as+    markDone a+    -- ^^^ do first in case the next line triggers an exception+    withAgent agentProgram a+    atEndOfRound endRoundProgram+    checkPopSize popRange  --   The input parameter is a list of agents. The first agent in the --   list is the agent whose turn it is to use the CPU. The rest of@@ -94,31 +91,28 @@ runInteractingAgents   :: (Universe u, Serialize (Agent u))     => AgentsProgram u -> (Int, Int) -> StateT u IO () -> StateT u IO ()-      -> StateT u IO Bool+      -> StateT u IO () runInteractingAgents agentsProgram popRange startRoundProgram     endRoundProgram = do   atStartOfRound startRoundProgram   as <- lineup   markDone (head as)-  -- do that first in case the next line triggers an exception+  -- ^^^ do first in case the next line triggers an exception   withAgents agentsProgram as   atEndOfRound endRoundProgram-  popSizeInBounds popRange+  checkPopSize popRange -popSizeInBounds :: Universe u => (Int, Int) -> StateT u IO Bool-popSizeInBounds (minAgents, maxAgents) = do+checkPopSize :: Universe u => (Int, Int) -> StateT u IO ()+checkPopSize (minAgents, maxAgents) = do   n <- popSize   writeToLog $ "Pop. size=" ++ show n-  if n < minAgents-    then do-      writeToLog "Requesting shutdown (population too small)"-      return False-    else-      if n > maxAgents-        then do-          writeToLog "Requesting shutdown (population too big)"-          return False-        else return True+  when (n < minAgents) $ requestShutdown "population too small"+  when (n > maxAgents) $ requestShutdown "population too big"++requestShutdown :: Universe u => String -> StateT u IO ()+requestShutdown s = do+  writeToLog $ "Requesting shutdown: " ++ s+  lift D.requestShutdown  atStartOfRound :: Universe u => StateT u IO () -> StateT u IO () atStartOfRound program = do