summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2012-08-13 15:11:55 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2012-08-13 15:12:11 +0200
commit359769944a8cb0ac80537458af0e49cc8f68d01b (patch)
tree484068988be1571b25ff0a81c7e74cb9cd579325 /src
parent73837127825529d44e2e0d4ed440da0d7b180020 (diff)
parent05f268c3a831325f65a662c6ccdff75a1c441d83 (diff)
downloadxmobar-359769944a8cb0ac80537458af0e49cc8f68d01b.tar.gz
xmobar-359769944a8cb0ac80537458af0e49cc8f68d01b.tar.bz2
Merge for pull request #53
Diffstat (limited to 'src')
-rw-r--r--src/Commands.hs20
-rw-r--r--src/Config.hs6
-rw-r--r--src/IPC/DBus.hs64
-rw-r--r--src/Main.hs7
-rw-r--r--src/Parsers.hs11
-rw-r--r--src/Plugins/BufferedPipeReader.hs83
-rw-r--r--src/Plugins/Utils.hs6
-rw-r--r--src/Runnable.hs5
-rw-r--r--src/Signal.hs70
-rw-r--r--src/Window.hs167
-rw-r--r--src/Xmobar.hs195
11 files changed, 458 insertions, 176 deletions
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 ()