-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{-# LANGUAGE RankNTypes, FlexibleContexts, OverloadedLabels, RecursiveDo #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, GADTs, ScopedTypeVariables #-}

{-|
Description : Execute monadic actions with access to reactive operators on GTK
Copyright   : Sven Bartscher 2020
License     : MPL-2.0
Maintainer  : sven.bartscher@weltraumschlangen.de
Stability   : experimental

This module provides the top-level entry-point for running reactive
GTK applications, namely 'runReflexGtk'.
-}
module Reflex.GI.Gtk.Host
  ( runReflexGtk
  , ReflexGtk
  , ReflexGtkT
  ) where

import Control.Concurrent ( isCurrentThreadBound
                          , runInBoundThread
                          )
import Control.Concurrent.Async ( async
                                , waitCatchSTM
                                )
import Control.Concurrent.Chan ( newChan
                               , readChan
                               )
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class ( MonadIO
                              , liftIO
                              )
import Control.Monad.Primitive (PrimMonad)
import Control.Monad.Ref ( MonadRef
                         , Ref
                         , readRef
                         )
import Control.Monad.Trans (lift)
import Data.Dependent.Sum ( DSum((:=>))
                          , (==>)
                          )
import Data.Function (fix)
import Data.GI.Base.Signals (disconnectSignalHandler)
import Data.Int (Int32)
import Data.Maybe (catMaybes)
import Data.Void (absurd)
import GI.GLib ( Thread
               , threadSelf
               )
import GI.Gtk ( Application
              , on
              )
import Reflex ( Adjustable( runWithReplace
                          , traverseIntMapWithKeyWithAdjust
                          , traverseDMapWithKeyWithAdjust
                          , traverseDMapWithKeyWithAdjustWithMove
                          )
              , FireCommand(FireCommand)
              , MonadHold
              , MonadSample
              , NotReady
              , PerformEvent
              , PerformEventT
              , PostBuild
              , PostBuildT
              , SpiderHost
              , SpiderTimeline
              , TriggerEvent
              , TriggerEventT
              , TriggerInvocation(TriggerInvocation)
              , hostPerformEventT
              , newEventWithLazyTriggerWithOnComplete
              , runPostBuildT
              , runSpiderHostForTimeline
              , runTriggerEventT
              , unEventTriggerRef
              , withSpiderTimeline
              )
import Reflex.GI.Gtk.Input ( FireAsync( FireAsync
                                      , FireSync
                                      )
                           , MonadGtkSource(eventFromSignalWith)
                           )
import Reflex.GI.Gtk.Run ( MonadRunGtk( runGtk
                                      , runGtk_
                                      , runGtkPromise
                                      )
                         )
import Reflex.GI.Gtk.Run.Base ( RunGtkT
                              , runGtkT
                              , askRunGtk
                              , askRunGtk_
                              , askMakeSynchronousFire
                              )
import Reflex.Host.Class ( HostFrame
                         , ReflexHost
                         , newEventWithTriggerRef
                         )
import Reflex.Spider.Internal (HasSpiderTimeline)

-- | A monad providing an implementation for
-- 'Reflex.GI.Gtk.Class.MonadReflexGtk' given a suitable reflex host
-- (such as 'SpiderHost') as a base monad.
--
-- Your probably want to look at 'ReflexGtk', as it is the only
-- specialization of this type that can be executed using
-- 'runReflexGtk'.
newtype ReflexGtkT (t :: *) (m :: k) a = ReflexGtkT
  { ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT :: PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
  }
  deriving (a -> ReflexGtkT t m b -> ReflexGtkT t m a
(a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
(forall a b. (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b)
-> (forall a b. a -> ReflexGtkT t m b -> ReflexGtkT t m a)
-> Functor (ReflexGtkT t m)
forall a b. a -> ReflexGtkT t m b -> ReflexGtkT t m a
forall a b. (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
forall t k (m :: k) a b.
ReflexHost t =>
a -> ReflexGtkT t m b -> ReflexGtkT t m a
forall t k (m :: k) a b.
ReflexHost t =>
(a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ReflexGtkT t m b -> ReflexGtkT t m a
$c<$ :: forall t k (m :: k) a b.
ReflexHost t =>
a -> ReflexGtkT t m b -> ReflexGtkT t m a
fmap :: (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
$cfmap :: forall t k (m :: k) a b.
ReflexHost t =>
(a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
Functor, Functor (ReflexGtkT t m)
a -> ReflexGtkT t m a
Functor (ReflexGtkT t m) =>
(forall a. a -> ReflexGtkT t m a)
-> (forall a b.
    ReflexGtkT t m (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b)
-> (forall a b c.
    (a -> b -> c)
    -> ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m c)
-> (forall a b.
    ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b)
-> (forall a b.
    ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m a)
-> Applicative (ReflexGtkT t m)
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m a
ReflexGtkT t m (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
(a -> b -> c)
-> ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m c
forall a. a -> ReflexGtkT t m a
forall a b.
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m a
forall a b.
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
forall a b.
ReflexGtkT t m (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
forall t k (m :: k). ReflexHost t => Functor (ReflexGtkT t m)
forall t k (m :: k) a. ReflexHost t => a -> ReflexGtkT t m a
forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m a
forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
forall t k (m :: k) a b c.
ReflexHost t =>
(a -> b -> c)
-> ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m c
forall a b c.
(a -> b -> c)
-> ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m a
$c<* :: forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m a
*> :: ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
$c*> :: forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
liftA2 :: (a -> b -> c)
-> ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m c
$cliftA2 :: forall t k (m :: k) a b c.
ReflexHost t =>
(a -> b -> c)
-> ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m c
<*> :: ReflexGtkT t m (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
$c<*> :: forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m (a -> b) -> ReflexGtkT t m a -> ReflexGtkT t m b
pure :: a -> ReflexGtkT t m a
$cpure :: forall t k (m :: k) a. ReflexHost t => a -> ReflexGtkT t m a
$cp1Applicative :: forall t k (m :: k). ReflexHost t => Functor (ReflexGtkT t m)
Applicative, Applicative (ReflexGtkT t m)
a -> ReflexGtkT t m a
Applicative (ReflexGtkT t m) =>
(forall a b.
 ReflexGtkT t m a -> (a -> ReflexGtkT t m b) -> ReflexGtkT t m b)
-> (forall a b.
    ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b)
-> (forall a. a -> ReflexGtkT t m a)
-> Monad (ReflexGtkT t m)
ReflexGtkT t m a -> (a -> ReflexGtkT t m b) -> ReflexGtkT t m b
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
forall a. a -> ReflexGtkT t m a
forall a b.
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
forall a b.
ReflexGtkT t m a -> (a -> ReflexGtkT t m b) -> ReflexGtkT t m b
forall t k (m :: k). ReflexHost t => Applicative (ReflexGtkT t m)
forall t k (m :: k) a. ReflexHost t => a -> ReflexGtkT t m a
forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> (a -> ReflexGtkT t m b) -> ReflexGtkT t m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ReflexGtkT t m a
$creturn :: forall t k (m :: k) a. ReflexHost t => a -> ReflexGtkT t m a
>> :: ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
$c>> :: forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> ReflexGtkT t m b -> ReflexGtkT t m b
>>= :: ReflexGtkT t m a -> (a -> ReflexGtkT t m b) -> ReflexGtkT t m b
$c>>= :: forall t k (m :: k) a b.
ReflexHost t =>
ReflexGtkT t m a -> (a -> ReflexGtkT t m b) -> ReflexGtkT t m b
$cp1Monad :: forall t k (m :: k). ReflexHost t => Applicative (ReflexGtkT t m)
Monad, Monad (ReflexGtkT t m)
Monad (ReflexGtkT t m) =>
(forall a. (a -> ReflexGtkT t m a) -> ReflexGtkT t m a)
-> MonadFix (ReflexGtkT t m)
(a -> ReflexGtkT t m a) -> ReflexGtkT t m a
forall a. (a -> ReflexGtkT t m a) -> ReflexGtkT t m a
forall t k (m :: k). ReflexHost t => Monad (ReflexGtkT t m)
forall t k (m :: k) a.
ReflexHost t =>
(a -> ReflexGtkT t m a) -> ReflexGtkT t m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: (a -> ReflexGtkT t m a) -> ReflexGtkT t m a
$cmfix :: forall t k (m :: k) a.
ReflexHost t =>
(a -> ReflexGtkT t m a) -> ReflexGtkT t m a
$cp1MonadFix :: forall t k (m :: k). ReflexHost t => Monad (ReflexGtkT t m)
MonadFix)

-- | This is the monad that reactive GTK code is run in. Notably this
-- type implements 'Reflex.GI.Gtk.Class.MonadReflexGtk' when run with
-- 'runReflexGtk'.
type ReflexGtk x = ReflexGtkT (SpiderTimeline x) (SpiderHost x)

deriving instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (ReflexGtkT t m)
deriving instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (ReflexGtkT t m)
deriving instance (ReflexHost t, NotReady t (PerformEventT t m)) => NotReady t (ReflexGtkT t m)
deriving instance ( ReflexHost t
                  , MonadRef (HostFrame t)
                  , Ref (HostFrame t) ~ Ref IO
                  ) => TriggerEvent t (ReflexGtkT t m)
deriving instance (ReflexHost t) => PostBuild t (ReflexGtkT t m)
deriving instance (ReflexHost t) => MonadSample t (ReflexGtkT t m)
deriving instance (ReflexHost t, MonadHold t m) => MonadHold t (ReflexGtkT t m)
deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (ReflexGtkT t m)

instance ( ReflexHost t
         , PrimMonad (HostFrame t)
         , MonadHold t m
         , Ref m ~ Ref IO
         ) => Adjustable t (ReflexGtkT t m) where
  runWithReplace :: ReflexGtkT t m a
-> Event t (ReflexGtkT t m b) -> ReflexGtkT t m (a, Event t b)
runWithReplace initial :: ReflexGtkT t m a
initial replace :: Event t (ReflexGtkT t m b)
replace =
    PostBuildT
  t (TriggerEventT t (RunGtkT (PerformEventT t m))) (a, Event t b)
-> ReflexGtkT t m (a, Event t b)
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT
   t (TriggerEventT t (RunGtkT (PerformEventT t m))) (a, Event t b)
 -> ReflexGtkT t m (a, Event t b))
-> PostBuildT
     t (TriggerEventT t (RunGtkT (PerformEventT t m))) (a, Event t b)
-> ReflexGtkT t m (a, Event t b)
forall a b. (a -> b) -> a -> b
$ PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> Event
     t (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) b)
-> PostBuildT
     t (TriggerEventT t (RunGtkT (PerformEventT t m))) (a, Event t b)
forall t (m :: * -> *) a b.
Adjustable t m =>
m a -> Event t (m b) -> m (a, Event t b)
runWithReplace (ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
forall t k (m :: k) a.
ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT ReflexGtkT t m a
initial) (ReflexGtkT t m b
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) b
forall t k (m :: k) a.
ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT (ReflexGtkT t m b
 -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) b)
-> Event t (ReflexGtkT t m b)
-> Event
     t (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t (ReflexGtkT t m b)
replace)
  traverseDMapWithKeyWithAdjust :: (forall a. k a -> v a -> ReflexGtkT t m (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> ReflexGtkT t m (DMap k v', Event t (PatchDMap k v'))
traverseDMapWithKeyWithAdjust f :: forall a. k a -> v a -> ReflexGtkT t m (v' a)
f initial :: DMap k v
initial =
    PostBuildT
  t
  (TriggerEventT t (RunGtkT (PerformEventT t m)))
  (DMap k v', Event t (PatchDMap k v'))
-> ReflexGtkT t m (DMap k v', Event t (PatchDMap k v'))
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT
   t
   (TriggerEventT t (RunGtkT (PerformEventT t m)))
   (DMap k v', Event t (PatchDMap k v'))
 -> ReflexGtkT t m (DMap k v', Event t (PatchDMap k v')))
-> (Event t (PatchDMap k v)
    -> PostBuildT
         t
         (TriggerEventT t (RunGtkT (PerformEventT t m)))
         (DMap k v', Event t (PatchDMap k v')))
-> Event t (PatchDMap k v)
-> ReflexGtkT t m (DMap k v', Event t (PatchDMap k v'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 k a
 -> v a
 -> PostBuildT
      t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> PostBuildT
     t
     (TriggerEventT t (RunGtkT (PerformEventT t m)))
     (DMap k v', Event t (PatchDMap k v'))
forall t (m :: * -> *) (k :: * -> *) (v :: * -> *) (v' :: * -> *).
(Adjustable t m, GCompare k) =>
(forall a. k a -> v a -> m (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> m (DMap k v', Event t (PatchDMap k v'))
traverseDMapWithKeyWithAdjust (\k :: k a
k v :: v a
v -> ReflexGtkT t m (v' a)
-> PostBuildT
     t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a)
forall t k (m :: k) a.
ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT (ReflexGtkT t m (v' a)
 -> PostBuildT
      t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a))
-> ReflexGtkT t m (v' a)
-> PostBuildT
     t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a)
forall a b. (a -> b) -> a -> b
$ k a -> v a -> ReflexGtkT t m (v' a)
forall a. k a -> v a -> ReflexGtkT t m (v' a)
f k a
k v a
v) DMap k v
initial
  traverseDMapWithKeyWithAdjustWithMove :: (forall a. k a -> v a -> ReflexGtkT t m (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> ReflexGtkT t m (DMap k v', Event t (PatchDMapWithMove k v'))
traverseDMapWithKeyWithAdjustWithMove f :: forall a. k a -> v a -> ReflexGtkT t m (v' a)
f initial :: DMap k v
initial =
    PostBuildT
  t
  (TriggerEventT t (RunGtkT (PerformEventT t m)))
  (DMap k v', Event t (PatchDMapWithMove k v'))
-> ReflexGtkT t m (DMap k v', Event t (PatchDMapWithMove k v'))
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT
   t
   (TriggerEventT t (RunGtkT (PerformEventT t m)))
   (DMap k v', Event t (PatchDMapWithMove k v'))
 -> ReflexGtkT t m (DMap k v', Event t (PatchDMapWithMove k v')))
-> (Event t (PatchDMapWithMove k v)
    -> PostBuildT
         t
         (TriggerEventT t (RunGtkT (PerformEventT t m)))
         (DMap k v', Event t (PatchDMapWithMove k v')))
-> Event t (PatchDMapWithMove k v)
-> ReflexGtkT t m (DMap k v', Event t (PatchDMapWithMove k v'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 k a
 -> v a
 -> PostBuildT
      t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> PostBuildT
     t
     (TriggerEventT t (RunGtkT (PerformEventT t m)))
     (DMap k v', Event t (PatchDMapWithMove k v'))
forall t (m :: * -> *) (k :: * -> *) (v :: * -> *) (v' :: * -> *).
(Adjustable t m, GCompare k) =>
(forall a. k a -> v a -> m (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> m (DMap k v', Event t (PatchDMapWithMove k v'))
traverseDMapWithKeyWithAdjustWithMove (\k :: k a
k v :: v a
v -> ReflexGtkT t m (v' a)
-> PostBuildT
     t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a)
forall t k (m :: k) a.
ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT (ReflexGtkT t m (v' a)
 -> PostBuildT
      t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a))
-> ReflexGtkT t m (v' a)
-> PostBuildT
     t (TriggerEventT t (RunGtkT (PerformEventT t m))) (v' a)
forall a b. (a -> b) -> a -> b
$ k a -> v a -> ReflexGtkT t m (v' a)
forall a. k a -> v a -> ReflexGtkT t m (v' a)
f k a
k v a
v) DMap k v
initial
  traverseIntMapWithKeyWithAdjust :: (Key -> v -> ReflexGtkT t m v')
-> IntMap v
-> Event t (PatchIntMap v)
-> ReflexGtkT t m (IntMap v', Event t (PatchIntMap v'))
traverseIntMapWithKeyWithAdjust f :: Key -> v -> ReflexGtkT t m v'
f initial :: IntMap v
initial =
    PostBuildT
  t
  (TriggerEventT t (RunGtkT (PerformEventT t m)))
  (IntMap v', Event t (PatchIntMap v'))
-> ReflexGtkT t m (IntMap v', Event t (PatchIntMap v'))
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT
   t
   (TriggerEventT t (RunGtkT (PerformEventT t m)))
   (IntMap v', Event t (PatchIntMap v'))
 -> ReflexGtkT t m (IntMap v', Event t (PatchIntMap v')))
-> (Event t (PatchIntMap v)
    -> PostBuildT
         t
         (TriggerEventT t (RunGtkT (PerformEventT t m)))
         (IntMap v', Event t (PatchIntMap v')))
-> Event t (PatchIntMap v)
-> ReflexGtkT t m (IntMap v', Event t (PatchIntMap v'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
 -> v
 -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) v')
-> IntMap v
-> Event t (PatchIntMap v)
-> PostBuildT
     t
     (TriggerEventT t (RunGtkT (PerformEventT t m)))
     (IntMap v', Event t (PatchIntMap v'))
forall t (m :: * -> *) v v'.
Adjustable t m =>
(Key -> v -> m v')
-> IntMap v
-> Event t (PatchIntMap v)
-> m (IntMap v', Event t (PatchIntMap v'))
traverseIntMapWithKeyWithAdjust (\k :: Key
k v :: v
v -> ReflexGtkT t m v'
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) v'
forall t k (m :: k) a.
ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT (ReflexGtkT t m v'
 -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) v')
-> ReflexGtkT t m v'
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) v'
forall a b. (a -> b) -> a -> b
$ Key -> v -> ReflexGtkT t m v'
f Key
k v
v) IntMap v
initial

instance (ReflexHost t, MonadIO (HostFrame t)) => MonadRunGtk (ReflexGtkT t m) where
  runGtk :: IO a -> ReflexGtkT t m a
runGtk = PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
 -> ReflexGtkT t m a)
-> (IO a
    -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
-> IO a
-> ReflexGtkT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
forall (m :: * -> *) a. MonadRunGtk m => IO a -> m a
runGtk
  runGtk_ :: IO a -> ReflexGtkT t m ()
runGtk_ = PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) ()
-> ReflexGtkT t m ()
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) ()
 -> ReflexGtkT t m ())
-> (IO a
    -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) ())
-> IO a
-> ReflexGtkT t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) ()
forall (m :: * -> *) a. MonadRunGtk m => IO a -> m ()
runGtk_
  runGtkPromise :: IO a -> ReflexGtkT t m (ReflexGtkT t m a)
runGtkPromise = (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
 -> ReflexGtkT t m a)
-> ReflexGtkT
     t
     m
     (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
-> ReflexGtkT t m (ReflexGtkT t m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (ReflexGtkT
   t
   m
   (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
 -> ReflexGtkT t m (ReflexGtkT t m a))
-> (IO a
    -> ReflexGtkT
         t
         m
         (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a))
-> IO a
-> ReflexGtkT t m (ReflexGtkT t m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostBuildT
  t
  (TriggerEventT t (RunGtkT (PerformEventT t m)))
  (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
-> ReflexGtkT
     t
     m
     (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT
   t
   (TriggerEventT t (RunGtkT (PerformEventT t m)))
   (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
 -> ReflexGtkT
      t
      m
      (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a))
-> (IO a
    -> PostBuildT
         t
         (TriggerEventT t (RunGtkT (PerformEventT t m)))
         (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a))
-> IO a
-> ReflexGtkT
     t
     m
     (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a
-> PostBuildT
     t
     (TriggerEventT t (RunGtkT (PerformEventT t m)))
     (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
forall (m :: * -> *) a. MonadRunGtk m => IO a -> m (m a)
runGtkPromise

-- Lift an operation from 'RunGtkT' to 'ReflexGtkT'.
liftFromRunGtkT :: (ReflexHost t) => RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a
liftFromRunGtkT :: RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a
liftFromRunGtkT = PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
forall k t (m :: k) a.
PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
-> ReflexGtkT t m a
ReflexGtkT (PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
 -> ReflexGtkT t m a)
-> (RunGtkT (PerformEventT t m) a
    -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
-> RunGtkT (PerformEventT t m) a
-> ReflexGtkT t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TriggerEventT t (RunGtkT (PerformEventT t m)) a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TriggerEventT t (RunGtkT (PerformEventT t m)) a
 -> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a)
-> (RunGtkT (PerformEventT t m) a
    -> TriggerEventT t (RunGtkT (PerformEventT t m)) a)
-> RunGtkT (PerformEventT t m) a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunGtkT (PerformEventT t m) a
-> TriggerEventT t (RunGtkT (PerformEventT t m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Returns a function to fire synchronous or asynchronous event as
-- specified by the argument.
askMakeFireWith :: (ReflexHost t)
                => FireAsync
                -> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeFireWith :: FireAsync -> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeFireWith FireAsync = ((a -> IO () -> IO ()) -> a -> IO ())
-> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((a -> IO () -> IO ()) -> a -> IO ())
 -> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ()))
-> ((a -> IO () -> IO ()) -> a -> IO ())
-> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
forall a b. (a -> b) -> a -> b
$ \f :: a -> IO () -> IO ()
f x :: a
x -> a -> IO () -> IO ()
f a
x (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
askMakeFireWith FireSync = RunGtkT (PerformEventT t m) ((a -> IO () -> IO ()) -> a -> IO ())
-> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
forall k t (m :: k) a.
ReflexHost t =>
RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a
liftFromRunGtkT RunGtkT (PerformEventT t m) ((a -> IO () -> IO ()) -> a -> IO ())
forall (m :: * -> *) a.
Monad m =>
RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeSynchronousFire

instance ( ReflexHost t
         , MonadIO (HostFrame t)
         , MonadRef (HostFrame t)
         , Ref (HostFrame t) ~ Ref IO
         ) => MonadGtkSource t (ReflexGtkT t m) where
  eventFromSignalWith :: Registerer object info
-> FireAsync
-> object
-> SignalProxy object info
-> ((a -> IO ()) -> HaskellCallbackType info)
-> ReflexGtkT t m (Event t a)
eventFromSignalWith register :: Registerer object info
register sync :: FireAsync
sync object :: object
object signal :: SignalProxy object info
signal f :: (a -> IO ()) -> HaskellCallbackType info
f = do
    IO SignalHandlerId -> IO SignalHandlerId
runGtk' <- RunGtkT
  (PerformEventT t m) (IO SignalHandlerId -> IO SignalHandlerId)
-> ReflexGtkT t m (IO SignalHandlerId -> IO SignalHandlerId)
forall k t (m :: k) a.
ReflexHost t =>
RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a
liftFromRunGtkT RunGtkT
  (PerformEventT t m) (IO SignalHandlerId -> IO SignalHandlerId)
forall (m :: * -> *) a. Monad m => RunGtkT m (IO a -> IO a)
askRunGtk
    IO () -> IO ()
runGtk_' <- RunGtkT (PerformEventT t m) (IO () -> IO ())
-> ReflexGtkT t m (IO () -> IO ())
forall k t (m :: k) a.
ReflexHost t =>
RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a
liftFromRunGtkT RunGtkT (PerformEventT t m) (IO () -> IO ())
forall (m :: * -> *) a. Monad m => RunGtkT m (IO a -> IO ())
askRunGtk_
    (a -> IO () -> IO ()) -> a -> IO ()
makeSynchronousFire <- FireAsync -> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
forall k t (m :: k) a.
ReflexHost t =>
FireAsync -> ReflexGtkT t m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeFireWith FireAsync
sync
    ((a -> IO () -> IO ()) -> IO (IO ())) -> ReflexGtkT t m (Event t a)
forall t (m :: * -> *) a.
TriggerEvent t m =>
((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)
newEventWithLazyTriggerWithOnComplete (((a -> IO () -> IO ()) -> IO (IO ()))
 -> ReflexGtkT t m (Event t a))
-> ((a -> IO () -> IO ()) -> IO (IO ()))
-> ReflexGtkT t m (Event t a)
forall a b. (a -> b) -> a -> b
$ \fire :: a -> IO () -> IO ()
fire ->
      IO () -> IO ()
runGtk_' (IO () -> IO ())
-> (SignalHandlerId -> IO ()) -> SignalHandlerId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. object -> SignalHandlerId -> IO ()
forall o. GObject o => o -> SignalHandlerId -> IO ()
disconnectSignalHandler object
object
      (SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SignalHandlerId -> IO SignalHandlerId
runGtk' ( object
object Registerer object info
`register` SignalProxy object info
signal (HaskellCallbackType info -> IO SignalHandlerId)
-> HaskellCallbackType info -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
                    (a -> IO ()) -> HaskellCallbackType info
f ((a -> IO ()) -> HaskellCallbackType info)
-> (a -> IO ()) -> HaskellCallbackType info
forall a b. (a -> b) -> a -> b
$ \x :: a
x -> (a -> IO () -> IO ()) -> a -> IO ()
makeSynchronousFire a -> IO () -> IO ()
fire a
x
                  )

-- | The top-level entry point for reactive GTK applications.
--
-- You have to provide an existing 'Application' which will run the
-- GTK application. 'GI.Gtk.applicationRun' should not be called on
-- the Application manually, as this function expects to start the
-- mainloop by itself. However, apart from that, you may use the
-- 'Application' as you wish, for example by setting appropriate
-- 'GI.Gtk.ApplicationFlags', binding to its signals, assigning
-- 'GI.Gtk.Window's to it or changing its attributes.
runReflexGtk :: Application
             -- ^ The application to run the GTK mainloop on.
             -> Maybe [String]
             -- ^ The arguments to provide to 'GI.Gtk.applicationRun'
             -> (forall x. (HasSpiderTimeline x) => ReflexGtk x ())
             -- ^ The user-provided monadic action to set up your
             -- reactive network.
             -> IO Int32
             -- ^ The exit code as returned by 'GI.Gtk.applicationRun'
runReflexGtk :: Application
-> Maybe [String]
-> (forall x. HasSpiderTimeline x => ReflexGtk x ())
-> IO Int32
runReflexGtk app :: Application
app argv :: Maybe [String]
argv a :: forall x. HasSpiderTimeline x => ReflexGtk x ()
a = IO Int32 -> IO Int32
forall a. IO a -> IO a
runInBoundThread (IO Int32 -> IO Int32) -> IO Int32 -> IO Int32
forall a b. (a -> b) -> a -> b
$ do
  SignalHandlerId
_ <- Application
app Application
-> SignalProxy Application ApplicationStartupSignalInfo
-> HaskellCallbackType ApplicationStartupSignalInfo
-> IO SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> HaskellCallbackType info
-> m SignalHandlerId
`on` IsLabel
  "startup" (SignalProxy Application ApplicationStartupSignalInfo)
SignalProxy Application ApplicationStartupSignalInfo
#startup (HaskellCallbackType ApplicationStartupSignalInfo
 -> IO SignalHandlerId)
-> HaskellCallbackType ApplicationStartupSignalInfo
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
    (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO ())
-> HaskellCallbackType ApplicationStartupSignalInfo
forall r.
(forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r)
-> IO r
withSpiderTimeline
    ((forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO ())
 -> HaskellCallbackType ApplicationStartupSignalInfo)
-> (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO ())
-> HaskellCallbackType ApplicationStartupSignalInfo
forall a b. (a -> b) -> a -> b
$ \tl :: SpiderTimelineEnv x
tl -> (SpiderHost x () -> SpiderTimelineEnv x -> IO ())
-> SpiderTimelineEnv x -> SpiderHost x () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SpiderHost x () -> SpiderTimelineEnv x -> IO ()
forall x a. SpiderHost x a -> SpiderTimelineEnv x -> IO a
runSpiderHostForTimeline SpiderTimelineEnv x
tl (SpiderHost x () -> IO ()) -> SpiderHost x () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
eventChan <- IO
  (Chan
     [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
-> SpiderHost
     x
     (Chan
        [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO
  (Chan
     [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
forall a. IO (Chan a)
newChan
    rec
      let waitForEventThreadException :: STM SomeException
waitForEventThreadException =
            (SomeException -> SomeException)
-> (Void -> SomeException)
-> Either SomeException Void
-> SomeException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> SomeException
forall a. a -> a
id Void -> SomeException
forall a. Void -> a
absurd (Either SomeException Void -> SomeException)
-> STM (Either SomeException Void) -> STM SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async Void -> STM (Either SomeException Void)
forall a. Async a -> STM (Either SomeException a)
waitCatchSTM Async Void
eventThread

      (postBuildE :: Event (SpiderTimeline x) ()
postBuildE, postBuildTriggerRef :: IORef (Maybe (RootTrigger x ()))
postBuildTriggerRef) <- SpiderHost
  x (Event (SpiderTimeline x) (), IORef (Maybe (RootTrigger x ())))
forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef
      ((), FireCommand fireCommand :: forall a.
[DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) a -> SpiderHost x [a]
fireCommand) <-
        PerformEventT (SpiderTimeline x) (SpiderHost x) ()
-> SpiderHost x ((), FireCommand (SpiderTimeline x) (SpiderHost x))
forall t (m :: * -> *) a.
(Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m,
 Ref m ~ Ref IO) =>
PerformEventT t m a -> m (a, FireCommand t m)
hostPerformEventT (PerformEventT (SpiderTimeline x) (SpiderHost x) ()
 -> SpiderHost
      x ((), FireCommand (SpiderTimeline x) (SpiderHost x)))
-> PerformEventT (SpiderTimeline x) (SpiderHost x) ()
-> SpiderHost x ((), FireCommand (SpiderTimeline x) (SpiderHost x))
forall a b. (a -> b) -> a -> b
$
        IO Thread -> PerformEventT (SpiderTimeline x) (SpiderHost x) Thread
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Thread
getCurrentAsGtkThread
        PerformEventT (SpiderTimeline x) (SpiderHost x) Thread
-> (Thread -> PerformEventT (SpiderTimeline x) (SpiderHost x) ())
-> PerformEventT (SpiderTimeline x) (SpiderHost x) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RunGtkT (PerformEventT (SpiderTimeline x) (SpiderHost x)) ()
-> STM SomeException
-> Thread
-> PerformEventT (SpiderTimeline x) (SpiderHost x) ()
forall (m :: * -> *) a.
MonadIO m =>
RunGtkT m a -> STM SomeException -> Thread -> m a
runGtkT (
        TriggerEventT
  (SpiderTimeline x)
  (RunGtkT (PerformEventT (SpiderTimeline x) (SpiderHost x)))
  ()
-> Chan
     [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> RunGtkT (PerformEventT (SpiderTimeline x) (SpiderHost x)) ()
forall t (m :: * -> *) a.
TriggerEventT t m a
-> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
runTriggerEventT ( PostBuildT
  (SpiderTimeline x)
  (TriggerEventT
     (SpiderTimeline x)
     (RunGtkT (PerformEventT (SpiderTimeline x) (SpiderHost x))))
  ()
-> Event (SpiderTimeline x) ()
-> TriggerEventT
     (SpiderTimeline x)
     (RunGtkT (PerformEventT (SpiderTimeline x) (SpiderHost x)))
     ()
forall t (m :: * -> *) a. PostBuildT t m a -> Event t () -> m a
runPostBuildT (ReflexGtkT (SpiderTimeline x) (SpiderHost x) ()
-> PostBuildT
     (SpiderTimeline x)
     (TriggerEventT
        (SpiderTimeline x)
        (RunGtkT (PerformEventT (SpiderTimeline x) (SpiderHost x))))
     ()
forall t k (m :: k) a.
ReflexGtkT t m a
-> PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
unReflexGtkT ReflexGtkT (SpiderTimeline x) (SpiderHost x) ()
forall x. HasSpiderTimeline x => ReflexGtk x ()
a) Event (SpiderTimeline x) ()
postBuildE
                         ) Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
eventChan
        ) STM SomeException
waitForEventThreadException

      Ref (SpiderHost x) (Maybe (RootTrigger x ()))
-> SpiderHost x (Maybe (RootTrigger x ()))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (RootTrigger x ()))
Ref (SpiderHost x) (Maybe (RootTrigger x ()))
postBuildTriggerRef
        SpiderHost x (Maybe (RootTrigger x ()))
-> (Maybe (RootTrigger x ()) -> SpiderHost x ()) -> SpiderHost x ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (RootTrigger x () -> SpiderHost x [()])
-> Maybe (RootTrigger x ()) -> SpiderHost x ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\trigger :: RootTrigger x ()
trigger -> [DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) () -> SpiderHost x [()]
forall a.
[DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) a -> SpiderHost x [a]
fireCommand [RootTrigger x ()
trigger RootTrigger x () -> () -> DSum (RootTrigger x) Identity
forall (f :: * -> *) (tag :: * -> *) a.
Applicative f =>
tag a -> a -> DSum tag f
==> ()] (ReadPhase (SpiderHost x) () -> SpiderHost x [()])
-> ReadPhase (SpiderHost x) () -> SpiderHost x [()]
forall a b. (a -> b) -> a -> b
$ () -> ReadPhase x ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

      Async Void
eventThread <- IO (Async Void) -> SpiderHost x (Async Void)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async Void) -> SpiderHost x (Async Void))
-> IO (Async Void) -> SpiderHost x (Async Void)
forall a b. (a -> b) -> a -> b
$ IO Void -> IO (Async Void)
forall a. IO a -> IO (Async a)
async (IO Void -> IO (Async Void)) -> IO Void -> IO (Async Void)
forall a b. (a -> b) -> a -> b
$ (SpiderHost x Void -> SpiderTimelineEnv x -> IO Void)
-> SpiderTimelineEnv x -> SpiderHost x Void -> IO Void
forall a b c. (a -> b -> c) -> b -> a -> c
flip SpiderHost x Void -> SpiderTimelineEnv x -> IO Void
forall x a. SpiderHost x a -> SpiderTimelineEnv x -> IO a
runSpiderHostForTimeline SpiderTimelineEnv x
tl (SpiderHost x Void -> IO Void) -> SpiderHost x Void -> IO Void
forall a b. (a -> b) -> a -> b
$ (SpiderHost x Void -> SpiderHost x Void) -> SpiderHost x Void
forall a. (a -> a) -> a
fix ((SpiderHost x Void -> SpiderHost x Void) -> SpiderHost x Void)
-> (SpiderHost x Void -> SpiderHost x Void) -> SpiderHost x Void
forall a b. (a -> b) -> a -> b
$ \loop :: SpiderHost x Void
loop -> do
        [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
invocations <- IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> SpiderHost
     x [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
 -> SpiderHost
      x [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
-> IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> SpiderHost
     x [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
forall a b. (a -> b) -> a -> b
$ Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
forall a. Chan a -> IO a
readChan Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
eventChan
        [DSum (RootTrigger x) Identity]
triggers <-
          [Maybe (DSum (RootTrigger x) Identity)]
-> [DSum (RootTrigger x) Identity]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (DSum (RootTrigger x) Identity)]
 -> [DSum (RootTrigger x) Identity])
-> SpiderHost x [Maybe (DSum (RootTrigger x) Identity)]
-> SpiderHost x [DSum (RootTrigger x) Identity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          (DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation
 -> SpiderHost x (Maybe (DSum (RootTrigger x) Identity)))
-> [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> SpiderHost x [Maybe (DSum (RootTrigger x) Identity)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(triggerRef :: EventTriggerRef (SpiderTimeline x) a
triggerRef :=> TriggerInvocation x _) ->
                       (RootTrigger x a -> DSum (RootTrigger x) Identity)
-> Maybe (RootTrigger x a) -> Maybe (DSum (RootTrigger x) Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RootTrigger x a -> a -> DSum (RootTrigger x) Identity
forall (f :: * -> *) (tag :: * -> *) a.
Applicative f =>
tag a -> a -> DSum tag f
==> a
x) (Maybe (RootTrigger x a) -> Maybe (DSum (RootTrigger x) Identity))
-> SpiderHost x (Maybe (RootTrigger x a))
-> SpiderHost x (Maybe (DSum (RootTrigger x) Identity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ref (SpiderHost x) (Maybe (RootTrigger x a))
-> SpiderHost x (Maybe (RootTrigger x a))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef (EventTriggerRef (SpiderTimeline x) a
-> IORef (Maybe (EventTrigger (SpiderTimeline x) a))
forall t a. EventTriggerRef t a -> IORef (Maybe (EventTrigger t a))
unEventTriggerRef EventTriggerRef (SpiderTimeline x) a
triggerRef)
                   ) [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
invocations
        [()]
_ <- [DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) () -> SpiderHost x [()]
forall a.
[DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) a -> SpiderHost x [a]
fireCommand [DSum (RootTrigger x) Identity]
[DSum (EventTrigger (SpiderTimeline x)) Identity]
triggers (ReadPhase (SpiderHost x) () -> SpiderHost x [()])
-> ReadPhase (SpiderHost x) () -> SpiderHost x [()]
forall a b. (a -> b) -> a -> b
$ () -> ReadPhase x ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        IO () -> SpiderHost x ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpiderHost x ()) -> IO () -> SpiderHost x ()
forall a b. (a -> b) -> a -> b
$ (DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation
 -> IO ())
-> [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(_ :=> (TriggerInvocation _ done)) -> IO ()
done) [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
invocations
        SpiderHost x Void
loop
    () -> SpiderHost x ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  #run app argv

-- | Like myThreadId, but returns a GLib 'Thread' combined with the
-- assertion that the current thread is bound.
getCurrentAsGtkThread :: IO Thread
getCurrentAsGtkThread :: IO Thread
getCurrentAsGtkThread = do
  Bool
iAmBound <- IO Bool
isCurrentThreadBound
  if Bool
iAmBound
    then IO Thread
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Thread
threadSelf
    else String -> IO Thread
forall a. HasCallStack => String -> a
error "getCurrentAsGtkThread: Can't be GTK thread, because I am not bound"