summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar.hs')
-rw-r--r--src/Xmobar.hs306
1 files changed, 306 insertions, 0 deletions
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
new file mode 100644
index 0000000..2f5aa3c
--- /dev/null
+++ b/src/Xmobar.hs
@@ -0,0 +1,306 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Xmobar
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- A status bar for the Xmonad Window Manager
+--
+-----------------------------------------------------------------------------
+
+module Xmobar
+ ( -- * Main Stuff
+ -- $main
+ X , XConf (..), runX
+ , eventLoop
+ -- * Program Execution
+ -- $command
+ , startCommand
+ -- * Window Management
+ -- $window
+ , createWin, updateWin
+ -- * Printing
+ -- $print
+ , drawInWin, printStrings
+ ) where
+
+import Prelude hiding (catch)
+import Graphics.X11.Xlib hiding (textExtents, textWidth)
+import Graphics.X11.Xlib.Extras
+import Graphics.X11.Xinerama
+
+import Control.Arrow ((&&&))
+import Control.Monad.Reader
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception hiding (handle)
+import Data.Bits
+import Data.Maybe(fromMaybe)
+import Data.Typeable (Typeable)
+
+import Config
+import Parsers
+import Commands
+import Runnable
+import XUtil
+
+-- $main
+--
+-- The Xmobar data type and basic loops and functions.
+
+-- | The X type is a ReaderT
+type X = ReaderT XConf IO
+
+-- | The ReaderT inner component
+data XConf =
+ XConf { display :: Display
+ , rect :: Rectangle
+ , window :: Window
+ , fontS :: XFont
+ , config :: Config
+ }
+
+-- | Runs the ReaderT
+runX :: XConf -> X () -> IO ()
+runX xc f = runReaderT f xc
+
+data WakeUp = WakeUp deriving (Show,Typeable)
+instance Exception WakeUp
+
+-- | The event loop
+eventLoop :: XConf -> [(Maybe ThreadId, TVar String)] -> IO ()
+eventLoop xc@(XConf d _ w fs c) v = block $ do
+ tv <- atomically $ newTVar []
+ t <- myThreadId
+ ct <- forkIO (checker t tv "" `catch` \(SomeException _) -> return ())
+ go tv ct
+ where
+ -- interrupt the drawing thread every time a var is updated
+ checker t tvar ov = do
+ nval <- atomically $ do
+ nv <- fmap concat $ mapM readTVar (map snd v)
+ guard (nv /= ov)
+ writeTVar tvar nv
+ return nv
+ throwTo t WakeUp
+ checker t tvar nval
+
+ -- Continuously wait for a timer interrupt or an expose event
+ go tv ct = do
+ catch (unblock $ allocaXEvent $ \e ->
+ handle tv ct =<< (nextEvent' d e >> getEvent e))
+ (\WakeUp -> runX xc (updateWin tv) >> return ())
+ go tv ct
+
+ -- event hanlder
+ handle _ ct (ConfigureEvent {ev_window = win}) = do
+ rootw <- rootWindow d (defaultScreen d)
+ when (win == rootw) $ block $ do
+ killThread ct
+ destroyWindow d w
+ (r',w') <- createWin d fs c
+ eventLoop (XConf d r' w' fs c) v
+
+ handle tvar _ (ExposeEvent {}) = runX xc (updateWin tvar)
+
+ handle _ _ _ = 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)
+ | alias com == "" = do var <- atomically $ newTVar is
+ atomically $ writeTVar var "Could not parse the template"
+ return (Nothing,var)
+ | otherwise = do var <- atomically $ newTVar is
+ let cb str = atomically $ writeTVar var (s ++ str ++ ss)
+ h <- forkIO $ start com cb
+ 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
+ selectInput d win (exposureMask .|. structureNotifyMask)
+ setProperties r c d win srs
+ when (lowerOnStart c) (lowerWindow d win)
+ mapWindow d win
+ return (r,win)
+
+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 (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
+
+ 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
+ changeProperty32 d w a1 c1 propModeReplace $ map fi $
+ getStrutValues r (position c) (getRootWindowHeight srs)
+ changeProperty32 d w a2 c2 propModeReplace [fromIntegral v]
+
+getRootWindowHeight :: [Rectangle] -> Int
+getRootWindowHeight srs = foldr1 max (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
+ let (conf,rec) = (config &&& rect) xc
+ [lc,rc] = if length (alignSep conf) == 2
+ then alignSep conf
+ else alignSep defaultConfig
+ i <- io $ atomically $ readTVar v
+ let def = [i,[],[]]
+ [l,c,r] = case break (==lc) i of
+ (le,_:re) -> case break (==rc) re of
+ (ce,_:ri) -> [le,ce,ri]
+ _ -> def
+ _ -> def
+ ps <- io $ mapM (parseString conf) [l,c,r]
+ drawInWin rec ps
+
+-- $print
+
+-- | Draws in and updates the window
+drawInWin :: Rectangle -> [[(String, String)]] -> X ()
+drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
+ r <- ask
+ let (c,d ) = (config &&& display) r
+ (w,fs) = (window &&& fontS ) r
+ strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw))
+ withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
+ gc <- io $ createGC d w
+ -- create a pixmap to write to and fill it with a rectangle
+ p <- io $ createPixmap d w wid ht
+ (defaultDepthOfScreen (defaultScreenOfDisplay d))
+ -- the fgcolor of the rectangle will be the bgcolor of the window
+ io $ setForeground d gc bgcolor
+ io $ fillRectangle d p gc 0 0 wid ht
+ -- write to the pixmap the new string
+ printStrings p gc fs 1 L =<< strLn left
+ printStrings p gc fs 1 R =<< strLn right
+ printStrings p gc fs 1 C =<< strLn center
+ -- draw 1 pixel border if requested
+ io $ drawBorder (border c) d p gc bdcolor wid ht
+ -- copy the pixmap with the new string to the window
+ io $ copyArea d p w gc 0 0 wid ht 0 0
+ -- free up everything (we do not want to leak memory!)
+ io $ freeGC d gc
+ io $ freePixmap d p
+ -- 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 rm = fi m; mp = fi m in
+ sf >> drawRectangle d p gc mp mp (w - rm) (h - rm)
+ 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 ()
+printStrings _ _ _ _ _ [] = return ()
+printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
+ r <- ask
+ (as,ds) <- io $ textExtents fontst s
+ let (conf,d) = (config &&& display) r
+ Rectangle _ _ wid ht = rect r
+ totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
+ valign = fi $ as + ds
+ remWidth = fi wid - fi totSLen
+ offset = case a of
+ C -> (remWidth + offs) `div` 2
+ R -> remWidth
+ L -> offs
+ (fc,bc) = case (break (==',') c) of
+ (f,',':b) -> (f, b )
+ (f, _) -> (f, bgColor conf)
+ withColors d [bc] $ \[bc'] -> do
+ io $ setForeground d gc bc'
+ io $ fillRectangle d dr gc offset 0 (fi l) ht
+ io $ printString d dr fontst gc fc bc offset valign s
+ printStrings dr gc fontst (offs + l) a xs
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-21 05:56:36 +0000