-- |Native interpreter for 'Gtk'.
-- Internal.
module Helic.Interpreter.Gtk where

import Exon (exon)
import qualified GI.Gdk as GiGdk
import qualified GI.Gtk as GiGtk
import Polysemy.Conc (interpretScopedResumable)
import qualified Polysemy.Log as Log

import Helic.Data.X11Config (DisplayId (DisplayId), X11Config (X11Config))
import qualified Helic.Effect.Gtk as Gtk
import Helic.Effect.Gtk (Gtk)
import Helic.Gtk (getDisplay)
import Helic.Stop (tryStop)

-- |In the case where no default display is available from the manager, attempt to connect to a named display.
tryOpenDisplay ::
  Members [Stop Text, Log, Embed IO] r =>
  DisplayId ->
  GiGdk.DisplayManager ->
  Sem r ()
tryOpenDisplay :: DisplayId -> DisplayManager -> Sem r ()
tryOpenDisplay (DisplayId Text
fallbackDisplay) DisplayManager
dm = do
  Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.warn [exon|No default display available. Trying to connect to #{fallbackDisplay}|]
  IO (Maybe Display) -> Sem r (Maybe Display)
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (DisplayManager -> Text -> IO (Maybe Display)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplayManager a) =>
a -> Text -> m (Maybe Display)
GiGdk.displayManagerOpenDisplay DisplayManager
dm Text
fallbackDisplay) Sem r (Maybe Display) -> (Maybe Display -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Display
_ ->
      Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.info [exon|Connected to display #{fallbackDisplay}|]
    Maybe Display
Nothing ->
      Text -> Sem r ()
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop [exon|Could not connect to display #{fallbackDisplay}|]

-- |Test whether the display manager has a default display available.
noDisplayAvailable ::
  Members [Stop Text, Embed IO] r =>
  GiGdk.DisplayManager ->
  Sem r Bool
noDisplayAvailable :: DisplayManager -> Sem r Bool
noDisplayAvailable DisplayManager
dm =
  IO Bool -> Sem r Bool
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (Maybe Display -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Display -> Bool) -> IO (Maybe Display) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DisplayManager -> IO (Maybe Display)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplayManager a) =>
a -> m (Maybe Display)
GiGdk.displayManagerGetDefaultDisplay DisplayManager
dm)

-- |Initialize GTK, run the scoped action, then tear down the GTK environment.
bracketGtk ::
  Members [Resource, Log, Embed IO] r =>
  DisplayId ->
  (GiGdk.Display -> Sem (Stop Text : r) a) ->
  Sem (Stop Text : r) a
bracketGtk :: DisplayId
-> (Display -> Sem (Stop Text : r) a) -> Sem (Stop Text : r) a
bracketGtk DisplayId
fallbackDisplay =
  Sem (Stop Text : r) Display
-> (Display -> Sem (Stop Text : r) ())
-> (Display -> Sem (Stop Text : r) a)
-> Sem (Stop Text : r) a
forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket Sem (Stop Text : r) Display
acquire Display -> Sem (Stop Text : r) ()
forall a (r :: EffectRow).
(IsDescendantOf Display a, GObject a, Member (Embed IO) r,
 Member (Stop Text) r, Member Log r) =>
a -> Sem r ()
release
  where
    acquire :: Sem (Stop Text : r) Display
acquire = do
      Sem (Stop Text : r) Bool
-> Sem (Stop Text : r) () -> Sem (Stop Text : r) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((Bool, Maybe [Text]) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Maybe [Text]) -> Bool)
-> Sem (Stop Text : r) (Bool, Maybe [Text])
-> Sem (Stop Text : r) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Bool, Maybe [Text]) -> Sem (Stop Text : r) (Bool, Maybe [Text])
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (Maybe [Text] -> IO (Bool, Maybe [Text])
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe [Text] -> m (Bool, Maybe [Text])
GiGtk.initCheck Maybe [Text]
forall a. Maybe a
Nothing)) do
        DisplayManager
dm <- IO DisplayManager -> Sem (Stop Text : r) DisplayManager
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop IO DisplayManager
forall (m :: * -> *). (HasCallStack, MonadIO m) => m DisplayManager
GiGdk.displayManagerGet
        Sem (Stop Text : r) Bool
-> Sem (Stop Text : r) ()
-> Sem (Stop Text : r) ()
-> Sem (Stop Text : r) ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (DisplayManager -> Sem (Stop Text : r) Bool
forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
DisplayManager -> Sem r Bool
noDisplayAvailable DisplayManager
dm) (DisplayId -> DisplayManager -> Sem (Stop Text : r) ()
forall (r :: EffectRow).
Members '[Stop Text, Log, Embed IO] r =>
DisplayId -> DisplayManager -> Sem r ()
tryOpenDisplay DisplayId
fallbackDisplay DisplayManager
dm) (Text -> Sem (Stop Text : r) ()
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop Text
"GTK intialization failed")
      Sem (Stop Text : r) Display
forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Sem r Display
getDisplay
    release :: a -> Sem r ()
release a
display = do
      Text -> Sem r ()
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug Text
"Quitting the GTK main loop"
      IO () -> Sem r ()
forall (r :: EffectRow). Member (Embed IO) r => IO () -> Sem r ()
ignoreException do
        a -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m ()
GiGdk.displayFlush a
display
        a -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m ()
GiGdk.displayClose a
display
      IO () -> Sem r ()
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
GiGtk.mainQuit

-- |Interpret 'Gtk' natively, using the "GI.Gtk" and "Gi.Gdk" libraries.
-- This uses 'Scoped' to bracket the initialization and termination of the GTK environment.
interpretGtk ::
  Members [Resource, Log, Embed IO] r =>
  X11Config ->
  InterpreterFor (Scoped GiGdk.Display (Gtk GiGdk.Display) !! Text) r
interpretGtk :: X11Config
-> InterpreterFor (Scoped Display (Gtk Display) !! Text) r
interpretGtk (X11Config Maybe DisplayId
fallbackDisplay) =
  (forall x.
 (Display -> Sem (Stop Text : r) x) -> Sem (Stop Text : r) x)
-> (forall (r0 :: EffectRow) x.
    Display -> Gtk Display (Sem r0) x -> Sem (Stop Text : r) x)
-> InterpreterFor (Scoped Display (Gtk Display) !! Text) r
forall resource (effect :: (* -> *) -> * -> *) err
       (r :: EffectRow).
(forall x.
 (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x)
-> (forall (r0 :: EffectRow) x.
    resource -> effect (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Scoped resource effect !! err) r
interpretScopedResumable (DisplayId
-> (Display -> Sem (Stop Text : r) x) -> Sem (Stop Text : r) x
forall (r :: EffectRow) a.
Members '[Resource, Log, Embed IO] r =>
DisplayId
-> (Display -> Sem (Stop Text : r) a) -> Sem (Stop Text : r) a
bracketGtk (DisplayId -> Maybe DisplayId -> DisplayId
forall a. a -> Maybe a -> a
fromMaybe DisplayId
":0" Maybe DisplayId
fallbackDisplay)) \ Display
display -> \case
    Gtk Display (Sem r0) x
Gtk.Main ->
      Sem (Stop Text : r) x
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
GiGtk.main
    Gtk Display (Sem r0) x
Gtk.Resource ->
      Display -> Sem (Stop Text : r) Display
forall (f :: * -> *) a. Applicative f => a -> f a
pure Display
display