{-# LANGUAGE CPP, FlexibleContexts #-}
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 { Bitmap -> Dimension
width :: Dimension
, Bitmap -> Dimension
height :: Dimension
, Bitmap -> Pixmap
pixmap :: Pixmap
, Bitmap -> Maybe Pixmap
shapePixmap :: Maybe Pixmap
, Bitmap -> BitmapType
bitmapType :: BitmapType
}
type BitmapCache = Map FilePath Bitmap
updateCache :: Display -> Window -> BitmapCache -> FilePath -> [FilePath]
-> IO BitmapCache
updateCache :: Display
-> Pixmap -> BitmapCache -> String -> [String] -> IO BitmapCache
updateCache Display
dpy Pixmap
win BitmapCache
cache String
iconRoot [String]
paths = do
let expandPath :: String -> String
expandPath path :: String
path@(Char
'/':String
_) = String
path
expandPath path :: String
path@(Char
'.':Char
'/':String
_) = String
path
expandPath path :: String
path@(Char
'.':Char
'.':Char
'/':String
_) = String
path
expandPath String
path = String
iconRoot String -> String -> String
</> String
path
go :: BitmapCache -> String -> IO BitmapCache
go BitmapCache
m String
path = if String -> BitmapCache -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member String
path BitmapCache
m
then BitmapCache -> IO BitmapCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BitmapCache
m
else do bitmap <- Display -> Pixmap -> String -> IO (Maybe Bitmap)
loadBitmap Display
dpy Pixmap
win (String -> IO (Maybe Bitmap)) -> String -> IO (Maybe Bitmap)
forall a b. (a -> b) -> a -> b
$ String -> String
expandPath String
path
return $ maybe m (\Bitmap
b -> String -> Bitmap -> BitmapCache -> BitmapCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert String
path Bitmap
b BitmapCache
m) bitmap
(BitmapCache -> String -> IO BitmapCache)
-> BitmapCache -> [String] -> IO BitmapCache
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM BitmapCache -> String -> IO BitmapCache
go BitmapCache
cache [String]
paths
readBitmapFile'
:: (MonadError String m, MonadIO m)
=> Display
-> Drawable
-> String
-> m (Dimension, Dimension, Pixmap)
readBitmapFile' :: forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
Display -> Pixmap -> String -> m (Dimension, Dimension, Pixmap)
readBitmapFile' Display
d Pixmap
w String
p = do
res <- IO
(Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
-> m (Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
-> m (Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt)))
-> IO
(Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
-> m (Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
forall a b. (a -> b) -> a -> b
$ Display
-> Pixmap
-> String
-> IO
(Either
String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
readBitmapFile Display
d Pixmap
w String
p
case res of
Left String
err -> String -> m (Dimension, Dimension, Pixmap)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
err
Right (Dimension
bw, Dimension
bh, Pixmap
bp, Maybe CInt
_, Maybe CInt
_) -> (Dimension, Dimension, Pixmap) -> m (Dimension, Dimension, Pixmap)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dimension
bw, Dimension
bh, Pixmap
bp)
loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap)
loadBitmap :: Display -> Pixmap -> String -> IO (Maybe Bitmap)
loadBitmap Display
d Pixmap
w String
p = do
exist <- String -> IO Bool
doesFileExist String
p
if exist
then do
#ifdef XPM
res <- runExceptT (tryXBM <|> tryXPM)
#else
res <- runExceptT tryXBM
#endif
case res of
Right Bitmap
b -> Maybe Bitmap -> IO (Maybe Bitmap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bitmap -> IO (Maybe Bitmap))
-> Maybe Bitmap -> IO (Maybe Bitmap)
forall a b. (a -> b) -> a -> b
$ Bitmap -> Maybe Bitmap
forall a. a -> Maybe a
Just Bitmap
b
Left String
err -> do
String -> IO ()
putStrLn String
err
Maybe Bitmap -> IO (Maybe Bitmap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bitmap
forall a. Maybe a
Nothing
else
return Nothing
where tryXBM :: ExceptT String IO Bitmap
tryXBM = do
(bw, bh, bp) <- Display
-> Pixmap
-> String
-> ExceptT String IO (Dimension, Dimension, Pixmap)
forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
Display -> Pixmap -> String -> m (Dimension, Dimension, Pixmap)
readBitmapFile' Display
d Pixmap
w String
p
liftIO $ addFinalizer bp (freePixmap d bp)
return $ Bitmap bw bh bp Nothing (Mono 1)
#ifdef XPM
tryXPM :: ExceptT String IO Bitmap
tryXPM = do
(bw, bh, bp, mbpm) <- Display
-> Pixmap
-> String
-> ExceptT String IO (Dimension, Dimension, Pixmap, Maybe Pixmap)
forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
Display
-> Pixmap
-> String
-> m (Dimension, Dimension, Pixmap, Maybe Pixmap)
readXPMFile Display
d Pixmap
w String
p
liftIO $ addFinalizer bp (freePixmap d bp)
case mbpm of
Maybe Pixmap
Nothing -> () -> ExceptT String IO ()
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Pixmap
bpm -> IO () -> ExceptT String IO ()
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String IO ()) -> IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ Pixmap -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer Pixmap
bpm (Display -> Pixmap -> IO ()
freePixmap Display
d Pixmap
bpm)
return $ Bitmap bw bh bp mbpm Poly
#endif
drawBitmap :: Display -> Drawable -> GC -> String -> String
-> Position -> Position -> Bitmap -> IO ()
drawBitmap :: Display
-> Pixmap
-> GC
-> String
-> String
-> Position
-> Position
-> Bitmap
-> IO ()
drawBitmap Display
d Pixmap
p GC
gc String
fc String
bc Position
x Position
y Bitmap
i =
Display -> [String] -> ([Pixmap] -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Display -> [String] -> ([Pixmap] -> m a) -> m a
withColors Display
d [String
fc, String
bc] (([Pixmap] -> IO ()) -> IO ()) -> ([Pixmap] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Pixmap]
cs -> do
let (Pixmap
fc', Pixmap
bc') = ([Pixmap] -> Pixmap
forall a. HasCallStack => [a] -> a
head [Pixmap]
cs, [Pixmap]
cs [Pixmap] -> Int -> Pixmap
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)
w :: Dimension
w = Bitmap -> Dimension
width Bitmap
i
h :: Dimension
h = Bitmap -> Dimension
height Bitmap
i
y' :: Position
y' = Position
1 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
- Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
h Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
Display -> GC -> Pixmap -> IO ()
setForeground Display
d GC
gc Pixmap
fc'
Display -> GC -> Pixmap -> IO ()
setBackground Display
d GC
gc Pixmap
bc'
case Bitmap -> Maybe Pixmap
shapePixmap Bitmap
i of
Maybe Pixmap
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Pixmap
mask -> Display -> GC -> Position -> Position -> IO ()
setClipOrigin Display
d GC
gc Position
x Position
y' IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Display -> GC -> Pixmap -> IO ()
setClipMask Display
d GC
gc Pixmap
mask
case Bitmap -> BitmapType
bitmapType Bitmap
i of
BitmapType
Poly -> Display
-> Pixmap
-> Pixmap
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea Display
d (Bitmap -> Pixmap
pixmap Bitmap
i) Pixmap
p GC
gc Position
0 Position
0 Dimension
w Dimension
h Position
x Position
y'
Mono Pixmap
pl -> Display
-> Pixmap
-> Pixmap
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> Pixmap
-> IO ()
copyPlane Display
d (Bitmap -> Pixmap
pixmap Bitmap
i) Pixmap
p GC
gc Position
0 Position
0 Dimension
w Dimension
h Position
x Position
y' Pixmap
pl
Display -> GC -> Pixmap -> IO ()
setClipMask Display
d GC
gc Pixmap
0