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
  ) where

import Control.Concurrent ( ThreadId
                          , myThreadId
                          , 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.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( askRunGtk_
                                           , askRunGtkPromise
                                           , askMakeSynchronousFire
                                           )
                               )
import Reflex.Host.Class ( MonadReflexCreateTrigger
                         , MonadReflexHost
                         , MonadSubscribeEvent
                         , ReflexHost
                         )

data RunGtkEnv = RunGtkEnv
  { actionQueue :: TChan (IO ())
  , gtkThreadId :: ThreadId
  , waitEventThreadException :: STM SomeException
  }

newtype RunGtkT t 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 t m)
deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RunGtkT t m)
deriving instance MonadReflexHost t m => MonadReflexHost t (RunGtkT t m)
deriving instance MonadSample t m => MonadSample t (RunGtkT t m)
deriving instance MonadHold t m => MonadHold t (RunGtkT t m)
deriving instance NotReady t m => NotReady t (RunGtkT t m)

instance Adjustable t m => Adjustable t (RunGtkT t 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 t m) where
  type Performable (RunGtkT t m) = RunGtkT t (Performable m)
  performEvent = RunGtkT . performEvent . fmap unGtkT
  performEvent_ = RunGtkT . performEvent_ . fmap unGtkT

instance (MonadIO m) => MonadRunGtk (RunGtkT t m) where
  askRunGtk_ = do
    actionChan <- RunGtkT $ asks actionQueue
    gtkTId <- RunGtkT $ asks gtkThreadId
    pure $ \a -> do
      myTId <- myThreadId
      let execute = if myTId == gtkTId
                    then id
                    else scheduleAction actionChan
      execute $ void a
  askRunGtkPromise = do
    actionQueue <- RunGtkT $ asks actionQueue
    gtkTId <- RunGtkT $ asks gtkThreadId
    pure $ \a -> do
      myTId <- myThreadId
      if myTId == gtkTId
        then pure <$> a
        else do
        answerMVar <- newEmptyMVar
        scheduleAction actionQueue $ try @SomeException a >>= putMVar answerMVar
        pure $ readMVar answerMVar >>= either throwIO pure
  askMakeSynchronousFire = do
    actionChan <- RunGtkT $ asks actionQueue
    waitEventThreadException' <- RunGtkT $ asks waitEventThreadException
    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
      fix $ \loop -> join $ atomically $
        (pure () <$ waitCompleted)
        `orElse` ( do
                     gtkAction <- readTChan actionChan
                     pure $ runGtkAction gtkAction >> loop
                 )
        `orElse` (waitEventThreadException' >>= throwSTM)

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 t m a
        -> STM SomeException
        -> ThreadId
        -> m a
runGtkT (RunGtkT a) waitEventThreadException gtkThreadId = do
  actionQueue <- liftIO newTChanIO
  runReaderT a RunGtkEnv{..}

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