module Helic.Interpreter.Gtk where
import qualified GI.Gdk as GiGdk
import GI.Gdk (Display)
import qualified GI.Gtk as GiGtk
import Polysemy.Conc (interpretScopedResumable)
import qualified Polysemy.Log as Log
import qualified Helic.Effect.Gtk as Gtk
import Helic.Effect.Gtk (Gtk)
import Helic.Gtk (getDisplay)
import Helic.Stop (tryStop)
bracketGtk ::
Members [Resource, Log, Embed IO] r =>
(Display -> Sem (Stop Text : r) a) ->
Sem (Stop Text : r) a
bracketGtk :: (Display -> Sem (Stop Text : r) a) -> Sem (Stop Text : r) a
bracketGtk =
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
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
interpretGtk ::
Members [Resource, Log, Embed IO] r =>
InterpreterFor (Scoped Display (Gtk Display) !! Text) r
interpretGtk :: InterpreterFor (Scoped Display (Gtk Display) !! Text) r
interpretGtk =
(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 forall (r :: EffectRow) a.
Members '[Resource, Log, Embed IO] r =>
(Display -> Sem (Stop Text : r) a) -> Sem (Stop Text : r) a
forall x.
(Display -> Sem (Stop Text : r) x) -> Sem (Stop Text : r) x
bracketGtk \ 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