summaryrefslogtreecommitdiffhomepage
path: root/src/Bitmap.hs
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2014-09-04 20:38:53 +0200
committerjao <jao@gnu.org>2014-09-04 20:38:53 +0200
commit8d658f93df22d69ea4170234b15fd03cdd3f7f4f (patch)
tree478344a55fc84b95475ec47d33caeada7bdf28f9 /src/Bitmap.hs
parentce60a9fcca7c05fee01758bd49b2f9e410693769 (diff)
parent8512afbb2c3be1897101da0b23edb258715475e6 (diff)
downloadxmobar-8d658f93df22d69ea4170234b15fd03cdd3f7f4f.tar.gz
xmobar-8d658f93df22d69ea4170234b15fd03cdd3f7f4f.tar.bz2
Merge branch 'xpm' of https://github.com/projedi/xmobar
Diffstat (limited to 'src/Bitmap.hs')
-rw-r--r--src/Bitmap.hs58
1 files changed, 52 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