From cfd729999901c39f6e0aac1c271d56ae6e704d3e Mon Sep 17 00:00:00 2001
From: Edward O'Callaghan <victoredwardocallaghan@gmail.com>
Date: Mon, 21 Jan 2013 06:19:26 +1100
Subject: XBM icon support

<icon=/path/to/icon>
---
 src/XUtil.hsc | 42 +++++++++++++++++++++++++++++++++++++++---
 1 file changed, 39 insertions(+), 3 deletions(-)

(limited to 'src/XUtil.hsc')

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' ->
-- 
cgit v1.2.3