add utf8 support to the core system

darcs-hash:20080216080151-d6583-367d1e30dba8744259e35db87d3edae8dcc27950.gz

2 files changed, 39 insertions, 33 deletions

diff --git a/Main.hs b/Main.hs
index b661436..34440cd 100644
--- a/Main.hs
+++ b/Main.hs
@@ -3,12 +3,12 @@
 -- Module      :  Xmobar.Main
 -- Copyright   :  (c) Andrea Rossato
 -- License     :  BSD-style (see LICENSE)
--- 
+--
 -- Maintainer  :  Andrea Rossato <andrea.rossato@unibz.it>
 -- Stability   :  unstable
 -- Portability :  unportable
 --
--- The main module of Xmobar, a text based status bar 
+-- The main module of Xmobar, a text based status bar
 --
 -----------------------------------------------------------------------------
 
@@ -22,20 +22,25 @@ module Main ( -- * Main Stuff
 import Xmobar
 import Parsers
 import Config
+import HsLocale
 
+import Prelude hiding (readFile)
 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
- 
+
 -- | The main entry point
 main :: IO ()
 main = do
   d   <- openDisplay ""
+  setupLocale
   args     <- getArgs
   (o,file) <- getOpts args
   c        <- case file of
@@ -49,13 +54,13 @@ main = do
   civ      <- newIORef c
   doOpts civ o
   conf     <- readIORef civ
-  let loadFont = loadQueryFont d . font
-  fs       <- catch (loadFont conf) (const $ loadFont defaultConfig)
+  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
   eventLoop (XConf d r w fs conf) vars
-  freeFont d fs
+  freeFontSet d fs
 
 -- | Reads the configuration files or quits with an error
 readConfig :: FilePath -> IO Config
@@ -76,7 +81,7 @@ readDefaultConfig = do
   if f then readConfig path else return defaultConfig
 
 data Opts = Help
-          | Version 
+          | Version
           | Font     String
           | BgColor  String
           | FgColor  String
@@ -85,9 +90,9 @@ data Opts = Help
           | AlignSep String
           | Commands String
           | SepChar  String
-          | Template String 
+          | Template String
        deriving Show
-    
+
 options :: [OptDescr Opts]
 options =
     [ Option ['h','?' ] ["help"     ] (NoArg  Help                ) "This help"
@@ -104,7 +109,7 @@ options =
     ]
 
 getOpts :: [String] -> IO ([Opts], [String])
-getOpts argv = 
+getOpts argv =
     case getOpt Permute options argv of
       (o,n,[])   -> return (o,n)
       (_,_,errs) -> error (concat errs ++ usage)
@@ -141,7 +146,7 @@ doOpts conf (o:oo) =
       SepChar  s -> modifyIORef conf (\c -> c { sepChar  = s     }) >> go
       Template s -> modifyIORef conf (\c -> c { template = s     }) >> go
       Commands s -> case readCom s of
-                      Right x -> modifyIORef conf (\c -> c { commands = x }) >> go 
+                      Right x -> modifyIORef conf (\c -> c { commands = x }) >> go
                       Left e  -> putStr (e ++ usage) >> exitWith (ExitFailure 1)
     where readCom str =
               case readStr str of
diff --git a/Xmobar.hs b/Xmobar.hs
index 4ee8772..16cc85e 100644
--- a/Xmobar.hs
+++ b/Xmobar.hs
@@ -4,12 +4,12 @@
 -- Module      :  Xmobar
 -- Copyright   :  (c) Andrea Rossato
 -- License     :  BSD-style (see LICENSE)
--- 
+--
 -- Maintainer  :  Andrea Rossato <andrea.rossato@unibz.it>
 -- Stability   :  unstable
 -- Portability :  unportable
 --
--- A status bar for the Xmonad Window Manager 
+-- A status bar for the Xmonad Window Manager
 --
 -----------------------------------------------------------------------------
 
@@ -44,6 +44,7 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception hiding (handle)
 import Data.Bits
+import Data.Char
 import System.Posix.Types (Fd(..))
 
 import Config
@@ -63,7 +64,7 @@ data XConf =
     XConf { display :: Display
           , rect    :: Rectangle
           , window  :: Window
-          , fontS   :: FontStruct
+          , fontS   :: FontSet
           , config  :: Config
           }
 
@@ -75,9 +76,9 @@ runX xc f = runReaderT f xc
 eventLoop :: XConf -> [(Maybe ThreadId, TVar String)] -> IO ()
 eventLoop xc@(XConf d _ w fs c) v = block $ do
     tv <- atomically $ newTVar []
-    t <- myThreadId
+    t  <- myThreadId
     ct <- forkIO (checker t tv "" `catch` \_ -> return ())
-    go tv ct   
+    go tv ct
  where
     -- interrupt the drawing thread every time a var is updated
     checker t tvar ov = do
@@ -127,13 +128,13 @@ startCommand (com,s,ss)
 -- $window
 
 -- | The function to create the initial window
-createWin :: Display -> FontStruct -> Config -> IO (Rectangle,Window)
+createWin :: Display -> FontSet -> Config -> IO (Rectangle,Window)
 createWin d fs c = do
   let dflt = defaultScreen d
   r:_   <- getScreenInfo d
   rootw <- rootWindow d dflt
-  let (_,as,ds,_) = textExtents fs []
-      ht          = as + ds + 2
+  let (_,rl)      = wcTextExtents fs "Tg"
+      ht          = rect_height rl + 2
       (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)
@@ -145,7 +146,7 @@ setPosition :: XPosition -> Rectangle -> Dimension -> (Position,Position,Dimensi
 setPosition p (Rectangle rx ry rw rh) ht =
     case p of
     Top                -> (rx      , ry    , rw   , h    , True)
-    TopW L i           -> (rx      , ry    , nw i , h    , True) 
+    TopW L i           -> (rx      , ry    , nw i , h    , True)
     TopW R i           -> (right  i, ry    , nw i , h    , True)
     TopW C i           -> (center i, ry    , nw i , h    , True)
     Bottom             -> (rx      , ny    , rw   , h    , True)
@@ -185,8 +186,8 @@ updateWin :: TVar String -> X ()
 updateWin v = do
   xc <- ask
   let (conf,rec) = (config &&& rect) xc
-      [lc,rc]    = if length (alignSep conf) == 2 
-                   then alignSep conf 
+      [lc,rc]    = if length (alignSep conf) == 2
+                   then alignSep conf
                    else alignSep defaultConfig
   i <- io $ atomically $ readTVar v
   let def     = [i,[],[]]
@@ -209,7 +210,7 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
   bgcolor <- io $ initColor d $ bgColor c
   gc      <- io $ createGC  d w
   --let's get the fonts
-  io $ setFont d gc (fontFromFontStruct fs)
+--  io $ setFont d gc (fontFromFontStruct fs)
   -- create a pixmap to write to and fill it with a rectangle
   p <- io $ createPixmap d w wid ht
             (defaultDepthOfScreen (defaultScreenOfDisplay d))
@@ -217,7 +218,7 @@ 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,textWidth fs s))
+  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
@@ -230,16 +231,16 @@ 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 -> FontStruct -> Position
+printStrings :: Drawable -> GC -> FontSet -> Position
              -> Align -> [(String, String, Position)] -> X ()
 printStrings _ _ _ _ _ [] = return ()
 printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
   r <- ask
   let (conf,d)             = (config &&& display) r
       Rectangle _ _ wid ht = rect r
-      (_,as,ds,_)          = textExtents fontst s
+      (_,rl) = wcTextExtents fontst s
       totSLen              = foldr (\(_,_,len) -> (+) len) 0 sl
-      valign               = (fi ht + fi as - fi ds) `div` 2
+      valign               = (fi ht + fi (rect_height rl)) `div` 2
       remWidth             = fi wid - fi totSLen
       offset               = case a of
                                C -> (remWidth + offs) `div` 2
@@ -249,14 +250,14 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
                (f,',':b) -> do
                  fgc <- io $ initColor d f
                  bgc <- io $ initColor d b
-                 return (fgc,bgc) 
+                 return (fgc,bgc)
                (f,_) -> do
                  fgc <- io $ initColor d f
                  bgc <- io $ initColor d (bgColor conf)
-                 return (fgc,bgc) 
+                 return (fgc,bgc)
   io $ setForeground d gc fc
   io $ setBackground d gc bc
-  io $ drawImageString d dr gc offset valign s
+  io $ wcDrawImageString d dr fontst gc offset valign s
   printStrings dr gc fontst (offs + l) a xs
 
 {- $unmanwin
@@ -279,11 +280,11 @@ mkUnmanagedWindow :: Display
 mkUnmanagedWindow dpy scr rw x y w h o = do
   let visual   = defaultVisualOfScreen scr
       attrmask = cWOverrideRedirect
-  allocaSetWindowAttributes $ 
+  allocaSetWindowAttributes $
          \attributes -> do
            set_override_redirect attributes o
-           createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) 
-                        inputOutput visual attrmask attributes                                
+           createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
+                        inputOutput visual attrmask attributes
 
 {- $utility
 Utilities