XBM icon support

<icon=/path/to/icon>

5 files changed, 122 insertions, 17 deletions

diff --git a/src/Parsers.hs b/src/Parsers.hs
index c658be6..4703733 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -17,9 +17,11 @@ module Parsers
     ( parseString
     , parseTemplate
     , parseConfig
+    , Widget(..)
     ) where
 
 import Config
+import Types
 import Runnable
 import Commands
 
@@ -27,24 +29,28 @@ import qualified Data.Map as Map
 import Text.ParserCombinators.Parsec
 import Text.ParserCombinators.Parsec.Perm
 
+type ColorString = String
+
 -- | Runs the string parser
-parseString :: Config -> String -> IO [(String, String)]
+parseString :: Config -> String -> IO [(Widget, ColorString)]
 parseString c s =
     case parse (stringParser (fgColor c)) "" s of
-      Left  _ -> return [("Could not parse string: " ++ s, fgColor c)]
+      Left  _ -> return [(Text $ "Could not parse string: " ++ s, fgColor c)]
       Right x -> return (concat x)
 
 -- | Gets the string and combines the needed parsers
-stringParser :: String -> Parser [[(String, String)]]
-stringParser c = manyTill (textParser c <|> colorParser) eof
+stringParser :: String -> Parser [[(Widget, ColorString)]]
+stringParser c = manyTill (textParser c <|> try (iconParser c) <|> colorParser) eof
 
 -- | Parses a maximal string without color markup.
-textParser :: String -> Parser [(String, String)]
+textParser :: String -> Parser [(Widget, ColorString)]
 textParser c = do s <- many1 $
                     noneOf "<" <|>
-                    ( try $ notFollowedBy' (char '<')
-                                           (string "fc=" <|> string "/fc>" ) )
-                  return [(s, c)]
+                    (try $ notFollowedBy' (char '<')
+                                          (string "fc="  <|>
+                                          string "icon=" <|> string "/fc>"))
+                  return [(Text s, c)]
+
 
 -- | Wrapper for notFollowedBy that returns the result of the first parser.
 --   Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy
@@ -54,11 +60,19 @@ notFollowedBy' p e = do x <- p
                         notFollowedBy $ try (e >> return '*')
                         return x
 
+icon :: Parser String
+icon = many1 $ noneOf ">"
+
+iconParser :: String -> Parser [(Widget, ColorString)]
+iconParser c = do
+  i <- between (string "<icon=") (string ">") icon
+  return [(Icon i, c)]
+  
 -- | Parsers a string wrapped in a color specification.
-colorParser :: Parser [(String, String)]
+colorParser :: Parser [(Widget, ColorString)]
 colorParser = do
   c <- between (string "<fc=") (string ">") colors
-  s <- manyTill (textParser c <|> colorParser) (try $ string "</fc>")
+  s <- manyTill (try (textParser c <|> iconParser c) <|> colorParser) (try $ string "</fc>")
   return (concat s)
 
 -- | Parses a color specification (hex or named)
diff --git a/src/Types.hs b/src/Types.hs
new file mode 100644
index 0000000..3fcc6de
--- /dev/null
+++ b/src/Types.hs
@@ -0,0 +1,3 @@
+module Types where
+
+data Widget = Text String | Icon String
diff --git a/src/XGraphic.hs b/src/XGraphic.hs
new file mode 100644
index 0000000..9343580
--- /dev/null
+++ b/src/XGraphic.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XGraphic
+-- Copyright   :  Copyright © 2013 Edward O'Callaghan. All Rights Reserved.
+-- License     :  BSD3
+--
+-- Maintainer  :  Edward O'Callaghan - <victoredwardocallaghan@gmail.com>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-----------------------------------------------------------------------------
+
+module XGraphic
+    ( readBitmapFile
+    ) where
+
+import Graphics.X11.Xlib
+--import Graphics.X11.Xlib.Misc
+import Foreign
+import Foreign.C
+
+-- | interface to the X11 library function @XWriteBitmapFile@.
+readBitmapFile :: Display -> Drawable -> String
+                  -> IO (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt)
+readBitmapFile display d filename =
+  withCString filename $ \ c_filename ->
+  alloca $ \ width_return ->
+  alloca $ \ height_return ->
+  alloca $ \ bitmap_return ->
+  alloca $ \ x_hot_return ->
+  alloca $ \ y_hot_return -> do
+    _ <- xReadBitmapFile display d c_filename width_return height_return
+         bitmap_return x_hot_return y_hot_return
+    width <- peek width_return
+    height <- peek height_return
+    bitmap <- peek bitmap_return
+    x_hot <- peek x_hot_return
+    y_hot <- peek y_hot_return
+    let m_x_hot | x_hot == -1 = Nothing
+                | otherwise  = Just x_hot
+        m_y_hot | y_hot == -1 = Nothing
+                | otherwise  = Just y_hot
+    return (fromIntegral width, fromIntegral height, bitmap, m_x_hot, m_y_hot)
+foreign import ccall unsafe "X11/Xlib.h XReadBitmapFile"
+  xReadBitmapFile :: Display -> Drawable -> CString -> Ptr CInt -> Ptr CInt
+                     -> Ptr Pixmap -> Ptr CInt -> Ptr CInt -> IO CInt
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index 21dcf3e..f0a4b2d 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -33,12 +33,17 @@ import Control.Monad.Trans
 import Control.Exception (SomeException, handle)
 import Foreign
 -- import Foreign.C.Types
+import Data.Foldable (forM_)
 import Graphics.X11.Xlib hiding (textExtents, textWidth)
 import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)
 import Graphics.X11.Xlib.Extras
 import System.Mem.Weak ( addFinalizer )
 import System.Posix.Types (Fd(..))
+import System.Directory (doesFileExist)
 import System.IO
+import XGraphic
+import Types
+
 #if defined XFT || defined UTF8
 # if __GLASGOW_HASKELL__ < 612
 import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)
@@ -68,6 +73,11 @@ hGetLineSafe = UTF8.hGetLine
 hGetLineSafe = hGetLine
 #endif
 
+data Bitmap = Bitmap { width  :: Dimension
+                     , height :: Dimension
+                     , pixmap :: Pixmap
+                     }
+
 -- Hide the Core Font/Xft switching here
 data XFont = Core FontStruct
            | Utf8 FontSet
@@ -151,23 +161,49 @@ textExtents (Xft xftfont) _ = do
   return (ascent, descent)
 #endif
 
+loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap)
+loadBitmap d w p = do
+     exist <- doesFileExist p
+     if exist
+	then do
+	   (bw, bh, bp, _, _) <- readBitmapFile d w p
+	   return $ Just $ Bitmap bw bh bp
+	else
+	   return Nothing
+
+drawBitmap :: Display -> Drawable -> XFont -> GC -> String -> String
+            -> Position -> Position -> Bitmap -> IO ()
+drawBitmap d p _ gc fc bc x y i = do
+    withColors d [fc, bc] $ \[fc', bc'] -> do
+        setForeground d gc fc'
+        setBackground d gc bc'
+        io $ copyPlane d (pixmap i) p gc 0 0 (width i) (height i) x (y - (fi $ height i)) 1
+
 printString :: Display -> Drawable -> XFont -> GC -> String -> String
+            -> Position -> Position -> Widget -> IO ()
+printString d p fs gc fc bc x y w = do
+    case w of 
+        (Text s) -> printString' d p fs gc fc bc x y s
+        (Icon i) -> do bitmap <- loadBitmap d p i
+                       forM_ bitmap $ drawBitmap d p fs gc fc bc x y
+
+printString' :: Display -> Drawable -> XFont -> GC -> String -> String
             -> Position -> Position -> String  -> IO ()
-printString d p (Core fs) gc fc bc x y s = do
+printString' d p (Core fs) gc fc bc x y s = do
     setFont d gc $ fontFromFontStruct fs
     withColors d [fc, bc] $ \[fc', bc'] -> do
       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 =
+printString' d p (Utf8 fs) gc fc bc x y s =
     withColors d [fc, bc] $ \[fc', bc'] -> do
       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) _ fc bc x y s = do
+printString' dpy drw fs@(Xft font) _ fc bc x y s = do
   (a,d)  <- textExtents fs s
   gi <- xftTxtExtents dpy font s
   withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 5fc0cd4..7730620 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -231,12 +231,15 @@ updateWin v = do
 -- $print
 
 -- | Draws in and updates the window
-drawInWin :: Rectangle -> [[(String, String)]] -> X ()
+drawInWin :: Rectangle -> [[(Widget, String)]] -> X ()
 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))
+      strLn  = io . mapM getWidth
+      getWidth (Text s,cl) = textWidth d fs s >>= \tw -> return (Text s,cl,fi tw)
+      getWidth (Icon s,cl) = return (Icon s,cl,fi ht)
+
   withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do
     gc <- io $ createGC  d w
     -- create a pixmap to write to and fill it with a rectangle
@@ -261,11 +264,13 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
 
 -- | An easy way to print the stuff we need to print
 printStrings :: Drawable -> GC -> XFont -> Position
-             -> Align -> [(String, String, Position)] -> X ()
+             -> Align -> [(Widget, 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 fromWidget (Text t) = t
+      fromWidget (Icon t) = t
+  (as,ds) <- io $ textExtents fontst (fromWidget s)
   let (conf,d)             = (config &&& display) r
       Rectangle _ _ wid ht = rect r
       totSLen              = foldr (\(_,_,len) -> (+) len) 0 sl