Use new caching framework for scaled icons in taskbar

lib/Phi/Border.hs

@@ -57,8 +57,6 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
                                    }
 
 data Border w s c = (Widget w s c) => Border !BorderConfig !w
-deriving instance Show (Border w s c)
-deriving instance Eq (Border w s c)
 
 data BorderCache w s c = (Widget w s c) => BorderCache !c
 

lib/Phi/Widget.hs

@@ -13,6 +13,7 @@ module Phi.Widget ( Display(..)
                   , IOCache
                   , RenderCache
                   , createIOCache
+                  , runIOCache
                   , createRenderCache
                   , renderCached
                   , Separator
@@ -73,7 +74,7 @@ unionArea a b = fromIntegral $ uw*uh
 
 data SurfaceSlice = SurfaceSlice !Int !Surface
 
-class (Show w, Eq w, Eq s) => Widget w s c | w -> s, w -> c where
+class Eq s => Widget w s c | w -> s, w -> c where
   initWidget :: w -> Phi -> Display -> IO s
   
   initCache :: w -> c
@@ -97,6 +98,13 @@ type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surfac
 createIOCache :: Eq a => (a -> IO b) -> IOCache a b
 createIOCache = lift . Kleisli
 
+runIOCache :: Eq a => a -> StateT (IOCache a b) IO (b, Bool)
+runIOCache a = do
+  cache <- get
+  (b, updated, cache') <- liftIO $ runKleisli (runCache' cache) a
+  put cache'
+  return (b, updated)
+
 createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
                      -> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
 createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
@@ -116,8 +124,6 @@ renderCached widget state x y w h screen = do
   return [(updated, SurfaceSlice 0 surf)]
 
 data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
-deriving instance Eq (CompoundWidget a sa ca b sb cb)
-deriving instance Show (CompoundWidget a sa ca b sb cb)
 
 data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int
 deriving instance Eq (CompoundState a sa ca b sb cb)

lib/Phi/Widgets/AlphaBox.hs

@@ -14,8 +14,6 @@ import Graphics.Rendering.Cairo
 
 
 data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w
-deriving instance Show (AlphaBox w s c)
-deriving instance Eq (AlphaBox w s c)
 
 data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c
 

lib/Phi/Widgets/Taskbar.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
 
 module Phi.Widgets.Taskbar ( IconStyle
                            , idIconStyle
@@ -13,7 +13,7 @@ module Phi.Widgets.Taskbar ( IconStyle
 
 import Control.Concurrent
 import Control.Monad
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Control.Monad.Trans
 
 import Data.Array.MArray
@@ -24,7 +24,10 @@ import Data.IORef
 import Data.List
 import Data.Maybe
 import Data.Typeable
+import Data.Unique
 import Data.Word
+import qualified Data.Accessor.Basic as A
+import qualified Data.Accessor.Container as AC
 import qualified Data.Map as M
 
 import Foreign.C.Types
@@ -49,15 +52,10 @@ import Phi.X11.Atoms
 
 
 type IconStyle = Surface -> Render ()
-instance Show IconStyle where
-  show _ = "IconStyle <?>"
-instance Eq IconStyle where
-  _ == _ = True
 
 idIconStyle :: IconStyle
 idIconStyle = flip withPatternForSurface setSource
 
-
 desaturateIconStyle :: Double -> IconStyle
 desaturateIconStyle v icon = do
   w <- imageSurfaceGetWidth icon
@@ -106,20 +104,20 @@ data TaskStyle = TaskStyle { taskFont      :: !String
                            , taskColor     :: !Color
                            , taskBorder    :: !BorderConfig
                            , taskIconStyle :: !IconStyle
-                           } deriving (Show, Eq)
+                           }
 
 data DesktopStyle = DesktopStyle { desktopFont       :: !String
                                  , desktopLabelWidth :: !Int
                                  , desktopLabelGap   :: !Int
                                  , desktopColor      :: !Color
                                  , desktopBorder     :: !BorderConfig
-                                 } deriving (Show, Eq)
+                                 }
 
 data TaskbarConfig = TaskbarConfig { taskMaxSize      :: !Int
                                    , normalTaskStyle  :: !TaskStyle
                                    , activeTaskStyle  :: !TaskStyle
                                    , desktopStyle     :: !(Maybe (DesktopStyle, DesktopStyle))
-                                   } deriving (Show, Eq)
+                                   }
 
 defaultStyle :: TaskStyle
 defaultStyle = TaskStyle { taskFont = "Sans 8"
@@ -135,45 +133,69 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
                                      , desktopStyle = Nothing
                                      }
 
-data Taskbar = Taskbar TaskbarConfig deriving (Show, Eq)
+data Taskbar = Taskbar TaskbarConfig
-
-instance Show Surface where
-  show _ = "Surface <?>"
 
 data TaskbarState = TaskbarState { taskbarActiveWindow      :: !Window
                                  , taskbarDesktopCount      :: !Int
                                  , taskbarCurrentDesktop    :: !Int
                                  , taskbarWindows           :: ![Window]
                                  , taskbarWindowStates      :: !(M.Map Window WindowState)
-                                 , taskbarWindowIcons       :: !(M.Map Window [(Int, Surface)])
+                                 } deriving Eq
-                                 , taskbarWindowScaledIcons :: !(M.Map Window (IORef (Maybe (Int, Surface))))
+
-                                 , taskbarWindowScreens     :: !(M.Map Window Xlib.Rectangle)
+data Icon = Icon !Unique !Int !Surface
-                                 } deriving Show
+instance Eq Icon where (Icon a _ _) == (Icon b _ _) = a == b
-instance Eq TaskbarState where
+instance Show Icon where show (Icon _ size _) = "Icon { size = " ++ (show size) ++ " }"
-  _ == _ = False
+
+createIcon :: Int -> Surface -> IO Icon
+createIcon size surface = do
+  id <- newUnique
+  return $ Icon id size surface
+
 
 data WindowState = WindowState { windowTitle   :: !String
                                , windowDesktop :: !Int
                                , windowVisible :: !Bool
-                               } deriving (Show, Eq)
+                               , windowIcons   :: ![Icon]
+                               , windowScreen  :: !Xlib.Rectangle
+                               } deriving (Eq, Show)
 
-data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState) !(M.Map Window [(Int, Surface)]) !(M.Map Window (IORef (Maybe (Int, Surface)))) !(M.Map Window Xlib.Rectangle)
+data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Surface))
+                               }
+
+emptyWindowCache :: WindowCache
+emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon
+                               }
+createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
+
+-- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant
+liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a
+liftT f m = do
+  s0 <- gets $ A.get f
+  (a,s1) <- lift $ runStateT m s0
+  modify $ A.set f s1
+  return a
+
+liftIOStateT :: (MonadIO m) => StateT s IO a -> StateT s m a
+liftIOStateT m = do 
+  s0 <- get
+  (a,s1) <- liftIO $ runStateT m s0
+  put s1
+  return a
+
+data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState)
                     | DesktopCountUpdate !Int
                     | CurrentDesktopUpdate !Int
                     | ActiveWindowUpdate !Window
-                    deriving (Show, Typeable)
+                    deriving (Typeable, Show)
 
-instance Show (IORef a) where
+instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
-  show _ = "IORef <?>"
-
-instance Widget Taskbar TaskbarState () where
   initWidget (Taskbar _) phi dispvar = do
     phi' <- dupPhi phi
     forkIO $ taskbarRunner phi' dispvar
     
-    return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty M.empty
+    return $ TaskbarState 0 0 (-1) [] M.empty
   
-  initCache _ = ()
+  initCache _ = M.empty
     
   minSize _ _ _ _ = 0
   weight _ = 1
@@ -183,11 +205,8 @@ instance Widget Taskbar TaskbarState () where
                                        , taskbarCurrentDesktop = currentDesktop
                                        , taskbarWindows = windows
                                        , taskbarWindowStates = windowStates
-                                       , taskbarWindowIcons = windowIcons
-                                       , taskbarWindowScaledIcons = windowScaledIcons
-                                       , taskbarWindowScreens = windowScreens
                                        } _ _ w h screen = do
-    let screenWindows  = filter ((== Just screen) . flip M.lookup windowScreens) windows
+    let screenWindows  = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows
         desktopNumbers = take desktopCount [0..]
         desktops       = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
         
@@ -207,7 +226,9 @@ instance Widget Taskbar TaskbarState () where
         windowWidth    = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
     
     surface <- liftIO $ createImageSurface FormatARGB32 w h
-    renderWith surface $ do
+    cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get
+    cache' <- renderWith surface $ flip execStateT cache $ do
+      lift $ do
         setOperator OperatorClear
         paint
         
@@ -220,6 +241,7 @@ instance Widget Taskbar TaskbarState () where
         case dstyle' of
           Just ds -> do
             let (r, g, b, a) = desktopColor ds
+            lift $ do
               save
               drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
               clip
@@ -233,30 +255,26 @@ instance Widget Taskbar TaskbarState () where
               let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
                   h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds)
                   mstate = M.lookup window windowStates
-                  micons = M.lookup window windowIcons
-                  mscaledIconRef = M.lookup window windowScaledIcons
                   x = dx + i*windowWidth
                   y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
               
-              case (mstate, micons, mscaledIconRef) of
+              case mstate of
-                (Just state, Just icons, Just scaledIconRef) ->
+                Just state ->
-                  renderTask state icons scaledIconRef style x y windowWidth h'
+                  liftT (AC.mapDefault emptyWindowCache window) $ renderTask state style x y windowWidth h'
             
-                _ -> return ()
+                Nothing -> return ()
         
           _ -> return ()
       
         return $ nwindows + length desktopWindows
+    put cache'
     
     return [(True, SurfaceSlice 0 surface)]
       
   
   handleMessage _ priv m = case (fromMessage m) of
-    Just (WindowListUpdate windows windowStates icons scaledIcons screens) -> priv { taskbarWindows = windows
+    Just (WindowListUpdate windows windowStates) -> priv { taskbarWindows = windows
                                                          , taskbarWindowStates = windowStates
-                                                                                   , taskbarWindowIcons = icons
-                                                                                   , taskbarWindowScaledIcons = scaledIcons
-                                                                                   , taskbarWindowScreens = screens
                                                          }
     Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
     Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
@@ -278,13 +296,14 @@ renderText font x y w h text = do
   moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
   showLayout layout
 
-renderTask :: WindowState -> [(Int, Surface)] -> IORef (Maybe (Int, Surface)) -> TaskStyle -> Int -> Int -> Int -> Int -> Render ()
+renderTask :: WindowState -> TaskStyle -> Int -> Int -> Int -> Int -> StateT WindowCache Render ()
-renderTask state icons scaledIconRef style x y w h = do
+renderTask state style x y w h = do
   let (r, g, b, a) = taskColor style
       leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
       rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
       h' = h - (borderV $ margin $ taskBorder style)
   
+  lift $ do
     save
     drawBorder (taskBorder style) x y w h
     clip
@@ -294,17 +313,9 @@ renderTask state icons scaledIconRef style x y w h = do
   
     restore
   
-  mscaledIcon <- liftIO $ readIORef scaledIconRef
+  (scaledIcon, updated) <- liftT createScaledIconCached' $ liftIOStateT $ runIOCache (windowIcons state, h')
-  scaledIcon <- case mscaledIcon of
-    Just (size, icon) | size == h' -> do
-      return $ Just icon
-    _ -> do
-      scaledIcon <- createScaledIcon icons h'
-      liftIO $ writeIORef scaledIconRef $ fmap ((,) h') scaledIcon
-      return scaledIcon
-  
   case scaledIcon of
-    Just icon -> do
+    Just icon -> lift $ do
       save
       translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style))
       taskIconStyle style icon
@@ -314,18 +325,18 @@ renderTask state icons scaledIconRef style x y w h = do
     _ -> return ()
                 
 
-createScaledIcon :: [(Int, Surface)] -> Int -> Render (Maybe Surface)
+createScaledIcon :: ([Icon], Int) -> IO (Maybe Surface)
-createScaledIcon icons h = do
+createScaledIcon (icons, h) = do
   case bestIcon of
-        Just icon -> do
+    Just (Icon _ _ icon) -> do
-          scaledIcon <- liftIO $ createSimilarSurface icon ContentColorAlpha h h
+      scaledIcon <- createSimilarSurface icon ContentColorAlpha h h
       renderWith scaledIcon $ do
         imageW <- imageSurfaceGetWidth icon
         imageH <- imageSurfaceGetHeight icon
         
         let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH)
         
-            case True of
+        case () of
           _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2)
             | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0
         
@@ -336,8 +347,8 @@ createScaledIcon icons h = do
     _ -> return Nothing
   
   where
-    bestIcon = fmap snd . listToMaybe $ sortBy compareIcons icons
+    bestIcon = listToMaybe $ sortBy compareIcons icons
-    compareIcons = flip (compare `on` fst)
+    compareIcons = flip (compare `on` (\(Icon _ size _) -> size))
 
 
 windowOnDesktop :: Int -> WindowState -> Bool
@@ -347,19 +358,19 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt
 taskbarRunner :: Phi -> Display -> IO ()
 taskbarRunner phi dispvar = do
   let screens = getScreens dispvar
-  (windows, states, icons, scaledIcons, windowScreens) <- liftIO $ withDisplay dispvar $ \disp -> do
+  (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
-    (windows, states, icons, scaledIcons, windowScreens) <- getWindowStates disp screens (getAtoms dispvar) M.empty M.empty M.empty M.empty
+    (windows, states) <- getWindowStates disp screens (getAtoms dispvar) M.empty
     desktopCount <- getDesktopCount disp (getAtoms dispvar) 
     current <- getCurrentDesktop disp (getAtoms dispvar) 
     activeWindow <- getActiveWindow disp (getAtoms dispvar) 
-    sendMessage phi $ WindowListUpdate windows states icons scaledIcons windowScreens
+    sendMessage phi $ WindowListUpdate windows states
     sendMessage phi $ DesktopCountUpdate desktopCount
     sendMessage phi $ CurrentDesktopUpdate current
     sendMessage phi $ ActiveWindowUpdate activeWindow
-    return (windows, states, icons, scaledIcons, windowScreens)
+    return (windows, states)
   sendMessage phi Repaint
   
-  flip evalStateT (windows, states, icons, scaledIcons, windowScreens) $ forever $ do
+  flip evalStateT (windows, states) $ forever $ do
     m <- receiveMessage phi
     case (fromMessage m) of
       Just event -> 
@@ -367,7 +378,7 @@ taskbarRunner phi dispvar = do
       _ ->
         return ()
 
-handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle) IO ()
+handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
 handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
   let atoms = getAtoms dispvar
   let screens = getScreens dispvar
@@ -397,48 +408,52 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
         sendMessage phi $ CurrentDesktopUpdate current
         sendMessage phi Repaint
       when (atom == atom_NET_CLIENT_LIST atoms) $ do
-        (windows, windowStates, icons, scaledIcons, windowScreens) <- get
+        (windows, windowStates) <- get
-        (windows', windowStates', icons', scaledIcons', windowScreens') <- liftIO $ getWindowStates disp screens atoms windowStates icons scaledIcons windowScreens
+        (windows', windowStates') <- liftIO $ getWindowStates disp screens atoms windowStates
         
         when (windows /= windows') $ do
-          sendMessage phi $ WindowListUpdate windows' windowStates' icons' scaledIcons' windowScreens'
+          sendMessage phi $ WindowListUpdate windows' windowStates'
           sendMessage phi Repaint
-          put (windows', windowStates', icons', scaledIcons', windowScreens')
+          put (windows', windowStates')
     
       else do
-      (windows, windowStates, icons, scaledIcons, windowScreens) <- get
+      (windows, windowStates) <- get
       when (elem window windows) $ do
-        when (atom == atom_NET_WM_ICON atoms) $ do
+        case () of
-          icon <- liftIO $ getWindowIcons disp atoms window
+          _ | (atom == atom_NET_WM_ICON atoms) -> do
-          scaledIcon <- liftIO $ newIORef Nothing
+            icons <- liftIO $ getWindowIcons disp atoms window
-          let icons' = M.insert window icon icons
+            let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates
-              scaledIcons' = M.insert window scaledIcon scaledIcons
+            sendMessage phi $ WindowListUpdate windows windowStates'
-          sendMessage phi $ WindowListUpdate windows windowStates icons' scaledIcons' windowScreens
             sendMessage phi Repaint
-          put (windows, windowStates, icons', scaledIcons', windowScreens)
+            put (windows, windowStates')
         
-        when (atom /= atom_NET_WM_ICON atoms) $ do
+            | otherwise -> do
-          let windowState = M.lookup window windowStates
+            (name, desktop, visible) <- liftIO $ getWindowInfo disp atoms window
-          windowState' <- liftIO $ getWindowState disp atoms window
+            let mwindowState = M.lookup window windowStates
+            case mwindowState of
+              Just windowState -> do
+                let windowState' = windowState {windowTitle = name, windowDesktop = desktop, windowVisible = visible}
             
-          when (windowState /= (Just windowState')) $ do
+                when (windowState /= windowState') $ do
                   let windowStates' = M.insert window windowState' windowStates
-            sendMessage phi $ WindowListUpdate windows windowStates' icons scaledIcons windowScreens
+                  sendMessage phi $ WindowListUpdate windows windowStates'
                   sendMessage phi Repaint
-            put (windows, windowStates', icons, scaledIcons, windowScreens)
+                  put (windows, windowStates')
+              Nothing ->
+                return ()
 
 handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
   let screens = getScreens dispvar
 
-  (windows, windowStates, icons, scaledIcons, windowScreens) <- get
+  (windows, windowStates) <- get
   when (elem window windows) $ withDisplay dispvar $ \disp -> do
-    let screen = M.lookup window windowScreens
+    let screen = fmap windowScreen . M.lookup window $  windowStates
     screen' <- liftIO $ getWindowScreen disp screens window
     when (screen /= (Just screen')) $ do
-      let windowScreens' = M.insert window screen' windowScreens
+      let windowStates' = M.update (\state -> Just state {windowScreen = screen'}) window windowStates
-      sendMessage phi $ WindowListUpdate windows windowStates icons scaledIcons windowScreens'
+      sendMessage phi $ WindowListUpdate windows windowStates'
       sendMessage phi Repaint
-      put (windows, windowStates, icons, scaledIcons, windowScreens')
+      put (windows, windowStates')
 
 handleEvent _ _ _ = return ()
 
@@ -456,74 +471,64 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window
 getActiveWindow disp atoms =
   liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
 
-getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> M.Map Window WindowState -> M.Map Window [(Int, Surface)] -> M.Map Window (IORef (Maybe (Int, Surface))) -> M.Map Window Xlib.Rectangle
+getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
-                   -> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle)
+getWindowStates disp screens atoms windowStates = do
-getWindowStates disp screens atoms windowStates windowIcons windowScaledIcons windowScreens = do
   windows <- getWindowList disp atoms
   
   let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
-      windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
-      windowScaledIcons' = map (\w -> (w, M.lookup w windowScaledIcons)) windows
-      windowScreens' = map (\w -> (w, M.lookup w windowScreens)) windows
   
   newWindowStates <- mapM getWindowState' windowStates'
-  newWindowIcons <- mapM getWindowIcons' windowIcons'
-  newWindowScaledIcons <- mapM getScaledIcons windowScaledIcons'
-  newWindowScreens <- mapM getWindowScreen' windowScreens'
   
-  return (windows, M.fromList newWindowStates, M.fromList newWindowIcons, M.fromList newWindowScaledIcons, M.fromList newWindowScreens)
+  return (windows, M.fromList newWindowStates)
     where
       getWindowState' (window, Just windowState) = return (window, windowState) 
       getWindowState' (window, Nothing) = do
         Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
-        windowState <- getWindowState disp atoms window
+        windowState <- getWindowState disp screens atoms window
         return (window, windowState)
 
-      getWindowIcons' (window, Just icons) = return (window, icons)
+getWindowState :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> Window -> IO WindowState
-      getWindowIcons' (window, Nothing) = do
+getWindowState disp screens atoms window = do
+  (name, workspace, visible) <- getWindowInfo disp atoms window
   icons <- getWindowIcons disp atoms window
-        return (window, icons)
-      
-      getScaledIcons (window, Just icon) = return (window, icon)
-      getScaledIcons (window, Nothing) = liftM2 (,) (return window) $ newIORef Nothing
-      
-      getWindowScreen' (window, Just screen) = return (window, screen)
-      getWindowScreen' (window, Nothing) = do
   screen <- getWindowScreen disp screens window
-        return (window, screen)
   
+  return $ WindowState { windowTitle = name 
+                       , windowDesktop = workspace 
+                       , windowVisible = visible 
+                       , windowIcons = icons
+                       , windowScreen = screen
+                       }
 
-getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
+getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
-getWindowState disp atoms window = do
+getWindowInfo disp atoms window = do
   netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
   wmname <- case netwmname of
     Just name -> return name
     Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
   
   workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
-  
   visible <- showWindow disp atoms window
   
-  return $ WindowState wmname workspace visible
+  return (wmname, workspace, visible)
     where
       unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
 
-getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [(Int, Surface)]
+getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon]
 getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
 
 
-readIcons :: [CLong] -> IO [(Int, Surface)]
+readIcons :: [CLong] -> IO [Icon]
 readIcons (width:height:iconData) = do
   if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
     let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
-    icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
+    surface <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
-    surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32)
+    surfaceData <- imageSurfaceGetPixels surface :: IO (SurfaceData Int Word32)
     forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
     
-    surfaceMarkDirty icon
+    surfaceMarkDirty surface
     
-    moreIcons <- readIcons rest
+    liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest)
-    return $ (fromIntegral $ max width height, icon):moreIcons
 
 readIcons _ = return []
 

phi.cabal

@@ -11,7 +11,7 @@ maintainer:          mschiffer@universe-factory.net
 build-type:          Simple
 
 library
-  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, arrows, CacheArrow
+  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, data-accessor, arrows, CacheArrow
   exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
                      Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
   other-modules:     Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler