Add LayoutModifier that ollows windows to be zoomed on with modm-z. When this happens, the window will float in the middle of the screen.

3 files changed, 71 insertions, 54 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index b710acf..a397467 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,5 +1,6 @@
 module Internal.Keys where
 
+import Internal.Layout
 import Text.Printf
 import Internal.PromptConfig
 import Data.List
@@ -107,12 +108,13 @@ newKeys =
 
         , ((modm .|. shiftMask, xK_bracketleft), sendMessage (IncMasterN (-1)))
         , ((modm .|. shiftMask, xK_bracketright), sendMessage (IncMasterN 1))
-        , ((modm, xK_bracketleft), sendMessage Shrink)
-        , ((modm, xK_bracketright), sendMessage Expand)
+        , ((modm, xK_bracketleft), sendMessage ShrinkZoom)
+        , ((modm, xK_bracketright), sendMessage ExpandZoom)
 
         , ((modm, xK_space), sendMessage NextLayout)
 
         , ((modm, xK_q), spawn "xmonad --recompile && xmonad --restart")
+        , ((modm, xK_z), sendMessage ToggleZoom)
         ]
 
 mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> Map (KeyMask, KeySym) (X ())
diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index bdac6d1..57102c6 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -1,59 +1,77 @@
 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
 module Internal.Layout where 
 
+import Control.Applicative
+import XMonad.Layout.Spacing
+import Data.List
 import XMonad.Layout.Spiral
 import XMonad.Layout.ThreeColumns
 import XMonad.Layout.Grid
 import XMonad.Layout
+import XMonad.Layout.LayoutModifier
 import XMonad
+import XMonad.Core
 
 import qualified XMonad.StackSet as W
 
 myLayout =
-    spiral (6/7) |||
-    Tall 1 (3/100) (1/2) |||
-    ThreeCol 1 (3/100) (1/2) |||
-    Grid
-
-data Manual = Manual RectSet
-
-data RectSet =
-      RectSet {
-                rectSetWidth :: Float -- 0.0 - 1.0 fraction of the float.
-              , rectSetHeight :: Float
-              , subRects :: RectChildren
-              }
-
-data RectChildren =
-      Leaf { boundWindow :: Maybe Window } |
-      Children { children :: [RectSet] }
-
-data RectSetD =
-    LeafD {
-      boundWindowD :: Maybe Window
-    , parent :: RectParentD
-    } |
-    Parent { self :: RectParentD }
-
-data RectParentD =
-    RectParentD {
-      currentChild :: RectSetD
-
-    , leftChildren :: [RectSetD]
-    , rightChildren :: [RectSetD]
-
-    , rectSetDWidth :: Float
-    , rectSetDHeight :: Float
-
-    , parentRect :: Maybe RectParentD
-    }
-
-derive :: RectSet -> Window -> Maybe RectSetD
-derive (RectSet w h sub) = undefined
-
-getWindowRect :: Window -> X (Maybe Rectangle)
-getWindowRect win = withDisplay $ \dpy -> do
-    (_, x, y, w, h, bw, _) <- liftIO $ getGeometry dpy win
-    catchX
-      (return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw))
-      (return Nothing)
+  ModifiedLayout (Zoomable False 0.05 0.05) $
+    spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $
+      spiral (6/7) |||
+      Tall 1 (3/100) (1/2) |||
+      ThreeCol 1 (3/100) (1/2) |||
+      Grid
+
+data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable)
+
+instance Message ResizeZoom where
+
+data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window.
+  deriving (Show, Read)
+
+data ToggleZoom = ToggleZoom
+  deriving (Typeable)
+
+data AlterZoom = AlterZoom Float Float
+  deriving (Typeable)
+
+instance Message ToggleZoom where
+
+instance Message AlterZoom where
+
+instance (Eq a) => LayoutModifier Zoomable a where
+  redoLayout (Zoomable doit ws hs) (Rectangle x y w h) stack returned =
+    if doit
+      then
+        let focused = W.focus <$> stack
+            (zoomed, rest) = partition ((==focused) . Just . fst) returned
+         in case zoomed of
+              [] -> return (rest, Nothing)
+              ((fwin, _):_) ->  return $ ((fwin, Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2))) : rest, Nothing)
+
+      else return (returned, Nothing)
+    where
+      wp = floor $ (fromIntegral w) * ws
+      hp = floor $ (fromIntegral h) * hs
+
+  handleMessOrMaybeModifyIt self@(Zoomable showing sw sh) mess =
+    return $
+      (handleResize <$> fromMessage mess)
+        <|> ((Left . handleZoom) <$> fromMessage mess)
+      where
+        handleResize r =
+          if showing
+            then Left $ Zoomable showing (guard $ sw + d) (guard $ sh + d)
+            else Right $ case r of
+                   ShrinkZoom -> SomeMessage Shrink
+                   ExpandZoom -> SomeMessage Expand
+
+          where d = (case r of
+                      ShrinkZoom -> -1
+                      ExpandZoom -> 1) * 0.02
+
+        handleZoom ToggleZoom = Zoomable (not showing) sw sh
+
+        guard f | f > 1 = 1
+                | f < 0 = 0
+                | otherwise = f
diff --git a/src/Main.hs b/src/Main.hs
index acde5a2..d80666a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -31,11 +31,8 @@ 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
-       , startupHook = do
-           spawn fp
+       , layoutHook = myLayout
+       , startupHook = spawn fp
        , manageHook = composeAll [
            isFullscreen --> doFullFloat
          , className =? "Tilda" --> doFloat