diff options
| -rw-r--r-- | HsLocale.hsc | 27 | ||||
| -rw-r--r-- | Main.hs | 24 | ||||
| -rw-r--r-- | Plugins.hs | 5 | ||||
| -rw-r--r-- | Plugins/PipeReader.hs | 3 | ||||
| -rw-r--r-- | Plugins/StdinReader.hs | 3 | ||||
| -rw-r--r-- | XUtil.hsc | 234 | ||||
| -rw-r--r-- | Xmobar.hs | 109 | ||||
| -rw-r--r-- | xmobar.cabal | 21 |
8 files changed, 289 insertions, 137 deletions
diff --git a/HsLocale.hsc b/HsLocale.hsc deleted file mode 100644 index a54ff34..0000000 --- a/HsLocale.hsc +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ------------------------------------------------------------------------------ --- | --- Module : HsLocale --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module HsLocale - ( setupLocale - ) where - -import Foreign.C - -#include <locale.h> -foreign import ccall unsafe "locale.h setlocale" - setlocale :: CInt -> CString -> IO CString - -setupLocale :: IO () -setupLocale = withCString "" $ \s -> do - setlocale (#const LC_ALL) s - return () @@ -22,16 +22,14 @@ module Main ( -- * Main Stuff import Xmobar import Parsers import Config -import HsLocale +import XUtil -import Prelude hiding (readFile) +import Prelude import Data.IORef import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras import System.Console.GetOpt import System.Exit import System.Environment -import System.IO.UTF8 (readFile) import System.Posix.Files -- $main @@ -40,7 +38,6 @@ import System.Posix.Files main :: IO () main = do d <- openDisplay "" - setupLocale args <- getArgs (o,file) <- getOpts args c <- case file of @@ -51,22 +48,21 @@ main = do rootw <- rootWindow d (defaultScreen d) selectInput d rootw structureNotifyMask - civ <- newIORef c + civ <- newIORef c doOpts civ o - conf <- readIORef civ - let loadFont = createFontSet d . font - (_,_,fs) <- catch (loadFont conf) (const $ loadFont defaultConfig) - cl <- parseTemplate conf (template conf) - vars <- mapM startCommand cl - (r,w) <- createWin d fs conf + conf <- readIORef civ + fs <- initFont d (font conf) + cl <- parseTemplate conf (template conf) + vars <- mapM startCommand cl + (r,w) <- createWin d fs conf eventLoop (XConf d r w fs conf) vars - freeFontSet d fs + releaseFont d fs -- | Reads the configuration files or quits with an error readConfig :: FilePath -> IO Config readConfig f = do file <- fileExist f - s <- if file then readFile f else error $ f ++ ": file not found!\n" ++ usage + s <- if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage case reads s of [(conf,_)] -> return conf [] -> error $ f ++ ": configuration file contains errors!\n" ++ usage @@ -16,6 +16,9 @@ module Plugins ( Exec (..) , tenthSeconds + , readFileSafe + , hGetLineSafe ) where -import Commands
\ No newline at end of file +import Commands +import XUtil diff --git a/Plugins/PipeReader.hs b/Plugins/PipeReader.hs index 6c84f71..a0709b1 100644 --- a/Plugins/PipeReader.hs +++ b/Plugins/PipeReader.hs @@ -15,7 +15,6 @@ module Plugins.PipeReader where import System.IO -import qualified System.IO.UTF8 as U import Plugins data PipeReader = PipeReader String String @@ -25,5 +24,5 @@ instance Exec PipeReader where alias (PipeReader _ a) = a start (PipeReader p _) cb = do h <- openFile p ReadMode - forever (U.hGetLine h >>= cb) + forever (hGetLineSafe h >>= cb) where forever a = a >> forever a diff --git a/Plugins/StdinReader.hs b/Plugins/StdinReader.hs index 4283a96..a12b722 100644 --- a/Plugins/StdinReader.hs +++ b/Plugins/StdinReader.hs @@ -18,7 +18,6 @@ import Prelude hiding (catch) import System.Posix.Process import System.Exit import System.IO -import qualified System.IO.UTF8 as U import Control.Exception (catch) import Plugins @@ -27,7 +26,7 @@ data StdinReader = StdinReader instance Exec StdinReader where start StdinReader cb = do - cb =<< catch (U.hGetLine stdin) (\e -> do hPrint stderr e; return "") + cb =<< catch (hGetLineSafe stdin) (\e -> do hPrint stderr e; return "") eof <- hIsEOF stdin if eof then exitImmediately ExitSuccess diff --git a/XUtil.hsc b/XUtil.hsc new file mode 100644 index 0000000..0271f89 --- /dev/null +++ b/XUtil.hsc @@ -0,0 +1,234 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : XUtil +-- Copyright : (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module XUtil + ( XFont + , initFont + , initCoreFont + , initUtf8Font + , releaseFont + , textExtents + , textWidth + , printString + , initColor + , mkUnmanagedWindow + , nextEvent' + , readFileSafe + , hGetLineSafe + , io + , fi + ) where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans +import Foreign +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import System.Posix.Types (Fd(..)) +import System.IO +#if defined XFT || defined UTF8 +import Foreign.C +import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) +#endif +#if defined XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +readFileSafe :: FilePath -> IO String +#if defined XFT || defined UTF8 +readFileSafe = UTF8.readFile +#else +readFileSafe = readFile +#endif + +hGetLineSafe :: Handle -> IO String +#if defined XFT || defined UTF8 +hGetLineSafe = UTF8.hGetLine +#else +hGetLineSafe = hGetLine +#endif + +-- Hide the Core Font/Xft switching here +data XFont =Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend +-- Example: 'xft:Sans-10' +initFont :: Display ->String -> IO XFont +initFont d s = +#ifdef XFT + if xftPrefix `isPrefixOf` s then + do setupLocale + xftdraw <- xftFontOpen d (defaultScreenOfDisplay d) (drop (length xftPrefix) s) + return (Xft xftdraw) + else +#endif +#ifdef UTF8 + (setupLocale >> initUtf8Font d s >>= (return . Utf8)) +#else + (initCoreFont d s >>= (return . Core)) +#endif +#ifdef XFT + where xftPrefix = "xft:" +#endif + +releaseFont :: Display -> XFont -> IO () +#ifdef XFT +releaseFont d (Xft xftfont) = xftFontClose d xftfont +#endif +releaseFont d (Utf8 fs) = releaseUtf8Font d fs +releaseFont d (Core fs) = releaseCoreFont d fs + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: Display -> String -> IO FontStruct +initCoreFont dpy s = catch (getIt dpy) (fallBack dpy) + where getIt d = loadQueryFont d s + fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseCoreFont :: Display -> FontStruct -> IO () +releaseCoreFont d = freeFont d + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initUtf8Font :: Display -> String -> IO FontSet +initUtf8Font dpy s = do + (_,_,fs) <- catch (getIt dpy) (fallBack dpy) + return fs + where getIt d = createFontSet d s + fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseUtf8Font :: Display -> FontSet -> IO () +releaseUtf8Font d = freeFontSet d + +textWidth :: Display -> XFont -> String -> IO Int +textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s +#ifdef XFT +textWidth dpy (Xft xftdraw) s = do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtents :: XFont -> String -> IO (Int32,Int32) +textExtents (Core fs) s = do + let (_,a,d,_) = Xlib.textExtents fs s + return (a,d) +textExtents (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +#ifdef XFT +textExtents (Xft xftfont) _ = do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +printString :: Display -> Drawable -> XFont -> GC -> String -> String + -> Position -> Position -> String -> IO () +printString d p (Core fs) gc fc bc x y s = do + setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM (initColor d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s +printString d p (Utf8 fs) gc fc bc x y s = do + [fc',bc'] <- mapM (initColor d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s +#ifdef XFT +printString dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + bcolor <- initColor dpy bc + (a,d) <- textExtents fs s + gi <- xftTextExtents dpy font s + setForeground dpy gc bcolor + fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi a) + (fi $ xglyphinfo_xOff gi) + (fi $ a + d) + withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x y s +#endif + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +initColor :: Display -> String -> IO Pixel +initColor dpy c = + catch (initColor' dpy c) (const . return . blackPixel dpy $ (defaultScreen dpy)) + +initColor' :: Display -> String -> IO Pixel +initColor' dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c + where colormap = defaultColormap dpy (defaultScreen dpy) + +-- | 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 + -> Bool + -> IO Window +mkUnmanagedWindow dpy scr rw x y w h o = do + let visual = defaultVisualOfScreen scr + attrmask = cWOverrideRedirect + allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes o + createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) + inputOutput visual attrmask attributes +-- | A version of nextEvent that does not block in foreign calls. +nextEvent' :: Display -> XEventPtr -> IO () +nextEvent' d p = do + pend <- pending d + if pend /= 0 + then nextEvent d p + else do + threadWaitRead (Fd fd) + nextEvent' d p + where + fd = connectionNumber d + +io :: MonadIO m => IO a -> m a +io = liftIO + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +#if defined XFT || defined UTF8 +#include <locale.h> +foreign import ccall unsafe "locale.h setlocale" + setlocale :: CInt -> CString -> IO CString + +setupLocale :: IO () +setupLocale = withCString "" $ \s -> do + setlocale (#const LC_ALL) s + return () +#endif @@ -29,12 +29,10 @@ module Xmobar (-- * Main Stuff -- * Unmamaged Windows -- $unmanwin , mkUnmanagedWindow - -- * Useful Utilities - , initColor, io, nextEvent', fi ) where import Prelude hiding (catch) -import Graphics.X11.Xlib +import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama @@ -45,12 +43,13 @@ import Control.Concurrent.STM import Control.Exception hiding (handle) import Data.Bits import Data.Char -import System.Posix.Types (Fd(..)) + import Config import Parsers import Commands import Runnable +import XUtil -- $main -- @@ -64,7 +63,7 @@ data XConf = XConf { display :: Display , rect :: Rectangle , window :: Window - , fontS :: FontSet + , fontS :: XFont , config :: Config } @@ -128,13 +127,13 @@ startCommand (com,s,ss) -- $window -- | The function to create the initial window -createWin :: Display -> FontSet -> Config -> IO (Rectangle,Window) +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) createWin d fs c = do let dflt = defaultScreen d - r:_ <- getScreenInfo d - rootw <- rootWindow d dflt - let (_,rl) = wcTextExtents fs "0" - ht = rect_height rl + 4 + r:_ <- getScreenInfo d + rootw <- rootWindow d dflt + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 (x,y,w,h,o) = setPosition (position c) r (fi ht) win <- mkUnmanagedWindow d (defaultScreenOfDisplay d) rootw x y w h o selectInput d win (exposureMask .|. structureNotifyMask) @@ -207,6 +206,7 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask let (c,d ) = (config &&& display) r (w,fs) = (window &&& fontS ) r + strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw)) bgcolor <- io $ initColor d $ bgColor c gc <- io $ createGC d w --let's get the fonts @@ -218,10 +218,9 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do io $ setForeground d gc bgcolor io $ fillRectangle d p gc 0 0 wid ht -- write to the pixmap the new string - let strWithLenth = map (\(s,cl) -> (s,cl,wcTextEscapement fs s)) - printStrings p gc fs 1 L $ strWithLenth left - printStrings p gc fs 1 R $ strWithLenth right - printStrings p gc fs 1 C $ strWithLenth center + printStrings p gc fs 1 L =<< strLn left + printStrings p gc fs 1 R =<< strLn right + printStrings p gc fs 1 C =<< strLn center -- copy the pixmap with the new string to the window io $ copyArea d p w gc 0 0 wid ht 0 0 -- free up everything (we do not want to leak memory!) @@ -231,91 +230,23 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do io $ sync d True -- | An easy way to print the stuff we need to print -printStrings :: Drawable -> GC -> FontSet -> Position +printStrings :: Drawable -> GC -> XFont -> Position -> Align -> [(String, String, Position)] -> X () printStrings _ _ _ _ _ [] = return () printStrings dr gc fontst offs a sl@((s,c,l):xs) = do r <- ask + (as,ds) <- io $ textExtents fontst s let (conf,d) = (config &&& display) r Rectangle _ _ wid _ = rect r - (_,rl) = wcTextExtents fontst s totSLen = foldr (\(_,_,len) -> (+) len) 0 sl - valign = fi $ rect_height rl + valign = fi $ as + ds remWidth = fi wid - fi totSLen offset = case a of C -> (remWidth + offs) `div` 2 R -> remWidth - 1 L -> offs - (fc,bc) <- case (break (==',') c) of - (f,',':b) -> do - fgc <- io $ initColor d f - bgc <- io $ initColor d b - return (fgc,bgc) - (f,_) -> do - fgc <- io $ initColor d f - bgc <- io $ initColor d (bgColor conf) - return (fgc,bgc) - io $ setForeground d gc fc - io $ setBackground d gc bc - io $ wcDrawImageString d dr fontst gc offset valign s + (fc,bc) = case (break (==',') c) of + (f,',':b) -> (f, b ) + (f, _) -> (f, bgColor conf) + io $ printString d dr fontst gc fc bc offset valign s printStrings dr gc fontst (offs + l) a xs - -{- $unmanwin - -This is a way to create unmamaged window. - --} - --- | 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 - -> Bool - -> IO Window -mkUnmanagedWindow dpy scr rw x y w h o = do - let visual = defaultVisualOfScreen scr - attrmask = cWOverrideRedirect - allocaSetWindowAttributes $ - \attributes -> do - set_override_redirect attributes o - createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) - inputOutput visual attrmask attributes - -{- $utility -Utilities --} - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -initColor :: Display -> String -> IO Pixel -initColor dpy c = - catch (initColor' dpy c) (const . return . blackPixel dpy $ (defaultScreen dpy)) - -initColor' :: Display -> String -> IO Pixel -initColor' dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c - where colormap = defaultColormap dpy (defaultScreen dpy) - --- | A version of nextEvent that does not block in foreign calls. -nextEvent' :: Display -> XEventPtr -> IO () -nextEvent' d p = do - pend <- pending d - if pend /= 0 - then nextEvent d p - else do - threadWaitRead (Fd fd) - nextEvent' d p - where - fd = connectionNumber d - --- | Short-hand for lifting in the IO monad -io :: IO a -> X a -io = liftIO - --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral diff --git a/xmobar.cabal b/xmobar.cabal index 7bb54b5..6651a63 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -13,12 +13,20 @@ license-file: LICENSE author: Andrea Rossato maintainer: andrea.rossato@unibz.it cabal-version: >= 1.2 +build-type: Simple + flag small_base description: Choose the new smaller, split-up base package. +flag use_xft + description: Use Xft to render text. UTF-8 support included. + +flag with_utf8 + description: With UTF-8 support. + executable xmobar main-is: Main.hs - other-Modules: Xmobar, Config, Parsers, Commands, HsLocale, Runnable, Plugins + other-Modules: Xmobar, Config, Parsers, Commands, XUtil, Runnable, Plugins ghc-options: -funbox-strict-fields -Wall -optl-Wl,-s -threaded ghc-prof-options: -prof -auto-all if flag(small_base) @@ -26,4 +34,13 @@ executable xmobar else build-depends: base < 3 - build-depends: X11>=1.3.0, mtl, unix, parsec, filepath, stm, utf8-string + + if flag(use_xft) + build-depends: utf8-string, X11-xft >= 0.2 + cpp-options: -DXFT + + if flag(with_utf8) + build-depends: utf8-string + cpp-options: -DUTF8 + + build-depends: X11>=1.3.0, mtl, unix, parsec, filepath, stm |