From a8ffb9f53aac66b31d4ef870ed88b7c0e6e5ca7e Mon Sep 17 00:00:00 2001 From: Andrea Rossato Date: Tue, 26 Jun 2007 13:39:48 +0200 Subject: splitted files darcs-hash:20070626113948-d6583-73d318293d1cd91894589450e5cd270dd39bdc02.gz --- xmobar.hs | 403 -------------------------------------------------------------- 1 file changed, 403 deletions(-) delete mode 100644 xmobar.hs (limited to 'xmobar.hs') diff --git a/xmobar.hs b/xmobar.hs deleted file mode 100644 index 088efe0..0000000 --- a/xmobar.hs +++ /dev/null @@ -1,403 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : XMobar --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Andrea Rossato --- Stability : unstable --- Portability : unportable --- --- A status bar for the Xmonad Window Manager --- ------------------------------------------------------------------------------ - -module Main ( -- * Configuration - -- $config - Config (..) - -- * Main Stuff - -- $main - , Xbar - , runXMobar - , main - , eventLoop - , createWin - -- * Printing - -- $print - , drawInWin - , printStrings - -- * Program Execution - -- $commands - , getOptions - , execCommands - , execCommand - , runCommandLoop - , readVariables - -- * Parsing - -- $parser - , parseString - , stringParser - , defaultColors - , colorsAndText - , templateStringParser - , templateCommandParser - , templateParser - , parseTemplate - -- * Unmamaged Windows - -- $unmanwin - , mkUnmanagedWindow - -- * Useful Utilities - , readConfig - , initColor - , io - ) where - -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Misc - -import Text.ParserCombinators.Parsec - -import Control.Monad.State -import Control.Monad.Reader -import Control.Concurrent -import System.Environment - -import System.Process -import System.Exit -import System.IO (hClose, hGetLine) - --- $config --- Configuration data type and default configuration - --- | The configuration data type -data Config = - Config { fonts :: String -- ^ Fonts - , bgColor :: String -- ^ Backgroud color - , fgColor :: String -- ^ Default font color - , xPos :: Int -- ^ x Window position (origin in the upper left corner) - , yPos :: Int -- ^ y Window position - , width :: Int -- ^ Window width - , hight :: Int -- ^ Window hight - , align :: String -- ^ text alignment - , refresh :: Int -- ^ Refresh rate in tenth of seconds - , commands :: [(String, Int, [String])] -- ^ For setting the refresh rate and - -- options for the programs to run (optionals) - , sepChar :: String -- ^ The character to be used for indicating - -- commands in the output template (default '%') - , template :: String -- ^ The output template - } deriving (Eq, Show, Read, Ord) - -defaultConfig :: Config -defaultConfig = - Config { fonts = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , bgColor = "#000000" - , fgColor = "#BFBFBF" - , xPos = 0 - , yPos = 0 - , width = 1024 - , hight = 15 - , align = "left" - , refresh = 10 - , commands = [("date", 10, [])] - , sepChar = "%" - , template = "Uptime: %uptime% ** %date%" - } - --- | 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 = - do args <- getArgs - config <- - if length args /= 1 - then do putStrLn ("No configuration file specified. Using default settings.") - return defaultConfig - else readConfig (args!!0) - cl <- parseTemplate config (template config) - var <- execCommands config cl - (d,w) <- createWin config - runXMobar config var d w eventLoop - --- | The event loop -eventLoop :: Xbar () -eventLoop = - do c <- ask - s <- get - i <- io $ readVariables (vars s) - ps <- io $ parseString c i - drawInWin ps - -- back again: we are never ending - io $ threadDelay $ 100000 * refresh c - eventLoop - --- | The function to create the initial window -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) - mapWindow dpy win - return (dpy,win) - - --- $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 :: GC - -> FontStruct - -> Position - -> [(String, String, Position)] - -> 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 - "center" -> (fromIntegral (width config) - fromIntegral totSLen) `div` 2 - "right" -> fromIntegral (width config) - fromIntegral totSLen - "left" -> offs - _ -> offs - 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 - --- | Gets the command options set in configuration. -getOptions :: Config -> String -> [String] -getOptions c com = - let l = commands c - p = filter (\(s,_,_) -> s == com) l - in case p of - [(_,_,opts)] -> opts - _ -> [] - --- | Gets the command options set in configuration. -getRefRate :: Config -> String -> Int -getRefRate c com = - let l = commands c - p = filter (\(s,_,_) -> s == com) l - in case p of - [(_,int,_)] -> int - _ -> refresh c - --- | Runs a list of programs -execCommands :: Config -> [(String,String,String)] -> IO [(ThreadId, MVar String)] -execCommands _ [] = return [] -execCommands c (x:xs) = - do i <- execCommand c x - is <- execCommands c xs - return $ i : is - -execCommand :: Config -> (String,String,String) -> IO (ThreadId, MVar String) -execCommand c com = - do var <- newMVar "Updating..." - h <- forkIO $ runCommandLoop var c com - return (h,var) - --- | Runs the external program -runCommandLoop :: MVar String -> Config -> (String,String,String) -> IO () -runCommandLoop var conf c@(s,com,ss) - | com == "" = - do modifyMVar_ var (\_ -> return $ "Could not parse the template") - threadDelay $ 100000 * refresh conf - runCommandLoop var conf c - | otherwise = - do (i,o,e,p) <- runInteractiveCommand (com ++ concat (map (' ':) $ getOptions conf com)) - -- the followinf leaks memory - --(i,o,e,p) <- runInteractiveProcess com (getOptions c com) Nothing Nothing - exit <- waitForProcess p - let closeHandles = do hClose o - hClose i - hClose e - case exit of - ExitSuccess -> do str <- hGetLine o - closeHandles - modifyMVar_ var (\_ -> return $ s ++ str ++ ss) - threadDelay $ 100000 * (getRefRate conf com) - runCommandLoop var conf c - _ -> do closeHandles - modifyMVar_ var $ \_ -> return $ "Could not execute command " ++ com - threadDelay $ 100000 * (getRefRate conf com) - runCommandLoop var conf c - - --- | Reads MVars set by 'runCommandLoop' -readVariables :: [(ThreadId, MVar String)] -> IO String -readVariables [] = return "" -readVariables ((_,v):xs) = - do f <- readMVar v - fs <- readVariables xs - return $! f ++ fs - -{- $parser -These are the neede parsers. Don't trust them too much. - -There are parsers for the commands output and parsers for the -formatting template. - -} - --- | Runs the actual string parsers -parseString :: Config -> String -> IO [(String, String)] -parseString config s = - case (parse (stringParser config) "" s) of - Left _ -> return [("Could not parse string: " ++ s - , (fgColor config))] - Right x -> return x - --- | Gets the string and combines the needed parsers -stringParser :: Config -> Parser [(String, String)] -stringParser c = manyTill (colorsAndText c <|> defaultColors c) eof - --- | Parses a string with the default color (no color set) -defaultColors :: Config -> Parser (String, String) -defaultColors config = - do { s <- many $ noneOf "<" - ; return (s,(fgColor config)) - } - <|> colorsAndText config - --- | Parses a string with a color set -colorsAndText :: Config -> Parser (String, String) -colorsAndText config = - do { string "" - ; s <- many $ noneOf "<" - ; string "" - ; return (s,"#"++n) - } - <|> defaultColors config - --- | Parses the output template string -templateStringParser :: Config -> Parser (String,String,String) -templateStringParser c = - do{ s <- many $ noneOf (sepChar c) - ; (_,com,_) <- templateCommandParser c - ; ss <- many $ noneOf (sepChar c) - ; return (s, com, ss) - } - --- | Parses the command part of the template string -templateCommandParser :: Config -> Parser (String,String,String) -templateCommandParser c = - do { let chr = head $ sepChar c - ; char chr - ; com <- many $ noneOf (sepChar c) - ; char chr - ; return $ ("",com,"") - } --- | Combines the template parsers -templateParser :: Config -> Parser [(String,String,String)] -templateParser c = many (templateStringParser c) - --- | Actually runs the template parsers -parseTemplate :: Config -> String -> IO [(String,String,String)] -parseTemplate config s = - case (parse (templateParser config) "" s) of - Left _ -> return [("","","")] - Right x -> return x - -{- $unmanwin - -This is a way to create unmamaged window. It was a mistery in Haskell. -Till I've found out...;-) - --} - --- | Creates a window with the attribute override_redirect set to True. --- Windows Managers should not touch this kind of windows. -mkUnmanagedWindow :: Display - -> Screen - -> Window - -> Position - -> Position - -> Dimension - -> Dimension - -> IO Window -mkUnmanagedWindow dpy scr rw x y w h = 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 -Utilities, aka stollen without givin' credit stuff. --} - --- | Reads the configuration files or quits with an error -readConfig :: FilePath -> IO Config -readConfig f = - do s <- readFile f - case reads s of - [(config,_)] -> return config - [] -> error ("Corrupt config file: " ++ f) - _ -> error ("Some problem occured. Aborting...") - - --- | 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) - --- | Short-hand for lifting in the IO monad -io :: IO a -> Xbar a -io = liftIO -- cgit v1.2.3