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 --- Xmobar.hs | 306 -------------------------------------------------------------- 1 file changed, 306 deletions(-) delete mode 100644 Xmobar.hs (limited to 'Xmobar.hs') diff --git a/Xmobar.hs b/Xmobar.hs deleted file mode 100644 index 2f5aa3c..0000000 --- a/Xmobar.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# 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