From 1d8a1955dd719846e51596b573ee5a6e2bcbcf5a Mon Sep 17 00:00:00 2001
From: Alexander Shabalin <shabalyn.a@gmail.com>
Date: Tue, 2 Sep 2014 21:15:00 +0400
Subject: Add .xpm support for <icon> via libXpm.

* Adds a new flag with_xpm to enable compilation with xpm support
* Adds a module XPMFile only exporting readXPMFile which almost mirrors
  Graphics.X11.Xlib.Misc.readBitmapFile
* During loadBitmap a file is first tried with readBitmapFile and if it
  fails with readXPMFile
---
 src/XPMFile.hsc | 44 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 44 insertions(+)
 create mode 100644 src/XPMFile.hsc

(limited to 'src/XPMFile.hsc')

diff --git a/src/XPMFile.hsc b/src/XPMFile.hsc
new file mode 100644
index 0000000..2284e4a
--- /dev/null
+++ b/src/XPMFile.hsc
@@ -0,0 +1,44 @@
+{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-}
+module XPMFile(readXPMFile) where
+
+import Control.Monad.Except(MonadError(..))
+import Control.Monad.Trans(MonadIO(..))
+import Graphics.X11.Xlib(Dimension, Display(..), Drawable, Pixmap)
+import Foreign.C.String(CString, withCString)
+import Foreign.C.Types(CInt(..), CLong)
+import Foreign.Ptr(Ptr)
+import Foreign.Marshal.Alloc(alloca, allocaBytes)
+import Foreign.Storable(peek, peekByteOff, pokeByteOff)
+
+#include <X11/xpm.h>
+
+foreign import ccall "XpmReadFileToPixmap"
+    xpmReadFileToPixmap :: Display -> Drawable -> CString -> Ptr Pixmap -> Ptr Pixmap -> Ptr () -> IO CInt
+
+readXPMFile
+    :: (MonadError String m, MonadIO m)
+    => Display
+    -> Drawable
+    -> String
+    -> m (Dimension, Dimension, Pixmap, Maybe Pixmap)
+readXPMFile display d filename =
+    toError $ withCString filename $ \c_filename ->
+    alloca $ \pixmap_return ->
+    alloca $ \shapemask_return ->
+    allocaBytes (#size XpmAttributes) $ \attributes -> do
+        (#poke XpmAttributes, valuemask) attributes ((#const XpmReturnAllocPixels) :: CLong)
+        res <- xpmReadFileToPixmap display d c_filename pixmap_return shapemask_return attributes
+        case res of
+             0 -> do
+                 width <- (#peek XpmAttributes, width) attributes
+                 height <- (#peek XpmAttributes, height) attributes
+                 pixmap <- peek pixmap_return
+                 shapemask <- peek shapemask_return
+                 return $ Right (width, height, pixmap, if shapemask == 0 then Nothing else Just shapemask)
+             1 -> return $ Left "readXPMFile: XpmColorError"
+             -1 -> return $ Left "readXPMFile: XpmOpenFailed"
+             -2 -> return $ Left "readXPMFile: XpmFileInvalid"
+             -3 -> return $ Left "readXPMFile: XpmNoMemory"
+             -4 -> return $ Left "readXPMFile: XpmColorFailed"
+             _ -> return $ Left "readXPMFile: Unknown error"
+    where toError m = either throwError return =<< liftIO m
-- 
cgit v1.2.3