add XFT support and make UTF-8 support configurable

This patch includes many changes:
- moved font and printing functions to XUtil.hs and created an
  abstraction layer to font management;
- ported the core, StdinReader and PipeReader to the new font
  management system.

To enable UTF-8 support configure with the "with_utf8" flag (requires
utf8-string):
runhaskell Setup.lhs configure --flags

darcs-hash:20080316121100-d6583-828134da356b706744b56a9d81203129b0e8e484.gz

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 ()
diff --git a/Main.hs b/Main.hs
index 34440cd..9ac16d4 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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
diff --git a/Plugins.hs b/Plugins.hs
index 17aa0f6..d6952b4 100644
--- a/Plugins.hs
+++ b/Plugins.hs
@@ -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
diff --git a/Xmobar.hs b/Xmobar.hs
index 014e22e..628036b 100644
--- a/Xmobar.hs
+++ b/Xmobar.hs
@@ -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