Merge branch 'xpm' of https://github.com/projedi/xmobar

2 files changed, 108 insertions, 6 deletions

diff --git a/src/Bitmap.hs b/src/Bitmap.hs
index 3673b7a..ff79262 100644
--- a/src/Bitmap.hs
+++ b/src/Bitmap.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Bitmap
@@ -15,7 +16,10 @@ module Bitmap
  , drawBitmap
  , Bitmap(..)) where
 
+import Control.Applicative((<|>))
 import Control.Monad
+import Control.Monad.Except(MonadError(..), runExceptT)
+import Control.Monad.Trans(MonadIO(..))
 import Data.Map hiding (foldr, map, filter)
 import Graphics.X11.Xlib
 import System.Directory (doesFileExist)
@@ -24,9 +28,17 @@ import ColorCache
 import Parsers (Widget(..))
 import Actions (Action)
 
+#ifdef XPM
+import XPMFile(readXPMFile)
+#endif
+
+data BitmapType = Mono Pixel | Poly
+
 data Bitmap = Bitmap { width  :: Dimension
                      , height :: Dimension
                      , pixmap :: Pixmap
+                     , shapePixmap :: Maybe Pixmap
+                     , bitmapType :: BitmapType
                      }
 
 updateCache :: Display -> Window -> Map FilePath Bitmap ->
@@ -41,21 +53,48 @@ updateCache dpy win cache ps = do
                              return $ maybe m (\b -> insert path b m) bitmap
   foldM go cache paths
 
+readBitmapFile'
+    :: (MonadError String m, MonadIO m)
+    => Display
+    -> Drawable
+    -> String
+    -> m (Dimension, Dimension, Pixmap)
+readBitmapFile' d w p = do
+   res <- liftIO $ readBitmapFile d w p
+   case res of
+    Left err -> throwError err
+    Right (bw, bh, bp, _, _) -> return (bw, bh, bp)
+
 loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap)
 loadBitmap d w p = do
     exist <- doesFileExist p
     if exist
        then do
-            bmap <- readBitmapFile d w p
-            case bmap of
-                 Right (bw, bh, bp, _, _) -> do
-                     addFinalizer bp (freePixmap d bp)
-                     return $ Just $ Bitmap bw bh bp
+            res <- runExceptT $
+                    tryXBM
+#ifdef XPM
+                <|> tryXPM
+#endif
+            case res of
+                 Right b -> return $ Just b
                  Left err -> do
                      putStrLn err
                      return Nothing
        else
            return Nothing
+ where tryXBM = do
+           (bw, bh, bp) <- readBitmapFile' d w p
+           liftIO $ addFinalizer bp (freePixmap d bp)
+           return $ Bitmap bw bh bp Nothing (Mono 1)
+#ifdef XPM
+       tryXPM = do
+           (bw, bh, bp, mbpm) <- readXPMFile d w p
+           liftIO $ addFinalizer bp (freePixmap d bp)
+           case mbpm of
+                Nothing -> return ()
+                Just bpm -> liftIO $ addFinalizer bpm (freePixmap d bpm)
+           return $ Bitmap bw bh bp mbpm Poly
+#endif
 
 drawBitmap :: Display -> Drawable -> GC -> String -> String
               -> Position -> Position -> Bitmap -> IO ()
@@ -63,6 +102,13 @@ drawBitmap d p gc fc bc x y i =
     withColors d [fc, bc] $ \[fc', bc'] -> do
     let w = width i
         h = height i
+        y' = 1 + y - fromIntegral h `div` 2
     setForeground d gc fc'
     setBackground d gc bc'
-    copyPlane d (pixmap i) p gc 0 0 w h x (1 + y - fromIntegral h `div` 2)  1
+    case (shapePixmap i) of
+         Nothing -> return ()
+         Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask
+    case bitmapType i of
+         Poly -> copyArea d (pixmap i) p gc 0 0 w h x y'
+         Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl
+    setClipMask d gc 0
diff --git a/src/XPMFile.hsc b/src/XPMFile.hsc
new file mode 100644
index 0000000..18c7dec
--- /dev/null
+++ b/src/XPMFile.hsc
@@ -0,0 +1,56 @@
+{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XPMFile
+-- Copyright   :  (C) 2014 Alexander Shabalin
+-- License     :  BSD3
+--
+-- Maintainer  :  jao@gnu.org
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-----------------------------------------------------------------------------
+
+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