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, PatternSynonyms, OverloadedLabels, RecursiveDo #-}

module Reflex.GI.Gtk.Host
  ( MonadGtk
  , runReflexGtk
  ) where

import Control.Concurrent (myThreadId)
import Control.Concurrent.Async ( async
                                , waitCatchSTM
                                )
import Control.Concurrent.Chan ( newChan
                               , readChan
                               )
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Ref (readRef)
import Data.Dependent.Sum ( DSum((:=>))
                          , (==>)
                          )
import Data.Function (fix)
import Data.Int (Int32)
import Data.Maybe (catMaybes)
import Data.Void (absurd)
import GI.Gtk ( Application
              , on
              )
import Reflex ( FireCommand(FireCommand)
              , TriggerInvocation(TriggerInvocation)
              , hostPerformEventT
              , runPostBuildT
              , runSpiderHostForTimeline
              , runTriggerEventT
              , unEventTriggerRef
              , withSpiderTimeline
              )
import Reflex.GI.Gtk.Class (MonadGtk)
import Reflex.GI.Gtk.Run.Base (runGtkT)
import Reflex.Host.Class (newEventWithTriggerRef)

runReflexGtk :: Application
             -> Maybe [String]
             -> (forall t m. (MonadGtk t m) => m ())
             -> IO Int32
runReflexGtk app argv a = 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 myThreadId
            >>= runGtkT (
            runTriggerEventT (  runPostBuildT 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