Control-Engine 0.0.3 → 0.0.4

raw patch · 2 files changed

+46/−48 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Control-Engine.cabal +1/−1
• Control/Engine.hs +45/−47

@@ -1,5 +1,5 @@ name:		Control-Engine-version:	0.0.3+version:	0.0.4 license:	BSD3 license-file:	LICENSE author:		Thomas DuBuisson <thomas.dubuisson@gmail.com>

@@ -68,10 +68,10 @@ 	) where  import Control.Concurrent-import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Concurrent.Chan import Control.Monad+import Data.IORef import Data.List (insert)  -- |An 'Engine' represents a pool of threads ready to execute tasks.@@ -82,13 +82,18 @@ 	, tvPreMutateHook	:: TVar [Hook state job] 	, tvPostMutateHook	:: TVar [Hook state result] 	, tvOutHook		:: TVar [Hook state result]-	, mvInHook		:: MVar [Hook state job]-	, mvPreMutateHook	:: MVar [Hook state job]-	, mvPostMutateHook	:: MVar [Hook state result]-	, mvOutHook		:: MVar [Hook state result] 	, state			:: TVar state     } +data RefEngine job result state =+	RefEng+	{ refInHook		:: IORef [Hook state job]+	, refPreMutateHook	:: IORef [Hook state job]+	, refPostMutateHook	:: IORef [Hook state result]+	, refOutHook		:: IORef [Hook state result]+	, refState		:: IORef state+    }+ -- |If all you want is a basic thread pool, this will work. -- You should consider using "Control.ThreadPool" instead. --@@ -130,36 +135,36 @@ 	c1 <- newChan 	c2 <- newChan -	inputHooks <- newMVar []-	outputHooks <- newMVar []-	preMutatorHooks <- newMVar []-	postMutatorHooks <- newMVar []--	ms <- newMVar initialState-	tv <- newTVarIO initialState+	inputHooks       <- newIORef []+	outputHooks      <- newIORef []+	preMutatorHooks  <- newIORef []+	postMutatorHooks <- newIORef []+	refState         <- newIORef initialState  	ch1tv <- newTVarIO [] 	ch2tv <- newTVarIO [] 	ch3tv <- newTVarIO [] 	ch4tv <- newTVarIO []+	stv    <- newTVarIO initialState -	let engine = Eng c1 c2 ch1tv ch2tv ch3tv ch4tv inputHooks preMutatorHooks postMutatorHooks outputHooks tv+	let engine = Eng c1 c2 ch1tv ch2tv ch3tv ch4tv stv+	    eref = RefEng inputHooks outputHooks preMutatorHooks postMutatorHooks refState -	forkIO $ inputManager input c1 inputHooks ms-	forkIO $ outputManager output c2 outputHooks ms-	forkIO $ stateManager engine ms-	forM_ [1..nrWorkers] $ \_ -> forkIO $ worker c1 preMutatorHooks ms mutator postMutatorHooks c2+	forkIO $ inputManager input c1 eref+	forkIO $ outputManager output c2 eref+	forkIO $ stateManager engine eref+	forM_ [1..nrWorkers] $ \_ -> forkIO $ worker c1 eref mutator c2 	return engine -worker :: Chan job -> MVar [Hook st job] -> MVar st -> (st -> job -> IO (Maybe result)) -> MVar [Hook st result] -> Chan result -> IO ()-worker c1 preMutatorHooks ms mutator postMutatorHooks c2 = forever $ worker'+worker :: Chan job -> RefEngine job result st -> (st -> job -> IO (Maybe result)) -> Chan result -> IO ()+worker c1 eref mutator c2 = forever $ worker'   where   worker' = do 	-- Get next message, newest hooks, and state-	msg <- readChan c1-	preMH <- readMVar preMutatorHooks-	postMH <- readMVar postMutatorHooks-	st <- readMVar ms+	msg    <- readChan c1+	preMH  <- readIORef (refPreMutateHook eref)+	postMH <- readIORef (refPostMutateHook eref)+	st     <- readIORef (refState eref)  	-- run hook1, mutator, hook2 	msg' <- runHooks preMH st msg@@ -173,26 +178,24 @@   runStage _ Nothing = return Nothing   runStage stage (Just a) = stage a --- FIXME, clean up this redundant code - its ugly!-stateManager :: (Eq st) => Engine job result st -> MVar st -> IO ()-stateManager eng ms = do-	curr@(s,ih,eh,th,oh) <- atomically $ do+stateManager :: (Eq st) => Engine job result st -> RefEngine job result st -> IO ()+stateManager eng eref = do+	curr <- atomically $ do 			s  <- readTVar (state eng) 			ih <- readTVar (tvInHook eng) 			eh <- readTVar (tvPreMutateHook eng) 			th <- readTVar (tvPostMutateHook eng) 			oh <- readTVar (tvOutHook eng) 			return (s,ih, eh, th, oh)-	swapMVar' ms s-	swapMVar' (mvInHook eng) ih-	swapMVar' (mvPreMutateHook eng) eh-	swapMVar' (mvPostMutateHook eng) th-	swapMVar' (mvOutHook eng) oh 	updateState curr   where-  swapMVar' m v = swapMVar m v >> return ()   updateState (s, ih, eh, th, oh) = do-	new@(s', ih', eh', th', oh') <- atomically $ do+	writeIORef (refState eref) s+	writeIORef (refInHook eref) ih+	writeIORef (refPreMutateHook eref) eh+	writeIORef (refPostMutateHook eref) th+	writeIORef (refOutHook eref) oh+	new <- atomically $ do 		s'  <- readTVar (state eng) 		ih' <- readTVar (tvInHook eng) 		eh' <- readTVar (tvPreMutateHook eng)@@ -200,31 +203,26 @@ 		oh' <- readTVar (tvOutHook eng) 		when (s' == s && ih' == ih && eh' == eh && th' == th && oh' == oh) retry 		return (s', ih', eh', th', oh')-	when (s' /= s)   (swapMVar ms s' >> return ())-	when (ih' /= ih) (swapMVar (mvInHook eng) ih' >> return ())-	when (eh' /= eh) (swapMVar (mvPreMutateHook eng) eh' >> return ())-	when (th' /= th) (swapMVar (mvPostMutateHook eng) th' >> return ())-	when (oh' /= oh) (swapMVar (mvOutHook eng) oh' >> return ()) 	updateState new  -- Input.hs-inputManager :: (IO msg) -> Chan msg -> MVar [Hook st msg] -> MVar st -> IO ()-inputManager input outChan hookMV stMV= forever $ input >>= handleMsg+inputManager :: (IO job) -> Chan job -> RefEngine job result st -> IO ()+inputManager input outChan eref = forever $ input >>= handleMsg   where   handleMsg msg = do-	hook <- readMVar hookMV-	s <- readMVar stMV+	hook <- readIORef (refInHook eref)+	s <- readIORef (refState eref) 	new <- runHooks hook s msg 	case new of 		Just m -> writeChan outChan m 		Nothing -> return ()  -- Output.hs-outputManager :: (result -> IO ()) -> Chan result -> MVar [Hook st result] -> MVar st -> IO ()-outputManager output msgChan hookMV stMV = forever $ do+outputManager :: (result -> IO ()) -> Chan result -> RefEngine job result state -> IO ()+outputManager output msgChan eref = forever $ do 	m <- readChan msgChan-	hook <- readMVar hookMV-	s <- readMVar stMV+	hook <- readIORef (refOutHook eref)+	s <- readIORef (refState eref) 	new <- runHooks hook s m 	case new of 		Just n -> output n