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