summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar.hs
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/Xmobar.hs
parent73837127825529d44e2e0d4ed440da0d7b180020 (diff)
parent05f268c3a831325f65a662c6ccdff75a1c441d83 (diff)
downloadxmobar-359769944a8cb0ac80537458af0e49cc8f68d01b.tar.gz
xmobar-359769944a8cb0ac80537458af0e49cc8f68d01b.tar.bz2
Merge for pull request #53
Diffstat (limited to 'src/Xmobar.hs')
-rw-r--r--src/Xmobar.hs195
1 files changed, 37 insertions, 158 deletions
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 ()