splitted files

darcs-hash:20070626113948-d6583-73d318293d1cd91894589450e5cd270dd39bdc02.gz

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