{-|
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)
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 :: 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