Rename LayoutZipper to LayoutList. Add more utils for handling a selector

3 files changed, 84 insertions, 50 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index d340062..01e438c 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -46,7 +46,7 @@ import XMonad.Actions.SpawnOn as SpawnOn
 import qualified Data.Map as Map
 import qualified XMonad.StackSet as W
 
-import Internal.LayoutZipper
+import Internal.LayoutList
 import Internal.MouseMotion
 import Internal.Windows
 import Internal.Lib
diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs
index 562f947..6c78c70 100644
--- a/src/Internal/Layout.hs
+++ b/src/Internal/Layout.hs
@@ -25,7 +25,7 @@ import XMonad
 import XMonad.Core
 import XMonad.Layout.NoBorders (smartBorders, noBorders)
 
-import Internal.LayoutZipper
+import Internal.LayoutList
 import Internal.Windows
 
 import qualified Data.Map as M
@@ -36,9 +36,9 @@ myLayout =
     avoidStruts $
       spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $
         layoutZipper $
-          mods (spiral (6/7)) |:
+          mods (reinterpretIncMaster $ spiral (6/7)) |:
           mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |:
-          mods (Corner (3/4) (3/100)) |:
+          mods (reinterpretIncMaster $ 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 |:
@@ -69,14 +69,14 @@ instance DoReinterpret "ForMosaic" where
   
   -- IncMaster message
   reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do
-    (fmap $ SomeMessage .
+    fmap (SomeMessage .
       (if n > 0
         then expandWindowAlt
         else shrinkWindowAlt)) <$> getFocusedWindow
   
   -- ResizeMaster message
   reinterpretMessage _ (fromMessage -> Just m) = do
-    (fmap $ SomeMessage .
+    fmap (SomeMessage .
       (case m of
         Expand -> expandWindowAlt
         Shrink -> shrinkWindowAlt)) <$> getFocusedWindow
@@ -84,6 +84,14 @@ instance DoReinterpret "ForMosaic" where
   -- Messages that don't match the above, just leave it unmodified.
   reinterpretMessage _ m = return (Just m)
 
+instance DoReinterpret "IncMasterToResizeMaster" where
+  reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) =
+    return $ Just $
+      if n > 0
+        then SomeMessage Expand
+        else SomeMessage Shrink
+  reinterpretMessage _ m = return (Just m)
+
 -- Data construct for association a DoReinterpret function with a concrete
 -- construct that can be used in the LayoutModifier instance.
 --
@@ -117,6 +125,10 @@ instance (DoReinterpret k) =>
 modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a
 modifyMosaic = ModifiedLayout ReinterpretMessage
 
+reinterpretIncMaster ::
+  l a -> ModifiedLayout (ReinterpretMessage "IncMasterToResizeMaster") l a
+reinterpretIncMaster = ModifiedLayout ReinterpretMessage
+
 mods =
   ModifiedLayout (Zoomable False 0.05 0.05) .
     ModifiedLayout (Flippable False) .
diff --git a/src/Internal/LayoutZipper.hs b/src/Internal/LayoutList.hs
index 7fd4a5f..2405f71 100644
--- a/src/Internal/LayoutZipper.hs
+++ b/src/Internal/LayoutList.hs
@@ -9,8 +9,8 @@
  - The indexing uses a type-safe zipper to keep track of the currently-selected
  - layout.
  -}
-module Internal.LayoutZipper (
-  LayoutZipper,
+module Internal.LayoutList (
+  LayoutList,
   layoutZipper,
   LCons,
   LNil,
@@ -24,7 +24,7 @@ module Internal.LayoutZipper (
 import Control.Applicative ((<|>))
 import Data.Void
 import Control.Monad.Identity (runIdentity)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, fromJust)
 import Control.Arrow (second)
 import XMonad
 import qualified XMonad.StackSet as W
@@ -41,7 +41,7 @@ data LCons l t a = LCons (l a) (t a) deriving (Read, Show)
 -- These types can be composed to create what is effectively a bounded integer.
 -- I.e. there can be a type like
 --
--- Sel (Sel (Sel (Sel Zero)))
+-- Sel (Sel (Sel (Sel End)))
 --
 -- Such a type is equivalent to an integer bounded at 4, because this type can
 -- exist in no more than 4 states:
@@ -51,25 +51,27 @@ data LCons l t a = LCons (l a) (t a) deriving (Read, Show)
 -- Skip (Skip Sel)
 -- Skip (Skip (Skip Sel))
 --
--- Note that a type (Sel Zero) can only be in the Sel as Zero may not be
+-- Note that a type (Sel End) can only be in the Sel as End may not be
 -- construted (without using undefined).
 data Sel l =
     Sel |
     (Selector l) => Skip l
 deriving instance (Read l, Selector l) => Read (Sel l)
 deriving instance (Show l, Selector l) => Show (Sel l)
+deriving instance (Eq l, Selector l) => Eq (Sel l)
 
--- Reimplement Void as Zero, just to keep the two separate, but Zero is for all
+-- Reimplement Void as End, just to keep the two separate, but End is for all
 -- intents and purposes Void.
-data Zero
-deriving instance Read Zero
-deriving instance Show Zero
+data End
+deriving instance Read End
+deriving instance Show End
+deriving instance Eq End
 
 
 -- Types that constitute a selection. Selections can be moved to the next
 -- selection, moved to the previous selection, optionally there could be a
 -- previous selection and they may be currently selected.
-class Selector c where
+class (Eq c) => Selector c where
   -- Increments the selection to the next state
   --
   -- Returns Nothing if the selection class is in the final state and cannot be
@@ -111,42 +113,62 @@ instance (Selector t) => Selector (Sel t) where
   -- Navigates to the end of the structure to find the final form.
   final = Just $ maybe Sel Skip final
 
--- The Zero structure (which is equivalent to Void) is the "null" selector; the
+-- The End structure (which is equivalent to Void) is the "null" selector; the
 -- basecase that the Sel selector terminates at.
-instance Selector Zero where
+instance Selector End where
 
-  -- Incrementing the Zero Selector doesn't do anything.
+  -- Incrementing the End Selector doesn't do anything.
   increment = const Nothing
 
-  -- Decrementing the Zero Selector doesn't do anythig
+  -- Decrementing the End Selector doesn't do anythig
   decrement = const Nothing
 
-  -- There is no initial value for the Zero selector.
+  -- There is no initial value for the End selector.
   initial = Nothing
 
-  -- There is not final state for the Zero selector.
+  -- There is not final state for the End selector.
   final = Nothing
 
--- A LayoutZipper consists of a LayoutSelect type and a corresponding Selector.
-data LayoutZipper l a where
-  LayoutZipper ::
+-- Increment a selector, but cyclicly
+incrementCycle :: (Selector c) => c -> c
+incrementCycle c =
+  case increment c of
+    Nothing -> fromMaybe c initial
+    Just x -> x
+
+-- Add two selectors together, incrementing the first until the second cannot be
+-- incremented anymore.
+addSelector :: (Selector c) => c -> c -> c
+addSelector c1 c2 = addSel c1 (decrement c2)
+  where
+    addSel c1 Nothing = c1
+    addSel c1 (Just c2) = addSel (incrementCycle c1) (decrement c2)
+
+-- Turn an int into a selector by repeatably incrementing.
+intToSelector :: (Selector c) => Int -> c
+intToSelector 0 = fromJust initial
+intToSelector n = incrementCycle $ intToSelector (n - 1)
+
+-- A LayoutList consists of a LayoutSelect type and a corresponding Selector.
+data LayoutList l a where
+  LayoutList ::
     (LayoutSelect l a, Selector (SelectorFor l)) =>
-      SelectorFor l -> l a -> LayoutZipper l a
+      SelectorFor l -> l a -> LayoutList l a
 
-deriving instance (LayoutSelect l a) => Show (LayoutZipper l a)
-deriving instance (LayoutSelect l a) => Read (LayoutZipper l a)
+deriving instance (LayoutSelect l a) => Show (LayoutList l a)
+deriving instance (LayoutSelect l a) => Read (LayoutList l a)
 
 (|:) :: (LayoutSelect t a, LayoutClass l a) => l a -> t a -> LCons l t a
 (|:) = LCons
 
 infixr 5 |: 
 
--- Constructs a LayoutZipper. This function enforces that the SelectorFor l
+-- Constructs a LayoutList. This function enforces that the SelectorFor l
 -- is a 'Sel' type. Essentially this enforces that there must be at least one
--- underlying layout, otherwise a LayoutZipper cannot be constructed.
+-- underlying layout, otherwise a LayoutList cannot be constructed.
 layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) =>
-  l a -> LayoutZipper l a
-layoutZipper = LayoutZipper Sel
+  l a -> LayoutList l a
+layoutZipper = LayoutList Sel
 
 -- The termination of a layout zipper.
 nil :: LNil a
@@ -162,7 +184,7 @@ newtype NavigateLayout =
 
 -- NavigateLayout instance to move to the next layout, circularly.
 toNextLayout :: NavigateLayout
-toNextLayout = NavigateLayout $ \c -> fromMaybe c (increment c <|> initial)
+toNextLayout = NavigateLayout $ addSelector (intToSelector 1)
 
 -- NavigateLayout instance to move to the previous layout, circularly.
 toPreviousLayout :: NavigateLayout
@@ -212,7 +234,7 @@ instance (Read (l a),
     LayoutSelect (LCons l t) a where
 
   -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure
-  -- Sel (Sel (Sel ( ... (Sel Zero) .. ))) where the number of Sel's match the
+  -- Sel (Sel (Sel ( ... (Sel End) .. ))) where the number of Sel's match the
   -- number of Cons in this structure enforcing safe selection.
   type SelectorFor (LCons l t) = Sel (SelectorFor t)
 
@@ -226,48 +248,48 @@ instance (Read (l a),
     fmap (second $ \t' -> LCons l t') <$> update s t fn
 
 -- LNil is a layout select. It doesn't do anything. Indeed update really can't
--- be called on on this because that would require instantiating a Zero type.
+-- be called on on this because that would require instantiating a End type.
 instance LayoutSelect LNil a where
-  type SelectorFor LNil = Zero -- LNil cannot be selected.
+  type SelectorFor LNil = End -- LNil cannot be selected.
   update _ _ _ = return Nothing
 
--- Instance of layout class for LayoutZipper. The implementation for this
+-- Instance of layout class for LayoutList. The implementation for this
 -- just delegates to the underlying LayoutSelect class using the generic
 -- update method.
 instance (Show (l a), Typeable l, LayoutSelect l a) =>
-    LayoutClass (LayoutZipper l) a where
+    LayoutClass (LayoutList l) a where
 
-  runLayout (W.Workspace i (LayoutZipper idx l) ms) r = do
+  runLayout (W.Workspace i (LayoutList idx l) ms) r = do
     r <- update idx l $ \layout ->
             runLayout (W.Workspace i layout ms) r
     case r of
       Nothing -> return ([], Nothing)
-      Just (r, la) -> return (r, Just (LayoutZipper idx la))
+      Just (r, la) -> return (r, Just (LayoutList idx la))
 
-  pureLayout (LayoutZipper idx l) r s = runIdentity $ do
+  pureLayout (LayoutList idx l) r s = runIdentity $ do
     r <- update idx l $ \layout -> return (pureLayout layout r s, Nothing)
     case r of
       Nothing -> return []
       Just (r, a) -> return r
 
-  emptyLayout (LayoutZipper idx l) r = do
+  emptyLayout (LayoutList idx l) r = do
     r <- update idx l $ \layout -> emptyLayout layout r
     case r of
       Nothing -> return ([], Nothing)
-      Just (r, la) -> return (r, Just (LayoutZipper idx la))
+      Just (r, la) -> return (r, Just (LayoutList idx la))
 
-  handleMessage (LayoutZipper idx l) (fromMessage -> Just (NavigateLayout fn)) =
-    return $ Just (LayoutZipper (fn idx) l)
+  handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) =
+    return $ Just (LayoutList (fn idx) l)
 
-  handleMessage (LayoutZipper idx l) m = do
+  handleMessage (LayoutList idx l) m = do
     r <- update idx l $ \layout -> ((),) <$> handleMessage layout m
-    return $ LayoutZipper idx . snd <$> r
+    return $ LayoutList idx . snd <$> r
 
-  pureMessage (LayoutZipper idx l) m = runIdentity $ do
+  pureMessage (LayoutList idx l) m = runIdentity $ do
     r <- update idx l $ \layout -> return ((), pureMessage layout m)
-    return $ LayoutZipper idx . snd <$> r
+    return $ LayoutList idx . snd <$> r
 
-  description (LayoutZipper idx l) = runIdentity $ do
+  description (LayoutList idx l) = runIdentity $ do
     r <- update idx l $ \l -> return (description l, Nothing)
     return $
       case r of