summaryrefslogtreecommitdiffhomepage
path: root/src/lib/Xmobar/X11/Bitmap.hs
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2018-11-25 15:10:29 +0000
committerjao <jao@gnu.org>2018-11-25 15:10:29 +0000
commit77df1ac30fa7af5948f7ff64f5fee9aed64552b3 (patch)
tree647a4eb67ff1c293a5c530538ee88fc0093b577a /src/lib/Xmobar/X11/Bitmap.hs
parente0d6da82de8d0d1cef98896164c6016b84e47068 (diff)
downloadxmobar-77df1ac30fa7af5948f7ff64f5fee9aed64552b3.tar.gz
xmobar-77df1ac30fa7af5948f7ff64f5fee9aed64552b3.tar.bz2
Back to app/src, since it seems they're the default convention for stack
Diffstat (limited to 'src/lib/Xmobar/X11/Bitmap.hs')
-rw-r--r--src/lib/Xmobar/X11/Bitmap.hs130
1 files changed, 0 insertions, 130 deletions
diff --git a/src/lib/Xmobar/X11/Bitmap.hs b/src/lib/Xmobar/X11/Bitmap.hs
deleted file mode 100644
index c0dba14..0000000
--- a/src/lib/Xmobar/X11/Bitmap.hs
+++ /dev/null
@@ -1,130 +0,0 @@
-{-# LANGUAGE CPP, FlexibleContexts #-}
------------------------------------------------------------------------------
--- |
--- Module : X11.Bitmap
--- Copyright : (C) 2013, 2015, 2017, 2018 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.X11.ColorCache
-import Xmobar.X11.Parsers (Widget(..))
-import Xmobar.Actions (Action)
-
-#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
- }
-
-updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->
- [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)
-updateCache dpy win cache iconRoot ps = do
- let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps
- icons (Icon _, _, _, _) = True
- icons _ = False
- 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] $ \[fc', bc'] -> do
- let 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