Killed Dependency on Cairo. Vastly improved layout experience.

5 files changed, 155 insertions, 100 deletions

diff --git a/extras/HOME/.xmonad/startup b/extras/HOME/.xmonad/startup
index 25df7d1..59621af 100755
--- a/extras/HOME/.xmonad/startup
+++ b/extras/HOME/.xmonad/startup
@@ -4,6 +4,10 @@ common() {
   # Startup commands common to all the hosts.
   xsetroot -cursor_name left_ptr
   xset r rate 200 60
+
+  xrdb "$HOME/.Xresources"
+
+  rm -rf "$HOME/.xmonad/icons/cache/"
 }
 
 hostname_rahm1() {
@@ -31,7 +35,6 @@ hostname_photon() {
 
 common
 
-xrdb "$HOME/.Xresources"
 hostname_fn="hostname_$(cat /etc/hostname)"
 
 if [[ "$(type -t "$hostname_fn")" == function ]] ; then
diff --git a/package.yaml b/package.yaml
index e6e3648..bc8e530 100644
--- a/package.yaml
+++ b/package.yaml
@@ -14,9 +14,9 @@ dependencies:
   - filepath
   - process
   - containers
-  - cairo
   - bytestring
   - cryptohash
   - listsafe
   - X11
   - split
+  - mtl
diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index 853a885..eb33a5e 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -13,6 +13,7 @@ import XMonad.Layout.ThreeColumns
 import XMonad.Layout.Grid
 import XMonad.Layout.Dishes
 import XMonad.Layout.MosaicAlt
+import qualified XMonad.Layout.Dwindle as D
 import XMonad.Layout
 import XMonad.Layout.LayoutModifier
 import XMonad
@@ -27,12 +28,56 @@ myLayout =
       ModifiedLayout (HFlippable False) $
         spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ avoidStruts $
           spiral (6/7) |||
-          Tall 1 (3/100) (1/2) |||
-          ThreeCol 1 (3/100) (1/2) |||
+          ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2)) |||
+          ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2)) |||
           Full |||
           Grid |||
           Dishes 2 (1/6) |||
-          (MosaicAlt M.empty :: MosaicAlt Window)
+          (MosaicAlt M.empty :: MosaicAlt Window) |||
+          (D.Dwindle D.R D.CW 1.5 1.1)
+
+data ModifyDescription m l a = ModifyDescription m (l a)
+  deriving (Show, Read)
+
+data TallDescriptionModifier = TallDescriptionModifier
+  deriving (Show, Read)
+
+data ThreeColDescMod = ThreeColDescMod
+  deriving (Show, Read)
+
+class DescriptionModifier m l where
+  newDescription :: m -> l a -> String -> String
+
+instance (Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where
+  runLayout (W.Workspace t (ModifyDescription m l) a) rect = do
+    (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect
+    return (rects, fmap (ModifyDescription m) maybeNewLayout)
+
+  doLayout (ModifyDescription m l) a s = do
+    (rects, maybeNewLayout) <- doLayout l a s
+    return (rects, fmap (ModifyDescription m) maybeNewLayout)
+
+  pureLayout (ModifyDescription m l) a s = pureLayout l a s
+
+  emptyLayout (ModifyDescription m l) a = do
+    (rects, maybeNewLayout) <- emptyLayout l a
+    return (rects, fmap (ModifyDescription m) maybeNewLayout)
+
+  handleMessage (ModifyDescription m l) a = do
+    maybeNewLayout <- handleMessage l a
+    return (ModifyDescription m <$> maybeNewLayout)
+
+  pureMessage (ModifyDescription m l) a =
+    let maybeNewLayout = pureMessage l a in
+      ModifyDescription m <$> maybeNewLayout
+
+  description (ModifyDescription m l) = newDescription m l (description l)
+
+instance DescriptionModifier TallDescriptionModifier Tall where
+  newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")"
+
+instance DescriptionModifier ThreeColDescMod ThreeCol where
+  newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")"
 
 data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable)
 
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)
diff --git a/stack.yaml b/stack.yaml
index e8e9582..81e3e0b 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -71,7 +71,3 @@ packages:
 #
 # Allow a newer minor version of GHC than the snapshot specifies
 # compiler-check: newer-minor
-
-extra-deps:
-  - gtk2hs-buildtools-0.13.8.1@sha256:78e0dc8e3ae2d3ebe01d8d65e5f3f463102ea13a66be6bb1bff7a20a3d93486d,5238
-  - cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa8779b23b2b67a9,4075