Implement icon caching

4 files changed, 47 insertions, 34 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 5ef5db6..1438ab5 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -26,6 +26,7 @@ import Config
 import XUtil
 
 import Data.List (intercalate)
+import qualified Data.Map as Map
 
 import Paths_xmobar (version)
 import Data.Version (showVersion)
@@ -60,7 +61,8 @@ main = do
   sig   <- setupSignalHandler
   vars  <- mapM (mapM $ startCommand sig) cls
   (r,w) <- createWin d fs conf
-  startLoop (XConf d r w fs conf) sig vars
+  let ic = Map.empty
+  startLoop (XConf d r w fs ic conf) sig vars
 
 -- | Splits the template in its parts
 splitTemplate :: Config -> [String]
diff --git a/src/Types.hs b/src/Types.hs
index 3fcc6de..94f2373 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -1,3 +1,9 @@
 module Types where
+import Graphics.X11.Xlib
 
 data Widget = Text String | Icon String
+
+data Bitmap = Bitmap { width  :: Dimension
+                     , height :: Dimension
+                     , pixmap :: Pixmap
+                     }
diff --git a/src/XUtil.hsc b/src/XUtil.hsc
index 3c9f799..720e895 100644
--- a/src/XUtil.hsc
+++ b/src/XUtil.hsc
@@ -17,6 +17,8 @@ module XUtil
     , initFont
     , initCoreFont
     , initUtf8Font
+    , loadBitmap
+    , drawBitmap
     , textExtents
     , textWidth
     , printString
@@ -73,11 +75,6 @@ hGetLineSafe = UTF8.hGetLine
 hGetLineSafe = hGetLine
 #endif
 
-data Bitmap = Bitmap { width  :: Dimension
-                     , height :: Dimension
-                     , pixmap :: Pixmap
-                     }
-
 -- Hide the Core Font/Xft switching here
 data XFont = Core FontStruct
            | Utf8 FontSet
@@ -181,30 +178,22 @@ drawBitmap d p _ gc fc bc x y i = do
     io $ copyPlane d (pixmap i) p gc 0 0 (width i) (height i) x (y - (fi $ height i)) 1
 
 printString :: Display -> Drawable -> XFont -> GC -> String -> String
-            -> Position -> Position -> Widget -> IO ()
-printString d p fs gc fc bc x y w = do
-    case w of 
-        (Text s) -> printString' d p fs gc fc bc x y s
-        (Icon i) -> do bitmap <- loadBitmap d p i
-                       forM_ bitmap $ drawBitmap d p fs gc fc bc x y
-
-printString' :: Display -> Drawable -> XFont -> GC -> String -> String
             -> Position -> Position -> String  -> IO ()
-printString' d p (Core fs) gc fc bc x y s = do
+printString d p (Core fs) gc fc bc x y s = do
     setFont d gc $ fontFromFontStruct fs
     withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
       setBackground d gc bc'
       drawImageString d p gc x y s
 
-printString' d p (Utf8 fs) gc fc bc x y s =
+printString d p (Utf8 fs) gc fc bc x y s =
     withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
       setBackground d gc bc'
       io $ wcDrawImageString d p fs gc x y s
 
 #ifdef XFT
-printString' dpy drw fs@(Xft font) _ fc bc x y s = do
+printString dpy drw fs@(Xft font) _ fc bc x y s = do
   (a,d)  <- textExtents fs s
   gi <- xftTxtExtents dpy font s
   withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 7730620..b7355c4 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -23,13 +23,13 @@ module Xmobar
     , startCommand
     -- * Window Management
     -- $window
-    , createWin, updateWin
+    , createWin
     -- * Printing
     -- $print
     , drawInWin, printStrings
     ) where
 
-import Prelude
+import Prelude hiding (lookup)
 import Graphics.X11.Xlib hiding (textExtents, textWidth)
 import Graphics.X11.Xlib.Extras
 import Graphics.X11.Xinerama
@@ -41,12 +41,14 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception (handle, SomeException(..))
 import Data.Bits
+import Data.Map hiding (foldr, map, filter)
 
 import Config
 import Parsers
 import Commands
 import Runnable
 import Signal
+import Types
 import Window
 import XUtil
 import ColorCache
@@ -72,6 +74,7 @@ data XConf =
           , rect    :: Rectangle
           , window  :: Window
           , fontS   :: XFont
+          , iconS   :: Map FilePath Bitmap
           , config  :: Config
           }
 
@@ -81,7 +84,7 @@ runX xc f = runReaderT f xc
 
 -- | Starts the main event loop and threads
 startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO ()
-startLoop xcfg@(XConf _ _ w _ _) sig vs = do
+startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do
 #ifdef XFT
     xftInitFtLibrary
 #endif
@@ -98,7 +101,7 @@ startLoop xcfg@(XConf _ _ w _ _) sig vs = do
     eventLoop tv xcfg sig
   where
     handler thing (SomeException _) =
-      putStrLn ("Thread " ++ thing ++ " failed") >> return ()
+      void $ putStrLn ("Thread " ++ thing ++ " failed")
     -- Reacts on events from X
     eventer signal =
       allocaXEvent $ \e -> do
@@ -139,12 +142,14 @@ checker tvar ov vs signal = do
 
 -- | Continuously wait for a signal from a thread or a interrupt handler
 eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO ()
-eventLoop tv xc@(XConf d r w fs cfg) signal = do
+eventLoop tv xc@(XConf d r w fs is cfg) signal = do
       typ <- atomically $ takeTMVar signal
       case typ of
          Wakeup -> do
-            runX xc (updateWin tv)
-            eventLoop tv xc signal
+            str <- updateString cfg tv
+            xc' <- updateCache d w is str >>= \c -> return xc { iconS = c }
+            runX xc' $ drawInWin r str
+            eventLoop tv xc' signal
 
          Reposition ->
             reposWindow cfg
@@ -187,7 +192,7 @@ eventLoop tv xc@(XConf d r w fs cfg) signal = do
 
         reposWindow rcfg = do
           r' <- repositionWin d w fs rcfg
-          eventLoop tv (XConf d r' w fs rcfg) signal
+          eventLoop tv (XConf d r' w fs is rcfg) signal
 
         updateConfigPosition ocfg =
           case position ocfg of
@@ -219,14 +224,23 @@ startCommand sig (com,s,ss)
                            return (Just h,var)
     where is = s ++ "Updating..." ++ ss
 
-updateWin :: TVar [String] -> X ()
-updateWin v = do
-  xc <- ask
-  s <- io $ atomically $ readTVar v
-  let (conf,rec) = (config &&& rect) xc
-      l:c:r:_ = s ++ repeat ""
-  ps <- io $ mapM (parseString conf) [l, c, r]
-  drawInWin rec ps
+updateString :: Config -> TVar [String] -> IO [[(Widget, String)]]
+updateString conf v = do
+  s <- atomically $ readTVar v
+  let l:c:r:_ = s ++ repeat ""
+  io $ mapM (parseString conf) [l, c, r]
+
+updateCache :: Display -> Window -> Map FilePath Bitmap -> [[(Widget, String)]] -> IO (Map FilePath Bitmap)
+updateCache dpy win cache ps = do
+  let paths = map (\(Icon p, _) -> p) . concatMap (filter icons) $ ps
+      icons (Icon _, _) = True
+      icons _ = False
+  foldM (\m path -> if member path m
+                       then return m
+                       else do bitmap <- io $ loadBitmap dpy win path
+                               case bitmap of
+                                    Nothing -> return m
+                                    Just bmap -> return $ insert path bmap m) cache paths
 
 -- $print
 
@@ -283,5 +297,7 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
       (fc,bc)              = case break (==',') c of
                                (f,',':b) -> (f, b           )
                                (f,    _) -> (f, bgColor conf)
-  io $ printString d dr fontst gc fc bc offset valign s
+  case s of
+    (Text t) -> io $ printString d dr fontst gc fc bc offset valign t
+    (Icon p) -> io $ maybe (return ()) (drawBitmap d dr fontst gc fc bc offset valign) (lookup p (iconS r))
   printStrings dr gc fontst (offs + l) a xs