Clean up LayoutDraw.hs

4 files changed, 110 insertions, 91 deletions

diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index 06ac7d6..cb8c19b 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -97,14 +97,19 @@ data HFlipLayout = HFlipLayout deriving (Typeable)
 data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window.
   deriving (Show, Read)
 
-data ToggleZoom = ToggleZoom
+-- Toggles if the current window should be zoomed or not. Set the boolean
+-- to set the zoom.
+data ZoomModifier =
+       ToggleZoom |
+       Zoom |
+       Unzoom
   deriving (Typeable)
 
 instance Message FlipLayout where
 
 instance Message HFlipLayout where
 
-instance Message ToggleZoom where
+instance Message ZoomModifier where
 
 instance (Eq a) => LayoutModifier Flippable a where
   pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned =
@@ -179,6 +184,8 @@ instance (Eq a) => LayoutModifier Zoomable a where
                       ExpandZoom -> 1) * 0.02
 
         handleZoom ToggleZoom = Zoomable (not showing) sw sh
+        handleZoom Zoom = Zoomable True sw sh
+        handleZoom Unzoom = Zoomable False sw sh
 
         guard f | f > 1 = 1
                 | f < 0 = 0
diff --git a/src/Internal/LayoutDraw.hs b/src/Internal/LayoutDraw.hs
index 78ff59d..8b029bd 100644
--- a/src/Internal/LayoutDraw.hs
+++ b/src/Internal/LayoutDraw.hs
@@ -1,45 +1,61 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
 ScopedTypeVariables, BangPatterns #-}
-module Internal.LayoutDraw where
+module Internal.LayoutDraw (drawLayout) 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 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
-import Internal.Hash
-
-showLayout :: X (Bool, String, Maybe String)
-showLayout = do
-    winset <- gets windowset
-    let layout = S.layout . S.workspace . S.current $ winset
-
-    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)
 
+import Control.Arrow (second)
+import Control.Concurrent (threadDelay)
+import Control.Exception (handle)
+import Control.Monad.Writer (execWriter, tell)
+import Data.Foldable (find)
+import Data.Maybe (fromMaybe)
+import Internal.Hash (quickHash)
+import Internal.Layout (ZoomModifier(..))
+import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.FilePath ((</>))
+import Text.Printf (printf)
+import XMonad.Layout.Spacing (SpacingModifier(..), Border(..))
+
+import XMonad (X,
+               Rectangle(..),
+               Dimension,
+               LayoutClass,
+               Message,
+               Window,
+               SomeMessage(..))
+
+import qualified XMonad as X
+import qualified XMonad.StackSet as S
+
+-- Draws and returns an XPM for the current layout.
+--
+-- Returns
+--  - Bool   - true if the xpm has already been written, and is thus cached.
+--  - String - description of the current layout
+--  - String - the text to send to XMobar
+--
+-- This function actually runs the current layout's doLayout function to
+-- generate the XPM, so it's completely portable to all layouts.
+--
+-- Note this function is impure and running the layout to create the XPM is also
+-- impure. While in-practice most layouts are pure, it should be kept in mind.
+drawLayout :: X (Bool, String, String)
+drawLayout = do
+    winset <- X.gets X.windowset
+    let layout = S.layout $ S.workspace $ S.current $ winset
+
+    -- Gotta reset the layout to a consistent state.
+    layout' <- foldM (flip ($)) layout $ [
+         handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0,
+         handleMessage' $ Unzoom
+       ]
+
+    (cached, xpm) <- drawXpmIO layout'
+
+    return $ (cached, X.description layout, printf "<icon=%s/>" xpm)
+
+-- Returns true if a point is inside a rectangle (inclusive).
 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'
@@ -47,17 +63,29 @@ pointInRect (x, y) (Rectangle x' y' w h) =
     fi :: (Integral a, Num b) => a -> b
     fi = fromIntegral
 
+-- Scale factory. Scaling the rectangles before writing the XPM helps to reduce
+-- noise from things like AvoidStruts, as there is unfortunately no way to force
+-- avoid struts to be off, one can only toggle it.
 sf :: (Integral a) => a
 sf = 1024
 
+handleMessage' ::
+    (LayoutClass layout a, Message m) => m -> layout a -> X (layout a)
+handleMessage' message layout  = do
+  fromMaybe layout <$> X.handleMessage layout (SomeMessage message)
+
+-- Creates the XPM for the given layout and returns the path to it.
+--
+-- This function does run doLayout on the given layout, and that should be
+-- accounted for.
 drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String)
 drawXpmIO l = do
-  dir <- getXMonadDir
+  dir <- X.getXMonadDir
 
-  let shrinkAmt = 4
+  let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps.
 
-  let (w, h) = (56 + shrinkAmt, 28 + shrinkAmt)
-  let descr = description l
+  let (w, h) = (56, 24)
+  let descr = X.description l
   let iconCacheDir = dir </> "icons" </> "cache"
   let iconPath = iconCacheDir </> (quickHash descr ++ ".xpm")
 
@@ -66,14 +94,14 @@ drawXpmIO l = do
         "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ]
 
   (rects', _) <-
-    runLayout
-      (Workspace "0" l (differentiate [1 .. 7]))
-      (Rectangle 0 0 (w * sf) (h * sf))
+    X.runLayout
+      (S.Workspace "0" l (S.differentiate [1 .. 5]))
+      (Rectangle 0 0 ((w + shrinkAmt) * sf) ((h + shrinkAmt) * 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
+  X.liftIO $ do
     exists <- doesFileExist iconPath
     createDirectoryIfMissing True iconCacheDir
 
@@ -83,34 +111,37 @@ drawXpmIO l = do
 
     return (exists, iconPath)
 
-drawXpm :: (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String
+--
+-- Create's an XPM, purely. Returns a string with the XPM contents.
+-- Takes as arguments
+-- 
+--   - dimensions of the icon.
+--   - list of (color, rectangle) pairs.
+--   - The amount to shrink the windows by for those pretty gaps.
+--
+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)
+    tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1)
 
-    let zipRects = (zip ['A' .. 'Z'] rects)
+    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
+    forM_ [0 .. h - 1] $ \y -> do
       tell "\""
-      forM_ [0 .. w - 1 - shrinkAmt] $ \x -> 
+      forM_ [0 .. w - 1] $ \x -> 
         (case find (matches x y) zipRects of
           Nothing -> tell "%"
           Just (chr, _) -> tell [chr])
       tell "\""
       when (y /= h - 1 - shrinkAmt) (tell ",")
       tell "\n"
-    tell "};"
+    tell "};\n"
 
   where
     matches x y (_, (_, r)) = pointInRect (x, y) r
diff --git a/src/Internal/XMobarLog.hs b/src/Internal/XMobarLog.hs
index b36ba27..d0ff8f8 100644
--- a/src/Internal/XMobarLog.hs
+++ b/src/Internal/XMobarLog.hs
@@ -5,7 +5,7 @@ import Control.Monad.Writer (tell, execWriter)
 import Data.List (sortBy)
 import Data.Maybe (mapMaybe)
 import Data.Ord (comparing)
-import Internal.LayoutDraw (showLayout)
+import Internal.LayoutDraw (drawLayout)
 import System.IO (Handle, hSetEncoding, hPutStrLn, utf8)
 import XMonad.Util.NamedWindows (getName)
 import XMonad.Util.Run (spawnPipe)
@@ -20,6 +20,10 @@ data XMobarLog = XMobarLog Handle
 
 -- The log hook for XMobar. This is a custom log hook that does not use any
 -- of the Xmonad dynamic log libraries.
+--
+-- This is because the given dynamic log libraries don't handle unicode properly
+-- and this has been causing issues. It is also more flexible and frankly easier
+-- to just DIY.
 
 spawnXMobar :: IO XMobarLog
 spawnXMobar = do
@@ -27,9 +31,11 @@ spawnXMobar = do
   hSetEncoding pipe utf8
   return (XMobarLog pipe)
 
+
+-- XMonad Log Hook meant to be used with the XMonad config logHook.
 xMobarLogHook :: XMobarLog -> X ()
 xMobarLogHook (XMobarLog xmproc) = do
-  (_, _, layout) <- showLayout
+  (_, _, layoutXpm) <- drawLayout
 
   winset <- X.gets X.windowset
   title <- maybe (pure "") (fmap show . getName) . S.peek $ winset
@@ -37,7 +43,7 @@ xMobarLogHook (XMobarLog xmproc) = do
 
   X.liftIO $ do
     hPutStrLn xmproc $ trunc 80 $ execWriter $ do
-      mapM_ tell layout
+      tell layoutXpm
       tell $ "<fc=#404040> │ </fc>"
 
       forM_ wss $ \(t, name) -> do
@@ -52,6 +58,8 @@ xMobarLogHook (XMobarLog xmproc) = do
       tell $ title
       tell $ "</fn></fc>"
 
+-- Truncate an XMobar string to the provided number of _visible_ characters.
+-- This is to keep long window titles from overrunning the whole bar.
 trunc :: Int -> String -> String
 trunc amt str = reverse $ trunc' False amt str []
   where
@@ -69,6 +77,8 @@ trunc amt str = reverse $ trunc' False amt str []
                 3 -> trunc' False 0 as ("..." ++ acc)
                 _ -> trunc' False (amt - 1) as (a : acc)
 
+-- Returns all the workspaces with a stack on them and if that workspace is
+-- Visible, Current or Hidden.
 getWorkspaces :: (Ord i) => S.StackSet i l a sid sd -> [(WorkspaceState, i)]
 getWorkspaces (S.StackSet (S.Screen cur _ _) vis hi _) =
   sortBy (comparing snd) $
diff --git a/src/Main.hs b/src/Main.hs
index 86bc2dc..0d49e21 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,34 +1,5 @@
 import XMonad
 
--- import Control.Concurrent
--- import Control.Exception
--- import Control.Monad
--- import Control.Monad (when)
--- import Control.Monad.Writer
--- import Data.Ord
--- import Data.List (partition, isPrefixOf, sortBy)
--- import Data.List.Split
--- import Data.Maybe
--- import Internal.Keys
--- import Internal.Layout
--- import Internal.LayoutDraw
--- import Internal.XMobarLog
--- import System.Directory
--- import System.FilePath
--- import System.IO
--- import System.Process
--- import Text.Printf
--- import XMonad.Actions.WindowNavigation
--- import XMonad.Hooks.DynamicLog
--- import XMonad.Hooks.EwmhDesktops
--- import XMonad.Hooks.ManageDocks
--- import XMonad.Hooks.ManageHelpers
--- import XMonad.Layout.IndependentScreens
--- import XMonad.Layout.Spacing
--- import XMonad.Util.CustomKeys
--- import XMonad.Util.NamedWindows
--- import XMonad.Util.Run (spawnPipe)
-
 import XMonad.Hooks.ManageDocks (docks)
 import System.Directory (getHomeDirectory)
 import System.FilePath ((</>))