{-# options_haddock prune #-}
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