README and Cabal edits

Added some more credits, corrected typos, updated darcs version to 0.7,
changed name to Xmonbar and removed references to XMonad. Xmobar is now just
a minimalistic text based status bar for any kind of WM (the XMonad
community adopted the more advanced and stable dzen, after all ;-)

darcs-hash:20070714103913-d6583-b143dedf4ed5cbcb59b4f630ffce9afe82e32b86.gz

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