1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
{-# LANGUAGE CPP, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Bitmap
-- Copyright : (C) 2013 Alexander Polakov
-- License : BSD3
--
-- Maintainer : jao@gnu.org
-- Stability : unstable
-- Portability : unportable
--
-----------------------------------------------------------------------------
module Bitmap
( updateCache
, 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)
import System.FilePath ((</>))
import System.Mem.Weak ( addFinalizer )
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 -> FilePath ->
[[(Widget, String, Maybe [Action])]] -> IO (Map FilePath Bitmap)
updateCache dpy win cache iconRoot ps = do
let paths = map (\(Icon p, _, _) -> p) . concatMap (filter icons) $ ps
icons (Icon _, _, _) = True
icons _ = False
expandPath path@('/':_) = path
expandPath path@('.':'/':_) = path
expandPath path@('.':'.':'/':_) = path
expandPath path = iconRoot </> path
go m path = if member path m
then return m
else do bitmap <- loadBitmap dpy win $ expandPath path
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
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 ()
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'
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
|
