-- |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 Polysemy.Final (withWeavingToFinal)
import qualified Polysemy.Log as Log

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 :: Text -> IO a -> Sem r a
gtkUi Text
desc IO a
ma = do
  MVar (Maybe a)
result <- IO (MVar (Maybe a)) -> Sem r (MVar (Maybe a))
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO (MVar (Maybe a))
forall a. IO (MVar a)
newEmptyMVar
  let
    recovering :: IO x -> IO x
    recovering :: IO x -> IO x
recovering =
      (IO x -> IO () -> IO x) -> IO () -> IO x -> IO x
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO x -> IO () -> IO x
forall a b. IO a -> IO b -> IO a
Base.onException (MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
result Maybe a
forall a. Maybe a
Nothing)
  Word32
_ <- IO Word32 -> Sem r Word32
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (IO Word32 -> Sem r Word32) -> IO Word32 -> Sem r Word32
forall a b. (a -> b) -> a -> b
$ IO Word32 -> IO Word32
forall x. IO x -> IO x
recovering (IO Word32 -> IO Word32) -> IO Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$ Int32 -> SourceFunc -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> SourceFunc -> m Word32
GiGdk.threadsAddIdle Int32
Glib.PRIORITY_DEFAULT do
    MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
result (Maybe a -> IO ()) -> (a -> Maybe a) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a -> IO a
forall x. IO x -> IO x
recovering IO a
ma
    pure Bool
False
  Text -> Maybe a -> Sem r a
forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote [exon|Gtk ui thread computation '#{desc}' failed|] (Maybe a -> Sem r a) -> Sem r (Maybe a) -> Sem r a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe a) -> Sem r (Maybe a)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar (Maybe a) -> IO (Maybe a)
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 :: Display -> Selection -> m Clipboard
unsafeGtkClipboard Display
display Selection
name = do
  Atom
selection <- Text -> Bool -> m Atom
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Bool -> m Atom
GiGdk.atomIntern (Selection -> Text
Selection.toXString Selection
name) Bool
False
  Display -> Atom -> m Clipboard
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 :: Display -> Selection -> Sem r Clipboard
gtkClipboard Display
display Selection
name =
  IO Clipboard -> Sem r Clipboard
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop (Display -> Selection -> IO Clipboard
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 =
  IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Base.catch @SomeException IO ()
run \ SomeException
e ->
    Either Text Text -> IO ()
handle (Text -> Either Text Text
forall a b. a -> Either a b
Left (SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeException
e))
  where
    run :: IO ()
run =
      Clipboard -> ClipboardTextReceivedFunc -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsClipboard a) =>
a -> ClipboardTextReceivedFunc -> m ()
GiGtk.clipboardRequestText Clipboard
clipboard ((Maybe Text -> IO ()) -> ClipboardTextReceivedFunc
forall a b. a -> b -> a
const (Either Text Text -> IO ()
handle (Either Text Text -> IO ())
-> (Maybe Text -> Either Text Text) -> Maybe Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Either Text Text
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 :: Clipboard -> (Either Text Text -> Sem r ()) -> Sem r ()
subscribeWith Clipboard
clipboard Either Text Text -> Sem r ()
handle =
  ThroughWeavingToFinal IO (Sem r) () -> Sem r ()
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 = IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f (Sem r ()) -> IO (f ())
forall x. f (Sem r x) -> IO (f x)
wv (Sem r ()
ma Sem r () -> f () -> f (Sem r ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
    f ()
s f () -> IO SignalHandlerId -> IO (f ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Clipboard -> ClipboardOwnerChangeCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsClipboard a, MonadIO m) =>
a -> ClipboardOwnerChangeCallback -> m SignalHandlerId
GiGtk.onClipboardOwnerChange Clipboard
clipboard \ EventOwnerChange
_ ->
      Clipboard -> (Either Text Text -> IO ()) -> IO ()
clipboardRequest Clipboard
clipboard (Sem r () -> IO ()
lower (Sem r () -> IO ())
-> (Either Text Text -> Sem r ()) -> Either Text Text -> IO ()
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 :: Clipboard -> Sem r (Maybe Text)
readClipboard =
  Text -> IO (Maybe Text) -> Sem r (Maybe Text)
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
Text -> IO a -> Sem r a
gtkUi Text
"readClipboard" (IO (Maybe Text) -> Sem r (Maybe Text))
-> (Clipboard -> IO (Maybe Text))
-> Clipboard
-> Sem r (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clipboard -> IO (Maybe Text)
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 :: Clipboard -> Text -> m ()
unsafeSetClipboard Clipboard
clipboard Text
text =
  Clipboard -> Text -> Int32 -> m ()
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 :: Clipboard -> Text -> Sem r ()
writeClipboard Clipboard
clipboard =
  Text -> IO () -> Sem r ()
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
Text -> IO a -> Sem r a
gtkUi Text
"writeClipboard" (IO () -> Sem r ()) -> (Text -> IO ()) -> Text -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clipboard -> Text -> IO ()
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 :: Sem r Display
getDisplay =
  Text -> Maybe Display -> Sem r Display
forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote Text
"couldn't get a GTK display" (Maybe Display -> Sem r Display)
-> Sem r (Maybe Display) -> Sem r Display
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe Display) -> Sem r (Maybe Display)
forall (r :: EffectRow) a.
Members '[Stop Text, Embed IO] r =>
IO a -> Sem r a
tryStop IO (Maybe Display)
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 :: Selection -> Sem r Clipboard
getClipboard Selection
selection = do
  Display
display <- Sem r Display
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask
  Display -> Selection -> Sem r Clipboard
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 :: (Selection -> Text -> Sem r ()) -> Selection -> Sem r ()
subscribeToClipboard Selection -> Text -> Sem r ()
f Selection
selection = do
  Clipboard
cb <- Selection -> Sem r Clipboard
forall (r :: EffectRow).
Members '[Reader Display, Stop Text, Embed IO] r =>
Selection -> Sem r Clipboard
getClipboard Selection
selection
  Clipboard -> (Either Text Text -> Sem r ()) -> Sem r ()
forall (r :: EffectRow).
Member (Final IO) r =>
Clipboard -> (Either Text Text -> Sem r ()) -> Sem r ()
subscribeWith Clipboard
cb \case
    Right Text
t -> do
      Text -> Sem r ()
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 ->
      Text -> Sem r ()
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 :: Selection -> Sem r (Maybe Text)
clipboardText =
  Clipboard -> Sem r (Maybe Text)
forall (r :: EffectRow).
Members '[Log, Stop Text, Embed IO] r =>
Clipboard -> Sem r (Maybe Text)
readClipboard (Clipboard -> Sem r (Maybe Text))
-> (Selection -> Sem r Clipboard)
-> Selection
-> Sem r (Maybe Text)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Selection -> Sem r Clipboard
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 :: Selection -> Text -> Sem r ()
setClipboardText Selection
sel Text
text = do
  Clipboard
cb <- Selection -> Sem r Clipboard
forall (r :: EffectRow).
Members '[Reader Display, Stop Text, Embed IO] r =>
Selection -> Sem r Clipboard
getClipboard Selection
sel
  Clipboard -> Text -> Sem r ()
forall (r :: EffectRow).
Members '[Stop Text, Embed IO] r =>
Clipboard -> Text -> Sem r ()
writeClipboard Clipboard
cb Text
text