module System.Taffybar
(
dyreTaffybar
, dyreTaffybarMain
, getTaffyFile
, startTaffybar
, taffybarDyreParams
) where
import qualified Config.Dyre as Dyre
import qualified Config.Dyre.Params as Dyre
import Control.Monad
import qualified Data.GI.Gtk.Threading as GIThreading
import qualified Data.Text as T
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk
import Graphics.X11.Xlib.Misc
import System.Directory
import System.Environment.XDG.BaseDir ( getUserConfigFile )
import System.Exit ( exitFailure )
import System.FilePath ( (</>) )
import qualified System.IO as IO
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.Hooks
import Paths_taffybar ( getDataDir )
taffybarDyreParams :: Dyre.Params TaffybarConfig
taffybarDyreParams :: Params TaffybarConfig
taffybarDyreParams =
Params Any
forall cfgType. Params cfgType
Dyre.defaultParams
{ projectName :: String
Dyre.projectName = String
"taffybar"
, realMain :: TaffybarConfig -> IO ()
Dyre.realMain = TaffybarConfig -> IO ()
dyreTaffybarMain
, showError :: TaffybarConfig -> String -> TaffybarConfig
Dyre.showError = TaffybarConfig -> String -> TaffybarConfig
showError
, ghcOpts :: [String]
Dyre.ghcOpts = [String
"-threaded", String
"-rtsopts"]
, rtsOptsHandling :: RTSOptionHandling
Dyre.rtsOptsHandling = [String] -> RTSOptionHandling
Dyre.RTSAppend [String
"-I0", String
"-V0"]
}
dyreTaffybar :: TaffybarConfig -> IO ()
dyreTaffybar :: TaffybarConfig -> IO ()
dyreTaffybar = Params TaffybarConfig -> TaffybarConfig -> IO ()
forall cfgType. Params cfgType -> cfgType -> IO ()
Dyre.wrapMain Params TaffybarConfig
taffybarDyreParams
showError :: TaffybarConfig -> String -> TaffybarConfig
showError :: TaffybarConfig -> String -> TaffybarConfig
showError TaffybarConfig
cfg String
msg = TaffybarConfig
cfg { errorMsg :: Maybe String
errorMsg = String -> Maybe String
forall a. a -> Maybe a
Just String
msg }
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
getDataFile :: String -> IO FilePath
getDataFile :: String -> IO String
getDataFile String
name = do
String
dataDir <- IO String
getDataDir
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dataDir String -> String -> String
</> String
name)
startCSS :: [FilePath] -> IO Gtk.CssProvider
startCSS :: [String] -> IO CssProvider
startCSS [String]
cssPaths = do
CssProvider
taffybarProvider <- IO CssProvider
forall (m :: * -> *). (HasCallStack, MonadIO m) => m CssProvider
Gtk.cssProviderNew
let loadIfExists :: String -> IO ()
loadIfExists String
filePath =
String -> IO Bool
doesFileExist String
filePath IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CssProvider -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsCssProvider a) =>
a -> Text -> m ()
Gtk.cssProviderLoadFromPath CssProvider
taffybarProvider (String -> Text
T.pack String
filePath))
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
loadIfExists [String]
cssPaths
Just Screen
scr <- IO (Maybe Screen)
forall (m :: * -> *). (HasCallStack, MonadIO m) => m (Maybe Screen)
Gdk.screenGetDefault
Screen -> CssProvider -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsScreen a, IsStyleProvider b) =>
a -> b -> Word32 -> m ()
Gtk.styleContextAddProviderForScreen Screen
scr CssProvider
taffybarProvider Word32
800
CssProvider -> IO CssProvider
forall (m :: * -> *) a. Monad m => a -> m a
return CssProvider
taffybarProvider
getTaffyFile :: String -> IO FilePath
getTaffyFile :: String -> IO String
getTaffyFile = String -> String -> IO String
getUserConfigFile String
"taffybar"
getDefaultCSSPaths :: IO [FilePath]
getDefaultCSSPaths :: IO [String]
getDefaultCSSPaths = do
String
defaultUserConfig <- String -> IO String
getTaffyFile String
"taffybar.css"
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
defaultUserConfig]
startTaffybar :: TaffybarConfig -> IO ()
startTaffybar :: TaffybarConfig -> IO ()
startTaffybar TaffybarConfig
config = do
String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
"" ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
defaultCSS <- String -> IO String
getDataFile String
"taffybar.css"
[String]
cssPaths <- IO [String]
-> (String -> IO [String]) -> Maybe String -> IO [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [String]
getDefaultCSSPaths ([String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> (String -> [String]) -> String -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return) (Maybe String -> IO [String]) -> Maybe String -> IO [String]
forall a b. (a -> b) -> a -> b
$ TaffybarConfig -> Maybe String
cssPath TaffybarConfig
config
CssProvider
_ <- [String] -> IO CssProvider
startCSS ([String] -> IO CssProvider) -> [String] -> IO CssProvider
forall a b. (a -> b) -> a -> b
$ String
defaultCSSString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
cssPaths
Context
_ <- TaffybarConfig -> IO Context
buildContext TaffybarConfig
config
IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
Gtk.main
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()