summaryrefslogtreecommitdiffhomepage
path: root/xmobar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'xmobar.hs')
-rw-r--r--xmobar.hs181
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)
+
+