helic 0.4.0.0 → 0.5.0.0

raw patch · 13 files changed

+116/−38 lines, 13 filesdep +aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson

API changes (from Hackage documentation)

Files

• changelog.md +5/−0
• helic.cabal +5/−2
• lib/Helic/App.hs +5/−5
• lib/Helic/Config/File.hs +1/−1
• lib/Helic/Data/Config.hs +2/−0
• lib/Helic/Data/X11Config.hs +22/−0
• lib/Helic/Gtk.hs +17/−18
• lib/Helic/Interpreter/Gtk.hs +31/−7
• lib/Helic/Json.hs +21/−0
• lib/Helic/Listen.hs +1/−1
• readme.md +1/−0
• test/Helic/Dev.hs +1/−1
• test/Helic/Test/ConfigFileTest.hs +4/−3

@@ -1,5 +1,10 @@ # Unreleased +# 0.5.0.0++* Allow empty config files.+* Forcibly connect to a GTK display if none is currently open.+ # 0.4.0.0  * Rewrite the GTK main loop effects for better resilience when no display is available (yet).

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           helic-version:        0.4.0.0+version:        0.5.0.0 synopsis:       Clipboard Manager description:    See <https://hackage.haskell.org/package/helic/docs/Helic.html> category:       Clipboard@@ -43,6 +43,7 @@       Helic.Data.NetConfig       Helic.Data.Selection       Helic.Data.TmuxConfig+      Helic.Data.X11Config       Helic.Data.XClipboardEvent       Helic.Data.YankConfig       Helic.Effect.Agent@@ -67,6 +68,7 @@       Helic.Interpreter.History       Helic.Interpreter.InstanceName       Helic.Interpreter.XClipboard+      Helic.Json       Helic.List       Helic.Listen       Helic.Net.Api@@ -137,7 +139,8 @@       ViewPatterns   ghc-options: -Wall -Wredundant-constraints -Wunused-packages -fplugin=Polysemy.Plugin   build-depends:-      base ==4.*+      aeson >=1.5+    , base ==4.*     , chronos >=1.1.1     , exon >=0.3     , gi-gdk >=3

@@ -59,7 +59,7 @@ listenApp ::   Config ->   Sem AppStack ()-listenApp (Config name tmux net maxHistory _) =+listenApp (Config name tmux net x11 maxHistory _) =   runReader (fromMaybe def tmux) $   runReader (fromMaybe def net) $   interpretEventsChan @XClipboardEvent $@@ -67,7 +67,7 @@   interpretAtomic mempty $   interpretInstanceName name $   interpretManager $-  interpretGtk $+  interpretGtk (fromMaybe def x11) $   interpretGtkMain (MilliSeconds 500) (Seconds 10) $   interpretGtkClipboard $   gtkMainLoop subscribeEvents $@@ -84,7 +84,7 @@   Config ->   YankConfig ->   Sem AppStack ()-yankApp (Config name _ net _ _) yankConfig =+yankApp (Config name _ net _ _ _) yankConfig =   interpretManager $   interpretInstanceName name $   runReader (fromMaybe def net) $@@ -104,7 +104,7 @@   Config ->   ListConfig ->   Sem AppStack ()-listApp (Config _ _ net _ _) listConfig =+listApp (Config _ _ net _ _ _) listConfig =   runReader listConfig $   runClient net $   list@@ -113,6 +113,6 @@   Config ->   LoadConfig ->   Sem AppStack ()-loadApp (Config _ _ net _ _) (LoadConfig event) =+loadApp (Config _ _ net _ _ _) (LoadConfig event) =   runClient net $   (void . fromEither =<< Client.load event)

@@ -17,7 +17,7 @@   Sem r Config parseFileConfig (toFilePath -> path) = do   Log.debug [exon|Reading config file #{toText path}|]-  fromEither =<< first formatError <$> embed (decodeFileEither path)+  fromEither =<< bimap formatError (fromMaybe def) <$> embed (decodeFileEither path)   where     formatError exc =       toText [exon|invalid config file: #{prettyPrintParseException exc}|]

@@ -7,12 +7,14 @@  import Helic.Data.NetConfig (NetConfig) import Helic.Data.TmuxConfig (TmuxConfig)+import Helic.Data.X11Config (X11Config)  data Config =   Config {     name :: Maybe Text,     tmux :: Maybe TmuxConfig,     net :: Maybe NetConfig,+    x11 :: Maybe X11Config,     maxHistory :: Maybe Int,     verbose :: Maybe Bool   }

@@ -0,0 +1,22 @@+{-# options_haddock prune #-}++-- |X11Config Data Type, Internal+module Helic.Data.X11Config where++import Helic.Json (json, unaryJson)++newtype DisplayId =+  DisplayId { unDisplayId :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString)++json ''DisplayId++data X11Config =+  X11Config {+    display :: Maybe DisplayId+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Default)++unaryJson ''X11Config

@@ -6,10 +6,8 @@ import Exon (exon) import qualified GI.GLib as Glib import qualified GI.Gdk as GiGdk-import qualified GI.Gdk as Gdk import GI.Gdk (Display) import qualified GI.Gtk as GiGtk-import qualified GI.Gtk as GI import Polysemy.Final (withWeavingToFinal) import qualified Polysemy.Log as Log @@ -33,7 +31,7 @@     recovering :: IO x -> IO x     recovering =       flip Base.onException (putMVar result Nothing)-  _ <- tryStop $ recovering $ Gdk.threadsAddIdle Glib.PRIORITY_DEFAULT do+  _ <- tryStop $ recovering $ GiGdk.threadsAddIdle Glib.PRIORITY_DEFAULT do     putMVar result . Just =<< recovering ma     pure False   stopNote [exon|Gtk ui thread computation '#{desc}' failed|] =<< embed (takeMVar result)@@ -44,24 +42,24 @@   MonadIO m =>   Display ->   Selection ->-  m GI.Clipboard+  m GiGtk.Clipboard unsafeGtkClipboard display name = do-  selection <- Gdk.atomIntern (Selection.toXString name) False-  GI.clipboardGetForDisplay display selection+  selection <- GiGdk.atomIntern (Selection.toXString name) False+  GiGtk.clipboardGetForDisplay display selection  -- |Return a GTK clipboard, converting all exceptions to 'Stop'. gtkClipboard ::   Members [Stop Text, Embed IO] r =>   Display ->   Selection ->-  Sem r GI.Clipboard+  Sem r GiGtk.Clipboard gtkClipboard display name =   tryStop (unsafeGtkClipboard display 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 ::-  GI.Clipboard ->+  GiGtk.Clipboard ->   (Either Text Text -> IO ()) ->   IO () clipboardRequest clipboard handle =@@ -69,7 +67,7 @@     handle (Left (show e))   where     run =-      GI.clipboardRequestText clipboard (const (handle . maybeToRight "no clipboard text"))+      GiGtk.clipboardRequestText clipboard (const (handle . maybeToRight "no clipboard text"))  -- |Registers a callback for the "owner change" event of a GTK clipboard, which is triggered whenever a client updates -- the text.@@ -77,39 +75,39 @@ -- exception was thrown. subscribeWith ::   Member (Final IO) r =>-  GI.Clipboard ->+  GiGtk.Clipboard ->   (Either Text Text -> Sem r ()) ->   Sem r () subscribeWith clipboard handle =   withWeavingToFinal \ s wv _ -> do     let lower ma = void (wv (ma <$ s))-    s <$ GI.onClipboardOwnerChange clipboard \ _ ->+    s <$ GiGtk.onClipboardOwnerChange clipboard \ _ ->       clipboardRequest clipboard (lower . 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 =>-  GI.Clipboard ->+  GiGtk.Clipboard ->   Sem r (Maybe Text) readClipboard =-  gtkUi "readClipboard" . GI.clipboardWaitForText+  gtkUi "readClipboard" . GiGtk.clipboardWaitForText  -- |Update the text contents of a clipboard. -- Does not catch exceptions. unsafeSetClipboard ::   MonadIO m =>-  GI.Clipboard ->+  GiGtk.Clipboard ->   Text ->   m () unsafeSetClipboard clipboard text =-  GI.clipboardSetText clipboard text (-1)+  GiGtk.clipboardSetText clipboard text (-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 =>-  GI.Clipboard ->+  GiGtk.Clipboard ->   Text ->   Sem r () writeClipboard clipboard =@@ -140,10 +138,11 @@ subscribeToClipboard f selection = do   cb <- getClipboard selection   subscribeWith cb \case-    Right t ->+    Right t -> do+      Log.debug [exon|GTK subscriber for #{show selection}: received #{t}|]       f selection t     Left e ->-      Log.warn [exon|GTK: #{e}|]+      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'.

@@ -2,28 +2,51 @@ -- Internal. module Helic.Interpreter.Gtk where +import Exon (exon) import qualified GI.Gdk as GiGdk-import GI.Gdk (Display) import qualified GI.Gtk as GiGtk import Polysemy.Conc (interpretScopedResumable) import qualified Polysemy.Log as Log +import Helic.Data.X11Config (DisplayId (DisplayId), X11Config (X11Config)) import qualified Helic.Effect.Gtk as Gtk import Helic.Effect.Gtk (Gtk) import Helic.Gtk (getDisplay) import Helic.Stop (tryStop) +tryOpenDisplay ::+  Members [Stop Text, Log, Embed IO] r =>+  DisplayId ->+  GiGdk.DisplayManager ->+  Sem r ()+tryOpenDisplay (DisplayId fallbackDisplay) dm = do+  Log.warn [exon|No default display available. Trying to connect to #{fallbackDisplay}|]+  tryStop (GiGdk.displayManagerOpenDisplay dm fallbackDisplay) >>= \case+    Just _ ->+      Log.info [exon|Connected to display #{fallbackDisplay}|]+    Nothing ->+      stop [exon|Could not connect to display #{fallbackDisplay}|]++noDisplayAvailable ::+  Members [Stop Text, Embed IO] r =>+  GiGdk.DisplayManager ->+  Sem r Bool+noDisplayAvailable dm =+  tryStop (isNothing <$> GiGdk.displayManagerGetDefaultDisplay dm)+ -- |Initialize GTK, run the scoped action, then tear down the GTK environment. bracketGtk ::   Members [Resource, Log, Embed IO] r =>-  (Display -> Sem (Stop Text : r) a) ->+  DisplayId ->+  (GiGdk.Display -> Sem (Stop Text : r) a) ->   Sem (Stop Text : r) a-bracketGtk =+bracketGtk fallbackDisplay =   bracket acquire release   where     acquire = do       unlessM (fst <$> tryStop (GiGtk.initCheck Nothing)) do-        stop "GTK intialization failed"+        dm <- tryStop GiGdk.displayManagerGet+        ifM (noDisplayAvailable dm) (tryOpenDisplay fallbackDisplay dm) (stop "GTK intialization failed")       getDisplay     release display = do       Log.debug "Quitting the GTK main loop"@@ -36,9 +59,10 @@ -- This uses 'Scoped' to bracket the initialization and termination of the GTK environment. interpretGtk ::   Members [Resource, Log, Embed IO] r =>-  InterpreterFor (Scoped Display (Gtk Display) !! Text) r-interpretGtk =-  interpretScopedResumable bracketGtk \ display -> \case+  X11Config ->+  InterpreterFor (Scoped GiGdk.Display (Gtk GiGdk.Display) !! Text) r+interpretGtk (X11Config fallbackDisplay) =+  interpretScopedResumable (bracketGtk (fromMaybe ":0" fallbackDisplay)) \ display -> \case     Gtk.Main ->       GiGtk.main     Gtk.Resource ->

@@ -0,0 +1,21 @@+-- |Aeson TH deriving, Internal+module Helic.Json where++import qualified Data.Aeson as Aeson+import Data.Aeson.TH (deriveJSON)+import qualified Language.Haskell.TH as TH++-- |Derive Aeson codecs for single-field types with custom settings.+unaryJson :: TH.Name -> TH.Q [TH.Dec]+unaryJson =+  deriveJSON Aeson.defaultOptions {+    Aeson.fieldLabelModifier = dropWhile ('_' ==)+  }++-- |Derive Aeson codecs with custom settings.+json :: TH.Name -> TH.Q [TH.Dec]+json =+  deriveJSON Aeson.defaultOptions {+    Aeson.fieldLabelModifier = dropWhile ('_' ==),+    Aeson.unwrapUnaryRecords = True+  }

@@ -24,7 +24,7 @@ listen =   Conc.subscribe do     Sync.putBlock Listening-    (forever (History.receive =<< Conc.consume))+    forever (History.receive =<< Conc.consume)  -- |Run an action with 'listen' in a thread, waiting for the event subscriber to be up and running before executing the -- action.

@@ -170,6 +170,7 @@ |`tmux.enable`|`true`|Whether to send events to *tmux*.| |`tmux.package`|`pkgs.tmux`|Only for *NixOS*: The `nixpkgs` package used for the *tmux* executable.| |`tmux.exe`|`tmux`|Only for YAML file: The path to the *tmux* executable|+|`x11.display`|`:0`|Only for YAML file: The path to the *tmux* executable|  # Neovim 

@@ -12,7 +12,7 @@  conf :: Config conf =-  Config (Just "dev") (Just def) (Just (NetConfig (Just 11111) Nothing Nothing)) Nothing (Just True)+  Config (Just "dev") (Just def) (Just (NetConfig (Just 11111) Nothing Nothing)) Nothing Nothing (Just True)  main :: IO () main =

@@ -1,5 +1,3 @@-{-# options_ghc -Wno-unused-imports #-}- module Helic.Test.ConfigFileTest where  import Path (Abs, File, Rel, absfile, relfile)@@ -11,15 +9,18 @@ import Helic.Data.Config (Config (Config)) import Helic.Data.NetConfig (NetConfig (NetConfig)) import Helic.Data.TmuxConfig (TmuxConfig (TmuxConfig))+import Helic.Data.X11Config (X11Config (X11Config))  target :: Config target =-  Config (Just "name") (Just tmux) (Just net) (Just 1000) (Just False)+  Config (Just "name") (Just tmux) (Just net) (Just x) (Just 1000) (Just False)   where     tmux =       TmuxConfig (Just True) (Just [absfile|/bin/tmux|])     net =       NetConfig (Just 10001) (Just 5) (Just ["remote:1000"])+    x =+      X11Config (Just ":1")  test_readConfigFile :: UnitTest test_readConfigFile = do