Host.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 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
  { unReflexGtkT :: PostBuildT t (TriggerEventT t (RunGtkT (PerformEventT t m))) a
  }
  deriving (Functor, Applicative, Monad, 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 initial replace =
    ReflexGtkT $ runWithReplace (unReflexGtkT initial) (unReflexGtkT <$> replace)
  traverseDMapWithKeyWithAdjust f initial =
    ReflexGtkT . traverseDMapWithKeyWithAdjust (\k v -> unReflexGtkT $ f k v) initial
  traverseDMapWithKeyWithAdjustWithMove f initial =
    ReflexGtkT . traverseDMapWithKeyWithAdjustWithMove (\k v -> unReflexGtkT $ f k v) initial
  traverseIntMapWithKeyWithAdjust f initial =
    ReflexGtkT . traverseIntMapWithKeyWithAdjust (\k v -> unReflexGtkT $ f k v) initial

instance (ReflexHost t, MonadIO (HostFrame t)) => MonadRunGtk (ReflexGtkT t m) where
  runGtk = ReflexGtkT . runGtk
  runGtk_ = ReflexGtkT . runGtk_
  runGtkPromise = fmap ReflexGtkT . ReflexGtkT . runGtkPromise

-- Lift an operation from 'RunGtkT' to 'ReflexGtkT'.
liftFromRunGtkT :: (ReflexHost t) => RunGtkT (PerformEventT t m) a -> ReflexGtkT t m a
liftFromRunGtkT = ReflexGtkT . lift . 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 = pure $ \f x -> f x $ pure ()
askMakeFireWith FireSync = liftFromRunGtkT askMakeSynchronousFire

instance ( ReflexHost t
         , MonadIO (HostFrame t)
         , MonadRef (HostFrame t)
         , Ref (HostFrame t) ~ Ref IO
         ) => MonadGtkSource t (ReflexGtkT t m) where
  eventFromSignalWith register sync object signal f = do
    runGtk' <- liftFromRunGtkT askRunGtk
    runGtk_' <- liftFromRunGtkT askRunGtk_
    makeSynchronousFire <- askMakeFireWith sync
    newEventWithLazyTriggerWithOnComplete $ \fire ->
      runGtk_' . disconnectSignalHandler object
      <$> runGtk' ( object `register` signal $
                    f $ \x -> makeSynchronousFire fire 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 app argv a = runInBoundThread $ do
  _ <- app `on` #startup $
    withSpiderTimeline
    $ \tl -> flip runSpiderHostForTimeline tl $ do
    eventChan <- liftIO newChan
    rec
      let waitForEventThreadException =
            either id absurd <$> waitCatchSTM eventThread

      (postBuildE, postBuildTriggerRef) <- newEventWithTriggerRef
      ((), FireCommand fireCommand) <-
        hostPerformEventT $
        liftIO getCurrentAsGtkThread
        >>= runGtkT (
        runTriggerEventT ( runPostBuildT (unReflexGtkT a) postBuildE
                         ) eventChan
        ) waitForEventThreadException

      readRef postBuildTriggerRef
        >>= mapM_ (\trigger -> fireCommand [trigger ==> ()] $ pure ())

      eventThread <- liftIO $ async $ flip runSpiderHostForTimeline tl $ fix $ \loop -> do
        invocations <- liftIO $ readChan eventChan
        triggers <-
          catMaybes <$>
          traverse (\(triggerRef :=> TriggerInvocation x _) ->
                       fmap (==> x) <$> readRef (unEventTriggerRef triggerRef)
                   ) invocations
        _ <- fireCommand triggers $ pure ()
        liftIO $ mapM_ (\(_ :=> (TriggerInvocation _ done)) -> done) invocations
        loop
    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 = do
  iAmBound <- isCurrentThreadBound
  if iAmBound
    then threadSelf
    else error "getCurrentAsGtkThread: Can't be GTK thread, because I am not bound"