module Monky
( startLoop
, startLoopT
)
where
import System.Timeout
import Data.Time.Clock.POSIX
import Control.Concurrent.MVar
import Data.IORef (IORef, readIORef, writeIORef, newIORef, atomicWriteIORef)
import Monky.Modules
import Control.Monad (when, void)
import Control.Concurrent (forkIO)
data ModuleWrapper = MWrapper Modules (IORef [MonkyOut])
packMod :: MVar Bool -> Modules -> IO ModuleWrapper
packMod _ x@(Poll (NMW m _)) = do
sref <- newIORef []
initialize m
return (MWrapper x sref)
packMod mvar x@(Evt (DW m)) = do
sref <- newIORef []
_ <- forkIO . startEvtLoop m $ \val -> do
atomicWriteIORef sref val
void $ tryPutMVar mvar True
return $ MWrapper x sref
getWrapperText :: Int -> ModuleWrapper -> IO [MonkyOut]
getWrapperText tick (MWrapper (Poll (NMW m i)) r) = do
when (tick `mod` i == 0) (writeIORef r =<< getOutput m)
readIORef r
getWrapperText _ (MWrapper (Evt _) r) = readIORef r
doMonkyLine :: MonkyOutput o => Int -> o -> [ModuleWrapper] -> IO ()
doMonkyLine t o xs =
doLine o =<< mapM (getWrapperText t) xs
doCachedLine :: MonkyOutput o => o -> [ModuleWrapper] -> IO ()
doCachedLine out xs =
doLine out =<< mapM (\(MWrapper _ r) -> readIORef r) xs
waitTick :: MonkyOutput o => Int -> MVar Bool -> o -> [ModuleWrapper] -> IO ()
waitTick limit mvar out xs = do
pre <- getPOSIXTime
ret <- timeout limit $ takeMVar mvar
case ret of
Nothing -> return ()
Just _ -> do
doCachedLine out xs
post <- getPOSIXTime
let passed = round . (* 1000000) $ post pre
if passed > limit
then return ()
else waitTick (limit passed) mvar out xs
mainLoop :: MonkyOutput o => Int -> MVar Bool -> Int -> o -> [ModuleWrapper] -> IO ()
mainLoop l r t o xs = do
doMonkyLine t o xs
waitTick l r o xs
mainLoop l r (t+1) o xs
startLoopT :: MonkyOutput o => Int -> IO o -> [IO Modules] -> IO ()
startLoopT t out mods = do
mvar <- newEmptyMVar
m <- sequence mods
l <- mapM (packMod mvar) m
o <- out
mainLoop t mvar 0 o l
startLoop :: MonkyOutput o => IO o -> [IO Modules] -> IO ()
startLoop out mods = startLoopT 1000000 out mods