4 files changed, 64 insertions, 72 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 0ff8da3..5284a9d 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -55,7 +55,7 @@ import Rahm.Desktop.Logger
 import Rahm.Desktop.RebindKeys
 import Rahm.Desktop.Swallow
 import Rahm.Desktop.Layout.Hole (toggleHole)
-import Rahm.Desktop.Layout.Pop (PopMessage(..))
+import Rahm.Desktop.Layout.Pop (togglePop)
 import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically)
 import Rahm.Desktop.Layout.Rotate (rotateLayout)
 import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward)
@@ -534,7 +534,7 @@ keymap = runKeys $ do
         bind xK_z $ do
           noMod -|- justMod $
             doc "Toggle zoom on the current window." $
-            sendMessage TogglePop
+            sendMessage togglePop
 
         -- Z is reserved to create sub keybindings to do various things.
         -- I don't really use these at the moment.
@@ -546,7 +546,7 @@ keymap = runKeys $ do
     -- modifier.
     shiftMod $
       doc "Toggle zoom on the current window." $
-      sendMessage TogglePop
+      sendMessage togglePop
 
   bind xF86XK_Calculator $ do
     noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3"
@@ -636,7 +636,7 @@ mouseMap = runButtons $ do
 
 
       bind button14 $ do
-        noMod $ noWindow $ click >> sendMessage TogglePop
+        noMod $ noWindow $ click >> sendMessage togglePop
 
       bind button15 $ do
         noMod $ noWindow $ spawnX "pavucontrol"
diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs
index fcf7d25..aeceff9 100644
--- a/src/Rahm/Desktop/Layout.hs
+++ b/src/Rahm/Desktop/Layout.hs
@@ -39,7 +39,7 @@ import qualified XMonad.StackSet as W
 
 withSpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True
 mods =
-  withSpacing . reinterpretResize . poppable . flippable . rotateable . hole
+  withSpacing . poppable . flippable . rotateable . hole
 
 myLayout =
   fullscreenFull $
diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs
index c3a1918..7e628fc 100644
--- a/src/Rahm/Desktop/Layout/LayoutDraw.hs
+++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs
@@ -11,7 +11,7 @@ import Control.Monad.Writer (execWriter, tell)
 import Data.Foldable (find)
 import Data.Maybe (fromMaybe)
 import Rahm.Desktop.Hash (quickHash)
-import Rahm.Desktop.Layout.Pop (PopMessage(..))
+import Rahm.Desktop.Layout.Pop (setPop)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath ((</>))
 import Text.Printf (printf)
@@ -49,7 +49,7 @@ drawLayout = do
     -- Gotta reset the layout to a consistent state.
     layout' <- foldM (flip ($)) layout $ [
          handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0,
-         handleMessage' Unpop
+         handleMessage' $ setPop $ const False
       ]
       -- Add some changes for the Mosaic layout to handle so it get's a
       -- unique looking icon. (The default state is pretty boring).
diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs
index 037e664..7e3dbd1 100644
--- a/src/Rahm/Desktop/Layout/Pop.hs
+++ b/src/Rahm/Desktop/Layout/Pop.hs
@@ -8,7 +8,9 @@ module Rahm.Desktop.Layout.Pop (
   Poppable(..),
   PopMessage(..),
   poppable,
-  reinterpretResize) where
+  resizePop,
+  togglePop,
+  setPop) where
 
 import XMonad
 import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..))
@@ -17,7 +19,7 @@ import qualified XMonad.StackSet as W
 
 import Rahm.Desktop.Layout.ReinterpretMessage
 
-data Poppable a = Poppable {
+data Poppable (l :: * -> *) (a :: *) = Poppable {
     -- True if the current window is popped out or not.
     isPopped :: Bool
 
@@ -26,79 +28,69 @@ data Poppable a = Poppable {
 
     -- Fraction of the screen height around the window.
   , yFrac :: Float
+
+  , wrap :: l  a
   } deriving (Show, Read, Eq, Ord)
 
-instance Default (Poppable a) where
-  def = Poppable {
-      isPopped = False
-    , xFrac = 0.05
-    , yFrac = 0.05
-    }
-
--- Returns a modified layout that converts Resize (Shrink/Expand) into ResizePop
--- messages. Unfortunately this is required because a LayoutModifier has no way
--- to intercept messages and block them from propegating, which is pretty silly.
---
--- So, reinterpretResize will turn a Shrink/Expand into a ResizePop, this will
--- be consumed by the Poppable layout modifier. If the Poppable LayoutModifier
--- is not active, it will turn the ResizePop back into a Shrink/Expand and
--- forward it to the underlying layout.
-reinterpretResize ::
-  l a -> ModifiedLayout (ReinterpretMessage "ForPop") l a
-reinterpretResize = ModifiedLayout ReinterpretMessage
-
-poppable :: l a -> ModifiedLayout Poppable l a
-poppable = ModifiedLayout def
-
--- Message to control the state of the popped layouts modifier.
-data PopMessage = TogglePop | Pop | Unpop | ResizePop Float
-  deriving (Typeable, Show, Eq, Ord, Message)
-
-instance DoReinterpret "ForPop" where
-  reinterpretMessage _ (fromMessage -> Just mess) =
-    return $ Just $ SomeMessage $
-      case mess of
-        Shrink -> ResizePop (-0.05)
-        Expand -> ResizePop 0.05
-
-  reinterpretMessage _ _ = return Nothing
-
-instance (Eq a) => LayoutModifier Poppable a where
+data PopMessage where
+  PopMessage :: (forall l a. Poppable l a -> Poppable l a) -> PopMessage
+  deriving (Message)
+
+resizePop :: Float -> PopMessage
+resizePop f = PopMessage $ \(Poppable b x y l) -> 
+  Poppable b (g $ x + f) (g $ y + f) l
+  where
+    g = max 0 . min 0.45
+
+setPop :: (Bool -> Bool) -> PopMessage
+setPop f = PopMessage $ \(Poppable b x y l) -> Poppable (f b) x y l
+
+togglePop :: PopMessage
+togglePop = setPop not
+
+poppable :: l a -> Poppable l a
+poppable = Poppable False 0.05 0.05
 
+instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where
+  
   -- If the current layout is not popped, then just return what the underlying
   -- layout returned.
-  redoLayout Poppable { isPopped = False } _ _ returned =
-     return (returned, Nothing)
 
-  -- Can't do anything with an empty stack.
-  redoLayout _ _ Nothing returned = return (returned, Nothing)
-  
-  redoLayout self (Rectangle x y w h) (Just (W.focus -> focused)) returned =
-      return ((focused, newRect) : remaining, Nothing)
+  runLayout (W.Workspace
+              t
+              (Poppable True xs ys l)
+              a@(Just (W.focus -> focused)))
+            rect@(Rectangle x y w h) = do
+    (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect
+    return
+      ((focused, newRect) : filter ((/=focused) . fst) returned,
+       Poppable True xs ys <$> maybeNewLayout)
     where
-      remaining = filter ((/=focused) . fst) returned
-      wp = floor $ fromIntegral w * xFrac self
-      hp = floor $ fromIntegral h * yFrac self
+      wp = floor $ fromIntegral w * xs
+      hp = floor $ fromIntegral h * ys
       newRect = Rectangle
         (x + wp)
         (y + hp)
         (w - fromIntegral (wp * 2))
         (h - fromIntegral (hp * 2))
 
-  -- Handle the Pop messages associated with this layout.
-  handleMessOrMaybeModifyIt self (fromMessage -> Just mess) =
-    return $ Just $ case mess of
-      TogglePop -> Left $ self { isPopped = not (isPopped self) }
-      Pop -> Left $ self { isPopped = True }
-      Unpop -> Left $ self { isPopped = False }
-      ResizePop amt | isPopped self ->
-          Left $ self {
-            xFrac = guard (xFrac self + amt),
-            yFrac = guard (yFrac self + amt)
-          }
-      ResizePop amt -> Right $ SomeMessage $
-        if amt > 0 then Expand else Shrink
-    where
-      guard = min 0.45 . max 0
-
-  handleMessOrMaybeModifyIt _ _ = return Nothing
+  -- If the pop is not active, just delegate to the underlying layout.
+  runLayout (W.Workspace t (Poppable b x y l) a) rect = do
+    (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect
+    return (rects, Poppable b x y <$> maybeNewLayout)
+
+  -- If the message is a PopMessage, handle that here.
+  handleMessage p (fromMessage -> Just (PopMessage f)) =
+    return $ Just $ f p
+
+  -- Intercept Shrink/Expand message if the pop is active, and resize the
+  -- pop size.
+  handleMessage p (fromMessage -> Just mess) | isPopped p =
+    case mess of
+      Shrink -> handleMessage p (SomeMessage $ resizePop 0.025)
+      Expand -> handleMessage p (SomeMessage $ resizePop (-0.025))
+
+  -- By default just pass the message to the underlying layout.
+  handleMessage (Poppable b x y l) mess = do
+    maybeNewLayout <- handleMessage l mess
+    return (Poppable b x y <$> maybeNewLayout)