init

darcs-hash:20070619080355-92444-a160705f4407b88738ba0e0cb44da7f0ae912985.gz

1 files changed, 181 insertions, 0 deletions

diff --git a/xmobar.hs b/xmobar.hs
new file mode 100644
index 0000000..f8d1ffc
--- /dev/null
+++ b/xmobar.hs
@@ -0,0 +1,181 @@
+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 i <- getLine
+       ps <- stringParse c i
+       w <- createWin c
+       runWin c w ps
+
+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) 0
+     mapWindow dpy win
+     return (dpy,win)
+
+runWin :: Config -> (Display, Window) -> [(String, String)] -> IO ()
+runWin config (dpy, win) str = do
+  -- 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 starring 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)
+
+