summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/X11/Bitmap.hs
blob: c5304d985767132d922abcf2a403ace277669239 (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
131
132
{-# LANGUAGE CPP, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  X11.Bitmap
-- Copyright   :  (C) 2013, 2015, 2017, 2018, 2022, 2024 Alexander Polakov
-- License     :  BSD3
--
-- Maintainer  :  jao@gnu.org
-- Stability   :  unstable
-- Portability :  unportable
--
-----------------------------------------------------------------------------

module Xmobar.X11.Bitmap
 ( updateCache
 , drawBitmap
 , Bitmap(..)
 , BitmapCache) where

import Control.Monad
import Control.Monad.Trans(MonadIO(..))
import Data.Map hiding (map)

import Graphics.X11.Xlib hiding (Segment)

import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.Mem.Weak ( addFinalizer )

import Xmobar.X11.ColorCache

#ifdef XPM
import Xmobar.X11.XPMFile(readXPMFile)
import Control.Applicative((<|>))
#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
                     }

type BitmapCache = Map FilePath Bitmap

updateCache :: Display -> Window -> BitmapCache -> FilePath -> [FilePath]
            -> IO BitmapCache
updateCache dpy win cache iconRoot paths = do
  let 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
#ifdef XPM
            res <- runExceptT (tryXBM <|> tryXPM)
#else
            res <- runExceptT tryXBM
#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] $ \cs -> do
    let (fc', bc') = (head cs, cs !! 1)
        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