{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Strict #-}
module Monomer.Main.WidgetTask (handleWidgetTasks) where
import Control.Concurrent.Async (poll)
import Control.Concurrent.STM.TChan (tryReadTChan)
import Control.Exception.Base
import Control.Lens ((&), (^.), (.=), use)
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Monad.STM (atomically)
import Data.Foldable (toList)
import Data.Maybe
import Data.Typeable
import qualified Data.Sequence as Seq
import Monomer.Core
import Monomer.Helper (collectJustM)
import Monomer.Main.Handlers
import Monomer.Main.Lens
import Monomer.Main.Util
import Monomer.Main.Types
import qualified Monomer.Core.Lens as L
handleWidgetTasks
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> m (HandlerStep s e)
handleWidgetTasks :: WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetTasks WidgetEnv s e
wenv WidgetNode s e
widgetRoot = do
Seq WidgetTask
tasks <- Getting (Seq WidgetTask) (MonomerCtx s e) (Seq WidgetTask)
-> m (Seq WidgetTask)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Seq WidgetTask) (MonomerCtx s e) (Seq WidgetTask)
forall s a. HasWidgetTasks s a => Lens' s a
widgetTasks
([WidgetTask]
active, [WidgetTask]
finished) <- (WidgetTask -> m Bool)
-> [WidgetTask] -> m ([WidgetTask], [WidgetTask])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM WidgetTask -> m Bool
forall s e (m :: * -> *). MonomerM s e m => WidgetTask -> m Bool
isThreadActive (Seq WidgetTask -> [WidgetTask]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq WidgetTask
tasks)
(Seq WidgetTask -> Identity (Seq WidgetTask))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasWidgetTasks s a => Lens' s a
widgetTasks ((Seq WidgetTask -> Identity (Seq WidgetTask))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Seq WidgetTask -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [WidgetTask] -> Seq WidgetTask
forall a. [a] -> Seq a
Seq.fromList [WidgetTask]
active
WidgetEnv s e
-> WidgetNode s e -> Seq WidgetTask -> m (HandlerStep s e)
forall s e (m :: * -> *) (t :: * -> *).
(MonomerM s e m, Traversable t) =>
WidgetEnv s e
-> WidgetNode s e -> t WidgetTask -> m (HandlerStep s e)
processTasks WidgetEnv s e
wenv WidgetNode s e
widgetRoot Seq WidgetTask
tasks
processTasks
:: (MonomerM s e m, Traversable t)
=> WidgetEnv s e
-> WidgetNode s e
-> t WidgetTask
-> m (HandlerStep s e)
processTasks :: WidgetEnv s e
-> WidgetNode s e -> t WidgetTask -> m (HandlerStep s e)
processTasks WidgetEnv s e
wenv WidgetNode s e
widgetRoot t WidgetTask
tasks = m (HandlerStep s e)
nextStep where
reducer :: (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> WidgetTask
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
reducer (WidgetEnv s e
wenv1, WidgetNode s e
root1, Seq (WidgetRequest s e)
reqs1) WidgetTask
task = do
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e
-> WidgetNode s e
-> WidgetTask
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> WidgetTask -> m (HandlerStep s e)
processTask WidgetEnv s e
wenv1 WidgetNode s e
root1 WidgetTask
task
(WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs1 Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
nextStep :: m (HandlerStep s e)
nextStep = (HandlerStep s e -> WidgetTask -> m (HandlerStep s e))
-> HandlerStep s e -> t WidgetTask -> m (HandlerStep s e)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HandlerStep s e -> WidgetTask -> m (HandlerStep s e)
forall (m :: * -> *) s e.
(Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m) =>
(WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> WidgetTask
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
reducer (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty) t WidgetTask
tasks
processTask
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> WidgetTask
-> m (HandlerStep s e)
processTask :: WidgetEnv s e
-> WidgetNode s e -> WidgetTask -> m (HandlerStep s e)
processTask WidgetEnv s e
wenv WidgetNode s e
widgetRoot (WidgetTask WidgetId
widgetId Async i
task) = do
Maybe (Either SomeException i)
taskStatus <- IO (Maybe (Either SomeException i))
-> m (Maybe (Either SomeException i))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either SomeException i))
-> m (Maybe (Either SomeException i)))
-> IO (Maybe (Either SomeException i))
-> m (Maybe (Either SomeException i))
forall a b. (a -> b) -> a -> b
$ Async i -> IO (Maybe (Either SomeException i))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async i
task
case Maybe (Either SomeException i)
taskStatus of
Just Either SomeException i
taskRes -> WidgetEnv s e
-> WidgetNode s e
-> WidgetId
-> Either SomeException i
-> m (HandlerStep s e)
forall s e (m :: * -> *) i.
(MonomerM s e m, Typeable i) =>
WidgetEnv s e
-> WidgetNode s e
-> WidgetId
-> Either SomeException i
-> m (HandlerStep s e)
processTaskResult WidgetEnv s e
wenv WidgetNode s e
widgetRoot WidgetId
widgetId Either SomeException i
taskRes
Maybe (Either SomeException i)
Nothing -> HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty)
processTask WidgetEnv s e
wenv WidgetNode s e
widgetRoot (WidgetProducer WidgetId
widgetId TChan i
channel Async ()
task) = do
[i]
channelStatus <- m (Maybe i) -> m [i]
forall (m :: * -> *) a. MonadIO m => m (Maybe a) -> m [a]
collectJustM (m (Maybe i) -> m [i])
-> (STM (Maybe i) -> m (Maybe i)) -> STM (Maybe i) -> m [i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe i) -> m (Maybe i)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe i) -> m (Maybe i))
-> (STM (Maybe i) -> IO (Maybe i)) -> STM (Maybe i) -> m (Maybe i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe i) -> IO (Maybe i)
forall a. STM a -> IO a
atomically (STM (Maybe i) -> m [i]) -> STM (Maybe i) -> m [i]
forall a b. (a -> b) -> a -> b
$ TChan i -> STM (Maybe i)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan i
channel
(HandlerStep s e -> i -> m (HandlerStep s e))
-> HandlerStep s e -> [i] -> m (HandlerStep s e)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HandlerStep s e -> i -> m (HandlerStep s e)
forall (m :: * -> *) s e i.
(Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m,
Typeable i) =>
(WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> i -> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
processMsg (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty) [i]
channelStatus
where
processMsg :: (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> i -> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
processMsg (WidgetEnv s e
wenv1, WidgetNode s e
root1, Seq (WidgetRequest s e)
reqs1) i
taskMsg = do
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e
-> WidgetNode s e
-> WidgetId
-> i
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *) i.
(MonomerM s e m, Typeable i) =>
WidgetEnv s e
-> WidgetNode s e -> WidgetId -> i -> m (HandlerStep s e)
processTaskEvent WidgetEnv s e
wenv1 WidgetNode s e
root1 WidgetId
widgetId i
taskMsg
(WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs1 Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
processTaskResult
:: (MonomerM s e m, Typeable i)
=> WidgetEnv s e
-> WidgetNode s e
-> WidgetId
-> Either SomeException i
-> m (HandlerStep s e)
processTaskResult :: WidgetEnv s e
-> WidgetNode s e
-> WidgetId
-> Either SomeException i
-> m (HandlerStep s e)
processTaskResult WidgetEnv s e
wenv WidgetNode s e
widgetRoot WidgetId
_ (Left SomeException
ex) = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Error processing Widget task result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
ex
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty)
processTaskResult WidgetEnv s e
wenv WidgetNode s e
widgetRoot WidgetId
widgetId (Right i
taskResult)
= WidgetEnv s e
-> WidgetNode s e -> WidgetId -> i -> m (HandlerStep s e)
forall s e (m :: * -> *) i.
(MonomerM s e m, Typeable i) =>
WidgetEnv s e
-> WidgetNode s e -> WidgetId -> i -> m (HandlerStep s e)
processTaskEvent WidgetEnv s e
wenv WidgetNode s e
widgetRoot WidgetId
widgetId i
taskResult
processTaskEvent
:: (MonomerM s e m, Typeable i)
=> WidgetEnv s e
-> WidgetNode s e
-> WidgetId
-> i
-> m (HandlerStep s e)
processTaskEvent :: WidgetEnv s e
-> WidgetNode s e -> WidgetId -> i -> m (HandlerStep s e)
processTaskEvent WidgetEnv s e
wenv WidgetNode s e
widgetRoot WidgetId
widgetId i
event = do
Path
path <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
widgetId
let emptyResult :: WidgetResult s e
emptyResult = WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
forall s e.
WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
WidgetResult WidgetNode s e
widgetRoot Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let msgResult :: Maybe (WidgetResult s e)
msgResult = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> i
-> Maybe (WidgetResult s e)
forall s e.
Widget s e
-> forall i.
Typeable i =>
WidgetEnv s e
-> WidgetNode s e -> Path -> i -> Maybe (WidgetResult s e)
widgetHandleMessage Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot Path
path i
event
let widgetResult :: WidgetResult s e
widgetResult = WidgetResult s e -> Maybe (WidgetResult s e) -> WidgetResult s e
forall a. a -> Maybe a -> a
fromMaybe WidgetResult s e
emptyResult Maybe (WidgetResult s e)
msgResult
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
wenv Bool
True WidgetResult s e
widgetResult
isThreadActive :: MonomerM s e m => WidgetTask -> m Bool
isThreadActive :: WidgetTask -> m Bool
isThreadActive (WidgetTask WidgetId
_ Async i
task) = (Maybe (Either SomeException i) -> Bool)
-> m (Maybe (Either SomeException i)) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Either SomeException i) -> Bool
forall a. Maybe a -> Bool
isNothing (IO (Maybe (Either SomeException i))
-> m (Maybe (Either SomeException i))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either SomeException i))
-> m (Maybe (Either SomeException i)))
-> IO (Maybe (Either SomeException i))
-> m (Maybe (Either SomeException i))
forall a b. (a -> b) -> a -> b
$ Async i -> IO (Maybe (Either SomeException i))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async i
task)
isThreadActive (WidgetProducer WidgetId
_ TChan i
_ Async ()
task) = (Maybe (Either SomeException ()) -> Bool)
-> m (Maybe (Either SomeException ())) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Either SomeException ()) -> Bool
forall a. Maybe a -> Bool
isNothing (IO (Maybe (Either SomeException ()))
-> m (Maybe (Either SomeException ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Either SomeException ()))
-> m (Maybe (Either SomeException ())))
-> IO (Maybe (Either SomeException ()))
-> m (Maybe (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ Async () -> IO (Maybe (Either SomeException ()))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async ()
task)
taskWidgetId :: WidgetTask -> WidgetId
taskWidgetId :: WidgetTask -> WidgetId
taskWidgetId (WidgetTask WidgetId
widgetId Async i
_) = WidgetId
widgetId
taskWidgetId (WidgetProducer WidgetId
widgetId TChan i
_ Async ()
_) = WidgetId
widgetId