Change mosaic to respond to multiple different kinds of messages

3 files changed, 85 insertions, 5 deletions

diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index a1aeb17..fba1254 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -1,8 +1,9 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-}
 module Internal.Layout where
 
 import GHC.TypeLits
 
+import Data.Proxy (Proxy(..))
 import Internal.CornerLayout (Corner(..))
 import Control.Arrow (second)
 import XMonad.Hooks.ManageDocks
@@ -25,19 +26,20 @@ import XMonad.Core
 import XMonad.Layout.NoBorders (smartBorders, noBorders)
 
 import Internal.LayoutZipper
+import Internal.Windows
 
 import qualified Data.Map as M
 import qualified XMonad.StackSet as W
 
+myLayout :: _
 myLayout =
   fullscreenFull $
     avoidStruts $
       spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $
         layoutZipper $
           mods (spiral (6/7)) |:
-          mods (MosaicAlt M.empty :: MosaicAlt Window) |:
-          mods ((Corner (3/4) (3/100) :: Corner Window)) |:
-
+          mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |:
+          mods (Corner (3/4) (3/100)) |:
           mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |:
           mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |:
           mods Grid |:
@@ -45,6 +47,76 @@ myLayout =
           mods (D.Dwindle D.R D.CW 1.5 1.1) |:
           nil
 
+-- This is a type class that defines how to reinterpret a message. One can think
+-- of this as a kind of type-level function. It lets one associate a function
+-- (reinterpretMessage) with a type construct, which for the case below is a
+-- Symbol.
+--
+-- It would be nice to attach this function to the LayoutModifier directly as a
+-- value, however LayoutModifiers must be Show-able and Read-able and functions
+-- are not. However encoding in the typesystem itsef which function is to be
+-- called is the best alternative I have.
+class DoReinterpret (k :: t) where
+  reinterpretMessage ::
+    Proxy k -> SomeMessage -> X (Maybe SomeMessage)
+
+-- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages
+-- intended to modify the master space and instead have those messages expand
+-- and shrink the current window.
+--
+-- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system
+-- hacking one can do in Haskell.
+instance DoReinterpret "ForMosaic" where
+  
+  -- IncMaster message
+  reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do
+    (fmap $ SomeMessage .
+      (if n > 0
+        then expandWindowAlt
+        else shrinkWindowAlt)) <$> getFocusedWindow
+  
+  -- ResizeMaster message
+  reinterpretMessage _ (fromMessage -> Just m) = do
+    (fmap $ SomeMessage .
+      (case m of
+        Expand -> expandWindowAlt
+        Shrink -> shrinkWindowAlt)) <$> getFocusedWindow
+
+  -- Messages that don't match the above, just leave it unmodified.
+  reinterpretMessage _ m = return (Just m)
+
+-- Data construct for association a DoReinterpret function with a concrete
+-- construct that can be used in the LayoutModifier instance.
+--
+-- It wolud be nice to have ReinterpretMessage hold the function as a value
+-- rather than delegate to this kind-instance, however, it won't work because
+-- LayoutModifiers have to be Read-able and Show-able, and functions are neither
+-- of those, so a value-level function may not be a member of a LayoutModifier,
+-- thus I have to settle for delegating to a hard-coded instance using
+-- type-classes.
+data ReinterpretMessage k a = ReinterpretMessage
+  deriving (Show, Read)
+
+-- Instance for ReinterpretMessage as a Layout modifier.
+instance (DoReinterpret k) =>
+      LayoutModifier (ReinterpretMessage k) a where 
+
+  handleMessOrMaybeModifyIt self message = do
+
+    -- Delegates to the reinterpretMessage function associatied with the
+    -- type-variable k.
+    newMessage <- reinterpretMessage (ofProxy self) message
+    case newMessage of
+      Just m -> return $ Just $ Right m
+      Nothing -> return $ Just $ Left self
+    where
+      -- ofProxy just provides reifies the phantom type k so the type system can
+      -- figure out what instance to go to.
+      ofProxy :: ReinterpretMessage k a -> Proxy k
+      ofProxy _ = Proxy
+
+modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a
+modifyMosaic = ModifiedLayout ReinterpretMessage
 
 mods =
   ModifiedLayout (Zoomable False 0.05 0.05) .
@@ -52,6 +124,7 @@ mods =
     ModifiedLayout (HFlippable False) .
     ModifiedLayout (Rotateable False)
 
+
 data ModifyDescription m l a = ModifyDescription m (l a)
   deriving (Show, Read)
 
diff --git a/src/Internal/LayoutZipper.hs b/src/Internal/LayoutZipper.hs
index 136b913..e34a078 100644
--- a/src/Internal/LayoutZipper.hs
+++ b/src/Internal/LayoutZipper.hs
@@ -42,12 +42,15 @@ data NavigateLayout =
           }
           deriving (Typeable)
 
+-- NavigateLayout instance to move to the next layout, circularly.
 toNextLayout :: NavigateLayout
 toNextLayout = SetLayout (+1) True
 
+-- NavigateLayout instance to move to the previous layout, circularly.
 toPreviousLayout :: NavigateLayout
 toPreviousLayout = SetLayout (\x -> x - 1) True
 
+-- NavigateLayotu instance to move to the first layout.
 toFirstLayout :: NavigateLayout
 toFirstLayout = SetLayout (const 0) True
 
diff --git a/src/Internal/Windows.hs b/src/Internal/Windows.hs
index 98baa51..45fea95 100644
--- a/src/Internal/Windows.hs
+++ b/src/Internal/Windows.hs
@@ -3,7 +3,7 @@ module Internal.Windows where
 import XMonad (windowset, X, Window, get)
 
 import Control.Applicative ((<|>))
-import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), integrate, integrate', allWindows)
+import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows)
 import Data.Maybe (listToMaybe, catMaybes)
 import qualified Data.Map as Map
 
@@ -52,6 +52,10 @@ forAllWindows fn = do
   stackSet <- windowset <$> get
   mapM_ fn (allWindows stackSet)
 
+getFocusedWindow :: X (Maybe Window)
+getFocusedWindow = do
+  (peek . windowset) <$> get
+
 {- Finds a Window and returns the screen its on and the workspace its on.
  - Returns nothing if the window doesn't exist.
  -