diff options
| -rw-r--r-- | news.md | 8 | ||||
| -rw-r--r-- | readme.md | 72 | ||||
| -rwxr-xr-x | samples/status.sh | 54 | ||||
| -rw-r--r-- | samples/xmobar.config | 1 | ||||
| -rw-r--r-- | src/Commands.hs | 20 | ||||
| -rw-r--r-- | src/Config.hs | 6 | ||||
| -rw-r--r-- | src/IPC/DBus.hs | 64 | ||||
| -rw-r--r-- | src/Main.hs | 7 | ||||
| -rw-r--r-- | src/Parsers.hs | 11 | ||||
| -rw-r--r-- | src/Plugins/BufferedPipeReader.hs | 83 | ||||
| -rw-r--r-- | src/Plugins/Utils.hs | 6 | ||||
| -rw-r--r-- | src/Runnable.hs | 5 | ||||
| -rw-r--r-- | src/Signal.hs | 70 | ||||
| -rw-r--r-- | src/Window.hs | 167 | ||||
| -rw-r--r-- | src/Xmobar.hs | 195 | ||||
| -rw-r--r-- | xmobar.cabal | 9 |
16 files changed, 596 insertions, 182 deletions
@@ -6,10 +6,16 @@ _New features_ - New monitor `AutoMPD`, which uses asynchronous events to display MPD status (thanks to Ben Boeckel). + - New monitor `BufferedPipeReader` displaying data from multiple + pipes (thanks to Jochen Keil). + - DBUS support: Jochen implemented an extension for DBUS signal + handling. + - Hide/Reveal: one can send signals to xmobar and make it (un)hide + itself (Jochen again). - Dependencies updated to latest mtl and libmpd (thanks to Sergei Trofimovich). - Dependencies on the deprecated dbus-core removed in favour of - dbus 0.10. + dbus 0.10 (thanks to Jochen Keil).. _Bug fixes_ @@ -221,6 +221,11 @@ Other configuration options: : position = Top +`persistent` +: When True the window status is fixed i.e. hiding or revealing is not + possible. This option can be toggled at runtime. + + `border` : TopB, TopBM, BottomB, BottomBM, FullB, FullBM or NoBorder (default). @@ -293,6 +298,34 @@ xmobar --help): Mail bug reports and suggestions to <xmobar@projects.haskell.org> +## The DBus Interface + +xmobar can be controlled over dbus. All signals defined in [src/Signal.hs] as +`data SignalType` can now be sent over dbus to xmobar. +Due to current limitations of the implementation only one process of xmobar can +aquire the dbus. This is handled in a FCFS manor, meaning that the first process +will get the dbus interface. Other processes will run without further problems, +yet have no dbus interface. + +[src/Signal.hs]: https://github.com/jaor/xmobar/raw/master/src/Signal.hs + +- Bus Name: `org.Xmobar.Control` +- Object Path: `/org/Xmobar/Control` +- Member Name: Any of SignalType, e.g. `string:Reveal` +- Interface Name: `org.Xmobar.Control` + +An example using the `dbus-send` command line utility: + + dbus-send \ + --session \ + --dest=org.Xmobar.Control \ + --type=method_call \ + --print-reply \ + '/org/Xmobar/Control' \ + org.Xmobar.Control.SendSignal \ + "string:Toggle" + + ## The Output Template The output template must contain at least one command. xmobar will @@ -919,6 +952,35 @@ can be used in the output template as `%mydate%` - Reads its displayed output from the given pipe. +`BufferedPipeReader Alias [ (Timeout, Bool, "/path/to/pipe1") + , (Timeout, Bool, "/path/to/pipe2") + , .. + ]` + +- Display data from multiple pipes. +- Timeout (in tenth of seconds) is the value after which the previous content is + restored i.e. if there was already something from a previous pipe it will be + put on display again, overwriting the current status. +- A pipe with Timout of 0 will be displayed permanently, just like `PipeReader` +- The boolean option indicates whether new data for this pipe should make xmobar + appear (unhide, reveal). In this case, the Timeout additionally specifies when + the window should be hidden again. The output is restored in any case. +- Use it for OSD like status bars e.g. for setting the volume or brightness: + + Run BufferedPipeReader "bpr" + [ ( 0, False, "/tmp/xmobar_window" ) + , ( 15, True, "/tmp/xmobar_status" ) + ] + + Have your window manager send window titles to `"/tmp/xmobar_window"`. They will + always be shown and not reveal your xmobar. + Sending some status information to `"/tmp/xmobar_status"` will reveal xmonad + for 1.5 seconds and temporarily overwrite the window titles. +- Take a look at [samples/status.sh] + +[samples/status.sh]: http://github.com/jaor/xmobar/raw/master/samples/status.sh + + `XMonadLog` - Aliases to XMonadLog @@ -1064,11 +1126,11 @@ the greater Haskell community. In particular, xmobar [incorporates patches] by Ben Boeckel, Roman Cheplyaka, John Goerzen, Juraj Hercek, Tomas Janousek, Spencer -Janssen, Lennart Kolmodin, Krzysztof Kosciuszkiewicz, Dmitry -Kurochkin, Svein Ove, Martin Perner, Jens Petersen, Petr Rockai, -Andrew Sackville-West, Alexander Solovyov, Artem Tarasov, Sergei -Trofimovich, Thomas Tuegel, Jan Vornberger, Daniel Wagner and Norbert -Zeh. +Janssen, Jochen Keil, Lennart Kolmodin, Krzysztof Kosciuszkiewicz, +Dmitry Kurochkin, Svein Ove, Martin Perner, Jens Petersen, Petr +Rockai, Andrew Sackville-West, Alexander Solovyov, Artem Tarasov, +Sergei Trofimovich, Thomas Tuegel, Jan Vornberger, Daniel Wagner and +Norbert Zeh. [incorporates patches]: http://www.ohloh.net/p/xmobar/contributors diff --git a/samples/status.sh b/samples/status.sh new file mode 100755 index 0000000..94e8fe7 --- /dev/null +++ b/samples/status.sh @@ -0,0 +1,54 @@ +#!/bin/bash + +STATUSPIPE="/tmp/xmobar_status_jrk" + +function isMuted () { + # retrieve mute status + # return an arbitrary string for true or nothing at all + echo +} + +function getPercent () { + # somehow retrieve the percent value as plain int (e.g. "66") + echo "66" +} + +function percentBar () { + local i=1 res= + normal=47 high=80 + fgColor='#657b83' mutedColor='#cb4b16' + lowColor='#859900' midColor='#b58900' + highColor='#cb4b16' + + bar="$(echo -ne "\u2588")" + percent="$( getPercent )" + muted="$( isMuted )" + + if [ -n "$muted" ]; then + res="<fc=$mutedColor>" + else + res="<fc=$lowColor>" + fi + + while [ $i -lt $percent ]; do + if [ $i -eq $normal -a -z "$muted" ]; then + res+="</fc><fc=$midColor>" + elif [ $i -eq $high -a -z "$muted" ]; then + res+="</fc><fc=$highColor>" + fi + + res+=$bar + i=$((i+1)) + done + + res+="</fc><fc=$fgColor>" + + while [ $i -lt 100 ]; do + res+='-' + i=$((i+1)) + done + + echo "$res</fc>" +} + +echo "$( percentBar )" > "$STATUSPIPE" diff --git a/samples/xmobar.config b/samples/xmobar.config index 1e41945..faf6ac6 100644 --- a/samples/xmobar.config +++ b/samples/xmobar.config @@ -5,6 +5,7 @@ Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" , fgColor = "grey" , position = Top , lowerOnStart = True + , persistent = False , commands = [ Run Weather "EGPF" ["-t","<station>: <tempC>C","-L","18","-H","25","--normal","green","--high","red","--low","lightblue"] 36000 , Run Network "eth0" ["-L","0","-H","32","--normal","green","--high","red"] 10 , Run Network "eth1" ["-L","0","-H","32","--normal","green","--high","red"] 10 diff --git a/src/Commands.hs b/src/Commands.hs index 1bfbb94..b501022 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -30,18 +30,22 @@ import Data.Char import System.Process import System.Exit import System.IO (hClose) + +import Signal import XUtil class Show e => Exec e where - alias :: e -> String - alias e = takeWhile (not . isSpace) $ show e - rate :: e -> Int - rate _ = 10 - run :: e -> IO String - run _ = return "" - start :: e -> (String -> IO ()) -> IO () - start e cb = go + alias :: e -> String + alias e = takeWhile (not . isSpace) $ show e + rate :: e -> Int + rate _ = 10 + run :: e -> IO String + run _ = return "" + start :: e -> (String -> IO ()) -> IO () + start e cb = go where go = run e >>= cb >> tenthSeconds (rate e) >> go + trigger :: e -> (Maybe SignalType -> IO ()) -> IO () + trigger _ sh = sh Nothing data Command = Com Program Args Alias Rate deriving (Show,Read,Eq) diff --git a/src/Config.hs b/src/Config.hs index 4405314..47358b0 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -28,6 +28,7 @@ import {-# SOURCE #-} Runnable import Plugins.Monitors import Plugins.Date import Plugins.PipeReader +import Plugins.BufferedPipeReader import Plugins.CommandReader import Plugins.StdinReader import Plugins.XMonadLog @@ -56,6 +57,8 @@ data Config = , borderColor :: String -- ^ Border color , lowerOnStart :: Bool -- ^ Lower to the bottom of the -- window stack on initialization + , persistent :: Bool -- ^ Whether automatic hiding should + -- be enabled or disabled , commands :: [Runnable] -- ^ For setting the command, the command arguments -- and refresh rate for the programs to run (optional) , sepChar :: String -- ^ The character to be used for indicating @@ -95,6 +98,7 @@ defaultConfig = , border = NoBorder , borderColor = "#BFBFBF" , lowerOnStart = True + , persistent = False , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 , Run StdinReader] , sepChar = "%" @@ -113,7 +117,7 @@ infixr :*: -- the 'Runnable.Runnable' Read instance. To install a plugin just add -- the plugin's type to the list of types (separated by ':*:') appearing in -- this function's type signature. -runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: +runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: BufferedPipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: #ifdef INOTIFY Mail :*: MBox :*: #endif diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs new file mode 100644 index 0000000..469a7c6 --- /dev/null +++ b/src/IPC/DBus.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DBus +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- DBus IPC module for Xmobar +-- +----------------------------------------------------------------------------- + +module IPC.DBus ( runIPC ) where + +import Prelude hiding (catch) + +import DBus +import DBus.Client +import Control.Monad (join, when) +import Control.Concurrent +import Control.Exception (catch) +import System.IO (stderr, hPutStrLn) + +import Signal +import Plugins.Utils (safeHead) + +busName :: BusName +busName = busName_ "org.Xmobar.Control" + +objectPath :: ObjectPath +objectPath = objectPath_ "/org/Xmobar/Control" + +interfaceName :: InterfaceName +interfaceName = interfaceName_ "org.Xmobar.Control" + +runIPC :: MVar SignalType -> IO () +runIPC mvst = catch exportConnection printException + where + printException :: ClientError -> IO () + printException = hPutStrLn stderr . clientErrorMessage + exportConnection = do + client <- connectSession + requestName client busName [ nameDoNotQueue ] + export client objectPath [ sendSignalMethod mvst ] + +sendSignalMethod :: MVar SignalType -> Method +sendSignalMethod mvst = method interfaceName sendSignalName + (signature_ [variantType $ toVariant $ (undefined :: SignalType)]) + (signature_ []) + sendSignalMethodCall + where + sendSignalName :: MemberName + sendSignalName = memberName_ "SendSignal" + + sendSignalMethodCall :: MethodCall -> IO Reply + sendSignalMethodCall mc = do + when ( methodCallMember mc == sendSignalName ) $ sendSignal $ + join $ safeHead $ map fromVariant $ methodCallBody mc + return ( replyReturn [] ) + + sendSignal :: Maybe SignalType -> IO () + sendSignal = maybe (return ()) (putMVar mvst) diff --git a/src/Main.hs b/src/Main.hs index 4c3f351..5ef5db6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -36,6 +36,8 @@ import System.Environment import System.Posix.Files import Control.Monad (unless) +import Signal (setupSignalHandler) + -- $main -- | The main entry point @@ -55,9 +57,10 @@ main = do conf <- doOpts c o fs <- initFont d (font conf) cls <- mapM (parseTemplate conf) (splitTemplate conf) - vars <- mapM (mapM startCommand) cls + sig <- setupSignalHandler + vars <- mapM (mapM $ startCommand sig) cls (r,w) <- createWin d fs conf - startLoop (XConf d r w fs conf) vars + startLoop (XConf d r w fs conf) sig vars -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/Parsers.hs b/src/Parsers.hs index f5f00a9..c92480e 100644 --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -131,13 +131,15 @@ parseConfig = runParser parseConf fields "Config" . stripComments <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition <|?> pBorder <|?> pBdColor - <|?> pLowerOnStart <|?> pCommands - <|?> pSepChar <|?> pAlignSep - <|?> pTemplate + <|?> pLowerOnStart <|?> pPersistent + <|?> pCommands <|?> pSepChar + <|?> pAlignSep <|?> pTemplate fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" , "border", "borderColor" ,"template", "position" - , "lowerOnStart", "commands"] + , "lowerOnStart", "persistent", "commands" + ] + pFont = strField font "font" pBgColor = strField bgColor "bgColor" pFgColor = strField fgColor "fgColor" @@ -148,6 +150,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments pPosition = field position "position" $ tillFieldEnd >>= read' "position" pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart" + pPersistent = field persistent "persistent" $ tillFieldEnd >>= read' "persistent" pBorder = field border "border" $ tillFieldEnd >>= read' "border" pCommands = field commands "commands" $ readCommands diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs new file mode 100644 index 0000000..be6a652 --- /dev/null +++ b/src/Plugins/BufferedPipeReader.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.BufferedPipeReader +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading (temporarily) from named pipes with reset +-- +----------------------------------------------------------------------------- + +module Plugins.BufferedPipeReader where + +import Control.Monad(forM_, when) +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +import System.IO.Unsafe(unsafePerformIO) + +import Plugins +import Signal + +data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] + deriving (Read, Show) + +signal :: MVar SignalType +signal = unsafePerformIO newEmptyMVar + +instance Exec BufferedPipeReader where + alias ( BufferedPipeReader a _ ) = a + + trigger br@( BufferedPipeReader _ _ ) sh = + takeMVar signal >>= sh . Just >> trigger br sh + + start ( BufferedPipeReader _ ps ) cb = do + + (chan, str, rst) <- initV + forM_ ps $ \p -> forkIO $ reader p chan + writer chan str rst + + where + initV :: IO ( TChan (Int, Bool, String), TMVar String, TVar Bool ) + initV = atomically $ do + tc <- newTChan + ts <- newEmptyTMVar + tb <- newTVar False + return (tc, ts, tb) + + reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () + reader p@(to, tg, fp) tc = do + openFile fp ReadWriteMode >>= hGetLineSafe >>= \dt -> + atomically $ writeTChan tc (to, tg, dt) + reader p tc + + writer :: TChan (Int, Bool, String) -> TMVar String -> TVar Bool -> IO () + writer tc ts otb = do + (to, tg, dt, ntb) <- update + cb dt + when tg $ putMVar signal Reveal + when (to /= 0) $ sfork $ reset to tg ts ntb + writer tc ts ntb + + where + sfork :: IO () -> IO () + sfork f = forkIO f >> return () + + update :: IO (Int, Bool, String, TVar Bool) + update = atomically $ do + (to, tg, dt) <- readTChan tc + when (to == 0) $ tryPutTMVar ts dt >> return () + writeTVar otb False + tb <- newTVar True + return (to, tg, dt, tb) + + reset :: Int -> Bool -> TMVar String -> TVar Bool -> IO () + reset to tg ts tb = do + threadDelay ( to * 100 * 1000 ) + readTVarIO tb >>= \b -> when b $ do + when tg $ putMVar signal Hide + atomically (tryTakeTMVar ts) >>= maybe (return ()) cb diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs index 1dbcd40..bbfa84f 100644 --- a/src/Plugins/Utils.hs +++ b/src/Plugins/Utils.hs @@ -15,7 +15,7 @@ ------------------------------------------------------------------------------ -module Plugins.Utils (expandHome, changeLoop) where +module Plugins.Utils (expandHome, changeLoop, safeHead) where import Control.Monad import Control.Concurrent.STM @@ -37,3 +37,7 @@ changeLoop s f = atomically s >>= go new <- s guard (new /= old) return new) + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x diff --git a/src/Runnable.hs b/src/Runnable.hs index 56fedb3..84d9b77 100644 --- a/src/Runnable.hs +++ b/src/Runnable.hs @@ -29,8 +29,9 @@ import Commands data Runnable = forall r . (Exec r, Read r, Show r) => Run r instance Exec Runnable where - start (Run a) = start a - alias (Run a) = alias a + start (Run a) = start a + alias (Run a) = alias a + trigger (Run a) = trigger a instance Show Runnable where show (Run x) = show x diff --git a/src/Signal.hs b/src/Signal.hs new file mode 100644 index 0000000..3c341f9 --- /dev/null +++ b/src/Signal.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Signal +-- Copyright : (c) Andrea Rosatto +-- : (c) Jose A. Ortega Ruiz +-- : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Signal handling, including DBUS when available +-- +----------------------------------------------------------------------------- + +module Signal where + +import Data.Typeable (Typeable) +import Control.Concurrent +import Control.Exception hiding (handle) +import System.Posix.Signals + +#ifdef DBUS +import DBus (IsVariant(..)) +import Control.Monad ((>=>)) + +import Plugins.Utils (safeHead) +#endif + +data WakeUp = WakeUp deriving (Show,Typeable) +instance Exception WakeUp + +data SignalType = Wakeup + | Reposition + | ChangeScreen + | Hide + | Reveal + | Toggle + | TogglePersistent + deriving (Read, Show) + +#ifdef DBUS +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType +#endif + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + +-- | Signal handling +setupSignalHandler :: IO (MVar SignalType) +setupSignalHandler = do + tid <- newEmptyMVar + installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing + installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing + return tid + +updatePosHandler :: MVar SignalType -> IO () +updatePosHandler sig = do + putMVar sig Reposition + return () + +changeScreenHandler :: MVar SignalType -> IO () +changeScreenHandler sig = do + putMVar sig ChangeScreen + return () diff --git a/src/Window.hs b/src/Window.hs new file mode 100644 index 0000000..0ffa139 --- /dev/null +++ b/src/Window.hs @@ -0,0 +1,167 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Window +-- Copyright : (c) 2011-12 Jose A. Ortega Ruiz +-- : (c) 2012 Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Window manipulation functions +-- +----------------------------------------------------------------------------- + +module Window where + +import Prelude hiding (catch) +import Control.Monad (when) +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama + +import Data.Maybe(fromMaybe) +import System.Posix.Process (getProcessID) + +import Config +import XUtil + +-- $window + +-- | The function to create the initial window +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin d fs c = do + let dflt = defaultScreen d + srs <- getScreenInfo d + rootw <- rootWindow d dflt + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + (r,o) = setPosition (position c) srs (fi ht) + win <- newWindow d (defaultScreenOfDisplay d) rootw r o + setProperties r c d win srs + when (lowerOnStart c) (lowerWindow d win) + mapWindow d win + return (r,win) + +-- | Updates the size and position of the window +repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle +repositionWin d win fs c = do + srs <- getScreenInfo d + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + (r,_) = setPosition (position c) srs (fi ht) + moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) + setProperties r c d win srs + return r + +setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) +setPosition p rs ht = + case p' of + Top -> (Rectangle rx ry rw h, True) + TopW a i -> (Rectangle (ax a i) ry (nw i) h, True) + TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True) + Bottom -> (Rectangle rx ny rw h, True) + BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True) + BottomSize a i ch -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True) + Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True) + OnScreen _ p'' -> setPosition p'' [scr] ht + where + (scr@(Rectangle rx ry rw rh), p') = + case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) + _ -> (head rs, p) + ny = ry + fi (rh - ht) + center i = rx + fi (div (remwid i) 2) + right i = rx + fi (remwid i) + remwid i = rw - pw (fi i) + ax L = const rx + ax R = right + ax C = center + pw i = rw * min 100 i `div` 100 + nw = fi . pw . fi + h = fi ht + mh h' = max (fi h') h + ny' h' = ry + fi (rh - mh h') + safeIndex i = lookup i . zip [0..] + +setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setProperties r c d w srs = do + a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False + c1 <- internAtom d "CARDINAL" False + a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False + c2 <- internAtom d "ATOM" False + v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False + p <- internAtom d "_NET_WM_PID" False + + setTextProperty d w "xmobar" wM_CLASS + setTextProperty d w "xmobar" wM_NAME + + changeProperty32 d w a1 c1 propModeReplace $ map fi $ + getStrutValues r (position c) (getRootWindowHeight srs) + changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] + + getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral + +getRootWindowHeight :: [Rectangle] -> Int +getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) + where + getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) + +getStrutValues :: Rectangle -> XPosition -> Int -> [Int] +getStrutValues r@(Rectangle x y w h) p rwh = + case p of + OnScreen _ p' -> getStrutValues r p' rwh + Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + Static {} -> getStaticStrutValues p rwh + where st = fi y + fi h + sb = rwh - fi y + nx = fi x + nw = fi (x + fi w - 1) + +-- get some reaonable strut values for static placement. +getStaticStrutValues :: XPosition -> Int -> [Int] +getStaticStrutValues (Static cx cy cw ch) rwh + -- if the yPos is in the top half of the screen, then assume a Top + -- placement, otherwise, it's a Bottom placement + | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] + | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] + where st = cy + ch + sb = rwh - cy + xs = cx -- a simple calculation for horizontal (x) placement + xe = xs + cw +getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + +drawBorder :: Border -> Display -> Drawable -> GC -> Pixel + -> Dimension -> Dimension -> IO () +drawBorder b d p gc c wi ht = case b of + NoBorder -> return () + TopB -> drawBorder (TopBM 0) d p gc c w h + BottomB -> drawBorder (BottomBM 0) d p gc c w h + FullB -> drawBorder (FullBM 0) d p gc c w h + TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 + BottomBM m -> let rw = fi h - fi m in + sf >> drawLine d p gc 0 rw (fi w) rw + FullBM m -> let pad = 2 * fi m; mp = fi m in + sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) + where sf = setForeground d gc c + (w, h) = (wi - 1, ht - 1) + +hideWindow :: Display -> Window -> IO () +hideWindow d w = do + a <- internAtom d "_NET_WM_STRUT_PARTIAL" False + c <- internAtom d "CARDINAL" False + changeProperty32 d w a c propModeReplace $ replicate 12 0 + unmapWindow d w + sync d False + +showWindow :: Display -> Window -> IO () +showWindow d w = mapWindow d w >> sync d False + +isMapped :: Display -> Window -> IO Bool +isMapped d w = fmap ism $ getWindowAttributes d w + where ism (WindowAttributes { wa_map_state = wms }) = wms /= waIsUnmapped diff --git a/src/Xmobar.hs b/src/Xmobar.hs index c348f99..2dbba11 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -39,19 +39,21 @@ import Control.Arrow ((&&&)) import Control.Monad.Reader import Control.Concurrent import Control.Concurrent.STM -import Control.Exception hiding (handle) +import Control.Exception (catch, SomeException(..)) import Data.Bits -import Data.Maybe(fromMaybe) -import Data.Typeable (Typeable) -import System.Posix.Process (getProcessID) -import System.Posix.Signals import Config import Parsers import Commands import Runnable +import Signal +import Window import XUtil +#ifdef DBUS +import IPC.DBus +#endif + -- $main -- -- The Xmobar data type and basic loops and functions. @@ -72,16 +74,10 @@ data XConf = runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc -data WakeUp = WakeUp deriving (Show,Typeable) -instance Exception WakeUp - -data SignalType = Wakeup | Reposition | ChangeScreen - -- | Starts the main event loop and threads -startLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO () -startLoop xcfg@(XConf _ _ w _ _) vs = do +startLoop :: XConf -> MVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () +startLoop xcfg@(XConf _ _ w _ _) sig vs = do tv <- atomically $ newTVar [] - sig <- setupSignalHandler _ <- forkIO (checker tv [] vs sig `catch` \(SomeException _) -> void (putStrLn "Thread checker failed")) #ifdef THREADED_RUNTIME @@ -90,6 +86,9 @@ startLoop xcfg@(XConf _ _ w _ _) vs = do _ <- forkIO (eventer sig `catch` #endif \(SomeException _) -> void (putStrLn "Thread eventer failed")) +#ifdef DBUS + runIPC sig +#endif eventLoop tv xcfg sig where -- Reacts on events from X @@ -147,7 +146,27 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do ncfg <- updateConfigPosition cfg reposWindow ncfg + Hide -> hide + Reveal -> reveal + Toggle -> toggle + + TogglePersistent -> eventLoop + tv xc { config = cfg { persistent = not $ persistent cfg } } signal + where + isPersistent = not $ persistent cfg + + hide = when isPersistent (hideWindow d w) >> eventLoop tv xc signal + + reveal = if isPersistent + then do + r' <- repositionWin d w fs cfg + showWindow d w + eventLoop tv (XConf d r' w fs cfg) signal + else eventLoop tv xc signal + + toggle = isMapped d w >>= \b -> if b then hide else reveal + reposWindow rcfg = do r' <- repositionWin d w fs rcfg eventLoop tv (XConf d r' w fs rcfg) signal @@ -163,149 +182,24 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do o -> return (ocfg {position = OnScreen 1 o}) - --- | Signal handling -setupSignalHandler :: IO (MVar SignalType) -setupSignalHandler = do - tid <- newEmptyMVar - installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing - installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing - return tid - -updatePosHandler :: MVar SignalType -> IO () -updatePosHandler sig = do - putMVar sig Reposition - return () - -changeScreenHandler :: MVar SignalType -> IO () -changeScreenHandler sig = do - putMVar sig ChangeScreen - return () - -- $command -- | Runs a command as an independent thread and returns its thread id -- and the TVar the command will be writing to. -startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String) -startCommand (com,s,ss) +startCommand :: MVar SignalType + -> (Runnable,String,String) + -> IO (Maybe ThreadId, TVar String) +startCommand sig (com,s,ss) | alias com == "" = do var <- atomically $ newTVar is atomically $ writeTVar var (s ++ ss) return (Nothing,var) | otherwise = do var <- atomically $ newTVar is let cb str = atomically $ writeTVar var (s ++ str ++ ss) h <- forkIO $ start com cb + _ <- forkIO $ trigger com ( maybe (return ()) (putMVar sig) ) return (Just h,var) where is = s ++ "Updating..." ++ ss --- $window - --- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) -createWin d fs c = do - let dflt = defaultScreen d - srs <- getScreenInfo d - rootw <- rootWindow d dflt - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,o) = setPosition (position c) srs (fi ht) - win <- newWindow d (defaultScreenOfDisplay d) rootw r o - setProperties r c d win srs - when (lowerOnStart c) (lowerWindow d win) - mapWindow d win - return (r,win) - --- | Updates the size and position of the window -repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle -repositionWin d win fs c = do - srs <- getScreenInfo d - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,_) = setPosition (position c) srs (fi ht) - moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) - setProperties r c d win srs - return r - -setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) -setPosition p rs ht = - case p' of - Top -> (Rectangle rx ry rw h, True) - TopW a i -> (Rectangle (ax a i) ry (nw i) h, True) - TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True) - Bottom -> (Rectangle rx ny rw h, True) - BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True) - BottomSize a i ch -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True) - Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True) - OnScreen _ p'' -> setPosition p'' [scr] ht - where - (scr@(Rectangle rx ry rw rh), p') = - case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) - _ -> (head rs, p) - ny = ry + fi (rh - ht) - center i = rx + fi (div (remwid i) 2) - right i = rx + fi (remwid i) - remwid i = rw - pw (fi i) - ax L = const rx - ax R = right - ax C = center - pw i = rw * min 100 i `div` 100 - nw = fi . pw . fi - h = fi ht - mh h' = max (fi h') h - ny' h' = ry + fi (rh - mh h') - safeIndex i = lookup i . zip [0..] - -setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () -setProperties r c d w srs = do - a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False - c1 <- internAtom d "CARDINAL" False - a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False - c2 <- internAtom d "ATOM" False - v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False - p <- internAtom d "_NET_WM_PID" False - - setTextProperty d w "xmobar" wM_CLASS - setTextProperty d w "xmobar" wM_NAME - - changeProperty32 d w a1 c1 propModeReplace $ map fi $ - getStrutValues r (position c) (getRootWindowHeight srs) - changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] - - getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral - -getRootWindowHeight :: [Rectangle] -> Int -getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) - where - getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) - -getStrutValues :: Rectangle -> XPosition -> Int -> [Int] -getStrutValues r@(Rectangle x y w h) p rwh = - case p of - OnScreen _ p' -> getStrutValues r p' rwh - Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - Static {} -> getStaticStrutValues p rwh - where st = fi y + fi h - sb = rwh - fi y - nx = fi x - nw = fi (x + fi w - 1) - --- get some reaonable strut values for static placement. -getStaticStrutValues :: XPosition -> Int -> [Int] -getStaticStrutValues (Static cx cy cw ch) rwh - -- if the yPos is in the top half of the screen, then assume a Top - -- placement, otherwise, it's a Bottom placement - | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] - | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] - where st = cy + ch - sb = rwh - cy - xs = cx -- a simple calculation for horizontal (x) placement - xe = xs + cw -getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - updateWin :: TVar [String] -> X () updateWin v = do xc <- ask @@ -346,21 +240,6 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do -- resync io $ sync d True -drawBorder :: Border -> Display -> Drawable -> GC -> Pixel - -> Dimension -> Dimension -> IO () -drawBorder b d p gc c wi ht = case b of - NoBorder -> return () - TopB -> drawBorder (TopBM 0) d p gc c w h - BottomB -> drawBorder (BottomBM 0) d p gc c w h - FullB -> drawBorder (FullBM 0) d p gc c w h - TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 - BottomBM m -> let rw = fi h - fi m in - sf >> drawLine d p gc 0 rw (fi w) rw - FullBM m -> let pad = 2 * fi m; mp = fi m in - sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) - where sf = setForeground d gc c - (w, h) = (wi - 1, ht - 1) - -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> XFont -> Position -> Align -> [(String, String, Position)] -> X () diff --git a/xmobar.cabal b/xmobar.cabal index a9b89e9..54f932e 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -65,6 +65,10 @@ flag with_mpris description: MPRIS v1, v2 support default: False +flag with_dbus + description: Publish a Service on the Session Bus for controlling xmobar + default: False + flag with_threaded description: Use threaded runtime default: False @@ -165,3 +169,8 @@ executable xmobar build-depends: dbus >= 0.10 other-modules: Plugins.Monitors.Mpris cpp-options: -DMPRIS + + if flag(with_dbus) || flag(all_extensions) + build-depends: dbus >= 0.10 + other-modules: IPC.DBus + cpp-options: -DDBUS |