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)
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}|]
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)
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
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