diff options
| -rw-r--r-- | xmobar.hs | 181 |
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) + + |