-- |General GTK API adapter functions.
-- Internal.
module Helic.Gtk where

import qualified Control.Exception as Base
import Exon (exon)
import qualified GI.GLib as Glib
import qualified GI.Gdk as GiGdk
import GI.Gdk (Display)
import qualified GI.Gtk as GiGtk
import qualified Log
import Polysemy.Final (withWeavingToFinal)

import qualified Helic.Data.Selection as Selection
import Helic.Data.Selection (Selection)
import Helic.Stop (tryStop)

-- |Safe wrapper around calls to ght GTK API.
-- This schedules an 'IO' action for execution on the GTK main loop thread, which is crucial for some actions to avoid
-- horrible crashes.
-- Since this results in asynchronous execution, an 'MVar' is used to extract the result.
-- Catches all exception and converts them to 'Stop'.
gtkUi ::
  Members [Stop Text, Embed IO] r =>
  Text ->
  IO a ->
  Sem r a
gtkUi :: forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
Text -> IO a -> Sem r a
gtkUi Text
desc IO a
ma = do
  MVar (Maybe a)
result <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed forall a. IO (MVar a)
newEmptyMVar
  let
    recovering :: IO x -> IO x
    recovering :: forall x. IO x -> IO x
recovering =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
Base.onException (forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
result forall a. Maybe a
Nothing)
  Word32
_ <- forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop forall a b. (a -> b) -> a -> b
$ forall x. IO x -> IO x
recovering forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> SourceFunc -> m Word32
GiGdk.threadsAddIdle Int32
Glib.PRIORITY_DEFAULT do
    forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
result forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall x. IO x -> IO x
recovering IO a
ma
    pure Bool
False
  forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote [exon|Gtk ui thread computation '#{desc}' failed|] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (forall a. MVar a -> IO a
takeMVar MVar (Maybe a)
result)

-- |Accesses a clipboard by creating the appropriate X11 atom structure.
-- Does not catch exceptions.
unsafeGtkClipboard ::
  MonadIO m =>
  Display ->
  Selection ->
  m GiGtk.Clipboard
unsafeGtkClipboard :: forall (m :: * -> *).
MonadIO m =>
Display -> Selection -> m Clipboard
unsafeGtkClipboard Display
display Selection
name = do
  Atom
selection <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Bool -> m Atom
GiGdk.atomIntern (Selection -> Text
Selection.toXString Selection
name) Bool
False
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> Atom -> m Clipboard
GiGtk.clipboardGetForDisplay Display
display Atom
selection

-- |Return a GTK clipboard, converting all exceptions to 'Stop'.
gtkClipboard ::
  Members [Stop Text, Embed IO] r =>
  Display ->
  Selection ->
  Sem r GiGtk.Clipboard
gtkClipboard :: forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Display -> Selection -> Sem r Clipboard
gtkClipboard Display
display Selection
name =
  forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (forall (m :: * -> *).
MonadIO m =>
Display -> Selection -> m Clipboard
unsafeGtkClipboard Display
display Selection
name)

-- |Request the text contents of a GTK clipboard, catching all exceptions, and passing the result to a handler.
-- If the clipboard is empty or an exception was thrown, the value passed to the handler is 'Left', otherwise 'Right'.
clipboardRequest ::
  GiGtk.Clipboard ->
  (Either Text Text -> IO ()) ->
  IO ()
clipboardRequest :: Clipboard -> (Either Text Text -> IO ()) -> IO ()
clipboardRequest Clipboard
clipboard Either Text Text -> IO ()
handle =
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Base.catch @SomeException IO ()
run \ SomeException
e ->
    Either Text Text -> IO ()
handle (forall a b. a -> Either a b
Left (forall b a. (Show a, IsString b) => a -> b
show SomeException
e))
  where
    run :: IO ()
run =
      forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsClipboard a) =>
a -> ClipboardTextReceivedFunc -> m ()
GiGtk.clipboardRequestText Clipboard
clipboard (forall a b. a -> b -> a
const (Either Text Text -> IO ()
handle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l r. l -> Maybe r -> Either l r
maybeToRight Text
"no clipboard text"))

-- |Registers a callback for the "owner change" event of a GTK clipboard, which is triggered whenever a client updates
-- the text.
-- The callback then fetches the current text and passes it to the supplied handler as 'Right', or a 'Left' if an
-- exception was thrown.
subscribeWith ::
  Member (Final IO) r =>
  GiGtk.Clipboard ->
  (Either Text Text -> Sem r ()) ->
  Sem r ()
subscribeWith :: forall (r :: EffectRow).
Member (Final IO) r =>
Clipboard -> (Either Text Text -> Sem r ()) -> Sem r ()
subscribeWith Clipboard
clipboard Either Text Text -> Sem r ()
handle =
  forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
ThroughWeavingToFinal m (Sem r) a -> Sem r a
withWeavingToFinal \ f ()
s forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
_ -> do
    let lower :: Sem r () -> IO ()
lower Sem r ()
ma = forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall x. f (Sem r x) -> IO (f x)
wv (Sem r ()
ma forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
    f ()
s forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a (m :: * -> *).
(IsClipboard a, MonadIO m) =>
a
-> ((?self::a) => ClipboardOwnerChangeCallback)
-> m SignalHandlerId
GiGtk.onClipboardOwnerChange Clipboard
clipboard \ EventOwnerChange
_ ->
      Clipboard -> (Either Text Text -> IO ()) -> IO ()
clipboardRequest Clipboard
clipboard (Sem r () -> IO ()
lower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text Text -> Sem r ()
handle)

-- |Safely request the text contents of a clipboard by scheduling an action on the UI thread and converting exceptions
-- into 'Stop'.
readClipboard ::
  Members [Log, Stop Text, Embed IO] r =>
  GiGtk.Clipboard ->
  Sem r (Maybe Text)
readClipboard :: forall (r :: EffectRow).
Members '[Log, Stop Text, Embed IO] r =>
Clipboard -> Sem r (Maybe Text)
readClipboard =
  forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
Text -> IO a -> Sem r a
gtkUi Text
"readClipboard" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsClipboard a) =>
a -> m (Maybe Text)
GiGtk.clipboardWaitForText

-- |Update the text contents of a clipboard.
-- Does not catch exceptions.
unsafeSetClipboard ::
  MonadIO m =>
  GiGtk.Clipboard ->
  Text ->
  m ()
unsafeSetClipboard :: forall (m :: * -> *). MonadIO m => Clipboard -> Text -> m ()
unsafeSetClipboard Clipboard
clipboard Text
text =
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsClipboard a) =>
a -> Text -> Int32 -> m ()
GiGtk.clipboardSetText Clipboard
clipboard Text
text (-Int32
1)

-- |Safely update the text contents of a clipboard by scheduling an action on the UI thread and converting exceptions
-- into 'Stop'.
writeClipboard ::
  Members [Stop Text, Embed IO] r =>
  GiGtk.Clipboard ->
  Text ->
  Sem r ()
writeClipboard :: forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Clipboard -> Text -> Sem r ()
writeClipboard Clipboard
clipboard =
  forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
Text -> IO a -> Sem r a
gtkUi Text
"writeClipboard" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => Clipboard -> Text -> m ()
unsafeSetClipboard Clipboard
clipboard

-- |Obtain the default GTK display, converting exceptions into 'Stop'.
getDisplay ::
  Members [Stop Text, Embed IO] r =>
  Sem r Display
getDisplay :: forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Sem r Display
getDisplay =
  forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote Text
"couldn't get a GTK display" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Maybe Display)
GiGdk.displayGetDefault

-- |Obtain a GTK clipboard handle for a specific 'Selection'
getClipboard ::
  Members [Reader Display, Stop Text, Embed IO] r =>
  Selection ->
  Sem r GiGtk.Clipboard
getClipboard :: forall (r :: EffectRow).
Members '[Reader Display, Stop Text, Embed IO] r =>
Selection -> Sem r Clipboard
getClipboard Selection
selection = do
  Display
display <- forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask
  forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Display -> Selection -> Sem r Clipboard
gtkClipboard Display
display Selection
selection

-- |Listen to clipboard events for a specific source, like "primary selection", and pass them to the callback.
subscribeToClipboard ::
  Members [Reader Display, Log, Stop Text, Embed IO, Final IO] r =>
  (Selection -> Text -> Sem r ()) ->
  Selection ->
  Sem r ()
subscribeToClipboard :: forall (r :: EffectRow).
Members '[Reader Display, Log, Stop Text, Embed IO, Final IO] r =>
(Selection -> Text -> Sem r ()) -> Selection -> Sem r ()
subscribeToClipboard Selection -> Text -> Sem r ()
f Selection
selection = do
  Clipboard
cb <- forall (r :: EffectRow).
Members '[Reader Display, Stop Text, Embed IO] r =>
Selection -> Sem r Clipboard
getClipboard Selection
selection
  forall (r :: EffectRow).
Member (Final IO) r =>
Clipboard -> (Either Text Text -> Sem r ()) -> Sem r ()
subscribeWith Clipboard
cb \case
    Right Text
t -> do
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|GTK subscriber for #{show selection}: received #{t}|]
      Selection -> Text -> Sem r ()
f Selection
selection Text
t
    Left Text
e ->
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.warn [exon|GTK subscriber for #{show selection}: #{e}|]

-- |Fetch the text contents of the GTK clipboard corresponding to the specified X11 selection, converting exceptions
-- into 'Stop'.
clipboardText ::
  Members [Reader Display, Log, Stop Text, Embed IO] r =>
  Selection ->
  Sem r (Maybe Text)
clipboardText :: forall (r :: EffectRow).
Members '[Reader Display, Log, Stop Text, Embed IO] r =>
Selection -> Sem r (Maybe Text)
clipboardText =
  forall (r :: EffectRow).
Members '[Log, Stop Text, Embed IO] r =>
Clipboard -> Sem r (Maybe Text)
readClipboard forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (r :: EffectRow).
Members '[Reader Display, Stop Text, Embed IO] r =>
Selection -> Sem r Clipboard
getClipboard

-- |Update the text contents of the GTK clipboard corresponding to the specified X11 selection, converting exceptions
-- into 'Stop'.
setClipboardText ::
  Members [Reader Display, Log, Stop Text, Embed IO, Final IO] r =>
  Selection ->
  Text ->
  Sem r ()
setClipboardText :: forall (r :: EffectRow).
Members '[Reader Display, Log, Stop Text, Embed IO, Final IO] r =>
Selection -> Text -> Sem r ()
setClipboardText Selection
sel Text
text = do
  Clipboard
cb <- forall (r :: EffectRow).
Members '[Reader Display, Stop Text, Embed IO] r =>
Selection -> Sem r Clipboard
getClipboard Selection
sel
  forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Clipboard -> Text -> Sem r ()
writeClipboard Clipboard
cb Text
text