module Shaker.Conductor(
initThread,
executeCommand
)
where
import Control.Monad
import Control.Monad.Reader
import Control.Concurrent
import Shaker.Type
import Shaker.Io
import Shaker.Listener
import Shaker.Cli
import qualified Data.Map as M
import Data.Maybe
import qualified Control.Exception as C
initThread :: Shaker IO()
initThread = do
shIn <- ask
input_action <- getInput
lift ( forkIO ( forever input_action) ) >>= addThreadIdToQuitMVar
let main_loop = runReaderT mainThread shIn
lift ( forkIO (forever main_loop) ) >>= addThreadIdToQuitMVar
quit_token <- asks (quitToken . threadData)
_ <- lift $ takeMVar quit_token
cleanAllThreads
mainThread :: Shaker IO()
mainThread = do
(InputState inputMv tokenMv) <- asks inputState
_ <- lift $ tryPutMVar tokenMv 42
maybe_cmd <- lift $ takeMVar inputMv
executeCommand maybe_cmd
data ConductorData = ConductorData ListenState ([FileInfo] -> IO () )
initializeConductorData :: Shaker IO () -> Shaker IO ConductorData
initializeConductorData fun = do
shIn <- ask
lstState <- initializeListener
mapM_ addThreadIdToListenMVar $ threadIds lstState
let theFun = \a -> runReaderT fun shIn {modifiedInfoFiles = a}
return $ ConductorData lstState theFun
cleanAllThreads :: Shaker IO ()
cleanAllThreads = do
asks ( threadIdListenList . threadData ) >>= cleanThreads
asks ( threadIdQuitList . threadData ) >>= cleanThreads
cleanThreads :: ThreadIdList -> Shaker IO()
cleanThreads thrdList = lift (readMVar thrdList) >>= lift . mapM_ killThread
threadExecutor :: ConductorData -> Shaker IO ()
threadExecutor conductorData = do
shIn <- ask
res <- lift $ handleContinuousInterrupt $ runReaderT (threadExecutor' conductorData) shIn
when res $ threadExecutor conductorData
asks ( threadIdListenList . threadData ) >>= cleanThreads
threadExecutor' :: ConductorData -> Shaker IO Bool
threadExecutor' (ConductorData listenState fun) = lift $ takeMVar (mvModifiedFiles listenState) >>= fun >> return True
executeCommand :: Maybe Command -> Shaker IO ()
executeCommand Nothing = executeAction [Action InvalidAction]
executeCommand (Just (Command OneShot act_list)) = executeAction act_list
executeCommand (Just (Command Continuous act)) = initializeConductorData ( executeAction act ) >>= threadExecutor
executeAction :: [Action] -> Shaker IO()
executeAction acts = do
shIn <- ask
let allActs = runReaderT (mapM_ executeAction' acts) shIn
lift $ handleActionInterrupt allActs
return ()
executeAction' :: Action -> Shaker IO()
executeAction' (ActionWithArg actKey args) = do
plMap <- asks pluginMap
local (\shIn -> shIn {argument = args} ) $ fromJust $ actKey `M.lookup` plMap
executeAction' (Action actKey) = do
plMap <- asks pluginMap
fromJust $ actKey `M.lookup` plMap
handleContinuousInterrupt :: IO Bool -> IO Bool
handleContinuousInterrupt = C.handle catchAll
where catchAll :: C.SomeException -> IO Bool
catchAll e = putStrLn ("Shaker caught " ++ show e ) >> return False
addThreadIdToListenMVar :: ThreadId -> Shaker IO()
addThreadIdToListenMVar thrdId = asks (threadIdListenList . threadData) >>= flip addThreadIdToMVar thrdId
addThreadIdToQuitMVar :: ThreadId -> Shaker IO()
addThreadIdToQuitMVar thrdId = asks (threadIdQuitList . threadData) >>= flip addThreadIdToMVar thrdId
addThreadIdToMVar :: ThreadIdList -> ThreadId -> Shaker IO ()
addThreadIdToMVar thrdList thrId = lift $ modifyMVar_ thrdList (\b -> return $ thrId:b)