diff options
| -rw-r--r-- | readme.md | 5 | ||||
| -rw-r--r-- | src/Bitmap.hs | 58 | ||||
| -rw-r--r-- | src/XPMFile.hsc | 44 | ||||
| -rw-r--r-- | xmobar.cabal | 9 |
4 files changed, 110 insertions, 6 deletions
@@ -152,6 +152,10 @@ Otherwise, you'll need to install them yourself. : Support for other timezones. Enables the DateZone plugin. Requires [timezone-olson] and [timezone-series] package. +`with_xpm` +: Support for xpm image file format. This will allow loading .xpm files in `<icon>`. + Requires the [libXpm] C library. + `all_extensions` : Enables all the extensions above. @@ -1495,3 +1499,4 @@ Copyright © 2007-2010 Andrea Rossato [alsa-mixer]: http://hackage.haskell.org/package/alsa-mixer [timezone-olson]: http://hackage.haskell.org/package/timezone-olson [timezone-series]: http://hackage.haskell.org/package/timezone-series +[libXpm]: http://cgit.freedesktop.org/xorg/lib/libXpm 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..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 diff --git a/xmobar.cabal b/xmobar.cabal index 9e0e509..716366e 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -66,6 +66,10 @@ flag with_dbus description: Publish a service on the session bus for controlling xmobar. default: False +flag with_xpm + description: Enable usage of xpm for icons + default: False + flag with_threaded description: Use threaded runtime. default: False @@ -166,3 +170,8 @@ executable xmobar build-depends: dbus >= 0.10 other-modules: IPC.DBus cpp-options: -DDBUS + + if flag(with_xpm) || flag(all_extensions) + extra-libraries: Xpm + other-modules: XPMFile + cpp-options: -DXPM |