diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Bitmap.hs | 58 | ||||
| -rw-r--r-- | src/XPMFile.hsc | 56 |
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 |