{-# LANGUAGE CPP, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  X11.Bitmap
-- Copyright   :  (C) 2013, 2015, 2017, 2018, 2022 Alexander Polakov
-- License     :  BSD3
--
-- Maintainer  :  jao@gnu.org
-- Stability   :  unstable
-- Portability :  unportable
--
-----------------------------------------------------------------------------

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

import Control.Monad
import Control.Monad.Trans(MonadIO(..))
import Data.Map hiding (map, filter)
import Graphics.X11.Xlib
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.Mem.Weak ( addFinalizer )
import Xmobar.Run.Actions (Action)
import Xmobar.Run.Parsers (TextRenderInfo(..), Widget(..))
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
                     }

updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->
               [[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)
updateCache :: Display
-> Pixmap
-> Map FilePath Bitmap
-> FilePath
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> IO (Map FilePath Bitmap)
updateCache Display
dpy Pixmap
win Map FilePath Bitmap
cache FilePath
iconRoot [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
ps = do
  let paths :: [FilePath]
paths = ((Widget, TextRenderInfo, Int, Maybe [Action]) -> FilePath)
-> [(Widget, TextRenderInfo, Int, Maybe [Action])] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\(Icon FilePath
p, TextRenderInfo
_, Int
_, Maybe [Action]
_) -> FilePath
p) ([(Widget, TextRenderInfo, Int, Maybe [Action])] -> [FilePath])
-> ([[(Widget, TextRenderInfo, Int, Maybe [Action])]]
    -> [(Widget, TextRenderInfo, Int, Maybe [Action])])
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Widget, TextRenderInfo, Int, Maybe [Action])]
 -> [(Widget, TextRenderInfo, Int, Maybe [Action])])
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> [(Widget, TextRenderInfo, Int, Maybe [Action])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Widget, TextRenderInfo, Int, Maybe [Action]) -> Bool)
-> [(Widget, TextRenderInfo, Int, Maybe [Action])]
-> [(Widget, TextRenderInfo, Int, Maybe [Action])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Widget, TextRenderInfo, Int, Maybe [Action]) -> Bool
forall b c d. (Widget, b, c, d) -> Bool
icons) ([[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> [FilePath])
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
ps
      icons :: (Widget, b, c, d) -> Bool
icons (Icon FilePath
_, b
_, c
_, d
_) = Bool
True
      icons (Widget, b, c, d)
_ = Bool
False
      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 :: Map FilePath Bitmap -> FilePath -> IO (Map FilePath Bitmap)
go Map FilePath Bitmap
m FilePath
path = if FilePath -> Map FilePath Bitmap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member FilePath
path Map FilePath Bitmap
m
                     then Map FilePath Bitmap -> IO (Map FilePath Bitmap)
forall (m :: * -> *) a. Monad m => a -> m a
return Map FilePath Bitmap
m
                     else do Maybe Bitmap
bitmap <- Display -> Pixmap -> FilePath -> IO (Maybe Bitmap)
loadBitmap Display
dpy Pixmap
win (FilePath -> IO (Maybe Bitmap)) -> FilePath -> IO (Maybe Bitmap)
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
expandPath FilePath
path
                             Map FilePath Bitmap -> IO (Map FilePath Bitmap)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath Bitmap -> IO (Map FilePath Bitmap))
-> Map FilePath Bitmap -> IO (Map FilePath Bitmap)
forall a b. (a -> b) -> a -> b
$ Map FilePath Bitmap
-> (Bitmap -> Map FilePath Bitmap)
-> Maybe Bitmap
-> Map FilePath Bitmap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map FilePath Bitmap
m (\Bitmap
b -> FilePath -> Bitmap -> Map FilePath Bitmap -> Map FilePath Bitmap
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert FilePath
path Bitmap
b Map FilePath Bitmap
m) Maybe Bitmap
bitmap
  (Map FilePath Bitmap -> FilePath -> IO (Map FilePath Bitmap))
-> Map FilePath Bitmap -> [FilePath] -> IO (Map FilePath Bitmap)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map FilePath Bitmap -> FilePath -> IO (Map FilePath Bitmap)
go Map FilePath Bitmap
cache [FilePath]
paths

readBitmapFile'
    :: (MonadError String m, MonadIO m)
    => Display
    -> Drawable
    -> String
    -> m (Dimension, Dimension, Pixmap)
readBitmapFile' :: 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 <- IO
  (Either
     FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
-> m (Either
        FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
 -> m (Either
         FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt)))
-> IO
     (Either
        FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
-> m (Either
        FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
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 -> FilePath -> m (Dimension, Dimension, Pixmap)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FilePath
err
    Right (Dimension
bw, Dimension
bh, Pixmap
bp, Maybe CInt
_, Maybe CInt
_) -> (Dimension, Dimension, Pixmap) -> m (Dimension, Dimension, Pixmap)
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 <- ExceptT FilePath IO Bitmap -> IO (Either FilePath Bitmap)
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 -> Maybe Bitmap -> IO (Maybe Bitmap)
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 FilePath
err -> do
                     FilePath -> IO ()
putStrLn FilePath
err
                     Maybe Bitmap -> IO (Maybe Bitmap)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bitmap
forall a. Maybe a
Nothing
       else
           Maybe Bitmap -> IO (Maybe Bitmap)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bitmap
forall a. Maybe a
Nothing
 where tryXBM :: ExceptT FilePath IO Bitmap
tryXBM = do
           (Dimension
bw, Dimension
bh, Pixmap
bp) <- Display
-> Pixmap
-> FilePath
-> ExceptT FilePath IO (Dimension, Dimension, Pixmap)
forall (m :: * -> *).
(MonadError FilePath m, MonadIO m) =>
Display -> Pixmap -> FilePath -> m (Dimension, Dimension, Pixmap)
readBitmapFile' Display
d Pixmap
w FilePath
p
           IO () -> ExceptT FilePath IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FilePath IO ())
-> IO () -> ExceptT FilePath IO ()
forall a b. (a -> b) -> a -> b
$ Pixmap -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer Pixmap
bp (Display -> Pixmap -> IO ()
freePixmap Display
d Pixmap
bp)
           Bitmap -> ExceptT FilePath IO Bitmap
forall (m :: * -> *) a. Monad m => a -> m a
return (Bitmap -> ExceptT FilePath IO Bitmap)
-> Bitmap -> ExceptT FilePath IO Bitmap
forall a b. (a -> b) -> a -> b
$ Dimension
-> Dimension -> Pixmap -> Maybe Pixmap -> BitmapType -> Bitmap
Bitmap Dimension
bw Dimension
bh Pixmap
bp Maybe Pixmap
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 =
    Display -> [FilePath] -> ([Pixmap] -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Display -> [FilePath] -> ([Pixmap] -> m a) -> m a
withColors Display
d [FilePath
fc, FilePath
bc] (([Pixmap] -> IO ()) -> IO ()) -> ([Pixmap] -> IO ()) -> IO ()
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 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 (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 (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