Habemus XMobar! was Re: [Xmonad] [dzen] release 0.5.0

Andrea Rossato mailing_list at istitutocolli.org
Tue Jun 19 02:26:56 EDT 2007


On Thu, Jun 14, 2007 at 09:21:44PM +0200, Robert Manea wrote:
> Well, i did not want to do too much parsing and tokenizing. Though the
> idea is a good one, patches welcome :).
> 

well, this is not a patch, but hope it will give you an Idea of what I
have in mind.

I've called it xmobar, but it's just a joke... I asked to myself, why
doesn't Robert rewrite dzen2 in haskell? I'll be delighted to help. As
I said I don't get C...

dear haskellelers,
do not start talking bad at me because the code is not so nice, etc.
etc. I just wanted a code that was clear to read also for the novice
(still I belong to this category) of hakell.
I'm thinking to use it as a tutorial for the Xlib library (for the
haskell wiki): as you know I'm far better at writing tutorials on
difficult stuff than simple code.

Who knows, perhaps someone is going to take the challenge and write an
xmonad status bar...

BTW, here's the usual ugly screen shot:
http://gorgias.mine.nu/xmobar/xmobar.jpg
here you'll fine more stuff (included binaries, hopefully working):
http://gorgias.mine.nu/xmobar/

Attached you'll find xmobar.hs, the main file (compile with 
ghc --make xmobar.hs -o xmobar).

Use like this: 
1. from a terminal write:
./xmobar xmobar.config

if you do not give a configuration file xmobar will use the default
configuration.

2. After that nothing is going to happen. You need to type, something
like:
^#ff0000Ciao ciao, my name is ^#00FF00Andrea!

3. Ok, you may now press enter. Something is supposed to happen. If it
   doesn't, well, that's better than you may think.

In the screen shot I use it with mymon:
ghc --make monitor.hs -o mymon
monitor.hs is attached. 
I found it here, but I modified it:
http://blog.csdn.net/danranx/archive/2007/06/10/1646608.aspx

I've put, in my .xinitrc:

while true ; do /path/to/mymon; sleep 5 ; done \
           | /path/to/xmobar &

do not forget the last & otherwise xmonad will not start, I think.

Let me know if you like the bits. That would reinforce my ego.
;-)

ciao
andrea

ps: I have the feeling that the parser actually sucks.
-------------- next part --------------
module Main where


import Graphics.X11.Xlib
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Extras

import Text.ParserCombinators.Parsec

import Control.Concurrent
import Control.Monad
import Data.Bits
import System

data Config = 
    Config { fonts :: String
           , bgColor :: String
           , fgColor :: String
           , xPos :: Int
           , yPos :: Int
           , width :: Int
           , hight :: Int
           } deriving (Eq, Show, Read, Ord)

defaultConfig :: Config
defaultConfig =
    Config { fonts = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" 
           , bgColor = "#000000"
           , fgColor = "#ffffff"
           , xPos = 0
           , yPos = 0
           , width = 1024
           , hight = 15
           }

main :: IO ()
main = 
    do args <- getArgs
       config <-
           if length args /= 1
              then do putStrLn ("No configuration file specified. Using default settings")
                      return defaultConfig
              else readConfig (args!!0)
       eventLoop config

eventLoop :: Config -> IO ()
eventLoop c =
    do a <- getLine
       b <- stringParse c a
       runWin c b


runWin :: Config -> [(String, String)] -> IO ()
runWin config str = 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) 0
  mapWindow dpy win

  -- get default colors
  bgcolor  <- initColor dpy $ bgColor config
  fgcolor  <- initColor dpy $ fgColor config

  -- window background 
  gc <- createGC dpy win
  setForeground dpy gc bgcolor
  fillRectangle dpy win gc 0 0 
                    (fromIntegral $ width config) 
                    (fromIntegral $ hight config)

  -- let's get the fonts
  fontst <- loadQueryFont dpy (fonts config)
  setFont dpy gc (fontFromFontStruct fontst)
  
  -- print what you need to print
  let strWithLenth = map (\(s,c) -> (s,c,textWidth fontst s)) str
  printStrings dpy win gc fontst 1 strWithLenth 

  -- refreesh, fre, resync... do what you gotta do
  freeGC dpy gc
  sync dpy True
  -- back again: we are never ending
  eventLoop config


{- $print
An easy way to print the stuff we need to print
-}

printStrings _ _ _ _ _ [] = return ()
printStrings dpy win gc fontst offset (x@(s,c,l):xs) =
    do let (_,asc,desc,_) = textExtents fontst s
       color  <- initColor dpy c
       setForeground dpy gc color
       drawString dpy win gc offset asc s
       printStrings dpy win gc fontst (offset + l) xs

{- $parser
This is suppose do be a parser. Don't trust him.
-}

stringParse :: Config -> String -> IO [(String, String)]
stringParse config s = 
    case (parse (stringParser config) "" s) of
      Left err -> return [("Sorry, if I were a decent parser you now would be starting at something meaningful...",(fgColor config))]
      Right x  -> return x

stringParser :: Config -> Parser [(String, String)]
stringParser c = manyTill (choice [colorsAndText c,defaultColors c]) eof

defaultColors :: Config -> Parser (String, String)
defaultColors config = 
    do { s <- many $ noneOf "^"
       ; notFollowedBy (char '#')
       ; return (s,(fgColor config))
       }
    <|> colorsAndText config

colorsAndText :: Config -> Parser (String, String) 
colorsAndText config = 
    do { string "^#"
       ; n <- count 6 hexDigit
       ; s <- many $ noneOf "^"
       ; notFollowedBy (char '#') 
       ; return (s,"#"++n)
       }
    <|> defaultColors config


{- $unmanwin

This is a way to create unmamaged window. It was a mistery in haskell. 
Till I've found out...;-)

-}

mkUnmanagedWindow :: Display
                  -> Screen
                  -> Window
                  -> Position
                  -> Position
                  -> Dimension
                  -> Dimension
                  -> Pixel
                  -> IO Window
mkUnmanagedWindow dpy scr rw x y w h bgcolor = do
  let visual = defaultVisualOfScreen scr
      attrmask = cWOverrideRedirect
  window <- allocaSetWindowAttributes $ 
            \attributes -> do
              set_override_redirect attributes True
              createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) 
                           inputOutput visual attrmask attributes                                
  return window

{- $utility

Utilitis, aka stollen without givin' credit stuff.

-}


readConfig :: FilePath -> IO Config
readConfig f = 
    do s <- readFile f
       case reads s of
         [(config, str)] -> return config
         [] -> error ("corrupt config file: " ++ f)


-- | 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)


-------------- next part --------------
Config { fonts = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*"
       , bgColor = "#000000"
       , fgColor = "#00ff00"
       , xPos = 0
       , yPos = 0
       , width = 1024
       , hight = 15
       }
-------------- next part --------------
#! /usr/bin/env runhaskell


import Data.Time (getZonedTime)
import Text.Printf (printf)
import System.Process (runInteractiveCommand)
import Data.List
import System.IO (hGetContents)


getOutput :: String -> IO String
getOutput cmd = do
    (_, out, _, _) <- runInteractiveCommand cmd
    hGetContents out 

memParse :: String -> String
memParse file = 
    let content = map words $ take 4 $ lines file
        [total, free, buffer, cache] = map (\line -> (read $ line !! 1 :: Float) / 1024) content
        rest = free + buffer + cache
        used = total - rest
        usedratio = used * 100 / total
        realused = if usedratio > 50 then "^#FF0000"++show used++"^#FFFFFF"
                   else "^#FF00FF"++show used++"^#FFFFFF"
    in
        printf "MEM: %sM %.1f%% used   %.0fM rest" realused usedratio rest


mem :: IO String
mem = do
    file <- readFile "/proc/meminfo"
    return $ memParse file


time :: IO String
time = do
    now <- getZonedTime
    return $ take 16 $ show now


temp :: IO String
temp = do
    file <- readFile "/proc/acpi/thermal_zone/THRM/temperature"
    let t = (words file) !! 1
        f t | read t > 60 = "^#FF0000"++t++"^#FFFFFF"
            | otherwise = "^#00FF00"++t++"^#FFFFFF"
    return $ "TEMP: " ++ (f t) ++ "C"


takeTail :: Int -> [a] -> [a]
takeTail n xs =
    let len = length xs in
        drop (len-n) xs


load :: IO String
load = do
    content <- getOutput "uptime"
    let l = map (delete ',') $ takeTail 3 $ words content
    return $ unwords $ "LOAD:" : l


sep :: IO String
sep = return "        "


main = do 
    putStr ""
    mapM_ (>>=putStr) $ intersperse sep [load, temp, mem, time]
    putChar '\n'


More information about the Xmonad mailing list