summaryrefslogtreecommitdiffhomepage
path: root/XMobar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'XMobar.hs')
-rw-r--r--XMobar.hs262
1 files changed, 262 insertions, 0 deletions
diff --git a/XMobar.hs b/XMobar.hs
new file mode 100644
index 0000000..9bc982e
--- /dev/null
+++ b/XMobar.hs
@@ -0,0 +1,262 @@
+{-# 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
+ , getOptions
+ , 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 System.Process
+import System.Exit
+import System.IO (hClose, hGetLine)
+
+import Config
+import Parsers
+
+-- $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 $ threadDelay $ 100000 * 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
+ (fromIntegral $ xPos config)
+ (fromIntegral $ yPos config)
+ (fromIntegral $ width config)
+ (fromIntegral $ hight 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 (fonts config)
+ io $ setFont dpy gc (fontFromFontStruct fontst)
+
+ -- set window background
+ io $ setForeground dpy gc bgcolor
+ io $ fillRectangle dpy win gc 0 0
+ (fromIntegral $ width config)
+ (fromIntegral $ hight config)
+ -- write
+ let strWithLenth = map (\(s,c) -> (s,c,textWidth fontst s)) str
+ printStrings gc fontst 1 strWithLenth
+ -- free everything
+ io $ freeFont dpy fontst
+ io $ freeGC dpy gc
+ io $ flush dpy
+
+-- | An easy way to print the stuff we need to print
+printStrings :: GC
+ -> FontStruct
+ -> Position
+ -> [(String, String, Position)]
+ -> Xbar ()
+printStrings _ _ _ [] = return ()
+printStrings 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 = (fromIntegral (hight config) + fromIntegral asc) `div` 2
+ offset = case (align config) of
+ "center" -> (fromIntegral (width config) - fromIntegral totSLen) `div` 2
+ "right" -> fromIntegral (width config) - fromIntegral totSLen
+ "left" -> offs
+ _ -> offs
+ color <- io $ initColor (display st) c
+ io $ setForeground (display st) gc color
+ io $ drawString (display st) (window st) gc offset valign s
+ printStrings gc fontst (offs + l) xs
+
+-- $commands
+
+-- | Gets the command options set in configuration.
+getOptions :: Config -> String -> [String]
+getOptions c com =
+ let l = commands c
+ p = filter (\(s,_,_) -> s == com) l
+ in case p of
+ [(_,_,opts)] -> opts
+ _ -> []
+
+-- | Gets the command options set in configuration.
+getRefRate :: Config -> String -> Int
+getRefRate c com =
+ let l = commands c
+ p = filter (\(s,_,_) -> s == com) l
+ in case p of
+ [(_,int,_)] -> int
+ _ -> refresh c
+
+-- | Runs a list of programs
+execCommands :: Config -> [(String,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 -> (String,String,String) -> IO (ThreadId, MVar String)
+execCommand c com =
+ do var <- newMVar "Updating..."
+ h <- forkIO $ runCommandLoop var c com
+ return (h,var)
+
+-- | Runs the external program
+runCommandLoop :: MVar String -> Config -> (String,String,String) -> IO ()
+runCommandLoop var conf c@(s,com,ss)
+ | com == "" =
+ do modifyMVar_ var (\_ -> return $ "Could not parse the template")
+ threadDelay $ 100000 * refresh conf
+ runCommandLoop var conf c
+ | otherwise =
+ do (i,o,e,p) <- runInteractiveCommand (com ++ concat (map (' ':) $ getOptions conf com))
+ -- the followinf leaks memory
+ --(i,o,e,p) <- runInteractiveProcess com (getOptions c com) Nothing Nothing
+ exit <- waitForProcess p
+ let closeHandles = do hClose o
+ hClose i
+ hClose e
+ case exit of
+ ExitSuccess -> do str <- hGetLine o
+ closeHandles
+ modifyMVar_ var (\_ -> return $ s ++ str ++ ss)
+ threadDelay $ 100000 * (getRefRate conf com)
+ runCommandLoop var conf c
+ _ -> do closeHandles
+ modifyMVar_ var $ \_ -> return $ "Could not execute command " ++ com
+ threadDelay $ 100000 * (getRefRate conf 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