module Xmobar.App.Main (xmobar, xmobarMain, configFromArgs) where
import Control.Concurrent.Async (Async, cancel)
import Control.Exception (bracket)
import Control.Monad (unless)
import Data.Foldable (for_)
import qualified Data.Map as Map
import Data.List (intercalate)
import System.Posix.Process (executeFile)
import System.Environment (getArgs)
import System.FilePath
import System.FilePath.Posix (takeBaseName, takeDirectory)
import Text.Parsec.Error (ParseError)
import Data.List.NonEmpty (NonEmpty(..))
import Graphics.X11.Xlib
import Xmobar.Config.Types
import Xmobar.Config.Parse
import Xmobar.System.Signal (setupSignalHandler, withDeferSignals)
import Xmobar.Run.Template
import Xmobar.X11.Types
import Xmobar.X11.Text
import Xmobar.X11.Window
import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts)
import Xmobar.App.EventLoop (startLoop, startCommand, newRefreshLock, refreshLock)
import Xmobar.App.Compile (recompile, trace)
import Xmobar.App.Config
import Xmobar.App.Timer (withTimer)
xmobar :: Config -> IO ()
xmobar :: Config -> IO ()
xmobar conf :: Config
conf = IO () -> IO ()
forall a. IO a -> IO a
withDeferSignals (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO Status
initThreads
Display
d <- String -> IO Display
openDisplay ""
XFont
fs <- Display -> String -> IO XFont
initFont Display
d (Config -> String
font Config
conf)
[XFont]
fl <- (String -> IO XFont) -> [String] -> IO [XFont]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> String -> IO XFont
initFont Display
d) (Config -> [String]
additionalFonts Config
conf)
[[(Runnable, String, String)]]
cls <- (String -> IO [(Runnable, String, String)])
-> [String] -> IO [[(Runnable, String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Runnable] -> String -> String -> IO [(Runnable, String, String)]
parseTemplate (Config -> [Runnable]
commands Config
conf) (Config -> String
sepChar Config
conf))
(String -> String -> [String]
splitTemplate (Config -> String
alignSep Config
conf) (Config -> String
template Config
conf))
TMVar SignalType
sig <- IO (TMVar SignalType)
setupSignalHandler
TMVar ()
refLock <- IO (TMVar ())
newRefreshLock
(IO () -> IO ()) -> IO () -> IO ()
forall a. (IO () -> IO ()) -> IO a -> IO a
withTimer (TMVar () -> IO () -> IO ()
forall a. TMVar () -> IO a -> IO a
refreshLock TMVar ()
refLock) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO [[([Async ()], TVar String)]]
-> ([[([Async ()], TVar String)]] -> IO ())
-> ([[([Async ()], TVar String)]] -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (([(Runnable, String, String)] -> IO [([Async ()], TVar String)])
-> [[(Runnable, String, String)]]
-> IO [[([Async ()], TVar String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)] -> IO [([Async ()], TVar String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)] -> IO [([Async ()], TVar String)])
-> ((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)]
-> IO [([Async ()], TVar String)]
forall a b. (a -> b) -> a -> b
$ TMVar SignalType
-> (Runnable, String, String) -> IO ([Async ()], TVar String)
startCommand TMVar SignalType
sig) [[(Runnable, String, String)]]
cls)
[[([Async ()], TVar String)]] -> IO ()
forall a. [[([Async ()], a)]] -> IO ()
cleanupThreads
(([[([Async ()], TVar String)]] -> IO ()) -> IO ())
-> ([[([Async ()], TVar String)]] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \vars :: [[([Async ()], TVar String)]]
vars -> do
(r :: Rectangle
r,w :: Window
w) <- Display -> XFont -> Config -> IO (Rectangle, Window)
createWin Display
d XFont
fs Config
conf
let ic :: Map k a
ic = Map k a
forall k a. Map k a
Map.empty
to :: Int
to = Config -> Int
textOffset Config
conf
ts :: [Int]
ts = Config -> [Int]
textOffsets Config
conf [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate ([XFont] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XFont]
fl) (-1)
XConf
-> TMVar SignalType
-> TMVar ()
-> [[([Async ()], TVar String)]]
-> IO ()
startLoop (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> [Int]
-> Map String Bitmap
-> Config
-> XConf
XConf Display
d Rectangle
r Window
w (XFont
fs XFont -> [XFont] -> NonEmpty XFont
forall a. a -> [a] -> NonEmpty a
:| [XFont]
fl) (Int
toInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ts) Map String Bitmap
forall k a. Map k a
ic Config
conf) TMVar SignalType
sig TMVar ()
refLock [[([Async ()], TVar String)]]
vars
configFromArgs :: Config -> IO Config
configFromArgs :: Config -> IO Config
configFromArgs cfg :: Config
cfg = IO [String]
getArgs IO [String]
-> ([String] -> IO ([Opts], [String])) -> IO ([Opts], [String])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO ([Opts], [String])
getOpts IO ([Opts], [String])
-> (([Opts], [String]) -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [Opts] -> IO Config
doOpts Config
cfg ([Opts] -> IO Config)
-> (([Opts], [String]) -> [Opts])
-> ([Opts], [String])
-> IO Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Opts], [String]) -> [Opts]
forall a b. (a, b) -> a
fst
cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads vars :: [[([Async ()], a)]]
vars =
[([Async ()], a)] -> (([Async ()], a) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([[([Async ()], a)]] -> [([Async ()], a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[([Async ()], a)]]
vars) ((([Async ()], a) -> IO ()) -> IO ())
-> (([Async ()], a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(asyncs :: [Async ()]
asyncs, _) ->
[Async ()] -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Async ()]
asyncs Async () -> IO ()
forall a. Async a -> IO ()
cancel
buildLaunch :: Bool -> Bool -> String -> ParseError -> IO ()
buildLaunch :: Bool -> Bool -> String -> ParseError -> IO ()
buildLaunch verb :: Bool
verb force :: Bool
force p :: String
p e :: ParseError
e = do
let exec :: String
exec = String -> String
takeBaseName String
p
confDir :: String
confDir = String -> String
takeDirectory String
p
ext :: String
ext = String -> String
takeExtension String
p
if String
ext String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [".hs", ".hsc", ".lhs"]
then IO String
xmobarDataDir IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \dd :: String
dd -> String -> String -> String -> Bool -> Bool -> IO Bool
forall (m :: * -> *).
MonadIO m =>
String -> String -> String -> Bool -> Bool -> m Bool
recompile String
confDir String
dd String
exec Bool
force Bool
verb IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile (String
confDir String -> String -> String
</> String
exec) Bool
False [] Maybe [(String, String)]
forall a. Maybe a
Nothing
else Bool -> String -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
trace Bool
True ("Invalid configuration file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Bool -> String -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
trace Bool
True "\n(No compilation attempted: \
\only .hs, .hsc or .lhs files are compiled)"
xmobar' :: [String] -> Config -> IO ()
xmobar' :: [String] -> Config -> IO ()
xmobar' defs :: [String]
defs cfg :: Config
cfg = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
defs Bool -> Bool -> Bool
|| Bool -> Bool
not (Config -> Bool
verbose Config
cfg)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Fields missing from config defaulted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," [String]
defs
Config -> IO ()
xmobar Config
cfg
xmobarMain :: IO ()
xmobarMain :: IO ()
xmobarMain = do
[String]
args <- IO [String]
getArgs
(flags :: [Opts]
flags, rest :: [String]
rest) <- [String] -> IO ([Opts], [String])
getOpts [String]
args
Maybe String
cf <- case [String]
rest of
[c :: String
c] -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
c)
[] -> IO (Maybe String)
xmobarConfigFile
_ -> String -> IO (Maybe String)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ "Too many arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
rest
case Maybe String
cf of
Nothing -> case [String]
rest of
(c :: String
c:_) -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": file not found"
_ -> Config -> [Opts] -> IO Config
doOpts Config
defaultConfig [Opts]
flags IO Config -> (Config -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> IO ()
xmobar
Just p :: String
p -> do Either ParseError (Config, [String])
r <- Config -> String -> IO (Either ParseError (Config, [String]))
readConfig Config
defaultConfig String
p
case Either ParseError (Config, [String])
r of
Left e :: ParseError
e ->
Bool -> Bool -> String -> ParseError -> IO ()
buildLaunch ([Opts] -> Bool
verboseFlag [Opts]
flags) ([Opts] -> Bool
recompileFlag [Opts]
flags) String
p ParseError
e
Right (c :: Config
c, defs :: [String]
defs) -> Config -> [Opts] -> IO Config
doOpts Config
c [Opts]
flags IO Config -> (Config -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> Config -> IO ()
xmobar' [String]
defs