{-# options_haddock prune #-}

-- |GTK Helpers, Internal
module Helic.Gtk where

import qualified Control.Exception as Base
import qualified GI.GLib as Glib
import qualified GI.Gdk as Gdk
import GI.Gdk (Display)
import qualified GI.Gtk as GI
import Polysemy.Final (embedFinal, withWeavingToFinal)
import Polysemy.Log (Log)

import qualified Helic.Data.GtkState as GtkState
import Helic.Data.GtkState (GtkState)
import qualified Helic.Data.Selection as Selection
import Helic.Data.Selection (Selection (Clipboard, Primary, Secondary))

gtkUi ::
  Member (Embed IO) r =>
  IO a ->
  Sem r a
gtkUi :: IO a -> Sem r a
gtkUi IO a
ma = do
  MVar a
result <- Sem r (MVar a)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  Word32
_ <- Int32 -> SourceFunc -> Sem r Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> SourceFunc -> m Word32
Gdk.threadsAddIdle Int32
Glib.PRIORITY_DEFAULT do
    a
a <- IO a
ma
    Bool
False Bool -> IO () -> SourceFunc
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar a -> a -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar a
result a
a
  MVar a -> Sem r a
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar a
result

gtkUiSem ::
  Member (Final IO) r =>
  Sem r a ->
  Sem r a
gtkUiSem :: Sem r a -> Sem r a
gtkUiSem Sem r a
ma = do
  ThroughWeavingToFinal IO (Sem r) a -> Sem r a
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
    MVar a
result <- IO (MVar a)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
    IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Word32 -> IO ()) -> IO Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> SourceFunc -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> SourceFunc -> m Word32
Gdk.threadsAddIdle Int32
Glib.PRIORITY_DEFAULT do
      f (Sem r ()) -> IO (f ())
forall x. f (Sem r x) -> IO (f x)
wv ((IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal (IO () -> Sem r ()) -> (a -> IO ()) -> a -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> a -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar a
result (a -> Sem r ()) -> Sem r a -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r a
ma) Sem r () -> f () -> f (Sem r ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
      pure Bool
False
    (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (a -> f a) -> IO a -> IO (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar a -> IO a
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar a
result

unsafeGtkClipboard ::
  MonadIO m =>
  Display ->
  Selection ->
  m GI.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
Gdk.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
GI.clipboardGetForDisplay Display
display Atom
selection

gtkClipboard ::
  Member (Embed IO) r =>
  Display ->
  Selection ->
  Sem r (Either Text GI.Clipboard)
gtkClipboard :: Display -> Selection -> Sem r (Either Text Clipboard)
gtkClipboard Display
display Selection
name =
  IO Clipboard -> Sem r (Either Text Clipboard)
forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny (Display -> Selection -> IO Clipboard
forall (m :: * -> *).
MonadIO m =>
Display -> Selection -> m Clipboard
unsafeGtkClipboard Display
display Selection
name)

unsafeSubscribe ::
  MonadIO m =>
  GI.Clipboard ->
  (Either Text Text -> IO ()) ->
  m ()
unsafeSubscribe :: Clipboard -> (Either Text Text -> IO ()) -> m ()
unsafeSubscribe Clipboard
clipboard Either Text Text -> IO ()
handle =
  m SignalHandlerId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m SignalHandlerId -> m ()) -> m SignalHandlerId -> m ()
forall a b. (a -> b) -> a -> b
$ Clipboard -> ClipboardOwnerChangeCallback -> m SignalHandlerId
forall a (m :: * -> *).
(IsClipboard a, MonadIO m) =>
a -> ClipboardOwnerChangeCallback -> m SignalHandlerId
GI.onClipboardOwnerChange Clipboard
clipboard \ EventOwnerChange
_ -> do
    IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Base.catch @SomeException (Clipboard -> ClipboardTextReceivedFunc -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsClipboard a) =>
a -> ClipboardTextReceivedFunc -> m ()
GI.clipboardRequestText Clipboard
clipboard ((Maybe Text -> IO ()) -> ClipboardTextReceivedFunc
forall a b. a -> b -> a
const ((Text -> IO ()) -> Maybe Text -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Either Text Text -> IO ()
handle (Either Text Text -> IO ())
-> (Text -> Either Text Text) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Text
forall a b. b -> Either a b
Right)))) \ 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))

clipboardRequest ::
  GI.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 ()
GI.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"))

subscribe ::
  Member (Final IO) r =>
  GI.Clipboard ->
  (Either Text Text -> Sem r ()) ->
  Sem r ()
subscribe :: Clipboard -> (Either Text Text -> Sem r ()) -> Sem r ()
subscribe 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
GI.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)

clipboardFor ::
  Member (Reader GtkState) r =>
  Selection ->
  Sem r GI.Clipboard
clipboardFor :: Selection -> Sem r Clipboard
clipboardFor = \case
  Selection
Clipboard -> (GtkState -> Clipboard) -> Sem r Clipboard
forall i j (r :: EffectRow).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks GtkState -> Clipboard
GtkState.clipboard
  Selection
Primary -> (GtkState -> Clipboard) -> Sem r Clipboard
forall i j (r :: EffectRow).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks GtkState -> Clipboard
GtkState.primary
  Selection
Secondary -> (GtkState -> Clipboard) -> Sem r Clipboard
forall i j (r :: EffectRow).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks GtkState -> Clipboard
GtkState.secondary

unsafeGetClipboard ::
  MonadIO m =>
  GI.Clipboard ->
  m (Maybe Text)
unsafeGetClipboard :: Clipboard -> m (Maybe Text)
unsafeGetClipboard Clipboard
clipboard =
  Clipboard -> m (Maybe Text)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsClipboard a) =>
a -> m (Maybe Text)
GI.clipboardWaitForText Clipboard
clipboard

getClipboard ::
  Members [Log, Embed IO] r =>
  GI.Clipboard ->
  Sem r (Maybe Text)
getClipboard :: Clipboard -> Sem r (Maybe Text)
getClipboard Clipboard
clipboard =
  IO (Maybe Text) -> Sem r (Maybe Text)
forall (r :: EffectRow) a. Member (Embed IO) r => IO a -> Sem r a
gtkUi (Clipboard -> IO (Maybe Text)
forall (m :: * -> *). MonadIO m => Clipboard -> m (Maybe Text)
unsafeGetClipboard Clipboard
clipboard)

getClipboardFor ::
  Members [Reader GtkState, Log, Embed IO] r =>
  Selection ->
  Sem r (Maybe Text)
getClipboardFor :: Selection -> Sem r (Maybe Text)
getClipboardFor Selection
sel = do
  Clipboard
cb <- Selection -> Sem r Clipboard
forall (r :: EffectRow).
Member (Reader GtkState) r =>
Selection -> Sem r Clipboard
clipboardFor Selection
sel
  Clipboard -> Sem r (Maybe Text)
forall (r :: EffectRow).
Members '[Log, Embed IO] r =>
Clipboard -> Sem r (Maybe Text)
getClipboard Clipboard
cb

unsafeSetClipboard ::
  MonadIO m =>
  GI.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 ()
GI.clipboardSetText Clipboard
clipboard Text
text (-Int32
1)

setClipboard ::
  Member (Embed IO) r =>
  GI.Clipboard ->
  Text ->
  Sem r ()
setClipboard :: Clipboard -> Text -> Sem r ()
setClipboard Clipboard
clipboard Text
text =
  IO () -> Sem r ()
forall (r :: EffectRow) a. Member (Embed IO) r => IO a -> Sem r a
gtkUi (Clipboard -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Clipboard -> Text -> m ()
unsafeSetClipboard Clipboard
clipboard Text
text)

setClipboardFor ::
  Members [Reader GtkState, Log, Embed IO, Final IO] r =>
  Selection ->
  Text ->
  Sem r ()
setClipboardFor :: Selection -> Text -> Sem r ()
setClipboardFor Selection
sel Text
text = do
  Clipboard
cb <- Selection -> Sem r Clipboard
forall (r :: EffectRow).
Member (Reader GtkState) r =>
Selection -> Sem r Clipboard
clipboardFor Selection
sel
  Clipboard -> Text -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Clipboard -> Text -> Sem r ()
setClipboard Clipboard
cb Text
text

syncXClipboard ::
  Members [Reader GtkState, Log, Embed IO, Final IO] r =>
  Text ->
  Selection ->
  Sem r ()
syncXClipboard :: Text -> Selection -> Sem r ()
syncXClipboard Text
text = \case
  Selection
Clipboard ->
    Sem r ()
forall (f :: * -> *). Applicative f => f ()
unit
  Selection
_ -> do
    Clipboard
cb <- (GtkState -> Clipboard) -> Sem r Clipboard
forall i j (r :: EffectRow).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks GtkState -> Clipboard
GtkState.clipboard
    Clipboard -> Text -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Clipboard -> Text -> Sem r ()
setClipboard Clipboard
cb Text
text