module Xmobar.App.Main (xmobar, xmobarMain, configFromArgs) where
import Control.Concurrent.Async (Async, cancel)
import Control.Concurrent.STM (newEmptyTMVarIO)
import Control.Exception (bracket)
import Control.Monad (unless)
import Data.Foldable (for_)
import qualified Data.Map as Map
import Data.List (intercalate)
import Data.Maybe (isJust)
import System.Posix.Process (executeFile)
import System.Environment (getArgs)
import System.FilePath ((</>), takeBaseName, takeDirectory, takeExtension)
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 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 String
""
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))
let confSig :: Maybe (TMVar SignalType)
confSig = SignalChan -> Maybe (TMVar SignalType)
unSignalChan (Config -> SignalChan
signal Config
conf)
TMVar SignalType
sig <- IO (TMVar SignalType)
-> (TMVar SignalType -> IO (TMVar SignalType))
-> Maybe (TMVar SignalType)
-> IO (TMVar SignalType)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (TMVar SignalType)
forall a. IO (TMVar a)
newEmptyTMVarIO TMVar SignalType -> IO (TMVar SignalType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TMVar SignalType)
confSig
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TMVar SignalType) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TMVar SignalType)
confSig) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> IO ()
setupSignalHandler TMVar SignalType
sig
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
$ \[[([Async ()], TVar String)]]
vars -> do
(Rectangle
r,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) (-Int
1)
XConf
-> TMVar SignalType
-> TMVar ()
-> [[([Async ()], TVar String)]]
-> IO ()
startLoop (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> NonEmpty 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
to Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty 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 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 [[([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
$ \([Async ()]
asyncs, a
_) ->
[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 :: [String] -> Bool -> Bool -> String -> ParseError -> IO ()
buildLaunch :: [String] -> Bool -> Bool -> String -> ParseError -> IO ()
buildLaunch [String]
args Bool
verb Bool
force String
p 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` [String
".hs", String
".hsc", String
".lhs"]
then IO String
xmobarDataDir IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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 [String]
args Maybe [(String, String)]
forall a. Maybe a
Nothing
else Bool -> String -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
trace Bool
True (String
"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 String
"\n(No compilation attempted: \
\only .hs, .hsc or .lhs files are compiled)"
xmobar' :: [String] -> Config -> IO ()
xmobar' :: [String] -> Config -> IO ()
xmobar' [String]
defs 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
$
String
"Fields missing from config defaulted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
defs
Config -> IO ()
xmobar Config
cfg
xmobarMain :: IO ()
xmobarMain :: IO ()
xmobarMain = do
[String]
args <- IO [String]
getArgs
([Opts]
flags, [String]
rest) <- [String] -> IO ([Opts], [String])
getOpts [String]
args
Maybe String
cf <- case [String]
rest of
[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]
_ -> 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
$ String
"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
Maybe String
Nothing -> case [String]
rest of
(String
c:[String]
_) -> 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]
++ String
": file not found"
[String]
_ -> 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 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 ParseError
e ->
[String] -> Bool -> Bool -> String -> ParseError -> IO ()
buildLaunch ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
p) [String]
args) ([Opts] -> Bool
verboseFlag [Opts]
flags) ([Opts] -> Bool
recompileFlag [Opts]
flags) String
p ParseError
e
Right (Config
c, [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