{-# 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 { 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 FilePath -> BitmapCache -> Bool
forall k a. Ord k => k -> Map k a -> Bool
member FilePath
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 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
                             BitmapCache -> IO BitmapCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BitmapCache -> IO BitmapCache) -> BitmapCache -> IO BitmapCache
forall a b. (a -> b) -> a -> b
$ BitmapCache
-> (Bitmap -> BitmapCache) -> Maybe Bitmap -> BitmapCache
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BitmapCache
m (\Bitmap
b -> FilePath -> Bitmap -> BitmapCache -> BitmapCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert FilePath
path Bitmap
b BitmapCache
m) Maybe Bitmap
bitmap
  (BitmapCache -> FilePath -> IO BitmapCache)
-> BitmapCache -> [FilePath] -> IO BitmapCache
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 <- IO
  (Either
     FilePath (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt))
-> m (Either
        FilePath (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
      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 a. FilePath -> m a
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 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 -> 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 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 FilePath
err -> do
                     FilePath -> IO ()
putStrLn FilePath
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
           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
 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 a. IO a -> ExceptT FilePath IO a
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 a. a -> ExceptT FilePath IO a
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]
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