Killed Dependency on Cairo. Vastly improved layout experience.

1 files changed, 102 insertions, 91 deletions

diff --git a/src/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs
index dedac0f..7f960f2 100644
--- a/src/Internal/LayoutDraw.hs
+++ b/src/Internal/LayoutDraw.hs
@@ -4,20 +4,20 @@ module Internal.LayoutDraw where
 
 import System.IO
 
+import Control.Monad.Writer
+import XMonad.Layout.Spacing
 import System.Process
 import Text.Printf
 import Control.Arrow
 import Control.Exception
 import Control.Monad
-import Graphics.Rendering.Cairo
-import Graphics.Rendering.Cairo.Internal (Render(runRender))
-import Graphics.Rendering.Cairo.Types (Cairo(Cairo))
 import Control.Concurrent (threadDelay)
 
 import System.FilePath
 import XMonad
 import XMonad.StackSet as S
 import Data.Maybe
+import Data.Foldable
 import System.Directory
 
 import Internal.Layout
@@ -27,93 +27,104 @@ showLayout :: X (Bool, String, Maybe String)
 showLayout = do
     winset <- gets windowset
     let layout = S.layout . S.workspace . S.current $ winset
-    (cached, xpm) <- drawPng layout
+
+    layout' <- handleMessage layout (
+       SomeMessage $ ModifyWindowBorder (
+          const (Border 0 0 0 0)))
+
+    let layout'' = layout'
+
+    (cached, xpm) <-
+        case layout'' of
+          Just l -> drawXpmIO l
+          Nothing -> drawXpmIO 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 (Bool, String)
-drawPng l = do
-    dir <- getXMonadDir
-    let sixWindows = [1..(4 :: Window)]
-    let stack = differentiate sixWindows
-    (rects, _) <-
-          runLayout
-            (Workspace "0" l stack)
-            (Rectangle 0 0 (fst iconSize * 30) (snd iconSize * 30))
-    return ()
-
-    let descr = description l
-    let pngCacheDir = dir </> "icons" </> "cache"
-
-    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)
-      -- padR (Rectangle x y w h) =
-      --   Rectangle x y (max 1 $ w - 120) (max 1 $ h - 120)
-
-newtype InterceptLayout l a =
-    InterceptLayout {
-       unIntercept :: (l a)
-    } deriving (Show, Read)
-
-instance (LayoutClass l Window) => LayoutClass (InterceptLayout l) Window where
-    runLayout (Workspace t l s) rect = do
-      (rects, mr) <- runLayout (Workspace t (unIntercept l) s) rect
-      return (rects, fmap InterceptLayout mr)
-
-    handleMessage this mesg = do
-      ret <- handleMessage (unIntercept this) mesg
-      -- mapM_ drawThing ret
-      return (InterceptLayout <$> ret)
-
-    description = ("Intercepted "++) . description . unIntercept
+pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool
+pointInRect (x, y) (Rectangle x' y' w h) =
+  x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y'
+  where
+    fi :: (Integral a, Num b) => a -> b
+    fi = fromIntegral
+
+sf :: (Integral a) => a
+sf = 1024
+
+drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String)
+drawXpmIO l = do
+  dir <- getXMonadDir
+
+  let shrinkAmt = 4
+
+  let (w, h) = (56 + shrinkAmt, 28 + shrinkAmt)
+  let descr = description l
+  let iconCacheDir = dir </> "icons" </> "cache"
+  let iconPath = iconCacheDir </> (quickHash descr ++ ".xpm")
+
+  let colors = [
+        "#cc9a9a",
+        "#cc9999",
+        "#cc8080",
+        "#cc6666",
+        "#cc4c4c",
+        "#cc3232",
+        "#cc1818"
+        ]
+
+  (rects', _) <-
+    runLayout
+      (Workspace "0" l (differentiate [1 .. 6]))
+      (Rectangle 0 0 (w * sf) (h * sf))
+
+  let rects = flip map rects' $ \(_, (Rectangle x y w h)) ->
+                Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf)
+
+  liftIO $ do
+    exists <- doesFileExist iconPath
+    createDirectoryIfMissing True iconCacheDir
+
+    when (not exists) $ do
+      let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4
+      writeFile iconPath xpmText
+
+    return (exists, iconPath)
+
+drawXpm :: (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String
+drawXpm (w, h) rects' shrinkAmt = execWriter $ do
+    tell "/* XPM */\n"
+    tell "static char *out[] = {\n"
+    forM_ rects' $ \(_, rect) -> do
+      tell $ "/* " ++ show rect ++ " */\n"
+    tell $ "/* --------------------------- */\n"
+    forM_ rects $ \(_, rect) -> do
+      tell $ "/* " ++ show rect ++ " */\n"
+      
+    tell $ printf "\"%d %d %d 1 \",\n" (w - shrinkAmt) (h - shrinkAmt) (length rects + 1)
+
+    let zipRects = (zip ['A' .. 'Z'] rects)
+
+    forM_ zipRects $ \(char, (color, _)) -> do
+      tell $ printf "\"%c c %s\",\n" char color
+    tell "\"% c None\"a,\n"
+
+    forM_ [0 .. h - 1 - shrinkAmt] $ \y -> do
+      tell "\""
+      forM_ [0 .. w - 1 - shrinkAmt] $ \x -> 
+        (case find (matches x y) zipRects of
+          Nothing -> tell "%"
+          Just (chr, _) -> tell [chr])
+      tell "\""
+      when (y /= h - 1 - shrinkAmt) (tell ",")
+      tell "\n"
+    tell "};"
+
+  where
+    matches x y (_, (_, r)) = pointInRect (x, y) r
+    rects = map (second (shrink shrinkAmt)) rects'
+    guard a b = if a <= shrinkAmt then 1 else b
+    shrink amt (Rectangle x y w h) =
+      Rectangle
+        x
+        y
+        (guard w $ w - fromIntegral amt)
+        (guard h $ h - fromIntegral amt)