summaryrefslogtreecommitdiffhomepage
path: root/src/Bitmap.hs
blob: ec99ad8b1219ebe152e2964478db9ce0d352f0f7 (plain)
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
120
121
122
123
124
125
126
127
128
129
130
{-# 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.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

#if MIN_VERSION_mtl(2, 2, 1)
import Control.Monad.Except(MonadError(..), runExceptT)

#else
import Control.Monad.Error(MonadError(..))
import Control.Monad.Trans.Error(ErrorT, runErrorT)

runExceptT :: ErrorT e m a -> m (Either e a)
runExceptT = runErrorT

#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