summaryrefslogtreecommitdiffhomepage
path: root/xmobar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'xmobar.hs')
-rw-r--r--xmobar.hs133
1 files changed, 73 insertions, 60 deletions
diff --git a/xmobar.hs b/xmobar.hs
index 42f9ea7..088efe0 100644
--- a/xmobar.hs
+++ b/xmobar.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMobar
@@ -18,13 +19,13 @@ module Main ( -- * Configuration
-- * Main Stuff
-- $main
, Xbar
- , main
, runXMobar
+ , main
, eventLoop
, createWin
- , drawInWin
-- * Printing
-- $print
+ , drawInWin
, printStrings
-- * Program Execution
-- $commands
@@ -57,6 +58,7 @@ import Graphics.X11.Xlib.Misc
import Text.ParserCombinators.Parsec
+import Control.Monad.State
import Control.Monad.Reader
import Control.Concurrent
import System.Environment
@@ -97,16 +99,31 @@ defaultConfig =
, hight = 15
, align = "left"
, refresh = 10
- , commands = [("date", 100, [])]
+ , commands = [("date", 10, [])]
, sepChar = "%"
, template = "Uptime: <fc=#00FF00>%uptime%</fc> ** <fc=#FF0000>%date%</fc>"
}
--- | This is just esthetics: see 'runXMobar'
-type Xbar a = ReaderT Config IO a
+-- | 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)]
+ }
-- $main
+-- | 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 main entry point
main :: IO ()
main =
@@ -116,80 +133,76 @@ main =
then do putStrLn ("No configuration file specified. Using default settings.")
return defaultConfig
else readConfig (args!!0)
- runReaderT runXMobar config
-
--- | Totally useless: since most of the operations are done in the IO
--- monad it is ofter simpler to pass Config instead of lifting everytime.
--- But we like the mtl library...;-)
-runXMobar :: Xbar ()
-runXMobar =
- do config <- ask
- dw <- createWin config
- cl <- io $ parseTemplate config (template config)
- var <- io $ execCommands config cl
- eventLoop dw var
+ cl <- parseTemplate config (template config)
+ var <- execCommands config cl
+ (d,w) <- createWin config
+ runXMobar config var d w eventLoop
-- | The event loop
-eventLoop :: (Display, Window) -> [(ThreadId, MVar String)] -> Xbar ()
-eventLoop (d,w) var =
+eventLoop :: Xbar ()
+eventLoop =
do c <- ask
- i <- io $ readVariables var
+ s <- get
+ i <- io $ readVariables (vars s)
ps <- io $ parseString c i
- io $ drawInWin c (d,w) ps
+ drawInWin ps
-- back again: we are never ending
io $ threadDelay $ 100000 * refresh c
- eventLoop (d,w) var
+ eventLoop
-- | The function to create the initial window
-createWin :: Config -> Xbar (Display, Window)
+createWin :: Config -> IO (Display, Window)
createWin config =
- do dpy <- io $ openDisplay ""
+ do dpy <- openDisplay ""
let dflt = defaultScreen dpy
- rootw <- io $ rootWindow dpy dflt
- win <- io $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
+ rootw <- rootWindow dpy dflt
+ win <- mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
(fromIntegral $ xPos config)
(fromIntegral $ yPos config)
(fromIntegral $ width config)
(fromIntegral $ hight config)
- io $ mapWindow dpy win
+ mapWindow dpy win
return (dpy,win)
--- | Draws in and updates the window
-drawInWin :: Config -> (Display, Window) -> [(String, String)] -> IO ()
-drawInWin config (dpy, win) str =
- do bgcolor <- initColor dpy $ bgColor config
- gc <- createGC dpy win
- --let's get the fonts
- fontst <- loadQueryFont dpy (fonts config)
- setFont dpy gc (fontFromFontStruct fontst)
-
- -- set window background
- setForeground dpy gc bgcolor
- 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 config dpy win gc fontst 1 strWithLenth
- -- free everything
- freeFont dpy fontst
- freeGC dpy gc
- flush dpy
-- $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 :: Config
- -> Display
- -> Drawable
- -> GC
+printStrings :: GC
-> FontStruct
-> Position
-> [(String, String, Position)]
- -> IO ()
-printStrings _ _ _ _ _ _ [] = return ()
-printStrings config dpy win gc fontst offs sl@((s,c,l):xs) =
- do let (_,asc,_,_) = textExtents fontst s
+ -> 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
@@ -197,10 +210,10 @@ printStrings config dpy win gc fontst offs sl@((s,c,l):xs) =
"right" -> fromIntegral (width config) - fromIntegral totSLen
"left" -> offs
_ -> offs
- color <- initColor dpy c
- setForeground dpy gc color
- drawString dpy win gc offset valign s
- printStrings config dpy win gc fontst (offs + l) xs
+ 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