diff options
Diffstat (limited to 'Xmobar.hs')
| -rw-r--r-- | Xmobar.hs | 254 |
1 files changed, 254 insertions, 0 deletions
diff --git a/Xmobar.hs b/Xmobar.hs new file mode 100644 index 0000000..dc05d7d --- /dev/null +++ b/Xmobar.hs @@ -0,0 +1,254 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it> +-- Stability : unstable +-- Portability : unportable +-- +-- A status bar for the Xmonad Window Manager +-- +----------------------------------------------------------------------------- + +module Xmobar (-- * Main Stuff + -- $main + Xbar + , runXmobar + , eventLoop + , createWin + -- * Printing + -- $print + , drawInWin + , printStrings + -- * Program Execution + -- $commands + , execCommands + , execCommand + , runCommandLoop + , readVariables + -- * Unmamaged Windows + -- $unmanwin + , mkUnmanagedWindow + -- * Useful Utilities + , initColor + , io + ) where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Misc + +import Control.Monad.State +import Control.Monad.Reader +import Control.Concurrent + +import Config +import Parsers +import Commands +import Runnable + +-- $main +-- +-- The Xmobar data type and basic loops and functions. + +-- | This is just esthetics, stolen from XMonad: see 'runXmobar' +newtype Xbar a = X (ReaderT Config (StateT XState IO) a) + deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader Config) + +-- | The State component of StateT +data XState = + XState { display :: Display + , window :: Window + , vars :: [(ThreadId, MVar String)] + } + +-- | Totally useless: but it is nice to be able to use get to get the +-- state and ask to get the configuration: functions requires less +-- arguments, after all. +runXmobar :: Config -> [(ThreadId, MVar String)] -> Display -> Window -> Xbar () -> IO () +runXmobar c v d w (X f) = + do runStateT (runReaderT f c) (XState d w v) + return () + +-- | The event loop +eventLoop :: Xbar () +eventLoop = + do c <- ask + s <- get + i <- io $ readVariables (vars s) + ps <- io $ parseString c i + drawInWin ps + -- back again: we are never ending + io $ tenthSeconds (refresh c) + eventLoop + +-- | The function to create the initial window +createWin :: Config -> IO (Display, Window) +createWin config = + do dpy <- openDisplay "" + let dflt = defaultScreen dpy + rootw <- rootWindow dpy dflt + win <- mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw + (fi $ xPos config) + (fi $ yPos config) + (fi $ width config) + (fi $ height config) + mapWindow dpy win + return (dpy,win) + + +-- $print + +-- | Draws in and updates the window +drawInWin :: [(String, String)] -> Xbar () +drawInWin str = + do config <- ask + st <- get + let (dpy,win) = (display st, window st) + bgcolor <- io $ initColor dpy $ bgColor config + gc <- io $ createGC dpy win + --let's get the fonts + fontst <- io $ loadQueryFont dpy (font config) + io $ setFont dpy gc (fontFromFontStruct fontst) + -- create a pixmap to write to and fill it with a rectangle + p <- io $ createPixmap dpy win + (fi (width config)) + (fi (height config)) + (defaultDepthOfScreen (defaultScreenOfDisplay dpy)) + -- the fgcolor of the rectangle will be the bgcolor of the window + io $ setForeground dpy gc bgcolor + io $ fillRectangle dpy p gc 0 0 + (fi $ width config) + (fi $ height config) + -- write to the pixmap the new string + let strWithLenth = map (\(s,c) -> (s,c,textWidth fontst s)) str + p' <- printStrings p gc fontst 1 strWithLenth + -- copy the pixmap with the new string to the window + io $ copyArea dpy p' win gc 0 0 (fi (width config)) (fi (height config)) 0 0 + -- free up everything (we do not want to leak memory!) + io $ freeFont dpy fontst + io $ freeGC dpy gc + io $ freePixmap dpy p' + -- resync + io $ sync dpy True + +-- | An easy way to print the stuff we need to print +printStrings :: Drawable + -> GC + -> FontStruct + -> Position + -> [(String, String, Position)] + -> Xbar Pixmap +printStrings p _ _ _ [] = return p +printStrings p gc fontst offs sl@((s,c,l):xs) = + do config <- ask + st <- get + let (_,asc,_,_) = textExtents fontst s + totSLen = foldr (\(_,_,len) -> (+) len) 0 sl + valign = (fi (height config) + fi asc) `div` 2 + remWidth = fi (width config) - fi totSLen + offset = case (align config) of + "center" -> (remWidth + offs) `div` 2 + "right" -> remWidth - 1 + "left" -> offs + _ -> offs + fgcolor <- io $ initColor (display st) c + bgcolor <- io $ initColor (display st) (bgColor config) + io $ setForeground (display st) gc fgcolor + io $ setBackground (display st) gc bgcolor + io $ drawImageString (display st) p gc offset valign s + p' <- printStrings p gc fontst (offs + l) xs + return p' + +-- $commands + +-- | Runs a list of programs as independent threads and returns their thread id +-- and the MVar they will be writing to. +execCommands :: Config -> [(Runnable,String,String)] -> IO [(ThreadId, MVar String)] +execCommands _ [] = return [] +execCommands c (x:xs) = + do i <- execCommand c x + is <- execCommands c xs + return $ i : is + +execCommand :: Config -> (Runnable,String,String) -> IO (ThreadId, MVar String) +execCommand c com = + do var <- newMVar "Updating..." + h <- forkIO $ runCommandLoop var c com + return (h,var) + +runCommandLoop :: MVar String -> Config -> (Runnable,String,String) -> IO () +runCommandLoop var conf c@(com,s,ss) + | alias com == "" = + do modifyMVar_ var (\_ -> return $ "Could not parse the template") + tenthSeconds (refresh conf) + runCommandLoop var conf c + | otherwise = + do str <- run com + modifyMVar_ var (\_ -> return $ s ++ str ++ ss) + tenthSeconds (rate com) + runCommandLoop var conf c + +-- | Reads MVars set by 'runCommandLoop' +readVariables :: [(ThreadId, MVar String)] -> IO String +readVariables [] = return "" +readVariables ((_,v):xs) = + do f <- readMVar v + fs <- readVariables xs + return $! f ++ fs + +{- $unmanwin + +This is a way to create unmamaged window. It was a mistery in Haskell. +Till I've found out...;-) + +-} + +-- | Creates a window with the attribute override_redirect set to True. +-- Windows Managers should not touch this kind of windows. +mkUnmanagedWindow :: Display + -> Screen + -> Window + -> Position + -> Position + -> Dimension + -> Dimension + -> IO Window +mkUnmanagedWindow dpy scr rw x y w h = do + let visual = defaultVisualOfScreen scr + attrmask = cWOverrideRedirect + win <- allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes True + createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) + inputOutput visual attrmask attributes + return win + +{- $utility +Utilities, aka stollen without givin' credit stuff. +-} + +-- | Get the Pixel value for a named color +initColor :: Display -> String -> IO Pixel +initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c + where colormap = defaultColormap dpy (defaultScreen dpy) + +-- | Short-hand for lifting in the IO monad +io :: IO a -> Xbar a +io = liftIO + +-- | Work arount to the Int max bound: since threadDelay takes an Int, it +-- is not possible to set a thread delay grater than about 45 minutes. +-- With a little recursion we solve the problem. +tenthSeconds :: Int -> IO () +tenthSeconds s | s >= x = do threadDelay y + tenthSeconds (x - s) + | otherwise = threadDelay (s * 100000) + where y = (maxBound :: Int) + x = y `div` 100000 + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral |