Finally, after much wailing and gnashing of teeth, fixed the Xmobar layout icon issue!

2 files changed, 88 insertions, 77 deletions

diff --git a/src/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs
index 7c69a08..dedac0f 100644
--- a/src/Internal/LayoutDraw.hs
+++ b/src/Internal/LayoutDraw.hs
@@ -2,6 +2,8 @@
 ScopedTypeVariables, BangPatterns #-}
 module Internal.LayoutDraw where
 
+import System.IO
+
 import System.Process
 import Text.Printf
 import Control.Arrow
@@ -21,17 +23,17 @@ import System.Directory
 import Internal.Layout
 import Internal.Hash
 
-showLayout :: X (Maybe String)
+showLayout :: X (Bool, String, Maybe String)
 showLayout = do
     winset <- gets windowset
     let layout = S.layout . S.workspace . S.current $ winset
-    xpm <- drawPng layout
-    return $ Just $ printf "<icon=%s/>" xpm
+    (cached, xpm) <- drawPng layout
+    return $ (cached, description layout, Just $ printf "<icon=%s/>" xpm)
 
 iconSize :: (Num a) => (a, a)
 iconSize = (64, 32)
 
-drawPng :: (LayoutClass layout Window) => layout Window -> X String
+drawPng :: (LayoutClass layout Window) => layout Window -> X (Bool, String)
 drawPng l = do
     dir <- getXMonadDir
     let sixWindows = [1..(4 :: Window)]
@@ -45,54 +47,54 @@ drawPng l = do
     let descr = description l
     let pngCacheDir = dir </> "icons" </> "cache"
 
-    liftIO $ createDirectoryIfMissing True pngCacheDir
-    let testf = dir </> "text.txt"
-    let filepathPng = pngCacheDir </> (quickHash descr ++ ".png")
-    let filepathXpm = pngCacheDir </> (quickHash descr ++ ".xpm")
-
-    let colors = [
-           -- (1.0, 1.0, 1.0),
-           -- (0.9, 0.9, 1.0),
-           -- (0.8, 0.8, 1.0),
-           -- (0.7, 0.7, 1.0),
-           (0.8, 0.6, 0.6),
-           (0.8, 0.5, 0.5),
-           (0.8, 0.4, 0.4),
-           (0.8, 0.3, 0.3),
-           (0.8, 0.2, 0.2),
-           (0.8, 0.1, 0.1),
-           (0.8, 0.0, 0.0)
-          ]
-
-    exists <- liftIO $ doesFileExist filepathXpm
-    when (not exists) $
-      liftIO $ do
-        withImageSurface FormatARGB32 64 32 $ \surface -> do
-            renderWith surface $ do
-              setLineCap LineCapButt
-              setLineJoin LineJoinMiter
-
-              forM_ (reverse $ zip (map (second extraPad) rects) colors) $
-                \((wind, Rectangle x y w h), (r, g, b)) -> do
-                  setSourceRGBA r g b 1
-
-                  rectangle
-                    (fromIntegral $ floor (fromIntegral x / 30.0))
-                    (fromIntegral $ floor (fromIntegral y / 30.0))
-                    (fromIntegral $ floor (fromIntegral w / 30.0))
-                    (fromIntegral $ floor (fromIntegral h / 30.0))
-
-                  fill
-
-            surfaceWriteToPNG surface filepathPng
-
-            out <- readProcessWithExitCode
-              "/usr/bin/convert"
-              [filepathPng, filepathXpm]
-              ""
-            return ()
-
-    return filepathXpm
+    liftIO $ do
+      createDirectoryIfMissing True pngCacheDir
+      let testf = dir </> "text.txt"
+      let filepathPng = pngCacheDir </> (quickHash descr ++ ".png")
+      let filepathXpm = pngCacheDir </> (quickHash descr ++ ".xpm")
+
+      let colors = [
+             -- (1.0, 1.0, 1.0),
+             -- (0.9, 0.9, 1.0),
+             -- (0.8, 0.8, 1.0),
+             -- (0.7, 0.7, 1.0),
+             (0.8, 0.6, 0.6),
+             (0.8, 0.5, 0.5),
+             (0.8, 0.4, 0.4),
+             (0.8, 0.3, 0.3),
+             (0.8, 0.2, 0.2),
+             (0.8, 0.1, 0.1),
+             (0.8, 0.0, 0.0)
+            ]
+
+      exists <- doesFileExist filepathXpm
+      when (not exists) $ do
+          withImageSurface FormatARGB32 64 32 $ \surface -> do
+              renderWith surface $ do
+                setLineCap LineCapButt
+                setLineJoin LineJoinMiter
+
+                forM_ (reverse $ zip (map (second extraPad) rects) colors) $
+                  \((wind, Rectangle x y w h), (r, g, b)) -> do
+                    setSourceRGBA r g b 1
+
+                    rectangle
+                      (fromIntegral $ floor (fromIntegral x / 30.0))
+                      (fromIntegral $ floor (fromIntegral y / 30.0))
+                      (fromIntegral $ floor (fromIntegral w / 30.0))
+                      (fromIntegral $ floor (fromIntegral h / 30.0))
+
+                    fill
+
+              surfaceWriteToPNG surface filepathPng
+
+              _ <- handle (\(e :: SomeException) -> return ()) $ void $ readProcessWithExitCode
+                     "/usr/bin/convert"
+                     [filepathPng, filepathXpm]
+                     ""
+              return ()
+
+      return (exists, filepathXpm)
     where
       extraPad (Rectangle x y w h) =
         Rectangle (x + 100) (y + 100) (w - 100) (h - 100)
diff --git a/src/Main.hs b/src/Main.hs
index 28d50ad..47a00e2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,7 @@
 import XMonad
+import Control.Exception
 import XMonad.Hooks.DynamicLog
+import Control.Concurrent
 import XMonad.Layout.Spacing
 import XMonad.Actions.WindowNavigation
 import XMonad.Util.CustomKeys
@@ -12,10 +14,15 @@ import XMonad.Layout.IndependentScreens
 import Text.Printf
 import Data.List.Split
 import XMonad.Hooks.EwmhDesktops
+import XMonad.Hooks.ManageDocks
+import XMonad.Util.Run (spawnPipe)
+import Control.Monad (when)
+import System.IO
 
 import Internal.Keys
 import Internal.LayoutDraw
 import Data.List (partition, isPrefixOf)
+import Data.Maybe
 
 
 main = do
@@ -23,8 +30,10 @@ main = do
   homeDir <- getHomeDirectory
   let fp = homeDir </> ".xmonad" </> "startup"
 
+  xmproc <- spawnPipe "xmobar"
+
   config <-
-    applyKeys $ def
+    applyKeys $ docks $ def
        { terminal    = "alacritty"
        , modMask     = mod3Mask
        , borderWidth = 2
@@ -49,33 +58,33 @@ main = do
        , handleEventHook = fullscreenEventHook
        , focusFollowsMouse = False
        , clickJustFocuses = False
-       }
+       , logHook = do
+           (_, _, layout) <- showLayout
 
-  let toggleStructsKey XConfig {XMonad.modMask = modMask} = (modMask, xK_b)
+           dynamicLogWithPP $ xmobarPP {
+               ppCurrent = xmobarColor "#ff8888" "red" . printf "<fn=1>%s</fn>"
+             , ppVisible = xmobarColor "#8888ff" "" . printf "<fn=6>%s</fn>"
+             , ppHidden  = xmobarColor "#888888" "" . printf "<fn=2>%s</fn>"
+             , ppWsSep = "<fn=1><fc=#808080> </fc></fn>"
+             , ppTitle =
+                 xmobarColor "#808080" "" .
+                    printf "<fn=3><fc=#bbbbbb>%s</fc></fn>" .
+                      parseOut .
+                        trunc 50
+
+             , ppSep = xmobarColor "#404040" "" " │ "
+             , ppLayout = const (fromMaybe "" layout)
+             , ppExtras = []
+             , ppOutput = hPutStrLn xmproc
+             , ppOrder =  \ss ->
+                 let (icons, etc) = partition ("<icon"`isPrefixOf`) ss
+                     in icons ++ etc
+             }
+       }
 
-  xmonad =<<
-    statusBar
-      "xmobar"
-      xmobarPP {
-                 ppCurrent = xmobarColor "#ff8888" "red" . printf "<fn=1>%s</fn>"
-               , ppVisible = xmobarColor "#8888ff" "" . printf "<fn=6>%s</fn>"
-               , ppHidden  = xmobarColor "#888888" "" . printf "<fn=2>%s</fn>"
-               , ppWsSep = "<fn=1><fc=#808080> </fc></fn>"
-               , ppTitle =
-                   xmobarColor "#808080" "" .
-                      printf "<fn=3><fc=#bbbbbb>%s</fc></fn>" .
-                        parseOut .
-                          trunc 50
+  -- let toggleStructsKey XConfig {XMonad.modMask = modMask} = (modMask, xK_b)
 
-               , ppSep = xmobarColor "#404040" "" " │ "
-               , ppLayout = const ""
-               , ppExtras = [showLayout]
-               , ppOrder =  \ss ->
-                   let (icons, etc) = partition ("<icon"`isPrefixOf`) ss
-                       in icons ++ etc
-               }
-      toggleStructsKey
-      config
+  xmonad config
 
   where
     parseOut :: String -> String