-- 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 GeneralizedNewtypeDeriving, RecordWildCards, UndecidableInstances, TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}

module Reflex.GI.Gtk.Run.Base
  ( RunGtkT
  , runGtkT
  , askRunGtk
  , askRunGtk_
  , askRunGtkPromise
  , askMakeSynchronousFire
  ) where

import Control.Concurrent ( isCurrentThreadBound
                          , newEmptyMVar
                          , putMVar
                          , readMVar
                          )
import Control.Concurrent.STM.TChan ( TChan
                                    , newTChanIO
                                    , readTChan
                                    , tryReadTChan
                                    , writeTChan
                                    )
import Control.Concurrent.STM.TVar ( newTVarIO
                                   , readTVar
                                   , writeTVar
                                   )
import Control.Exception ( SomeException
                         , catch
                         , mask_
                         , throwIO
                         , try
                         )
import Control.Monad ( join
                     , void
                     )
import Control.Monad.Exception (MonadException)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class ( MonadIO
                              , liftIO
                              )
import Control.Monad.Reader ( ReaderT
                            , asks
                            , runReaderT
                            )
import Control.Monad.Ref (MonadRef)
import Control.Monad.STM ( STM
                         , atomically
                         , orElse
                         , retry
                         , throwSTM
                         )
import Control.Monad.Trans (MonadTrans)
import Data.Function (fix)
import GI.GLib ( Thread
               , threadSelf
               )
import GI.GLib.Constants ( pattern PRIORITY_HIGH_IDLE
                         , pattern SOURCE_REMOVE
                         )
import GI.Gdk (threadsAddIdle)
import Reflex ( Adjustable( runWithReplace
                          , traverseIntMapWithKeyWithAdjust
                          , traverseDMapWithKeyWithAdjust
                          , traverseDMapWithKeyWithAdjustWithMove
                          )
              , MonadHold
              , MonadSample
              , NotReady( notReady
                        , notReadyUntil
                        )
              , PerformEvent( Performable
                            , performEvent
                            , performEvent_
                            )
              , PerformEventT
              )
import Reflex.GI.Gtk.Run.Class (MonadRunGtk( runGtk
                                           , runGtk_
                                           , runGtkPromise
                                           )
                               )
import Reflex.Host.Class ( MonadReflexCreateTrigger
                         , MonadReflexHost
                         , MonadSubscribeEvent
                         , ReflexHost
                         )

data RunGtkEnv = RunGtkEnv
  { RunGtkEnv -> TChan (IO ())
actionQueue :: TChan (IO ())
  , RunGtkEnv -> Thread
gtkThread :: Thread
  , RunGtkEnv -> STM SomeException
waitEventThreadException :: STM SomeException
  }

newtype RunGtkT m a = RunGtkT
  { RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT :: ReaderT RunGtkEnv m a
  }
  deriving ( a -> RunGtkT m b -> RunGtkT m a
(a -> b) -> RunGtkT m a -> RunGtkT m b
(forall a b. (a -> b) -> RunGtkT m a -> RunGtkT m b)
-> (forall a b. a -> RunGtkT m b -> RunGtkT m a)
-> Functor (RunGtkT m)
forall a b. a -> RunGtkT m b -> RunGtkT m a
forall a b. (a -> b) -> RunGtkT m a -> RunGtkT m b
forall (m :: * -> *) a b.
Functor m =>
a -> RunGtkT m b -> RunGtkT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RunGtkT m a -> RunGtkT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RunGtkT m b -> RunGtkT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RunGtkT m b -> RunGtkT m a
fmap :: (a -> b) -> RunGtkT m a -> RunGtkT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RunGtkT m a -> RunGtkT m b
Functor
           , Functor (RunGtkT m)
a -> RunGtkT m a
Functor (RunGtkT m) =>
(forall a. a -> RunGtkT m a)
-> (forall a b. RunGtkT m (a -> b) -> RunGtkT m a -> RunGtkT m b)
-> (forall a b c.
    (a -> b -> c) -> RunGtkT m a -> RunGtkT m b -> RunGtkT m c)
-> (forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m b)
-> (forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m a)
-> Applicative (RunGtkT m)
RunGtkT m a -> RunGtkT m b -> RunGtkT m b
RunGtkT m a -> RunGtkT m b -> RunGtkT m a
RunGtkT m (a -> b) -> RunGtkT m a -> RunGtkT m b
(a -> b -> c) -> RunGtkT m a -> RunGtkT m b -> RunGtkT m c
forall a. a -> RunGtkT m a
forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m a
forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m b
forall a b. RunGtkT m (a -> b) -> RunGtkT m a -> RunGtkT m b
forall a b c.
(a -> b -> c) -> RunGtkT m a -> RunGtkT m b -> RunGtkT 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
forall (m :: * -> *). Applicative m => Functor (RunGtkT m)
forall (m :: * -> *) a. Applicative m => a -> RunGtkT m a
forall (m :: * -> *) a b.
Applicative m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m a
forall (m :: * -> *) a b.
Applicative m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m b
forall (m :: * -> *) a b.
Applicative m =>
RunGtkT m (a -> b) -> RunGtkT m a -> RunGtkT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> RunGtkT m a -> RunGtkT m b -> RunGtkT m c
<* :: RunGtkT m a -> RunGtkT m b -> RunGtkT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m a
*> :: RunGtkT m a -> RunGtkT m b -> RunGtkT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m b
liftA2 :: (a -> b -> c) -> RunGtkT m a -> RunGtkT m b -> RunGtkT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> RunGtkT m a -> RunGtkT m b -> RunGtkT m c
<*> :: RunGtkT m (a -> b) -> RunGtkT m a -> RunGtkT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
RunGtkT m (a -> b) -> RunGtkT m a -> RunGtkT m b
pure :: a -> RunGtkT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> RunGtkT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (RunGtkT m)
Applicative
           , Applicative (RunGtkT m)
a -> RunGtkT m a
Applicative (RunGtkT m) =>
(forall a b. RunGtkT m a -> (a -> RunGtkT m b) -> RunGtkT m b)
-> (forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m b)
-> (forall a. a -> RunGtkT m a)
-> Monad (RunGtkT m)
RunGtkT m a -> (a -> RunGtkT m b) -> RunGtkT m b
RunGtkT m a -> RunGtkT m b -> RunGtkT m b
forall a. a -> RunGtkT m a
forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m b
forall a b. RunGtkT m a -> (a -> RunGtkT m b) -> RunGtkT m b
forall (m :: * -> *). Monad m => Applicative (RunGtkT m)
forall (m :: * -> *) a. Monad m => a -> RunGtkT m a
forall (m :: * -> *) a b.
Monad m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m b
forall (m :: * -> *) a b.
Monad m =>
RunGtkT m a -> (a -> RunGtkT m b) -> RunGtkT 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 -> RunGtkT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> RunGtkT m a
>> :: RunGtkT m a -> RunGtkT m b -> RunGtkT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m b
>>= :: RunGtkT m a -> (a -> RunGtkT m b) -> RunGtkT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RunGtkT m a -> (a -> RunGtkT m b) -> RunGtkT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (RunGtkT m)
Monad
           , m a -> RunGtkT m a
(forall (m :: * -> *) a. Monad m => m a -> RunGtkT m a)
-> MonadTrans RunGtkT
forall (m :: * -> *) a. Monad m => m a -> RunGtkT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> RunGtkT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> RunGtkT m a
MonadTrans
           , Monad (RunGtkT m)
Monad (RunGtkT m) =>
(forall a. IO a -> RunGtkT m a) -> MonadIO (RunGtkT m)
IO a -> RunGtkT m a
forall a. IO a -> RunGtkT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (RunGtkT m)
forall (m :: * -> *) a. MonadIO m => IO a -> RunGtkT m a
liftIO :: IO a -> RunGtkT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> RunGtkT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (RunGtkT m)
MonadIO
           , Monad (RunGtkT m)
a -> RunGtkT m (Ref (RunGtkT m) a)
Monad (RunGtkT m) =>
(forall a. a -> RunGtkT m (Ref (RunGtkT m) a))
-> (forall a. Ref (RunGtkT m) a -> RunGtkT m a)
-> (forall a. Ref (RunGtkT m) a -> a -> RunGtkT m ())
-> (forall a. Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ())
-> (forall a. Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ())
-> MonadRef (RunGtkT m)
Ref (RunGtkT m) a -> RunGtkT m a
Ref (RunGtkT m) a -> a -> RunGtkT m ()
Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
forall a. a -> RunGtkT m (Ref (RunGtkT m) a)
forall a. Ref (RunGtkT m) a -> RunGtkT m a
forall a. Ref (RunGtkT m) a -> a -> RunGtkT m ()
forall a. Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
forall (m :: * -> *).
Monad m =>
(forall a. a -> m (Ref m a))
-> (forall a. Ref m a -> m a)
-> (forall a. Ref m a -> a -> m ())
-> (forall a. Ref m a -> (a -> a) -> m ())
-> (forall a. Ref m a -> (a -> a) -> m ())
-> MonadRef m
forall (m :: * -> *). MonadRef m => Monad (RunGtkT m)
forall (m :: * -> *) a.
MonadRef m =>
a -> RunGtkT m (Ref (RunGtkT m) a)
forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> RunGtkT m a
forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> a -> RunGtkT m ()
forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
modifyRef' :: Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
$cmodifyRef' :: forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
modifyRef :: Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
$cmodifyRef :: forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> (a -> a) -> RunGtkT m ()
writeRef :: Ref (RunGtkT m) a -> a -> RunGtkT m ()
$cwriteRef :: forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> a -> RunGtkT m ()
readRef :: Ref (RunGtkT m) a -> RunGtkT m a
$creadRef :: forall (m :: * -> *) a.
MonadRef m =>
Ref (RunGtkT m) a -> RunGtkT m a
newRef :: a -> RunGtkT m (Ref (RunGtkT m) a)
$cnewRef :: forall (m :: * -> *) a.
MonadRef m =>
a -> RunGtkT m (Ref (RunGtkT m) a)
$cp1MonadRef :: forall (m :: * -> *). MonadRef m => Monad (RunGtkT m)
MonadRef
           , Monad (RunGtkT m)
e -> RunGtkT m a
Monad (RunGtkT m) =>
(forall e a. Exception e => e -> RunGtkT m a)
-> (forall e a.
    Exception e =>
    RunGtkT m a -> (e -> RunGtkT m a) -> RunGtkT m a)
-> (forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m a)
-> MonadException (RunGtkT m)
RunGtkT m a -> (e -> RunGtkT m a) -> RunGtkT m a
RunGtkT m a -> RunGtkT m b -> RunGtkT m a
forall e a. Exception e => e -> RunGtkT m a
forall e a.
Exception e =>
RunGtkT m a -> (e -> RunGtkT m a) -> RunGtkT m a
forall a b. RunGtkT m a -> RunGtkT m b -> RunGtkT m a
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a)
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> (forall a b. m a -> m b -> m a)
-> MonadException m
forall (m :: * -> *). MonadException m => Monad (RunGtkT m)
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> RunGtkT m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
RunGtkT m a -> (e -> RunGtkT m a) -> RunGtkT m a
forall (m :: * -> *) a b.
MonadException m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m a
finally :: RunGtkT m a -> RunGtkT m b -> RunGtkT m a
$cfinally :: forall (m :: * -> *) a b.
MonadException m =>
RunGtkT m a -> RunGtkT m b -> RunGtkT m a
catch :: RunGtkT m a -> (e -> RunGtkT m a) -> RunGtkT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
RunGtkT m a -> (e -> RunGtkT m a) -> RunGtkT m a
throw :: e -> RunGtkT m a
$cthrow :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> RunGtkT m a
$cp1MonadException :: forall (m :: * -> *). MonadException m => Monad (RunGtkT m)
MonadException
           , Monad (RunGtkT m)
Monad (RunGtkT m) =>
(forall a. (a -> RunGtkT m a) -> RunGtkT m a)
-> MonadFix (RunGtkT m)
(a -> RunGtkT m a) -> RunGtkT m a
forall a. (a -> RunGtkT m a) -> RunGtkT m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (RunGtkT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> RunGtkT m a) -> RunGtkT m a
mfix :: (a -> RunGtkT m a) -> RunGtkT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> RunGtkT m a) -> RunGtkT m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (RunGtkT m)
MonadFix
           )

deriving instance MonadSubscribeEvent t m => MonadSubscribeEvent t (RunGtkT m)
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RunGtkT m)
deriving instance MonadReflexHost t m => MonadReflexHost t (RunGtkT m)
deriving instance MonadSample t m => MonadSample t (RunGtkT m)
deriving instance MonadHold t m => MonadHold t (RunGtkT m)
deriving instance NotReady t m => NotReady t (RunGtkT m)

instance Adjustable t m => Adjustable t (RunGtkT m) where
  runWithReplace :: RunGtkT m a -> Event t (RunGtkT m b) -> RunGtkT m (a, Event t b)
runWithReplace (RunGtkT a :: ReaderT RunGtkEnv m a
a) e :: Event t (RunGtkT m b)
e = ReaderT RunGtkEnv m (a, Event t b) -> RunGtkT m (a, Event t b)
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (a, Event t b) -> RunGtkT m (a, Event t b))
-> ReaderT RunGtkEnv m (a, Event t b) -> RunGtkT m (a, Event t b)
forall a b. (a -> b) -> a -> b
$ ReaderT RunGtkEnv m a
-> Event t (ReaderT RunGtkEnv m b)
-> ReaderT RunGtkEnv 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 ReaderT RunGtkEnv m a
a (Event t (ReaderT RunGtkEnv m b)
 -> ReaderT RunGtkEnv m (a, Event t b))
-> Event t (ReaderT RunGtkEnv m b)
-> ReaderT RunGtkEnv m (a, Event t b)
forall a b. (a -> b) -> a -> b
$ RunGtkT m b -> ReaderT RunGtkEnv m b
forall (m :: * -> *) a. RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT (RunGtkT m b -> ReaderT RunGtkEnv m b)
-> Event t (RunGtkT m b) -> Event t (ReaderT RunGtkEnv m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t (RunGtkT m b)
e
  traverseIntMapWithKeyWithAdjust :: (Key -> v -> RunGtkT m v')
-> IntMap v
-> Event t (PatchIntMap v)
-> RunGtkT m (IntMap v', Event t (PatchIntMap v'))
traverseIntMapWithKeyWithAdjust f :: Key -> v -> RunGtkT m v'
f m :: IntMap v
m a :: Event t (PatchIntMap v)
a = ReaderT RunGtkEnv m (IntMap v', Event t (PatchIntMap v'))
-> RunGtkT m (IntMap v', Event t (PatchIntMap v'))
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (IntMap v', Event t (PatchIntMap v'))
 -> RunGtkT m (IntMap v', Event t (PatchIntMap v')))
-> ReaderT RunGtkEnv m (IntMap v', Event t (PatchIntMap v'))
-> RunGtkT m (IntMap v', Event t (PatchIntMap v'))
forall a b. (a -> b) -> a -> b
$ (Key -> v -> ReaderT RunGtkEnv m v')
-> IntMap v
-> Event t (PatchIntMap v)
-> ReaderT RunGtkEnv 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 Key -> v -> ReaderT RunGtkEnv m v'
f' IntMap v
m Event t (PatchIntMap v)
a
    where f' :: Key -> v -> ReaderT RunGtkEnv m v'
f' k :: Key
k v :: v
v = RunGtkT m v' -> ReaderT RunGtkEnv m v'
forall (m :: * -> *) a. RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT (RunGtkT m v' -> ReaderT RunGtkEnv m v')
-> RunGtkT m v' -> ReaderT RunGtkEnv m v'
forall a b. (a -> b) -> a -> b
$ Key -> v -> RunGtkT m v'
f Key
k v
v
  traverseDMapWithKeyWithAdjust :: (forall a. k a -> v a -> RunGtkT m (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> RunGtkT m (DMap k v', Event t (PatchDMap k v'))
traverseDMapWithKeyWithAdjust f :: forall a. k a -> v a -> RunGtkT m (v' a)
f m :: DMap k v
m e :: Event t (PatchDMap k v)
e =
    ReaderT RunGtkEnv m (DMap k v', Event t (PatchDMap k v'))
-> RunGtkT m (DMap k v', Event t (PatchDMap k v'))
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (DMap k v', Event t (PatchDMap k v'))
 -> RunGtkT m (DMap k v', Event t (PatchDMap k v')))
-> ReaderT RunGtkEnv m (DMap k v', Event t (PatchDMap k v'))
-> RunGtkT m (DMap k v', Event t (PatchDMap k v'))
forall a b. (a -> b) -> a -> b
$ (forall a. k a -> v a -> ReaderT RunGtkEnv m (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> ReaderT RunGtkEnv 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 -> RunGtkT m (v' a) -> ReaderT RunGtkEnv m (v' a)
forall (m :: * -> *) a. RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT (RunGtkT m (v' a) -> ReaderT RunGtkEnv m (v' a))
-> RunGtkT m (v' a) -> ReaderT RunGtkEnv m (v' a)
forall a b. (a -> b) -> a -> b
$ k a -> v a -> RunGtkT m (v' a)
forall a. k a -> v a -> RunGtkT m (v' a)
f k a
k v a
v) DMap k v
m Event t (PatchDMap k v)
e
  traverseDMapWithKeyWithAdjustWithMove :: (forall a. k a -> v a -> RunGtkT m (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> RunGtkT m (DMap k v', Event t (PatchDMapWithMove k v'))
traverseDMapWithKeyWithAdjustWithMove f :: forall a. k a -> v a -> RunGtkT m (v' a)
f m :: DMap k v
m e :: Event t (PatchDMapWithMove k v)
e =
    ReaderT RunGtkEnv m (DMap k v', Event t (PatchDMapWithMove k v'))
-> RunGtkT m (DMap k v', Event t (PatchDMapWithMove k v'))
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (DMap k v', Event t (PatchDMapWithMove k v'))
 -> RunGtkT m (DMap k v', Event t (PatchDMapWithMove k v')))
-> ReaderT
     RunGtkEnv m (DMap k v', Event t (PatchDMapWithMove k v'))
-> RunGtkT m (DMap k v', Event t (PatchDMapWithMove k v'))
forall a b. (a -> b) -> a -> b
$ (forall a. k a -> v a -> ReaderT RunGtkEnv m (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> ReaderT
     RunGtkEnv 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 -> RunGtkT m (v' a) -> ReaderT RunGtkEnv m (v' a)
forall (m :: * -> *) a. RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT (RunGtkT m (v' a) -> ReaderT RunGtkEnv m (v' a))
-> RunGtkT m (v' a) -> ReaderT RunGtkEnv m (v' a)
forall a b. (a -> b) -> a -> b
$ k a -> v a -> RunGtkT m (v' a)
forall a. k a -> v a -> RunGtkT m (v' a)
f k a
k v a
v) DMap k v
m Event t (PatchDMapWithMove k v)
e

instance PerformEvent t m => PerformEvent t (RunGtkT m) where
  type Performable (RunGtkT m) = RunGtkT (Performable m)
  performEvent :: Event t (Performable (RunGtkT m) a) -> RunGtkT m (Event t a)
performEvent = ReaderT RunGtkEnv m (Event t a) -> RunGtkT m (Event t a)
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (Event t a) -> RunGtkT m (Event t a))
-> (Event t (RunGtkT (Performable m) a)
    -> ReaderT RunGtkEnv m (Event t a))
-> Event t (RunGtkT (Performable m) a)
-> RunGtkT m (Event t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event t (ReaderT RunGtkEnv (Performable m) a)
-> ReaderT RunGtkEnv m (Event t a)
forall t (m :: * -> *) a.
PerformEvent t m =>
Event t (Performable m a) -> m (Event t a)
performEvent (Event t (ReaderT RunGtkEnv (Performable m) a)
 -> ReaderT RunGtkEnv m (Event t a))
-> (Event t (RunGtkT (Performable m) a)
    -> Event t (ReaderT RunGtkEnv (Performable m) a))
-> Event t (RunGtkT (Performable m) a)
-> ReaderT RunGtkEnv m (Event t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RunGtkT (Performable m) a -> ReaderT RunGtkEnv (Performable m) a)
-> Event t (RunGtkT (Performable m) a)
-> Event t (ReaderT RunGtkEnv (Performable m) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunGtkT (Performable m) a -> ReaderT RunGtkEnv (Performable m) a
forall (m :: * -> *) a. RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT
  performEvent_ :: Event t (Performable (RunGtkT m) ()) -> RunGtkT m ()
performEvent_ = ReaderT RunGtkEnv m () -> RunGtkT m ()
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m () -> RunGtkT m ())
-> (Event t (RunGtkT (Performable m) ()) -> ReaderT RunGtkEnv m ())
-> Event t (RunGtkT (Performable m) ())
-> RunGtkT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event t (ReaderT RunGtkEnv (Performable m) ())
-> ReaderT RunGtkEnv m ()
forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
performEvent_ (Event t (ReaderT RunGtkEnv (Performable m) ())
 -> ReaderT RunGtkEnv m ())
-> (Event t (RunGtkT (Performable m) ())
    -> Event t (ReaderT RunGtkEnv (Performable m) ()))
-> Event t (RunGtkT (Performable m) ())
-> ReaderT RunGtkEnv m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RunGtkT (Performable m) ()
 -> ReaderT RunGtkEnv (Performable m) ())
-> Event t (RunGtkT (Performable m) ())
-> Event t (ReaderT RunGtkEnv (Performable m) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunGtkT (Performable m) () -> ReaderT RunGtkEnv (Performable m) ()
forall (m :: * -> *) a. RunGtkT m a -> ReaderT RunGtkEnv m a
unGtkT

instance (MonadIO m) => MonadRunGtk (RunGtkT m) where
  runGtk :: IO a -> RunGtkT m a
runGtk a :: IO a
a = RunGtkT m (IO a -> IO a)
forall (m :: * -> *) a. Monad m => RunGtkT m (IO a -> IO a)
askRunGtk RunGtkT m (IO a -> IO a)
-> ((IO a -> IO a) -> RunGtkT m a) -> RunGtkT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> RunGtkT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RunGtkT m a)
-> ((IO a -> IO a) -> IO a) -> (IO a -> IO a) -> RunGtkT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$IO a
a)
  runGtk_ :: IO a -> RunGtkT m ()
runGtk_ a :: IO a
a = RunGtkT m (IO a -> IO ())
forall (m :: * -> *) a. Monad m => RunGtkT m (IO a -> IO ())
askRunGtk_ RunGtkT m (IO a -> IO ())
-> ((IO a -> IO ()) -> RunGtkT m ()) -> RunGtkT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> RunGtkT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RunGtkT m ())
-> ((IO a -> IO ()) -> IO ()) -> (IO a -> IO ()) -> RunGtkT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$IO a
a)
  runGtkPromise :: IO a -> RunGtkT m (RunGtkT m a)
runGtkPromise a :: IO a
a = RunGtkT m (IO a -> IO (IO a))
forall (m :: * -> *) a. Monad m => RunGtkT m (IO a -> IO (IO a))
askRunGtkPromise RunGtkT m (IO a -> IO (IO a))
-> ((IO a -> IO (IO a)) -> RunGtkT m (RunGtkT m a))
-> RunGtkT m (RunGtkT m a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (RunGtkT m a) -> RunGtkT m (RunGtkT m a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RunGtkT m a) -> RunGtkT m (RunGtkT m a))
-> ((IO a -> IO (IO a)) -> IO (RunGtkT m a))
-> (IO a -> IO (IO a))
-> RunGtkT m (RunGtkT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO a -> RunGtkT m a) -> IO (IO a) -> IO (RunGtkT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IO a -> RunGtkT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO a) -> IO (RunGtkT m a))
-> ((IO a -> IO (IO a)) -> IO (IO a))
-> (IO a -> IO (IO a))
-> IO (RunGtkT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$IO a
a)

askRunGtk :: (Monad m) => RunGtkT m (IO a -> IO a)
askRunGtk :: RunGtkT m (IO a -> IO a)
askRunGtk = (IO (IO a) -> IO a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO a) -> IO a) -> (IO a -> IO (IO a)) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((IO a -> IO (IO a)) -> IO a -> IO a)
-> RunGtkT m (IO a -> IO (IO a)) -> RunGtkT m (IO a -> IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunGtkT m (IO a -> IO (IO a))
forall (m :: * -> *) a. Monad m => RunGtkT m (IO a -> IO (IO a))
askRunGtkPromise

askRunGtk_ :: (Monad m) => RunGtkT m (IO a -> IO ())
askRunGtk_ :: RunGtkT m (IO a -> IO ())
askRunGtk_ = do
  TChan (IO ())
actionChan <- ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ()))
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ())))
-> ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ()))
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> TChan (IO ())) -> ReaderT RunGtkEnv m (TChan (IO ()))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> TChan (IO ())
actionQueue
  Thread
gtkThread' <- ReaderT RunGtkEnv m Thread -> RunGtkT m Thread
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m Thread -> RunGtkT m Thread)
-> ReaderT RunGtkEnv m Thread -> RunGtkT m Thread
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> Thread) -> ReaderT RunGtkEnv m Thread
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> Thread
gtkThread
  (IO a -> IO ()) -> RunGtkT m (IO a -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((IO a -> IO ()) -> RunGtkT m (IO a -> IO ()))
-> (IO a -> IO ()) -> RunGtkT m (IO a -> IO ())
forall a b. (a -> b) -> a -> b
$ \a :: IO a
a -> do
    Bool
iAmGuiThread <- Thread -> IO Bool
isThreadMe Thread
gtkThread'
    let execute :: IO () -> IO ()
execute = if Bool
iAmGuiThread
                  then IO () -> IO ()
forall a. a -> a
id
                  else TChan (IO ()) -> IO () -> IO ()
scheduleAction TChan (IO ())
actionChan
    IO () -> IO ()
execute (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO a
a

askRunGtkPromise :: (Monad m) => RunGtkT m (IO a -> IO (IO a))
askRunGtkPromise :: RunGtkT m (IO a -> IO (IO a))
askRunGtkPromise = do
    TChan (IO ())
actionQueue <- ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ()))
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ())))
-> ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ()))
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> TChan (IO ())) -> ReaderT RunGtkEnv m (TChan (IO ()))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> TChan (IO ())
actionQueue
    Thread
gtkThread' <- ReaderT RunGtkEnv m Thread -> RunGtkT m Thread
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m Thread -> RunGtkT m Thread)
-> ReaderT RunGtkEnv m Thread -> RunGtkT m Thread
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> Thread) -> ReaderT RunGtkEnv m Thread
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> Thread
gtkThread
    (IO a -> IO (IO a)) -> RunGtkT m (IO a -> IO (IO a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((IO a -> IO (IO a)) -> RunGtkT m (IO a -> IO (IO a)))
-> (IO a -> IO (IO a)) -> RunGtkT m (IO a -> IO (IO a))
forall a b. (a -> b) -> a -> b
$ \a :: IO a
a -> do
      Bool
iAmGtkThread <- Thread -> IO Bool
isThreadMe Thread
gtkThread'
      if Bool
iAmGtkThread
        then a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> IO a -> IO (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
a
        else do
        MVar (Either SomeException a)
answerMVar <- IO (MVar (Either SomeException a))
forall a. IO (MVar a)
newEmptyMVar
        TChan (IO ()) -> IO () -> IO ()
scheduleAction TChan (IO ())
actionQueue (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException IO a
a IO (Either SomeException a)
-> (Either SomeException a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException a) -> Either SomeException a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException a)
answerMVar
        IO a -> IO (IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ MVar (Either SomeException a) -> IO (Either SomeException a)
forall a. MVar a -> IO a
readMVar MVar (Either SomeException a)
answerMVar IO (Either SomeException a)
-> (Either SomeException a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO a)
-> (a -> IO a) -> Either SomeException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

askMakeSynchronousFire :: (Monad m) => RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeSynchronousFire :: RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeSynchronousFire = do
    TChan (IO ())
actionChan <- ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ()))
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ())))
-> ReaderT RunGtkEnv m (TChan (IO ())) -> RunGtkT m (TChan (IO ()))
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> TChan (IO ())) -> ReaderT RunGtkEnv m (TChan (IO ()))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> TChan (IO ())
actionQueue
    STM SomeException
waitEventThreadException' <- ReaderT RunGtkEnv m (STM SomeException)
-> RunGtkT m (STM SomeException)
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m (STM SomeException)
 -> RunGtkT m (STM SomeException))
-> ReaderT RunGtkEnv m (STM SomeException)
-> RunGtkT m (STM SomeException)
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> STM SomeException)
-> ReaderT RunGtkEnv m (STM SomeException)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> STM SomeException
waitEventThreadException
    Thread
gtkThread' <- ReaderT RunGtkEnv m Thread -> RunGtkT m Thread
forall (m :: * -> *) a. ReaderT RunGtkEnv m a -> RunGtkT m a
RunGtkT (ReaderT RunGtkEnv m Thread -> RunGtkT m Thread)
-> ReaderT RunGtkEnv m Thread -> RunGtkT m Thread
forall a b. (a -> b) -> a -> b
$ (RunGtkEnv -> Thread) -> ReaderT RunGtkEnv m Thread
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RunGtkEnv -> Thread
gtkThread
    ((a -> IO () -> IO ()) -> a -> IO ())
-> RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((a -> IO () -> IO ()) -> a -> IO ())
 -> RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ()))
-> ((a -> IO () -> IO ()) -> a -> IO ())
-> RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ())
forall a b. (a -> b) -> a -> b
$ \fireAsynchronously :: a -> IO () -> IO ()
fireAsynchronously x :: a
x -> do
      TVar Bool
firedTVar <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
      a -> IO () -> IO ()
fireAsynchronously a
x (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
firedTVar Bool
True
      let waitCompleted :: STM ()
waitCompleted = do
            Bool
hasFired <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
firedTVar
            if Bool
hasFired
              then () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              else STM ()
forall a. STM a
retry
      Bool
iAmGtkThread <- Thread -> IO Bool
isThreadMe Thread
gtkThread'
      (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \loop :: IO ()
loop -> IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
        (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () IO () -> STM () -> STM (IO ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM ()
waitCompleted)
        STM (IO ()) -> STM (IO ()) -> STM (IO ())
forall a. STM a -> STM a -> STM a
`orElse` ( if Bool
iAmGtkThread
                   then do
                     IO ()
gtkAction <- TChan (IO ()) -> STM (IO ())
forall a. TChan a -> STM a
readTChan TChan (IO ())
actionChan
                     IO () -> STM (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
runGtkAction IO ()
gtkAction IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
                   else STM (IO ())
forall a. STM a
retry -- If we're run outside the GTK thread,
                              -- we shouldn't runGTk actions.
                 )
        STM (IO ()) -> STM (IO ()) -> STM (IO ())
forall a. STM a -> STM a -> STM a
`orElse` (STM SomeException
waitEventThreadException' STM SomeException -> (SomeException -> STM (IO ())) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SomeException -> STM (IO ())
forall e a. Exception e => e -> STM a
throwSTM)

isThreadMe :: Thread -> IO Bool
isThreadMe :: Thread -> IO Bool
isThreadMe refThread :: Thread
refThread = do
  Bool
iAmBound <- IO Bool
isCurrentThreadBound
  if Bool
iAmBound
    then do
    Thread
myThread <- IO Thread
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Thread
threadSelf
    Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Thread
myThread Thread -> Thread -> Bool
forall a. Eq a => a -> a -> Bool
== Thread
refThread
    else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False -- If we are not bound, we can't reliably be any
                    -- OS thread.

scheduleAction :: TChan (IO ()) -> IO () -> IO ()
scheduleAction :: TChan (IO ()) -> IO () -> IO ()
scheduleAction actionChan :: TChan (IO ())
actionChan action :: IO ()
action =
  STM () -> IO ()
forall a. STM a -> IO a
atomically (TChan (IO ()) -> IO () -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (IO ())
actionChan IO ()
action)
  IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ( Int32 -> IO Bool -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> IO Bool -> m Word32
threadsAddIdle Int32
PRIORITY_HIGH_IDLE (IO Bool -> IO Word32) -> IO Bool -> IO Word32
forall a b. (a -> b) -> a -> b
$
            Bool
SOURCE_REMOVE Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TChan (IO ()) -> IO ()
runScheduledActions TChan (IO ())
actionChan
          )

runScheduledActions :: TChan (IO ()) -> IO ()
runScheduledActions :: TChan (IO ()) -> IO ()
runScheduledActions actionChan :: TChan (IO ())
actionChan =
  STM (Maybe (IO ())) -> IO (Maybe (IO ()))
forall a. STM a -> IO a
atomically (TChan (IO ()) -> STM (Maybe (IO ()))
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (IO ())
actionChan)
  IO (Maybe (IO ())) -> (Maybe (IO ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO () -> IO ()) -> Maybe (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\gtkAction :: IO ()
gtkAction -> IO () -> IO ()
runGtkAction IO ()
gtkAction IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TChan (IO ()) -> IO ()
runScheduledActions TChan (IO ())
actionChan)

runGtkAction :: IO () -> IO ()
runGtkAction :: IO () -> IO ()
runGtkAction a :: IO ()
a = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
a (IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> SomeException -> IO ())
-> IO () -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () :: SomeException -> IO ())

runGtkT :: (MonadIO m)
        => RunGtkT m a
        -> STM SomeException
        -> Thread
        -> m a
runGtkT :: RunGtkT m a -> STM SomeException -> Thread -> m a
runGtkT (RunGtkT a :: ReaderT RunGtkEnv m a
a) waitEventThreadException :: STM SomeException
waitEventThreadException gtkThread :: Thread
gtkThread = do
  TChan (IO ())
actionQueue <- IO (TChan (IO ())) -> m (TChan (IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan (IO ()))
forall a. IO (TChan a)
newTChanIO
  ReaderT RunGtkEnv m a -> RunGtkEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT RunGtkEnv m a
a RunGtkEnv :: TChan (IO ()) -> Thread -> STM SomeException -> RunGtkEnv
RunGtkEnv{..}

instance ( NotReady t m
         , ReflexHost t
         ) => NotReady t (PerformEventT t (RunGtkT m)) where
  notReady :: PerformEventT t (RunGtkT m) ()
notReady = () -> PerformEventT t (RunGtkT m) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  notReadyUntil :: Event t a -> PerformEventT t (RunGtkT m) ()
notReadyUntil _ = () -> PerformEventT t (RunGtkT m) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()