xmobar-0.7: Xmobar.hs
{-# 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
, runXbar
, eventLoop
, createWin
, updateWin
-- * Printing
-- $print
, drawInWin
, printStrings
-- * Program Execution
-- $commands
, execCommands
, execCommand
, runCommandLoop
, readVariables
-- * Unmamaged Windows
-- $unmanwin
, mkUnmanagedWindow
-- * Useful Utilities
, initColor
, io
) where
import Prelude hiding (catch)
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Event
import Control.Monad.State
import Control.Monad.Reader
import Control.Concurrent
import Control.Exception
import System.Posix.Types (Fd(..))
import Config
import Parsers
import Commands
import Runnable
-- $main
--
-- The Xmobar data type and basic loops and functions.
-- | This is copied from XMonad.
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)]
}
-- | We use get to get the state and ask to get the configuration: whis way
-- functions requires less arguments.
runXbar :: Config -> [(ThreadId, MVar String)] -> Display -> Window -> Xbar () -> IO ()
runXbar c v d w (X f) =
do runStateT (runReaderT f c) (XState d w v)
return ()
-- | A version of nextEvent that does not block in foreign calls.
nextEvent' :: Display -> XEventPtr -> IO ()
nextEvent' d p = do
pend <- pending d
if pend /= 0
then nextEvent d p
else do
threadWaitRead (Fd fd)
nextEvent' d p
where
fd = connectionNumber d
-- | The event loop
eventLoop :: Config -> [(ThreadId, MVar String)] -> Display -> Window -> IO ()
eventLoop c v d w = do
t <- forkIO (block go)
timer t
where
-- interrupt the drawing thread every so often
timer t = do
tenthSeconds (refresh c)
throwTo t (ErrorCall "Xmobar.eventLoop: yield")
timer t
-- Continuously wait for a timer interrupt or an expose event
go = do
runXbar c v d w updateWin
catch (unblock $ allocaXEvent $ nextEvent' d) (const $ return ())
go
-- | 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)
selectInput dpy win exposureMask
mapWindow dpy win
return (dpy,win)
updateWin :: Xbar ()
updateWin =
do c <- ask
s <- get
i <- io $ readVariables (vars s)
ps <- io $ parseString c i
drawInWin ps
-- $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
let lf c = loadQueryFont dpy (font c)
fontst <- io $ catch (lf config) (const $ lf defaultConfig)
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
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 ()
printStrings _ _ _ _ [] = return ()
printStrings d 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) d gc offset valign s
printStrings d gc fontst (offs + l) xs
-- $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 c xs = mapM (execCommand c) xs
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: if an invalid name is
-- given the black pixel will be returned.
initColor :: Display -> String -> IO Pixel
initColor dpy c =
catch (initColor' dpy c) (const $ return $ blackPixel dpy (defaultScreen dpy))
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