Base.hs

-- 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
  { actionQueue :: TChan (IO ())
  , gtkThread :: Thread
  , waitEventThreadException :: STM SomeException
  }

newtype RunGtkT m a = RunGtkT
  { unGtkT :: ReaderT RunGtkEnv m a
  }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadTrans
           , MonadIO
           , MonadRef
           , MonadException
           , 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 a) e = RunGtkT $ runWithReplace a $ unGtkT <$> e
  traverseIntMapWithKeyWithAdjust f m a = RunGtkT $ traverseIntMapWithKeyWithAdjust f' m a
    where f' k v = unGtkT $ f k v
  traverseDMapWithKeyWithAdjust f m e =
    RunGtkT $ traverseDMapWithKeyWithAdjust (\k v -> unGtkT $ f k v) m e
  traverseDMapWithKeyWithAdjustWithMove f m e =
    RunGtkT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unGtkT $ f k v) m e

instance PerformEvent t m => PerformEvent t (RunGtkT m) where
  type Performable (RunGtkT m) = RunGtkT (Performable m)
  performEvent = RunGtkT . performEvent . fmap unGtkT
  performEvent_ = RunGtkT . performEvent_ . fmap unGtkT

instance (MonadIO m) => MonadRunGtk (RunGtkT m) where
  runGtk a = askRunGtk >>= liftIO . ($a)
  runGtk_ a = askRunGtk_ >>= liftIO . ($a)
  runGtkPromise a = askRunGtkPromise >>= liftIO . fmap liftIO . ($a)

askRunGtk :: (Monad m) => RunGtkT m (IO a -> IO a)
askRunGtk = (join .) <$> askRunGtkPromise

askRunGtk_ :: (Monad m) => RunGtkT m (IO a -> IO ())
askRunGtk_ = do
  actionChan <- RunGtkT $ asks actionQueue
  gtkThread' <- RunGtkT $ asks gtkThread
  pure $ \a -> do
    iAmGuiThread <- isThreadMe gtkThread'
    let execute = if iAmGuiThread
                  then id
                  else scheduleAction actionChan
    execute $ void a

askRunGtkPromise :: (Monad m) => RunGtkT m (IO a -> IO (IO a))
askRunGtkPromise = do
    actionQueue <- RunGtkT $ asks actionQueue
    gtkThread' <- RunGtkT $ asks gtkThread
    pure $ \a -> do
      iAmGtkThread <- isThreadMe gtkThread'
      if iAmGtkThread
        then pure <$> a
        else do
        answerMVar <- newEmptyMVar
        scheduleAction actionQueue $ try @SomeException a >>= putMVar answerMVar
        pure $ readMVar answerMVar >>= either throwIO pure

askMakeSynchronousFire :: (Monad m) => RunGtkT m ((a -> IO () -> IO ()) -> a -> IO ())
askMakeSynchronousFire = do
    actionChan <- RunGtkT $ asks actionQueue
    waitEventThreadException' <- RunGtkT $ asks waitEventThreadException
    gtkThread' <- RunGtkT $ asks gtkThread
    pure $ \fireAsynchronously x -> do
      firedTVar <- newTVarIO False
      fireAsynchronously x $ atomically $ writeTVar firedTVar True
      let waitCompleted = do
            hasFired <- readTVar firedTVar
            if hasFired
              then pure ()
              else retry
      iAmGtkThread <- isThreadMe gtkThread'
      fix $ \loop -> join $ atomically $
        (pure () <$ waitCompleted)
        `orElse` ( if iAmGtkThread
                   then do
                     gtkAction <- readTChan actionChan
                     pure $ runGtkAction gtkAction >> loop
                   else retry -- If we're run outside the GTK thread,
                              -- we shouldn't runGTk actions.
                 )
        `orElse` (waitEventThreadException' >>= throwSTM)

isThreadMe :: Thread -> IO Bool
isThreadMe refThread = do
  iAmBound <- isCurrentThreadBound
  if iAmBound
    then do
    myThread <- threadSelf
    pure $ myThread == refThread
    else pure False -- If we are not bound, we can't reliably be any
                    -- OS thread.

scheduleAction :: TChan (IO ()) -> IO () -> IO ()
scheduleAction actionChan action =
  atomically (writeTChan actionChan action)
  >> void ( threadsAddIdle PRIORITY_HIGH_IDLE $
            SOURCE_REMOVE <$ runScheduledActions actionChan
          )

runScheduledActions :: TChan (IO ()) -> IO ()
runScheduledActions actionChan =
  atomically (tryReadTChan actionChan)
  >>= mapM_ (\gtkAction -> runGtkAction gtkAction >> runScheduledActions actionChan)

runGtkAction :: IO () -> IO ()
runGtkAction a = mask_ $ catch a (const $ pure () :: SomeException -> IO ())

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

instance ( NotReady t m
         , ReflexHost t
         ) => NotReady t (PerformEventT t (RunGtkT m)) where
  notReady = pure ()
  notReadyUntil _ = pure ()