From e3853a9cb2a9a2cffa174d1334e2ca8ba610f151 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Tue, 21 Dec 2010 02:36:35 +0100 Subject: Haskell sources moved to src/ to unclutter toplevel --- src/Xmobar.hs | 306 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 306 insertions(+) create mode 100644 src/Xmobar.hs (limited to 'src/Xmobar.hs') 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 +-- 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 -- cgit v1.2.3