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