packages feed

systranything 0.1.2.0 → 0.1.3.0

raw patch · 32 files changed

+854/−490 lines, 32 filesdep +gi-gdk3dep +gi-gtk3dep +hspec-expectationsdep −gi-gdkdep −gi-gtkdep ~aesondep ~basedep ~bytestring

Dependencies added: gi-gdk3, gi-gtk3, hspec-expectations, systranything, tasty, tasty-autocollect, tasty-hunit-compat

Dependencies removed: gi-gdk, gi-gtk

Dependency ranges changed: aeson, base, bytestring, extra, gi-ayatana-appindicator3, gi-glib, gi-gobject, optparse-applicative, text, yaml

Files

README.md view
@@ -28,12 +28,12 @@ - a menu to toggle dual monitor setups - anything that requires a status icon and scriptable actions -See [the example file](example.yaml) to get started.+See [the example file](./tests/data/example.yaml) to get started.  Run it with:  ```bash-$ systranything -f ./example.yaml+$ systranything -f ./tests/data/example.yaml ```  It has a verbose mode which can be turned on with `-v`. It writes on `stdout` 
+ lib/Model/Checkbox.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.Checkbox (Checkbox (..), newItem) where++import Control.Monad (void)+import Data.Aeson.TH (deriveJSON)+import Data.Text (Text)+import Data.Text qualified as T+import Foreign.C (CULong)+import GHC.Generics (Generic)+import GI.GObject qualified as GObject+import GI.Gtk qualified as Gtk+import Model.Common (runCommand)+import Model.Internal (options)++data Checkbox = MkCheckbox+  { chLabel :: Text,+    chOnClick :: Text,+    chOnGetStatus :: Text+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''Checkbox)++newItem :: Bool -> Checkbox -> IO (Gtk.CheckMenuItem, IO ())+newItem verbose MkCheckbox {..} = do+  item <- Gtk.checkMenuItemNewWithLabel chLabel++  signalId <- runCommandOnToggle verbose chOnClick item++  pure (item, updateAction item signalId)+  where+    updateAction item signalId = do+      mbOutput <- runCommand verbose chOnGetStatus+      let active = maybe False (not . T.null) mbOutput+      GObject.signalHandlerBlock item signalId+      Gtk.checkMenuItemSetActive item active+      GObject.signalHandlerUnblock item signalId++runCommandOnToggle :: Bool -> Text -> Gtk.CheckMenuItem -> IO CULong+runCommandOnToggle verbose command item =+  Gtk.on item #toggled $ void $ runCommand verbose command
+ lib/Model/Command.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.Command (Command (..), periodicallyUpdateIcon) where++import Control.Monad (void)+import Data.Aeson.TH (deriveJSON)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty.Extra ((!?))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word32)+import GHC.Generics (Generic)+import GI.AyatanaAppIndicator3 qualified as AI+import GI.GLib qualified as GLib+import Model.Common (runCommand)+import Model.Internal (options)+import Text.Read (readMaybe)++data Command = MkCommand+  { coOnTimeout :: Text,+    coPollingInterval :: Word32,+    coIcons :: [Text]+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''Command)++periodicallyUpdateIcon :: Bool -> AI.Indicator -> Text -> Command -> IO ()+periodicallyUpdateIcon verbose indicator icon MkCommand {..} =+  void . GLib.timeoutAddSeconds GLib.PRIORITY_DEFAULT coPollingInterval $ do+    mbOutput <- runCommand verbose coOnTimeout++    let newIcon = fromMaybe icon $ fromIndex =<< toInt =<< mbOutput++    AI.indicatorSetIconFull indicator newIcon Nothing++    pure True+  where+    fromIndex = (!?) (icon :| coIcons)+    toInt = readMaybe . T.unpack
+ lib/Model/Common.hs view
@@ -0,0 +1,38 @@+module Model.Common (runCommand, runCommand') where++import Control.Monad (when)+import Data.ByteString.Lazy as LBS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.IO qualified as T+import System.Exit (ExitCode (..))+import System.Process.Typed (readProcess, shell)++runCommand :: Bool -> Text -> IO (Maybe Text)+runCommand = runCommand' T.putStrLn++-- | Takes a print function, to be able to test the produced output+runCommand' :: (Text -> IO ()) -> Bool -> Text -> IO (Maybe Text)+runCommand' output verbose command = do+  when verbose . output $ "Running command: " <> command++  (exitCode, stdoutBS, stderrBS) <- readProcess . shell $ T.unpack command++  let stdoutTxt = T.decodeUtf8Lenient (LBS.toStrict stdoutBS)++  when (exitCode /= ExitSuccess) $ do+    output "Command failed: "+    output command++  when (verbose || exitCode /= ExitSuccess) $ do+    let stderrTxt = T.decodeUtf8Lenient (LBS.toStrict stderrBS)+    output "stdout: "+    output stdoutTxt+    output "stderr: "+    output stderrTxt++  pure $+    if exitCode /= ExitSuccess+      then Nothing+      else Just $ T.stripEnd stdoutTxt
+ lib/Model/Indicator.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.Indicator (Indicator (..), newIndicator) where++import Control.Monad (void, when)+import Data.Aeson.TH (deriveJSON)+import Data.Foldable (traverse_)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Text (Text)+import GHC.Generics (Generic)+import GI.AyatanaAppIndicator3 qualified as AI+import GI.Gdk qualified as Gdk+import GI.Gtk qualified as Gtk+import Model.Command (Command, periodicallyUpdateIcon)+import Model.Common (runCommand)+import Model.Internal (options)++data Indicator = MkIndicator+  { inIcon :: Text,+    inCommand :: Maybe Command,+    inOnScrollUp :: Maybe Text,+    inOnScrollDown :: Maybe Text+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''Indicator)++newIndicator :: Bool -> Indicator -> Maybe Gtk.Menu -> IO AI.Indicator+newIndicator verbose indicator@MkIndicator {..} menu = do+  gtkIndicator <-+    AI.indicatorNew+      "systranything"+      inIcon+      AI.IndicatorCategorySystemServices++  -- The indicator beeing not active by default means it is hidden+  AI.indicatorSetStatus gtkIndicator AI.IndicatorStatusActive+  AI.indicatorSetMenu gtkIndicator menu++  traverse_ (periodicallyUpdateIcon False gtkIndicator inIcon) inCommand++  onScrollEvent verbose gtkIndicator indicator++  pure gtkIndicator++onScrollEvent :: Bool -> AI.Indicator -> Indicator -> IO ()+onScrollEvent verbose indicator (MkIndicator {..}) = do+  -- GTK sends one scroll up or down event followed by smooth events. Getting+  -- the actual direction from smooth requires to access the scroll event+  -- itself which doesn't seem possible with the current version of+  -- libayarana-appindicator++  refDirection <- newIORef Gdk.ScrollDirectionDown++  void $ Gtk.on indicator #scrollEvent $ \_ direction -> do+    when (direction /= Gdk.ScrollDirectionSmooth) $ do+      writeIORef refDirection direction++    lastDirection <- readIORef refDirection++    traverse_ (runCommand verbose) $+      if lastDirection == Gdk.ScrollDirectionDown+        then inOnScrollDown+        else inOnScrollUp
+ lib/Model/Internal.hs view
@@ -0,0 +1,13 @@+module Model.Internal (options) where++import Data.Aeson (Options(..), SumEncoding(..), camelTo2, defaultOptions)++options :: Options+options =+  defaultOptions+    { fieldLabelModifier = camelTo2 '-' . drop 2,+      constructorTagModifier = camelTo2 '-' . drop 2,+      omitNothingFields = True,+      sumEncoding = ObjectWithSingleField+    }+
+ lib/Model/Item.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.Item (Item (..), populate) where++import Control.Monad (void)+import Data.Aeson.TH (deriveJSON)+import Data.Foldable (traverse_)+import Data.List (singleton)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import GHC.Generics (Generic)+import GI.Gtk qualified as Gtk+import Model.Checkbox (Checkbox (..))+import Model.Checkbox qualified as Checkbox+import Model.Internal (options)+import Model.Label (Label)+import Model.Label qualified as Label+import Model.RadioGroup (RadioGroup (..))+import Model.RadioGroup qualified as RadioGroup+import {-# SOURCE #-} Model.SubMenu (SubMenu)+import {-# SOURCE #-} Model.SubMenu qualified as SubMenu++data Item+  = MkItemLabel Label+  | MkItemCheckbox Checkbox+  | MkItemRadioGroup RadioGroup+  | MkItemSubMenu SubMenu+  | MkItemSeparator+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''Item)++populate :: Bool -> NonEmpty Item -> IO Gtk.Menu+populate verbose items = do+  menu <- Gtk.menuNew+  updateStateActions <- traverse (initAppendAndShow menu) items+  void $ Gtk.on menu #show $ sequence_ updateStateActions+  pure menu+  where+    initAppendAndShow :: Gtk.Menu -> Item -> IO (IO ())+    initAppendAndShow menu item = do+      (menuItems, updateAction) <- newItem verbose item+      traverse_ (appendAndShow menu) menuItems+      pure updateAction++    appendAndShow :: Gtk.Menu -> Gtk.MenuItem -> IO ()+    appendAndShow menu item = do+      Gtk.menuShellAppend menu item+      Gtk.widgetShow item++newItem :: Bool -> Item -> IO ([Gtk.MenuItem], IO ())+newItem verbose (MkItemLabel label) =+  (,mempty) . singleton <$> Label.newItem verbose label+newItem verbose (MkItemCheckbox checkbox) = do+  (item, updateAction) <- Checkbox.newItem verbose checkbox+  menuItems <- Gtk.toMenuItem item+  pure ([menuItems], updateAction)+newItem verbose (MkItemRadioGroup group) = do+  (items, updateAction) <- RadioGroup.newItems verbose group+  menuItems <- traverse Gtk.toMenuItem $ NE.toList items+  pure (menuItems, updateAction)+newItem verbose (MkItemSubMenu submenu) =+  (,mempty) . singleton <$> SubMenu.newItem verbose submenu+newItem _ MkItemSeparator =+  (,mempty) . singleton <$> (Gtk.toMenuItem =<< Gtk.separatorMenuItemNew)
+ lib/Model/Label.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.Label (Label (..), newItem) where++import Control.Monad (void)+import Data.Aeson.TH (deriveJSON)+import Data.Text (Text)+import GHC.Generics (Generic)+import GI.Gtk qualified as Gtk+import Model.Common (runCommand)+import Model.Internal (options)++data Label = MkLabel+  { laLabel :: Text,+    laOnClick :: Text+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''Label)++newItem :: Bool -> Label -> IO Gtk.MenuItem+newItem verbose MkLabel {..} = do+  item <- Gtk.menuItemNewWithLabel laLabel+  void $ Gtk.on item #activate $ void $ runCommand verbose laOnClick+  pure item
+ lib/Model/RadioButton.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.RadioButton (RadioButton (..), newItem) where++import Data.Aeson.TH (deriveJSON)+import Data.Text (Text)+import GHC.Generics (Generic)+import GI.Gtk qualified as Gtk+import Model.Internal (options)++data RadioButton = MkRadioButton+  { raLabel :: Text,+    raOnClick :: Text+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''RadioButton)++newItem :: Text -> RadioButton -> IO Gtk.RadioMenuItem+newItem selected MkRadioButton {..} = do+  menuItem <- Gtk.radioMenuItemNewWithLabel ([] :: [Gtk.RadioMenuItem]) raLabel+  Gtk.checkMenuItemSetActive menuItem (selected == raLabel)+  pure menuItem
+ lib/Model/RadioGroup.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.RadioGroup (RadioGroup (..), newItems) where++import Control.Monad (void, when)+import Data.Aeson.TH (deriveJSON)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Foreign.C (CULong)+import GHC.Generics (Generic)+import GI.GObject qualified as GI+import GI.Gtk qualified as Gtk+import Model.Common (runCommand)+import Model.Internal (options)+import Model.RadioButton (RadioButton (..))+import Model.RadioButton qualified as RadioButton++data RadioGroup = MkRadioGroup+  { raButtons :: NonEmpty RadioButton,+    raDefault :: Text,+    raOnGetStatus :: Text+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''RadioGroup)++newItems :: Bool -> RadioGroup -> IO (NonEmpty Gtk.RadioMenuItem, IO ())+newItems verbose MkRadioGroup {..} = do+  items@(x :| xs) <- traverse (RadioButton.newItem raDefault) raButtons++  traverse_ (`Gtk.radioMenuItemJoinGroup` Just x) xs++  signalIds <- traverse connectOnToggled $ NE.zip items raButtons++  pure (items, updateAction $ NE.zip items signalIds)+  where+    connectOnToggled (item, MkRadioButton {..}) = do+      checkMenuItem <- Gtk.toCheckMenuItem item+      runCommandOnToggleActive verbose raOnClick checkMenuItem++    updateAction itemsAndSignalIds = do+      mbOutput <- runCommand verbose raOnGetStatus+      let selected = fromMaybe raDefault mbOutput+      traverse_ (updateActive selected) itemsAndSignalIds++    updateActive selected (item, signalId) = do+      label <- Gtk.menuItemGetLabel item+      GI.signalHandlerBlock item signalId+      Gtk.setCheckMenuItemActive item $ label == selected+      GI.signalHandlerUnblock item signalId++runCommandOnToggleActive :: Bool -> Text -> Gtk.CheckMenuItem -> IO CULong+runCommandOnToggleActive verbose command item =+  Gtk.on item #toggled $ do+    isActive <- Gtk.checkMenuItemGetActive item+    when isActive . void $ runCommand verbose command
+ lib/Model/Root.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.Root (Root (..)) where++import Data.Aeson.TH (deriveJSON)+import Data.List.NonEmpty (NonEmpty)+import GHC.Generics (Generic)+import Model.Indicator (Indicator)+import Model.Internal (options)+import Model.Item (Item)++data Root = MkRoot+  { roIndicator :: Indicator,+    roMenu :: Maybe (NonEmpty Item)+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''Root)
+ lib/Model/SubMenu.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}++module Model.SubMenu (SubMenu (..), newItem) where++import Data.Aeson.TH (deriveJSON)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import GHC.Generics (Generic)+import GI.Gtk qualified as Gtk+import Model.Internal (options)+import Model.Item (Item, populate)++data SubMenu = MkSubMenu+  { suLabel :: Text,+    suItems :: NonEmpty Item+  }+  deriving stock (Eq, Generic, Show)++$(deriveJSON options ''SubMenu)++newItem :: Bool -> SubMenu -> IO Gtk.MenuItem+newItem verbose (MkSubMenu {..}) = do+  subMenu <- populate verbose suItems+  item <- Gtk.menuItemNewWithLabel suLabel+  Gtk.menuItemSetSubmenu item $ Just subMenu+  pure item
+ lib/Model/SubMenu.hs-boot view
@@ -0,0 +1,16 @@+module Model.SubMenu where++import Data.Aeson (FromJSON, ToJSON)+import GI.Gtk qualified as Gtk++data SubMenu++instance Eq SubMenu++instance Show SubMenu++instance FromJSON SubMenu++instance ToJSON SubMenu++newItem :: Bool -> SubMenu -> IO Gtk.MenuItem
systranything.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2  name: systranything-version: 0.1.2.0+version: 0.1.3.0 synopsis: Let you put anything in the system tray homepage: https://github.com/jecaro/systranything author: Jean-Charles Quillet@@ -15,7 +15,7 @@   contains the specification of the menu items with shell commands to execute   when the items are clicked. tested-with:-  GHC == 9.4.5,+  GHC == 9.4.8,   GHC == 9.6.4,   GHC == 9.8.2 extra-source-files:@@ -24,55 +24,22 @@   CHANGELOG.md   README.md   demo.gif+data-files:+  tests/data/example.yaml  source-repository head   type: git   location: https://github.com/jecaro/systranything.git -executable systranything-  main-is:-    Main.hs-  hs-source-dirs:-    systranything-  other-modules:-    Model.Checkbox-    Model.Command-    Model.Common-    Model.Indicator-    Model.Internal-    Model.Item-    Model.Label-    Model.RadioGroup-    Model.RadioButton-    Model.Root-    Model.SubMenu-    Options-  build-depends:-    aeson >= 2.1.2 && < 2.2,-    base >= 4.16 && < 5,-    bytestring >= 0.11.4 && < 0.12,-    extra >= 1.7.14 && < 1.8,-    gi-ayatana-appindicator3 >= 0.1.0 && < 0.2,-    gi-gdk >= 3.0.28 && < 3.1,-    gi-glib >= 2.0.29 && < 2.1,-    gi-gobject >= 2.0.30 && < 2.1,-    gi-gtk >= 3.0.39 && < 3.1,-    optparse-applicative >= 0.17.1 && < 0.19,-    text >= 2.0.2 && < 2.1,-    typed-process >= 0.2.11 && < 0.3,-    unliftio >= 0.2.25 && < 0.3,-    yaml >= 0.11.11 && < 0.12,+common defaults   default-language:-    Haskell2010+    GHC2021   default-extensions:-    DeriveGeneric     DerivingStrategies     OverloadedLabels     OverloadedStrings     RecordWildCards-    ScopedTypeVariables     StrictData-    TupleSections   ghc-options:     -Wall     -Wcompat@@ -82,5 +49,91 @@     -Wpartial-fields     -Wredundant-constraints     -Wunused-packages++library+  import:+    defaults+  hs-source-dirs:+    lib+  exposed-modules:+    Model.Checkbox+    Model.Command+    Model.Common+    Model.Indicator+    Model.Internal+    Model.Item+    Model.Label+    Model.RadioButton+    Model.RadioGroup+    Model.Root+    Model.SubMenu+    Paths_systranything+  autogen-modules:+    Paths_systranything+  build-depends:+    aeson >= 2.1.2 && < 2.3,+    base >= 4.17.2 && < 5,+    bytestring >= 0.11.5 && < 0.13,+    extra >= 1.7.16 && < 1.9,+    gi-ayatana-appindicator3 >= 0.1.1 && < 0.2,+    gi-gdk3 >= 3.0.29 && < 3.1,+    gi-glib >= 2.0.30 && < 2.1,+    gi-gobject >= 2.0.31 && < 2.1,+    gi-gtk3 >= 3.0.43 && < 3.1,+    text >= 2.0.2 && < 2.2,+    typed-process >= 0.2.11 && < 0.3,++executable systranything+  import:+    defaults+  main-is:+    Main.hs+  hs-source-dirs:+    systranything+  other-modules:+    Options+    Paths_systranything+  autogen-modules:+    Paths_systranything+  build-depends:+    base,+    gi-glib,+    gi-gtk3,+    optparse-applicative >= 0.18.1 && < 0.20,+    systranything,+    unliftio >= 0.2.25 && < 0.3,+    yaml >= 0.11.11 && < 0.12,+  ghc-options:     -threaded     -with-rtsopts=-N++test-suite tests+  import:+    defaults+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    tests+  main-is:+    Main.hs+  other-modules:+    Tests.Model.Common+    Tests.Model.Root+  ghc-options: -F -pgmF=tasty-autocollect+  build-tool-depends:+    tasty-autocollect:tasty-autocollect+  build-depends:+    base,+    hspec-expectations >= 0.8.4 && < 0.9,+    systranything,+    tasty >= 1.4.3 && < 1.6,+    tasty-hunit-compat >= 0.2.0 && < 0.3,+    text,+    yaml+  if impl(ghc < 9.6)+    build-depends:+      tasty-autocollect == 0.4.2+  else+    build-depends:+      tasty-autocollect >= 0.4.3 && < 0.5+
systranything/Main.hs view
@@ -2,33 +2,41 @@  import Control.Exception (Exception (..), SomeException) import Control.Monad (void)+import Data.Version (showVersion) import Data.Yaml (decodeFileThrow, prettyPrintParseException) import qualified GI.GLib as GLib import qualified GI.Gtk as Gtk import Model.Indicator (newIndicator) import Model.Item (populate) import Model.Root (Root (..))-import Options (Options (..), parseArgs)+import Options (Options (..), Settings (..), parseArgs)+import Paths_systranything (version)+import System.Environment (getProgName) import System.Exit (exitFailure) import System.IO (hPutStr, stderr) import UnliftIO (handleAny)  main :: IO () main = do-  MkOptions {..} <- parseArgs--  handleAny exceptions $ do-    MkRoot {..} <- decodeFileThrow opFilename+  options <- parseArgs+  case options of+    OpVersion -> do+      progName <- getProgName+      putStrLn $ progName <> " " <> showVersion version+    OpOptions (MkSettings {..}) ->+      handleAny exceptions $ do+        MkRoot {..} <- decodeFileThrow seFilename -    void . Gtk.init $ Nothing+        void . Gtk.init $ Nothing -    mbMenu <- traverse (populate opVerbose) roMenu-    indicator <- newIndicator opVerbose roIndicator mbMenu+        mbMenu <- traverse (populate seVerbose) roMenu+        indicator <- newIndicator seVerbose roIndicator mbMenu -    -- Make sure the indicator is not garbage collected. That's mandatory for-    -- the case when there is no periodic update to keep the indicator alive.-    Gtk.withManagedPtr indicator . const $-      GLib.mainLoopRun =<< GLib.mainLoopNew Nothing False+        -- Make sure the indicator is not garbage collected. That's mandatory+        -- for the case when there is no periodic update to keep the indicator+        -- alive.+        Gtk.withManagedPtr indicator . const $+          GLib.mainLoopRun =<< GLib.mainLoopNew Nothing False  exceptions :: SomeException -> IO () exceptions e = hPutStr stderr message >> exitFailure
− systranything/Model/Checkbox.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.Checkbox (Checkbox (..), newItem) where--import Control.Monad (void)-import Data.Aeson.TH (deriveJSON)-import Data.Text (Text)-import qualified Data.Text as T-import Foreign.C (CULong)-import GHC.Generics (Generic)-import qualified GI.GObject as GObject-import qualified GI.Gtk as Gtk-import Model.Common (runCommand)-import Model.Internal (options)--data Checkbox = MkCheckbox-  { chLabel :: Text,-    chOnClick :: Text,-    chOnGetStatus :: Text-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''Checkbox)--newItem :: Bool -> Checkbox -> IO (Gtk.CheckMenuItem, IO ())-newItem verbose MkCheckbox {..} = do-  item <- Gtk.checkMenuItemNewWithLabel chLabel--  signalId <- runCommandOnToggle verbose chOnClick item--  pure (item, updateAction item signalId)-  where-    updateAction item signalId = do-      mbOutput <- runCommand verbose chOnGetStatus-      let active = maybe False (not . T.null) mbOutput-      GObject.signalHandlerBlock item signalId-      Gtk.checkMenuItemSetActive item active-      GObject.signalHandlerUnblock item signalId--runCommandOnToggle :: Bool -> Text -> Gtk.CheckMenuItem -> IO CULong-runCommandOnToggle verbose command item =-  Gtk.on item #toggled . void $ runCommand verbose command
− systranything/Model/Command.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.Command (Command (..), periodicallyUpdateIcon) where--import Control.Monad (void)-import Data.Aeson.TH (deriveJSON)-import Data.List.NonEmpty (NonEmpty (..))-import Data.List.NonEmpty.Extra ((!?))-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Word (Word32)-import GHC.Generics (Generic)-import qualified GI.AyatanaAppIndicator3 as AI-import qualified GI.GLib as GLib-import Model.Common (runCommand)-import Model.Internal (options)-import Text.Read (readMaybe)--data Command = MkCommand-  { coOnTimeout :: Text,-    coPoolingInterval :: Word32,-    coIcons :: [Text]-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''Command)--periodicallyUpdateIcon :: Bool -> AI.Indicator -> Text -> Command -> IO ()-periodicallyUpdateIcon verbose indicator icon MkCommand {..} =-  void . GLib.timeoutAddSeconds GLib.PRIORITY_DEFAULT coPoolingInterval $ do-    mbOutput <- runCommand verbose coOnTimeout--    let newIcon = fromMaybe icon $ fromIndex =<< toInt =<< mbOutput--    AI.indicatorSetIconFull indicator newIcon Nothing--    pure True-  where-    fromIndex = (!?) (icon :| coIcons)-    toInt = readMaybe . T.unpack
− systranything/Model/Common.hs
@@ -1,34 +0,0 @@-module Model.Common (runCommand) where--import Control.Monad (when)-import Data.ByteString.Lazy as LBS-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.IO as T-import System.Exit (ExitCode (..))-import System.Process.Typed (readProcess, shell)--runCommand :: Bool -> Text -> IO (Maybe Text)-runCommand verbose command = do-  when verbose . T.putStrLn $ "Running command: " <> command--  (exitCode, stdoutBS, stderrBS) <- readProcess . shell $ T.unpack command--  let stdoutTxt = T.decodeUtf8Lenient (LBS.toStrict stdoutBS)--  when (exitCode /= ExitSuccess) $ do-    T.putStrLn "Command failed: "-    T.putStrLn command--  when (verbose || exitCode /= ExitSuccess) $ do-    let stderrTxt = T.decodeUtf8Lenient (LBS.toStrict stderrBS)-    T.putStrLn "stdout: "-    T.putStrLn stdoutTxt-    T.putStrLn "stderr: "-    T.putStrLn stderrTxt--  pure $-    if exitCode /= ExitSuccess-      then Nothing-      else Just $ T.stripEnd stdoutTxt
− systranything/Model/Indicator.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.Indicator (Indicator (..), newIndicator) where--import Control.Monad (void, when)-import Data.Aeson.TH (deriveJSON)-import Data.Foldable (traverse_)-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.Text (Text)-import GHC.Generics (Generic)-import qualified GI.AyatanaAppIndicator3 as AI-import qualified GI.Gdk as Gdk-import qualified GI.Gtk as Gtk-import Model.Command (Command, periodicallyUpdateIcon)-import Model.Common (runCommand)-import Model.Internal (options)--data Indicator = MkIndicator-  { inIcon :: Text,-    inCommand :: Maybe Command,-    inOnScrollUp :: Maybe Text,-    inOnScrollDown :: Maybe Text-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''Indicator)--newIndicator :: Bool -> Indicator -> Maybe Gtk.Menu -> IO AI.Indicator-newIndicator verbose indicator@MkIndicator {..} menu = do-  gtkIndicator <--    AI.indicatorNew-      "systranything"-      inIcon-      AI.IndicatorCategorySystemServices--  -- The indicator beeing not active by default means it is hidden-  AI.indicatorSetStatus gtkIndicator AI.IndicatorStatusActive-  AI.indicatorSetMenu gtkIndicator menu--  traverse_ (periodicallyUpdateIcon False gtkIndicator inIcon) inCommand--  onScrollEvent verbose gtkIndicator indicator--  pure gtkIndicator--onScrollEvent :: Bool -> AI.Indicator -> Indicator -> IO ()-onScrollEvent verbose indicator (MkIndicator {..}) = do-  -- GTK sends one scroll up or down event followed by smooth events. Getting-  -- the actual direction from smooth requires to access the scroll event-  -- itself which doesn't seem possible with the current version of-  -- libayarana-appindicator--  refDirection <- newIORef Gdk.ScrollDirectionDown--  void . Gtk.on indicator #scrollEvent $ \_ direction -> do-    when (direction /= Gdk.ScrollDirectionSmooth) $ do-      writeIORef refDirection direction--    lastDirection <- readIORef refDirection--    traverse_ (runCommand verbose) $-      if lastDirection == Gdk.ScrollDirectionDown-        then inOnScrollDown-        else inOnScrollUp
− systranything/Model/Internal.hs
@@ -1,13 +0,0 @@-module Model.Internal (options) where--import Data.Aeson (Options(..), SumEncoding(..), camelTo2, defaultOptions)--options :: Options-options =-  defaultOptions-    { fieldLabelModifier = camelTo2 '-' . drop 2,-      constructorTagModifier = camelTo2 '-' . drop 2,-      omitNothingFields = True,-      sumEncoding = ObjectWithSingleField-    }-
− systranything/Model/Item.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.Item (Item (..), populate) where--import Control.Monad (void)-import Data.Aeson.TH (deriveJSON)-import Data.Foldable (traverse_)-import Data.List (singleton)-import Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NE-import GHC.Generics (Generic)-import qualified GI.Gtk as Gtk-import Model.Checkbox (Checkbox (..))-import qualified Model.Checkbox as Checkbox-import Model.Internal (options)-import Model.Label (Label)-import qualified Model.Label as Label-import Model.RadioGroup (RadioGroup (..))-import qualified Model.RadioGroup as RadioGroup-import {-# SOURCE #-} Model.SubMenu (SubMenu)-import {-# SOURCE #-} qualified Model.SubMenu as SubMenu--data Item-  = MkItemLabel Label-  | MkItemCheckbox Checkbox-  | MkItemRadioGroup RadioGroup-  | MkItemSubMenu SubMenu-  | MkItemSeparator-  deriving stock (Generic, Show)--$(deriveJSON options ''Item)--populate :: Bool -> NonEmpty Item -> IO Gtk.Menu-populate verbose items = do-  menu <- Gtk.menuNew-  updateStateActions <- traverse (initAppendAndShow menu) items-  void . Gtk.on menu #show $ sequence_ updateStateActions-  pure menu-  where-    initAppendAndShow :: Gtk.Menu -> Item -> IO (IO ())-    initAppendAndShow menu item = do-      (menuItems, updateAction) <- newItem verbose item-      traverse_ (appendAndShow menu) menuItems-      pure updateAction--    appendAndShow :: Gtk.Menu -> Gtk.MenuItem -> IO ()-    appendAndShow menu item = do-      Gtk.menuShellAppend menu item-      Gtk.widgetShow item--newItem :: Bool -> Item -> IO ([Gtk.MenuItem], IO ())-newItem verbose (MkItemLabel label) =-  (,mempty) . singleton <$> Label.newItem verbose label-newItem verbose (MkItemCheckbox checkbox) = do-  (item, updateAction) <- Checkbox.newItem verbose checkbox-  menuItems <- Gtk.toMenuItem item-  pure ([menuItems], updateAction)-newItem verbose (MkItemRadioGroup group) = do-  (items, updateAction) <- RadioGroup.newItems verbose group-  menuItems <- traverse Gtk.toMenuItem $ NE.toList items-  pure (menuItems, updateAction)-newItem verbose (MkItemSubMenu submenu) =-  (,mempty) . singleton <$> SubMenu.newItem verbose submenu-newItem _ MkItemSeparator =-  (,mempty) . singleton <$> (Gtk.toMenuItem =<< Gtk.separatorMenuItemNew)
− systranything/Model/Label.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.Label (Label (..), newItem) where--import Control.Monad (void)-import Data.Aeson.TH (deriveJSON)-import Data.Text (Text)-import GHC.Generics (Generic)-import qualified GI.Gtk as Gtk-import Model.Common (runCommand)-import Model.Internal (options)--data Label = MkLabel-  { laLabel :: Text,-    laOnClick :: Text-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''Label)--newItem :: Bool -> Label -> IO Gtk.MenuItem-newItem verbose MkLabel {..} = do-  item <- Gtk.menuItemNewWithLabel laLabel-  void . Gtk.on item #activate . void $ runCommand verbose laOnClick-  pure item
− systranything/Model/RadioButton.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.RadioButton (RadioButton (..), newItem) where--import Data.Aeson.TH (deriveJSON)-import Data.Text (Text)-import GHC.Generics (Generic)-import qualified GI.Gtk as Gtk-import Model.Internal (options)--data RadioButton = MkRadioButton-  { raLabel :: Text,-    raOnClick :: Text-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''RadioButton)--newItem :: Text -> RadioButton -> IO Gtk.RadioMenuItem-newItem selected MkRadioButton {..} = do-  menuItem <- Gtk.radioMenuItemNewWithLabel ([] :: [Gtk.RadioMenuItem]) raLabel-  Gtk.checkMenuItemSetActive menuItem (selected == raLabel)-  pure menuItem
− systranything/Model/RadioGroup.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.RadioGroup (RadioGroup (..), newItems) where--import Control.Monad (void, when)-import Data.Aeson.TH (deriveJSON)-import Data.Foldable (traverse_)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Foreign.C (CULong)-import GHC.Generics (Generic)-import qualified GI.GObject as GI-import qualified GI.Gtk as Gtk-import Model.Common (runCommand)-import Model.Internal (options)-import Model.RadioButton (RadioButton (..))-import qualified Model.RadioButton as RadioButton--data RadioGroup = MkRadioGroup-  { raButtons :: NonEmpty RadioButton,-    raDefault :: Text,-    raOnGetStatus :: Text-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''RadioGroup)--newItems :: Bool -> RadioGroup -> IO (NonEmpty Gtk.RadioMenuItem, IO ())-newItems verbose MkRadioGroup {..} = do-  items@(x :| xs) <- traverse (RadioButton.newItem raDefault) raButtons--  traverse_ (`Gtk.radioMenuItemJoinGroup` Just x) xs--  signalIds <- traverse connectOnToggled $ NE.zip items raButtons--  pure (items, updateAction $ NE.zip items signalIds)-  where-    connectOnToggled (item, MkRadioButton {..}) = do-      checkMenuItem <- Gtk.toCheckMenuItem item-      runCommandOnToggleActive verbose raOnClick checkMenuItem--    updateAction itemsAndSignalIds = do-      mbOutput <- runCommand verbose raOnGetStatus-      let selected = fromMaybe raDefault mbOutput-      traverse_ (updateActive selected) itemsAndSignalIds--    updateActive selected (item, signalId) = do-      label <- Gtk.menuItemGetLabel item-      GI.signalHandlerBlock item signalId-      Gtk.setCheckMenuItemActive item $ label == selected-      GI.signalHandlerUnblock item signalId--runCommandOnToggleActive :: Bool -> Text -> Gtk.CheckMenuItem -> IO CULong-runCommandOnToggleActive verbose command item =-  Gtk.on item #toggled $ do-    isActive <- Gtk.checkMenuItemGetActive item-    when isActive . void $ runCommand verbose command
− systranything/Model/Root.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.Root (Root (..)) where--import Data.Aeson.TH (deriveJSON)-import Data.List.NonEmpty (NonEmpty)-import GHC.Generics (Generic)-import Model.Indicator (Indicator)-import Model.Internal (options)-import Model.Item (Item)--data Root = MkRoot-  { roIndicator :: Indicator,-    roMenu :: Maybe (NonEmpty Item)-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''Root)
− systranything/Model/SubMenu.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Model.SubMenu (SubMenu (..), newItem) where--import Data.Aeson.TH (deriveJSON)-import Data.List.NonEmpty (NonEmpty)-import Data.Text (Text)-import GHC.Generics (Generic)-import qualified GI.Gtk as Gtk-import Model.Internal (options)-import Model.Item (Item, populate)--data SubMenu = MkSubMenu-  { suLabel :: Text,-    suItems :: NonEmpty Item-  }-  deriving stock (Generic, Show)--$(deriveJSON options ''SubMenu)--newItem :: Bool -> SubMenu -> IO Gtk.MenuItem-newItem verbose (MkSubMenu {..}) = do-  subMenu <- populate verbose suItems-  item <- Gtk.menuItemNewWithLabel suLabel-  Gtk.menuItemSetSubmenu item $ Just subMenu-  pure item
− systranything/Model/SubMenu.hs-boot
@@ -1,14 +0,0 @@-module Model.SubMenu where--import Data.Aeson (FromJSON, ToJSON)-import qualified GI.Gtk as Gtk--data SubMenu--instance Show SubMenu--instance FromJSON SubMenu--instance ToJSON SubMenu--newItem :: Bool -> SubMenu -> IO Gtk.MenuItem
systranything/Options.hs view
@@ -1,9 +1,10 @@-module Options (Options (..), parseArgs) where+module Options (Options (..), Settings (..), parseArgs) where -import Control.Applicative ((<**>))+import Control.Applicative (Alternative ((<|>)), (<**>)) import Options.Applicative   ( Parser,     execParser,+    flag',     fullDesc,     help,     helper,@@ -15,26 +16,34 @@     switch,   ) -data Options = MkOptions-  { opVerbose :: Bool,-    opFilename :: FilePath+data Settings = MkSettings+  { seFilename :: FilePath,+    seVerbose :: Bool   }   deriving (Show) +data Options = OpOptions Settings | OpVersion+ parseArgs :: IO Options parseArgs = execParser (info (parser <**> helper) fullDesc)  parser :: Parser Options-parser =-  MkOptions-    <$> switch-      ( long "verbose"-          <> short 'v'-          <> help "Enable verbose mode"-      )-    <*> strOption+parser = OpOptions <$> settingsParser <|> OpVersion <$ versionParser++versionParser :: Parser Bool+versionParser = flag' True (long "version" <> short 'V' <> help "Show version")++settingsParser :: Parser Settings+settingsParser =+  MkSettings+    <$> strOption       ( long "filename"           <> short 'f'           <> metavar "FILENAME"           <> help "Path to the configuration file"+      )+    <*> switch+      ( long "verbose"+          <> short 'v'+          <> help "Enable verbose mode"       )
+ tests/Main.hs view
@@ -0,0 +1,1 @@+{- AUTOCOLLECT.MAIN -}
+ tests/Tests/Model/Common.hs view
@@ -0,0 +1,51 @@+{- AUTOCOLLECT.TEST -}++module Tests.Model.Common+  (+  {- AUTOCOLLECT.TEST.export -}+  )+where++import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Text qualified as Text+import Model.Common (runCommand')+import Test.Hspec.Expectations (shouldBe, shouldSatisfy)+import Test.Tasty (testGroup)+import Test.Tasty.HUnit (testCase)++test :: TestTree+test =+  testGroup+    "runCommand"+    [ testGroup+        "succeeding"+        [ testCase "outputs stdout" $ do+            result <- runCommandNoOutput False succeedingCommand+            result `shouldBe` Just "hello",+          testCase "in verbose mode prints stdout and stderr" $ do+            (_, output) <- runCommandWithOutput True succeedingCommand+            output `shouldSatisfy` containsAll ["stdout", "stderr"]+        ],+      testGroup+        "failing"+        [ testCase "returns nothing" $ do+            result <- runCommandNoOutput False failingCommand+            result `shouldBe` Nothing,+          testCase "prints the command to stdout" $ do+            (_, output) <- runCommandWithOutput False failingCommand+            output `shouldSatisfy` Text.isInfixOf "exit 1",+          testCase "prints stdout and stderr" $ do+            (_, output) <- runCommandWithOutput False failingCommand+            output `shouldSatisfy` containsAll ["stdout", "stderr"]+        ]+    ]+  where+    succeedingCommand = "echo 'hello'"+    failingCommand = "exit 1"+    runCommandNoOutput = runCommand' $ const $ pure ()+    runCommandWithOutput verbose cmd = do+      ref <- newIORef Text.empty+      result <- runCommand' (appendTo ref) verbose cmd+      (result,) <$> readIORef ref+    appendTo ref = modifyIORef ref . flip (<>)+    containsAll extracts text = all (`Text.isInfixOf` text) extracts
+ tests/Tests/Model/Root.hs view
@@ -0,0 +1,130 @@+{- AUTOCOLLECT.TEST -}++module Tests.Model.Root+  (+  {- AUTOCOLLECT.TEST.export -}+  )+where++import Data.List.NonEmpty (NonEmpty (..))+import Data.Text as Text (unlines)+import Data.Yaml (decodeFileThrow)+import Model.Checkbox (Checkbox (..))+import Model.Command (Command (..))+import Model.Indicator (Indicator (..))+import Model.Item (Item (..))+import Model.Label (Label (..))+import Model.RadioButton (RadioButton (..))+import Model.RadioGroup (RadioGroup (..))+import Model.Root (Root (..))+import Model.SubMenu (SubMenu (..))+import Test.Hspec.Expectations (shouldBe)+import Test.Tasty.HUnit (testCase)++test :: TestTree+test = testCase "Read tests/data/example.yaml" $ do+  root :: Root <- decodeFileThrow "tests/data/example.yaml"+  root+    `shouldBe` MkRoot+      { roIndicator =+          MkIndicator+            { inIcon = "dialog-warning",+              inCommand =+                Just+                  ( MkCommand+                      { coOnTimeout =+                          Text.unlines+                            [ "# This snippet increments a counter between zero and two. Its stores",+                              "# its state in the `indicator` file.",+                              "if [ ! -f indicator ]; then",+                              "  echo -1 > indicator",+                              "fi",+                              "",+                              "current=$(cat indicator)",+                              "next=$((($current + 1) % 3))",+                              "",+                              "echo $next > indicator",+                              "cat indicator"+                            ],+                        coPollingInterval = 3,+                        coIcons = ["dialog-error", "dialog-question"]+                      }+                  ),+              inOnScrollUp = Just "echo scroll up",+              inOnScrollDown = Just "echo scroll down"+            },+        roMenu =+          Just+            ( MkItemLabel+                ( MkLabel+                    { laLabel = "Hello",+                      laOnClick = "zenity --info --text=Hello"+                    }+                )+                :| [ MkItemCheckbox+                       ( MkCheckbox+                           { chLabel = "A checkbox",+                             chOnClick =+                               Text.unlines+                                 [ "if [ -f checkbox-file ] ; then",+                                   "  rm checkbox-file",+                                   "else",+                                   "  touch checkbox-file",+                                   "fi"+                                 ],+                             chOnGetStatus = "ls checkbox-file || true"+                           }+                       ),+                     MkItemSubMenu+                       ( MkSubMenu+                           { suLabel = "A submenu",+                             suItems =+                               MkItemRadioGroup+                                 ( MkRadioGroup+                                     { raButtons =+                                         MkRadioButton+                                           { raLabel = "No choice",+                                             raOnClick = "rm -f radio-file-1 radio-file-2\n"+                                           }+                                           :| [ MkRadioButton+                                                  { raLabel = "Choice 1",+                                                    raOnClick = "rm -f radio-file-2\ntouch radio-file-1\n"+                                                  },+                                                MkRadioButton+                                                  { raLabel = "Choice 2",+                                                    raOnClick = "rm -f radio-file-1\ntouch radio-file-2\n"+                                                  }+                                              ],+                                       raDefault = "No choice",+                                       raOnGetStatus =+                                         Text.unlines+                                           [ "if [ -f radio-file-1 ] ; then",+                                             "  echo \"Choice 1\"",+                                             "elif [ -f radio-file-2 ] ; then",+                                             "  echo \"Choice 2\"",+                                             "else",+                                             "  echo \"None\"",+                                             "fi"+                                           ]+                                     }+                                 )+                                 :| [ MkItemSeparator,+                                      MkItemLabel+                                        ( MkLabel+                                            { laLabel = "Another label",+                                              laOnClick = ""+                                            }+                                        )+                                    ]+                           }+                       ),+                     MkItemSeparator,+                     MkItemLabel+                       ( MkLabel+                           { laLabel = "Quit",+                             laOnClick = "pkill systranything"+                           }+                       )+                   ]+            )+      }
+ tests/data/example.yaml view
@@ -0,0 +1,106 @@+# Parameters for the icon present in the system tray+indicator:+  # The default icon. It can be either a path to an image either the name of a+  # GTK icon like the following.+  icon: dialog-warning+  # Optional: A command can be triggered periodically to change the current+  # icon+  command:+    # Run every 3 seconds+    polling-interval: 3+    # The other icons+    icons:+    - dialog-error+    - dialog-question+    # The command to be run. It must output the index of the icon to show. 0+    # being the default icon. Other icon indexes start at 1.+    on-timeout: |+        # This snippet increments a counter between zero and two. Its stores+        # its state in the `indicator` file.+        if [ ! -f indicator ]; then+          echo -1 > indicator+        fi++        current=$(cat indicator)+        next=$((($current + 1) % 3))++        echo $next > indicator+        cat indicator+  # Optional: A callback for scroll up events+  on-scroll-up: echo scroll up+  # Optional: A callback for scroll down events+  on-scroll-down: echo scroll down++# Optional: A context menu+menu:+# A simple label which triggers a command+- item-label:+    label: Hello+    on-click: zenity --info --text=Hello++# A checkbox+- item-checkbox:+    label: A checkbox+    # The command to toggle the state of the checkbox+    on-click: |+      if [ -f checkbox-file ] ; then+        rm checkbox-file+      else+        touch checkbox-file+      fi+    # If that next command outputs any text, the checkbox will appear as+    # checked+    on-get-status: ls checkbox-file || true++# Sub-menus are possible too+- item-sub-menu:+    # With the label+    label: A submenu++    # And a list of items+    items:++      # A group of radio buttons+      - item-radio-group:+          # The default choice+          default: No choice++          # The list of the other buttons and callbacks+          buttons:++          - label: No choice+            on-click: |+              rm -f radio-file-1 radio-file-2++          - label: Choice 1+            on-click: |+              rm -f radio-file-2+              touch radio-file-1++          - label: Choice 2+            on-click: |+              rm -f radio-file-1+              touch radio-file-2++          # That command must output the label of the currently selected button.+          # systranything will fallback on the default if needed.+          on-get-status: |+            if [ -f radio-file-1 ] ; then+              echo "Choice 1"+            elif [ -f radio-file-2 ] ; then+              echo "Choice 2"+            else+              echo "None"+            fi++      - item-separator: []++      - item-label:+          label: Another label+          on-click: ""++- item-separator: []++- item-label:+    label: Quit+    on-click: pkill systranything