------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.Main
-- Copyright: (c) 2018, 2019, 2020 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: portable
-- Created: Sun Nov 25, 2018 21:53
--
--
-- Support for creating executable main functions
--
------------------------------------------------------------------------------


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 ((</>), 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))
  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
$ \[[([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