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