{-|
Module      : Monomer.Main.WidgetTask
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Handles the lifecycle and reporting of generated events of WidgetTasks (single
message) and Producers (multiple messages).
-}
{-# 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

-- | Checks the status and collects results of active tasks.
handleWidgetTasks
  :: MonomerM s e m
  => WidgetEnv s e        -- ^ The widget environment.
  -> WidgetNode s e       -- ^ The widget root.
  -> m (HandlerStep s e)  -- ^ The updated "Monomer.Main.Handlers.HandlerStep".
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