{-# 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, putStrLnErr)
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 :: forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetTasks WidgetEnv s e
wenv WidgetNode s e
widgetRoot = do
Seq WidgetTask
tasks <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s a. HasWidgetTasks s a => Lens' s a
widgetTasks
([WidgetTask]
active, [WidgetTask]
finished) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM forall s e (m :: * -> *). MonomerM s e m => WidgetTask -> m Bool
isThreadActive (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq WidgetTask
tasks)
forall s a. HasWidgetTasks s a => Lens' s a
widgetTasks forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. [a] -> Seq a
Seq.fromList [WidgetTask]
active
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 :: 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 t WidgetTask
tasks = m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest 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) <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs1 forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
nextStep :: m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
nextStep = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM 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, 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 :: forall s e (m :: * -> *).
MonomerM s e m =>
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, 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 <- forall (m :: * -> *) a. MonadIO m => m (Maybe a) -> m [a]
collectJustM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan i
channel
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM 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, 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) <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs1 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 :: 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
_ (Left SomeException
ex) = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLnErr forall a b. (a -> b) -> a -> b
$ [Char]
"Error processing Widget task result: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show SomeException
ex
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, forall a. Seq a
Seq.empty)
processTaskResult WidgetEnv s e
wenv WidgetNode s e
widgetRoot WidgetId
widgetId (Right i
taskResult)
= 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 :: 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
event = do
Path
path <- forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
widgetId
let emptyResult :: WidgetResult s e
emptyResult = forall s e.
WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
WidgetResult WidgetNode s e
widgetRoot forall a. Seq a
Seq.empty
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot forall s a. s -> Getting a s a -> a
^. forall s a. HasWidget s a => Lens' s a
L.widget
let msgResult :: Maybe (WidgetResult s e)
msgResult = 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 = forall a. a -> Maybe a -> a
fromMaybe WidgetResult s e
emptyResult Maybe (WidgetResult s e)
msgResult
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 :: forall s e (m :: * -> *). MonomerM s e m => WidgetTask -> m Bool
isThreadActive (WidgetTask WidgetId
_ Async i
task) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isNothing (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async i
task)
isThreadActive (WidgetProducer WidgetId
_ TChan i
_ Async ()
task) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isNothing (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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