{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
-----------------------------------------------------------------------------
module System.Taffybar
  (
  -- | Taffybar is a system status bar meant for use with window managers like
  -- "XMonad" and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use
  -- more heavy weight GUI in the form of GTK rather than the mostly textual
  -- approach favored by the latter. This allows it to provide features like an
  -- SNI system tray, and a workspace widget with window icons.
  --

  -- * Configuration
  -- |
  -- The interface that Taffybar provides to the end user is roughly as follows:
  -- you give Taffybar a list of ('TaffyIO' actions that build) GTK widgets and
  -- it renders them in a horizontal bar for you (taking care of ugly details
  -- like reserving strut space so that window managers don't put windows over
  -- it).
  --
  -- The config file in which you specify the GTK widgets to render is just a
  -- Haskell source file which is used to produce a custom executable with the
  -- desired set of widgets. This approach requires that Taffybar be installed
  -- as a Haskell library (not merely as an executable), and that the GHC
  -- compiler be available for recompiling the configuration. The upshot of this
  -- approach is that Taffybar's behavior and widget set are not limited to the
  -- set of widgets provided by the library, because custom code and widgets can
  -- be provided to Taffybar for instantiation and execution.
  --
  -- The following code snippet is a simple example of what a Taffybar
  -- configuration might look like (also see "System.Taffybar.Example"):
  --
  -- > {-# LANGUAGE OverloadedStrings #-}
  -- > import Data.Default (def)
  -- > import System.Taffybar
  -- > import System.Taffybar.Information.CPU
  -- > import System.Taffybar.SimpleConfig
  -- > import System.Taffybar.Widget
  -- > import System.Taffybar.Widget.Generic.Graph
  -- > import System.Taffybar.Widget.Generic.PollingGraph
  -- >
  -- > cpuCallback = do
  -- >   (_, systemLoad, totalLoad) <- cpuLoad
  -- >   return [ totalLoad, systemLoad ]
  -- >
  -- > main = do
  -- >   let cpuCfg = def
  -- >                  { graphDataColors = [ (0, 1, 0, 1), (1, 0, 1, 0.5)]
  -- >                  , graphLabel = Just "cpu"
  -- >                  }
  -- >       clock = textClockNewWith def
  -- >       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
  -- >       workspaces = workspacesNew def
  -- >       simpleConfig = def
  -- >                        { startWidgets = [ workspaces ]
  -- >                        , endWidgets = [ sniTrayNew, clock, cpu ]
  -- >                        }
  -- >   simpleTaffybar simpleConfig
  --
  -- This configuration creates a bar with four widgets. On the left is a widget
  -- that shows information about the workspace configuration. The rightmost
  -- widget is the system tray, with a clock and then a CPU graph.
  --
  -- The CPU widget plots two graphs on the same widget: total CPU use in green
  -- and then system CPU use in a kind of semi-transparent purple on top of the
  -- green.
  --
  -- It is important to note that the widget lists are __not__ @'GI.Gtk.Widget'@. They are
  -- actually @'TaffyIO' 'GI.Gtk.Widget'@ since the bar needs to construct them after
  -- performing some GTK initialization.

    getTaffyFile

  -- ** Colors
  --
  -- | Although Taffybar is based on GTK, it ignores your GTK theme. The default
  -- theme that it uses lives at
  -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter
  -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking.
  -- For an idea of the customizations you can make, see
  -- <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.


  -- * Taffybar and DBus
  --
  -- | Taffybar has a strict dependency on "DBus", so you must ensure that the DBus daemon is
  -- started before starting Taffybar.
  --
  -- * If you start your window manager using a graphical login manager like @gdm@
  -- or @kdm@, DBus should be started automatically for you.
  --
  -- * If you start xmonad with a different graphical login manager that does
  -- not start DBus for you automatically, put the line
  -- @eval \`dbus-launch --auto-syntax\`@ into your @~\/.xsession@ *before* xmonad and taffybar are
  -- started. This command sets some environment variables that the two must
  -- agree on.
  --
  -- * If you start xmonad via @startx@ or a similar command, add the
  -- above command to @~\/.xinitrc@
  --
  -- * System tray compatability
  --
  -- "System.Taffybar.Widget.SNITray" only supports the newer
  -- StatusNotifierItem (SNI) protocol; older xembed applets will not work.
  -- AppIndicator is also a valid implementation of SNI.
  --
  -- Additionally, this module does not handle recognising new tray applets.
  -- Instead it is necessary to run status-notifier-watcher from the
  -- [status-notifier-item](https://github.com/taffybar/status-notifier-item)
  -- package early on system startup.
  -- In case this is not possible, the alternative widget
  -- 'System.Taffybar.Widget.SNITray.sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is available, but
  -- this may not necessarily be able to pick up everything.

  -- * Starting
  ,  startTaffybar

  -- ** Using Dyre
  , dyreTaffybar
  , dyreTaffybarMain
  , taffybarDyreParams
  ) where

import qualified Control.Concurrent.MVar as MV
import qualified Config.Dyre as Dyre
import qualified Config.Dyre.Params as Dyre
import           Control.Exception ( finally )
import           Data.Function ( on )
import           Control.Monad
import qualified Data.GI.Gtk.Threading as GIThreading
import           Data.List ( groupBy, sort, isPrefixOf )
import qualified Data.Text as T
import           Data.Word (Word32)
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk
import qualified GI.GLib as G
import           Graphics.X11.Xlib.Misc ( initThreads )
import           System.Directory
import           System.Environment.XDG.BaseDir ( getUserConfigFile )
import           System.Exit ( exitFailure )
import           System.FilePath ( (</>), normalise, takeDirectory, takeFileName )
import           System.FSNotify ( startManager, watchDir, stopManager, EventIsDirectory (..), Event (..) )
import qualified System.IO as IO
import           System.Log.Logger
import           System.Taffybar.Context
import           System.Taffybar.Hooks
import           System.Taffybar.Util ( onSigINT, maybeHandleSigHUP, rebracket_ )

import           Paths_taffybar ( getDataDir )

-- | The parameters that are passed to Dyre when taffybar is invoked with
-- 'dyreTaffybar'.
taffybarDyreParams :: Params TaffybarConfig ()
taffybarDyreParams =
  (String
-> (TaffybarConfig -> IO ())
-> (TaffybarConfig -> String -> TaffybarConfig)
-> Params TaffybarConfig ()
forall cfg a.
String -> (cfg -> IO a) -> (cfg -> String -> cfg) -> Params cfg a
Dyre.newParams String
"taffybar" TaffybarConfig -> IO ()
dyreTaffybarMain TaffybarConfig -> String -> TaffybarConfig
showError)
  { Dyre.ghcOpts = ["-threaded", "-rtsopts"]
  , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]
  }

-- | Use Dyre to configure and start Taffybar. This will automatically recompile
-- Taffybar whenever there are changes to your @taffybar.hs@ configuration file.
dyreTaffybar :: TaffybarConfig -> IO ()
dyreTaffybar :: TaffybarConfig -> IO ()
dyreTaffybar = Params TaffybarConfig () -> TaffybarConfig -> IO ()
forall cfgType a. Params cfgType a -> cfgType -> IO a
Dyre.wrapMain Params TaffybarConfig ()
taffybarDyreParams

showError :: TaffybarConfig -> String -> TaffybarConfig
showError :: TaffybarConfig -> String -> TaffybarConfig
showError TaffybarConfig
cfg String
msg = TaffybarConfig
cfg { errorMsg = Just msg }

-- | The main function that Dyre should run. This is used in 'taffybarDyreParams'.
dyreTaffybarMain :: TaffybarConfig -> IO ()
dyreTaffybarMain :: TaffybarConfig -> IO ()
dyreTaffybarMain TaffybarConfig
cfg =
  case TaffybarConfig -> Maybe String
errorMsg TaffybarConfig
cfg of
    Maybe String
Nothing -> TaffybarConfig -> IO ()
startTaffybar TaffybarConfig
cfg
    Just String
err -> do
      Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
      IO ()
forall a. IO a
exitFailure

-- | Locate installed vendor data file.
getDataFile :: String -> IO FilePath
getDataFile :: String -> IO String
getDataFile String
name = do
  String
dataDir <- IO String
getDataDir
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normalise (String
dataDir String -> String -> String
</> String
name))

-- | Locates full the 'FilePath' of the given Taffybar config file.
-- The [XDG Base Directory](https://specifications.freedesktop.org/basedir-spec/latest/) convention is used, meaning that config files are usually in @~\/.config\/taffybar@.
getTaffyFile :: String -> IO FilePath
getTaffyFile :: String -> IO String
getTaffyFile = String -> String -> IO String
getUserConfigFile String
"taffybar"

-- | Return CSS files which should be loaded for the given config.
getCSSPaths :: TaffybarConfig -> IO [FilePath]
getCSSPaths :: TaffybarConfig -> IO [String]
getCSSPaths TaffybarConfig{[String]
cssPaths :: [String]
cssPaths :: TaffybarConfig -> [String]
cssPaths} = [IO String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (IO String
defaultCSSIO String -> [IO String] -> [IO String]
forall a. a -> [a] -> [a]
:[IO String]
userCSS)
  where
    -- Vendor CSS file, which is always loaded before user's CSS.
    defaultCSS :: IO String
defaultCSS = String -> IO String
getDataFile String
"taffybar.css"
    -- User's configured CSS files, with XDG config file being the default.
    userCSS :: [IO String]
userCSS | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cssPaths = [String -> IO String
getTaffyFile String
"taffybar.css"]
            | Bool
otherwise     = (String -> IO String) -> [String] -> [IO String]
forall a b. (a -> b) -> [a] -> [b]
map String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
cssPaths

-- | Overrides the default GTK theme and settings with CSS styles from
-- the given files (if they exist).
--
-- This causes the bar (by design) to ignore the real GTK theme and
-- just use the provided minimal theme to set the background and text
-- colors.
startCSS :: [FilePath] -> IO (IO (), Gtk.CssProvider)
startCSS :: [String] -> IO (IO (), CssProvider)
startCSS = Word32 -> [String] -> IO (IO (), CssProvider)
startCSS' Word32
800

-- | Installs a GTK style provider at a certain priority and loads it
-- with styles from a list of CSS files (if they exist).
--
-- This will return the 'Gtk.CssProvider' object, paired with a
-- cleanup function which can be used later to uninstall the style
-- provider.
--
-- The priority defines how the Taffybar CSS cascades with the GTK theme, etc.
-- For your information, these are the GTK defined priorities:
--  * @GTK_STYLE_PROVIDER_PRIORITY_FALLBACK@ = 1
--  * @GTK_STYLE_PROVIDER_PRIORITY_THEME@ = 100
--  * @GTK_STYLE_PROVIDER_PRIORITY_SETTINGS@ = 400
--  * @GTK_STYLE_PROVIDER_PRIORITY_APPLICATION@ = 600
--  * @GTK_STYLE_PROVIDER_PRIORITY_USER@ = 800
--
-- The file @XDG_CONFIG_HOME/gtk-3.0/gtk.css@ uses priority 800.
startCSS' :: Word32  -> [FilePath] -> IO (IO (), Gtk.CssProvider)
startCSS' :: Word32 -> [String] -> IO (IO (), CssProvider)
startCSS' Word32
prio [String]
cssFilePaths = do
  CssProvider
provider <- IO CssProvider
forall (m :: * -> *). (HasCallStack, MonadIO m) => m CssProvider
Gtk.cssProviderNew
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CssProvider -> String -> IO ()
forall {a}.
(IsDescendantOf CssProvider a, GObject a) =>
a -> String -> IO ()
logLoadCSSFile CssProvider
provider) ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
cssFilePaths
  IO ()
uninstall <- CssProvider -> Maybe Screen -> IO (IO ())
install CssProvider
provider (Maybe Screen -> IO (IO ())) -> IO (Maybe Screen) -> IO (IO ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe Screen)
forall (m :: * -> *). (HasCallStack, MonadIO m) => m (Maybe Screen)
Gdk.screenGetDefault
  (IO (), CssProvider) -> IO (IO (), CssProvider)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ()
uninstall, CssProvider
provider)
  where
    logLoadCSSFile :: a -> String -> IO ()
logLoadCSSFile a
p String
f = Priority -> String -> IO ()
logTaffy Priority
INFO (String
"Loading stylesheet " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> String -> IO ()
forall {a} {m :: * -> *}.
(IsDescendantOf CssProvider a, MonadIO m, GObject a) =>
a -> String -> m ()
loadCSSFile a
p String
f
    loadCSSFile :: a -> String -> m ()
loadCSSFile a
p = a -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsCssProvider a) =>
a -> Text -> m ()
Gtk.cssProviderLoadFromPath a
p (Text -> m ()) -> (String -> Text) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    install :: CssProvider -> Maybe Screen -> IO (IO ())
install CssProvider
provider (Just Screen
scr) = do
      Screen -> CssProvider -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsScreen a, IsStyleProvider b) =>
a -> b -> Word32 -> m ()
Gtk.styleContextAddProviderForScreen Screen
scr CssProvider
provider Word32
prio
      IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Screen -> CssProvider -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsScreen a, IsStyleProvider b) =>
a -> b -> m ()
Gtk.styleContextRemoveProviderForScreen Screen
scr CssProvider
provider)
    install CssProvider
_ Maybe Screen
Nothing = IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Uses 'startCSS' in a 'bracket' block to ensure that the CSS
-- provider is removed when Taffybar finishes.
--
-- An @inotify@ watch list will be set up so that a change to any of
-- the CSS files causes the CSS provider to be reloaded.
--
-- If Taffybar is running as a daemon, then this also installs a
-- handler on @SIGHUP@ which triggers reloading of the CSS files, and
-- recreates the inotify watcher.
withCSSReloadable :: [FilePath] -> IO () -> IO ()
withCSSReloadable :: [String] -> IO () -> IO ()
withCSSReloadable [String]
css IO ()
action = IO (IO ()) -> (IO () -> IO ()) -> IO ()
forall a. IO (IO ()) -> (IO () -> IO a) -> IO a
rebracket_ ((IO (), CssProvider) -> IO ()
forall a b. (a, b) -> a
fst ((IO (), CssProvider) -> IO ())
-> IO (IO (), CssProvider) -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> IO (IO (), CssProvider)
startCSS [String]
css) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
reload -> do
  let reload' :: IO ()
reload' = IO ()
noteReload IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
reload
  IO (IO ()) -> (IO () -> IO ()) -> IO ()
forall a. IO (IO ()) -> (IO () -> IO a) -> IO a
rebracket_ ([String] -> IO () -> IO (IO ())
watchCSS [String]
css IO ()
reload') ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
rewatch -> do
    let rewatch' :: IO ()
rewatch' = IO ()
noteRewatch IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
rewatch IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
reload
    IO () -> IO () -> IO ()
forall a. IO () -> IO a -> IO a
maybeHandleSigHUP IO ()
rewatch' IO ()
action
  where
    noteReload :: IO ()
noteReload = Priority -> String -> IO ()
logTaffy Priority
NOTICE String
"Reloading CSS..."
    noteRewatch :: IO ()
noteRewatch = Priority -> String -> IO ()
logTaffy Priority
NOTICE String
"SIGHUP received - restarting file watchers..."

-- | Opens an @inotify@ instance and watches the directories containing
-- our CSS files.
--
-- The given notifier function will be called shortly after one of the
-- CSS files changes.
--
-- A cleanup function is returned which will clear the watch list and
-- close the @inotify@ instance.
watchCSS :: [FilePath] -> IO () -> IO (IO ())
watchCSS :: [String] -> IO () -> IO (IO ())
watchCSS [String]
css IO ()
notifier = do
  Event -> IO ()
callback <- Word32 -> IO () -> IO (Event -> IO ())
forall {a}. Word32 -> IO () -> IO (a -> IO ())
debounce Word32
100 IO ()
notifier
  WatchManager
mgr <- IO WatchManager
startManager
  [(String, [String])]
cssDirs <- [String] -> IO [(String, [String])]
getDirs [String]
css
  ((String, [String]) -> IO (IO ())) -> [(String, [String])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(String
dir, [String]
fs) -> WatchManager
-> String -> ActionPredicate -> (Event -> IO ()) -> IO (IO ())
watchDir WatchManager
mgr String
dir ([String] -> ActionPredicate
forall {t :: * -> *}. Foldable t => t String -> ActionPredicate
eventP [String]
fs) Event -> IO ()
callback) [(String, [String])]
cssDirs
  IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WatchManager -> IO ()
stopManager WatchManager
mgr)
  where
    getDirs :: [String] -> IO [(String, [String])]
getDirs = ((String, [String]) -> IO Bool)
-> [(String, [String])] -> IO [(String, [String])]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist (String -> IO Bool)
-> ((String, [String]) -> String) -> (String, [String]) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [String]) -> String
forall a b. (a, b) -> a
fst)
      ([(String, [String])] -> IO [(String, [String])])
-> ([String] -> [(String, [String])])
-> [String]
-> IO [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [String]) -> Bool)
-> [(String, [String])] -> [(String, [String])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, [String]) -> Bool) -> (String, [String]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"/nix/store/" (String -> Bool)
-> ((String, [String]) -> String) -> (String, [String]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [String]) -> String
forall a b. (a, b) -> a
fst)
      ([(String, [String])] -> [(String, [String])])
-> ([String] -> [(String, [String])])
-> [String]
-> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(String, [String])]
dirGroups
      ([String] -> [(String, [String])])
-> ([String] -> [String]) -> [String] -> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort
    dirGroups :: [String] -> [(String, [String])]
dirGroups [String]
xs = [ (String -> String
takeDirectory String
f, (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
takeFileName (String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fs))
                   | (String
f:[String]
fs) <- (String -> String -> Bool) -> [String] -> [[String]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> (String -> String) -> String -> String -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` String -> String
takeDirectory) [String]
xs]
    eventP :: t String -> ActionPredicate
eventP t String
fs Event
ev = Event -> EventIsDirectory
eventIsDirectory Event
ev EventIsDirectory -> EventIsDirectory -> Bool
forall a. Eq a => a -> a -> Bool
== EventIsDirectory
IsFile
      Bool -> Bool -> Bool
&& String -> String
takeFileName (Event -> String
eventPath Event
ev) String -> t String -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t String
fs

    -- inotify events arrive in batches. To avoid unnecessary reloads,
    -- accumulate events in an MVar and call the notifier after a
    -- short delay.
    debounce :: Word32 -> IO () -> IO (a -> IO ())
debounce Word32
msec IO ()
cb = do
      MVar [a]
buffer <- [a] -> IO (MVar [a])
forall a. a -> IO (MVar a)
MV.newMVar []
      let mainLoopCallback :: IO Bool
mainLoopCallback = do
             [a]
evs <- MVar [a] -> ([a] -> IO ([a], [a])) -> IO [a]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar [a]
buffer (([a], [a]) -> IO ([a], [a])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([a], [a]) -> IO ([a], [a]))
-> ([a] -> ([a], [a])) -> [a] -> IO ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],))
             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
evs) IO ()
cb
             Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
G.SOURCE_REMOVE
      (a -> IO ()) -> IO (a -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> IO ()) -> IO (a -> IO ()))
-> (a -> IO ()) -> IO (a -> IO ())
forall a b. (a -> b) -> a -> b
$ \a
ev -> do
        MVar [a] -> ([a] -> IO [a]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar [a]
buffer ([a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> IO [a]) -> ([a] -> [a]) -> [a] -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
eva -> [a] -> [a]
forall a. a -> [a] -> [a]
:))
        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 -> Word32 -> IO Bool -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> Word32 -> IO Bool -> m Word32
G.timeoutAdd Int32
G.PRIORITY_LOW Word32
msec IO Bool
mainLoopCallback

-- | Start Taffybar with the provided 'TaffybarConfig'. This function will not
-- handle recompiling taffybar automatically when @taffybar.hs@ is updated. If you
-- would like this feature, use 'dyreTaffybar' instead. If automatic
-- recompilation is handled by another mechanism such as stack or a custom user
-- script or not desired for some reason, it is perfectly fine (and probably
-- better) to use this function.
startTaffybar :: TaffybarConfig -> IO ()
startTaffybar :: TaffybarConfig -> IO ()
startTaffybar TaffybarConfig
config = do
  String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
"" Logger -> Logger
removeHandler
  String -> IO ()
setTaffyLogFormatter String
"System.Taffybar"
  String -> IO ()
setTaffyLogFormatter String
"StatusNotifier"
  Status
_ <- IO Status
initThreads
  Maybe [Text]
_ <- Maybe [Text] -> IO (Maybe [Text])
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe [Text] -> m (Maybe [Text])
Gtk.init Maybe [Text]
forall a. Maybe a
Nothing
  IO ()
GIThreading.setCurrentThreadAsGUIThread

  [String]
cssPathsToLoad <- TaffybarConfig -> IO [String]
getCSSPaths TaffybarConfig
config
  Context
context <- TaffybarConfig -> IO Context
buildContext TaffybarConfig
config

  [String] -> IO () -> IO ()
withCSSReloadable [String]
cssPathsToLoad (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
Gtk.main
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Priority -> String -> IO ()
logTaffy Priority
DEBUG String
"Finished main loop"
    IO () -> IO () -> IO ()
forall a. IO a -> IO () -> IO a
`onSigINT` do
      Priority -> String -> IO ()
logTaffy Priority
INFO String
"Interrupted"
      Context -> IO ()
exitTaffybar Context
context

  Priority -> String -> IO ()
logTaffy Priority
DEBUG String
"Exited normally"

logTaffy :: Priority -> String -> IO ()
logTaffy :: Priority -> String -> IO ()
logTaffy = String -> Priority -> String -> IO ()
logM String
"System.Taffybar"