-- |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 qualified Polysemy.Log as Log

import qualified Helic.Data.X11Config
import Helic.Data.X11Config (DisplayId (DisplayId), 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 :: forall (r :: EffectRow).
Members '[Stop Text, Log, Embed IO] r =>
DisplayId -> DisplayManager -> Sem r ()
tryOpenDisplay (DisplayId Text
fallbackDisplay) DisplayManager
dm = do
  forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.warn [exon|No default display available. Trying to connect to #{fallbackDisplay}|]
  forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplayManager a) =>
a -> Text -> m (Maybe Display)
GiGdk.displayManagerOpenDisplay DisplayManager
dm Text
fallbackDisplay) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Display
_ ->
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.info [exon|Connected to display #{fallbackDisplay}|]
    Maybe Display
Nothing ->
      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 :: forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
DisplayManager -> Sem r Bool
noDisplayAvailable DisplayManager
dm =
  forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 [Reader X11Config, Resource, Log, Embed IO] r =>
  (GiGdk.Display -> Sem (Stop Text : r) a) ->
  Sem (Stop Text : r) a
bracketGtk :: forall (r :: EffectRow) a.
Members '[Reader X11Config, Resource, Log, Embed IO] r =>
(Display -> Sem (Stop Text : r) a) -> Sem (Stop Text : r) a
bracketGtk =
  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 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
      forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe [Text] -> m (Bool, Maybe [Text])
GiGtk.initCheck forall a. Maybe a
Nothing)) do
        X11Config
conf <- forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask
        let fallbackDisplay :: DisplayId
fallbackDisplay = forall a. a -> Maybe a -> a
fromMaybe DisplayId
":0" X11Config
conf.display
        DisplayManager
dm <- forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop forall (m :: * -> *). (HasCallStack, MonadIO m) => m DisplayManager
GiGdk.displayManagerGet
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
DisplayManager -> Sem r Bool
noDisplayAvailable DisplayManager
dm) (forall (r :: EffectRow).
Members '[Stop Text, Log, Embed IO] r =>
DisplayId -> DisplayManager -> Sem r ()
tryOpenDisplay DisplayId
fallbackDisplay DisplayManager
dm) (forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop Text
"GTK intialization failed")
      forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Sem r Display
getDisplay
    release :: a -> Sem r ()
release a
display = do
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug Text
"Quitting the GTK main loop"
      forall (r :: EffectRow). Member (Embed IO) r => IO () -> Sem r ()
tryAny_ do
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m ()
GiGdk.displayFlush a
display
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m ()
GiGdk.displayClose a
display
      forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop 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 [Reader X11Config, Resource, Log, Embed IO] r =>
  InterpreterFor (Scoped_ (Gtk GiGdk.Display) !! Text) r
interpretGtk :: forall (r :: EffectRow).
Members '[Reader X11Config, Resource, Log, Embed IO] r =>
InterpreterFor (Scoped_ (Gtk Display) !! Text) r
interpretGtk =
  forall param resource (effect :: (* -> *) -> * -> *) err
       (r :: EffectRow).
(forall (q :: (* -> *) -> * -> *) x.
 param
 -> (resource -> Sem (Stop err : Opaque q : r) x)
 -> Sem (Stop err : Opaque q : r) x)
-> (forall (q :: (* -> *) -> * -> *) (r0 :: EffectRow) x.
    resource -> effect (Sem r0) x -> Sem (Stop err : Opaque q : r) x)
-> InterpreterFor (Scoped param effect !! err) r
interpretScopedResumable (forall a b. a -> b -> a
const forall (r :: EffectRow) a.
Members '[Reader X11Config, Resource, Log, Embed IO] r =>
(Display -> Sem (Stop Text : r) a) -> Sem (Stop Text : r) a
bracketGtk) \ Display
display -> \case
    Gtk Display (Sem r0) x
Gtk.Main ->
      forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
GiGtk.main
    Gtk Display (Sem r0) x
Gtk.Resource ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Display
display