Add ability to show layout format!

6 files changed, 150 insertions, 18 deletions

diff --git a/package.yaml b/package.yaml
index 056890d..6517d50 100644
--- a/package.yaml
+++ b/package.yaml
@@ -14,3 +14,6 @@ dependencies:
   - filepath
   - process
   - containers
+  - cairo
+  - bytestring
+  - cryptohash
diff --git a/src/Internal/Hash.hs b/src/Internal/Hash.hs
new file mode 100644
index 0000000..63f6043
--- /dev/null
+++ b/src/Internal/Hash.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Internal.Hash where
+
+import Numeric (showHex)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BC
+import qualified Crypto.Hash.SHA1 as SHA1
+
+quickHash :: String -> String
+quickHash str =
+    concatMap (flip showHex "") $ BS.unpack (SHA1.hash $ BC.pack str)
diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index 2b35dbc..4cfe3d3 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -10,11 +10,11 @@ import XMonad
 import qualified XMonad.StackSet as W
 
 myLayout =
-  spiral (6/7) |||
-  Center 0.7 |||
-  Tall 1 (3/100) (1/2) |||
-  ThreeCol 1 (3/100) (1/2) |||
-  Grid
+    spiral (6/7) |||
+    Center 0.7 |||
+    Tall 1 (3/100) (1/2) |||
+    ThreeCol 1 (3/100) (1/2) |||
+    Grid
 
 
 data Center a =
@@ -23,9 +23,8 @@ data Center a =
   }
   deriving (Show, Read)
 
-instance LayoutClass Center a where
-  doLayout l (Rectangle x y w h) stack =
-    
+instance (Show a) => LayoutClass Center a where
+  doLayout l r@(Rectangle x y w h) stack = do
     let wf = fromIntegral w
         hf = fromIntegral h
         x' = (wf - wf * proportion l) / 2
@@ -43,14 +42,16 @@ instance LayoutClass Center a where
 
         portion = fromIntegral $ nWin `div` 6
         winRem = fromIntegral $ nWin `mod` 6
-    in
-      return $
-        (zip (W.integrate stack) (
-          (:) middleRect $
-             (divRect topRect (portion * 2))
-             ++ (divRect rightRect portion)
-             ++ (divRect bottomRect (portion * 2))
-             ++ (divRect leftRect (portion + winRem))), Just l)
+      in do
+      let ret =
+            (zip (W.integrate stack) (
+              (:) middleRect $
+                 (divRect topRect (portion * 2))
+                 ++ (divRect rightRect portion)
+                 ++ (divRect bottomRect (portion * 2))
+                 ++ (divRect leftRect (portion + winRem))), Just l)
+      liftIO $ writeFile "/tmp/wtf.txt" (description l ++ ": " ++ show (fst ret))
+      return ret
    where
     divRect (Rectangle x y w h) n =
       if h > w
diff --git a/src/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs
new file mode 100644
index 0000000..3b3d3f0
--- /dev/null
+++ b/src/Internal/LayoutDraw.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
+ScopedTypeVariables #-}
+module Internal.LayoutDraw where
+
+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 System.FilePath
+import XMonad
+import XMonad.StackSet as S
+import Data.Maybe
+import System.Directory
+
+import Internal.Layout
+import Internal.Hash
+
+showLayout :: X (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
+
+drawPng :: (LayoutClass layout Window) => layout Window -> X String
+drawPng l = do
+    dir <- getXMonadDir
+    let sixWindows = [1..(4 :: Window)]
+    let stack = differentiate sixWindows
+    (rects, _) <-
+          runLayout (Workspace "0" l stack) (Rectangle 0 0 (64 * 30) (32 * 30))
+    return ()
+
+    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.6, 0.6, 1.0),
+           (0.5, 0.5, 1.0),
+           (0.4, 0.4, 1.0),
+           (0.3, 0.3, 1.0),
+           (0.2, 0.2, 1.0),
+           (0.1, 0.1, 1.0),
+           (0.0, 0.0, 1.0)
+          ]
+
+    exists <- liftIO $ doesFileExist filepathXpm
+    when (not exists) $
+      liftIO $ do
+        withImageSurface FormatARGB32 64 32 $ \surface -> do
+            renderWith surface $ do
+              setLineCap LineCapButt
+              setLineJoin LineJoinMiter
+
+              forM_ (zip (map (second padR) 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
+
+            _ <- readProcessWithExitCode
+              "/usr/bin/convert"
+              [filepathPng, filepathXpm]
+              ""
+            return ()
+
+    return filepathXpm
+    where
+      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
diff --git a/src/Main.hs b/src/Main.hs
index 98fb384..77a53a0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -18,6 +18,7 @@ main = do
   -- Execute some commands.
   homeDir <- getHomeDirectory
   let fp = homeDir </> ".xmonad" </> "startup"
+  let theLayout = myLayout
 
   config <-
     applyKeys $ def
@@ -27,8 +28,10 @@ main = do
        , keys = \config -> mempty
        , focusedBorderColor = "#FFFFFF"
        , normalBorderColor = "#000000"
-       , layoutHook = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $
-                      myLayout
+       , layoutHook =
+              spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $
+              InterceptLayout $
+                myLayout
        , startupHook = do
            spawn fp
        , manageHook = composeAll [
@@ -39,6 +42,7 @@ main = do
          , className =? "gnubby_ssh_prompt" --> doFloat
          ]
        }
+
   let toggleStructsKey XConfig {XMonad.modMask = modMask} = (modMask, xK_b)
 
   xmonad =<<
@@ -54,6 +58,7 @@ main = do
                       (printf "<fn=1>%s</fn>" :: String -> String)
 
                , ppSep = xmobarColor "#404040" "" "   ────   "
+               , ppExtras = [showLayout]
                }
       toggleStructsKey
       config { modMask = mod4Mask }
diff --git a/stack.yaml b/stack.yaml
index e42fa74..de1a6f8 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -44,6 +44,9 @@ packages:
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
 # extra-deps: []
+extra-deps:
+  - cairo-0.13.8.0@sha256:9b64a376ebaa4f153bba5866a32291fd4bed48147009cce9158ce6533928eba8,4075 
+  - gtk2hs-buildtools-0.13.8.0@sha256:132f38155fc677430a47ea750918973161c876fb6f281d342ac2f07eb99229ce,5238
 
 # Override default flag values for local packages and extra-deps
 # flags: {}