More refactoring. Started breaking up Layout. Moved Language extensions into stack file.

5 files changed, 838 insertions, 0 deletions

diff --git a/src/Rahm/Desktop/Layout/CornerLayout.hs b/src/Rahm/Desktop/Layout/CornerLayout.hs
new file mode 100644
index 0000000..f0952c7
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/CornerLayout.hs
@@ -0,0 +1,57 @@
+-- Creates a layout, the "corner layout" that keeps the master window in the
+-- corner and the other windows go around it.
+module Rahm.Desktop.Layout.CornerLayout where
+
+import Data.Typeable (Typeable)
+import XMonad (LayoutClass(..), Rectangle(..), Resize(..), fromMessage)
+import qualified XMonad.StackSet as S
+
+data Corner a = Corner Rational Rational
+  deriving (Show, Typeable, Read)
+
+instance LayoutClass Corner a where
+  pureLayout (Corner frac _) screen@(Rectangle x y w h) ss =
+    let w' = floor $ fromIntegral w * frac
+        h' = floor $ fromIntegral h * frac
+        corner = Rectangle 0 0 w' h'
+        vertRect = Rectangle (fromIntegral w') 0 (w - w') h
+        horizRect = Rectangle 0 (fromIntegral h') w' (h - h')
+        ws = S.integrate ss
+
+        vn = (length ws - 1) `div` 2
+        hn = (length ws - 1) - vn
+      in
+        case ws of
+          [a] -> [(a, screen)]
+          [a, b] -> [
+            (a, Rectangle x y w' h),
+            (b, Rectangle (x + fromIntegral w') y (w - w') h)]
+          _ ->
+            zip ws $ map (
+                \(Rectangle x' y' w h) -> Rectangle (x + x') (y + y') w h) $
+              corner :
+                splitVert vertRect vn ++
+                splitHoriz horizRect hn
+
+  pureMessage (Corner frac delta) m = fmap resize (fromMessage m)
+    where
+      resize Shrink = Corner (frac - delta) delta
+      resize Expand = Corner (frac + delta) delta
+
+splitVert :: Rectangle -> Int -> [Rectangle]
+splitVert (Rectangle x y w h) i' =
+  map
+    (\i -> Rectangle x (y + fromIntegral (step * i)) w step)
+    [0 .. i - 1]
+  where
+    i = fromIntegral i'
+    step = h `div` i
+
+splitHoriz :: Rectangle -> Int -> [Rectangle]
+splitHoriz (Rectangle x y w h) i' =
+  map
+    (\i -> Rectangle (x + fromIntegral (step * i)) y step h)
+    [0 .. i - 1]
+  where
+    step = w `div` i
+    i = fromIntegral i'
diff --git a/src/Rahm/Desktop/Layout/Layout.hs b/src/Rahm/Desktop/Layout/Layout.hs
new file mode 100644
index 0000000..93228e7
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/Layout.hs
@@ -0,0 +1,283 @@
+module Rahm.Desktop.Layout.Layout where
+
+import GHC.TypeLits
+
+import Data.Proxy (Proxy(..))
+import Control.Arrow (second)
+import XMonad.Hooks.ManageDocks
+import XMonad.Layout.Circle
+import XMonad.Layout.Accordion
+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.Dishes
+import XMonad.Layout.MosaicAlt
+import XMonad.Layout.Fullscreen
+import qualified XMonad.Layout.Dwindle as D
+import XMonad.Layout
+import XMonad.Layout.LayoutModifier
+import XMonad
+import XMonad.Core
+import XMonad.Layout.NoBorders (smartBorders, noBorders)
+
+import Rahm.Desktop.Layout.CornerLayout (Corner(..))
+import Rahm.Desktop.Layout.LayoutList
+import Rahm.Desktop.Windows
+import Rahm.Desktop.Layout.ReinterpretMessage
+
+import qualified Data.Map as M
+import qualified XMonad.StackSet as W
+
+myLayout =
+  fullscreenFull $
+    avoidStruts $
+      spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $
+        layoutZipper $
+          mods (reinterpretIncMaster $ spiral (6/7)) |:
+          mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |:
+          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 |:
+          mods (Dishes 2 (1/6)) |:
+          mods (reinterpretIncMaster $ D.Dwindle D.R D.CW 1.5 1.1) |:
+          nil
+
+-- 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)
+
+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)
+
+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) .
+    ModifiedLayout (HFlippable False) .
+    ModifiedLayout (Rotateable False)
+
+
+data ModifyDescription m l a = ModifyDescription m (l a)
+  deriving (Show, Read)
+
+data TallDescriptionModifier = TallDescriptionModifier
+  deriving (Show, Read)
+
+data ThreeColDescMod = ThreeColDescMod
+  deriving (Show, Read)
+
+class DescriptionModifier m l where
+  newDescription :: m -> l a -> String -> String
+
+instance (Typeable m, Show m, DescriptionModifier m l, LayoutClass l a) => LayoutClass (ModifyDescription m l) a where
+  runLayout (W.Workspace t (ModifyDescription m l) a) rect = do
+    (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect
+    return (rects, fmap (ModifyDescription m) maybeNewLayout)
+
+  doLayout (ModifyDescription m l) a s = do
+    (rects, maybeNewLayout) <- doLayout l a s
+    return (rects, fmap (ModifyDescription m) maybeNewLayout)
+
+  pureLayout (ModifyDescription m l) a s = pureLayout l a s
+
+  emptyLayout (ModifyDescription m l) a = do
+    (rects, maybeNewLayout) <- emptyLayout l a
+    return (rects, fmap (ModifyDescription m) maybeNewLayout)
+
+  handleMessage (ModifyDescription m l) a = do
+    maybeNewLayout <- handleMessage l a
+    return (ModifyDescription m <$> maybeNewLayout)
+
+  pureMessage (ModifyDescription m l) a =
+    let maybeNewLayout = pureMessage l a in
+      ModifyDescription m <$> maybeNewLayout
+
+  description (ModifyDescription m l) = newDescription m l (description l)
+
+instance DescriptionModifier TallDescriptionModifier Tall where
+  newDescription _ (Tall mast _ _) _ = "Tall(" ++ show mast ++ ")"
+
+instance DescriptionModifier ThreeColDescMod ThreeCol where
+  newDescription _ (ThreeCol mast _ _) _ = "ThreeCol(" ++ show mast ++ ")"
+  newDescription _ (ThreeColMid mast _ _) _ = "ThreeColMid(" ++ show mast ++ ")"
+
+data ResizeZoom = ShrinkZoom | ExpandZoom deriving (Typeable)
+
+instance Message ResizeZoom where
+
+newtype Flippable a = Flippable Bool -- True if flipped
+  deriving (Show, Read)
+
+newtype HFlippable a = HFlippable Bool -- True if flipped
+  deriving (Show, Read)
+
+newtype Rotateable a = Rotateable Bool -- True if rotated
+  deriving (Show, Read)
+
+data FlipLayout = FlipLayout deriving (Typeable)
+
+data HFlipLayout = HFlipLayout deriving (Typeable)
+
+data DoRotate = DoRotate deriving (Typeable)
+
+data Zoomable a = Zoomable Bool Float Float -- True if zooming in on the focused window.
+  deriving (Show, Read)
+
+-- Toggles if the current window should be zoomed or not. Set the boolean
+-- to set the zoom.mhar
+data ZoomModifier =
+       ToggleZoom |
+       Zoom |
+       Unzoom
+  deriving (Typeable)
+
+instance Message FlipLayout where
+
+instance Message HFlipLayout where
+
+instance Message ZoomModifier where
+
+instance Message DoRotate where
+
+instance (Eq a) => LayoutModifier Rotateable a where
+  pureModifier (Rotateable rotate) (Rectangle x' y' sw sh) _ returned =
+    if rotate
+      then (map (second (unzero . scaleRect . mirrorRect . zero)) returned, Nothing)
+      else (returned, Nothing)
+    where
+      zero (Rectangle x y w h) = Rectangle (x - x') (y - y') w h
+      unzero (Rectangle x y w h) = Rectangle (x + x') (y + y') w h
+
+      scaleRect (Rectangle x y w h) =
+        Rectangle (x * fi sw `div` fi sh)
+                  (y * fi sh `div` fi sw)
+                  (w * sw `div` sh)
+                  (h * sh `div` sw)
+
+      fi = fromIntegral
+
+
+  pureMess (Rotateable rot) mess =
+    fmap (\DoRotate -> Rotateable (not rot)) (fromMessage mess)
+
+  modifyDescription (Rotateable rot) underlying =
+    let descr = description underlying in
+      if rot
+        then descr ++ " Rotated"
+        else descr
+
+instance (Eq a) => LayoutModifier Flippable a where
+  pureModifier (Flippable flip) (Rectangle sx _ sw _) stack returned =
+    if flip
+      then (map (second doFlip) returned, Nothing)
+      else (returned, Nothing)
+    where
+      doFlip (Rectangle x y w h) =
+        Rectangle ((sx + fromIntegral sw) - x - fromIntegral w + sx) y w h
+
+  pureMess (Flippable flip) message =
+    case fromMessage message of
+      Just FlipLayout -> Just (Flippable (not flip))
+      Nothing -> Nothing
+
+  modifyDescription (Flippable flipped) underlying =
+    let descr = description underlying in
+      if flipped
+        then descr ++ " Flipped"
+        else descr
+
+instance (Eq a) => LayoutModifier HFlippable a where
+  pureModifier (HFlippable flip) (Rectangle _ sy _ sh) stack returned =
+    if flip
+      then (map (second doFlip) returned, Nothing)
+      else (returned, Nothing)
+    where
+      doFlip (Rectangle x y w h) =
+        Rectangle x ((sy + fromIntegral sh) - y - fromIntegral h + sy) w h
+
+  pureMess (HFlippable flip) message =
+    case fromMessage message of
+      Just HFlipLayout -> Just (HFlippable (not flip))
+      Nothing -> Nothing
+
+  modifyDescription (HFlippable flipped) underlying =
+    let descr = description underlying in
+      if flipped
+        then descr ++ " HFlipped"
+        else descr
+
+
+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
+        handleZoom Zoom = Zoomable True sw sh
+        handleZoom Unzoom = Zoomable False sw sh
+
+        guard f | f > 1 = 1
+                | f < 0 = 0
+                | otherwise = f
diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs
new file mode 100644
index 0000000..7e59284
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
+ScopedTypeVariables, BangPatterns #-}
+module Rahm.Desktop.Layout.LayoutDraw (drawLayout) where
+
+import Control.Monad
+
+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 Rahm.Desktop.Hash (quickHash)
+import Rahm.Desktop.Layout.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'
+  where
+    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 <- X.getXMonadDir
+
+  let shrinkAmt = 5 -- amount to shrink the windows by to make pretty gaps.
+
+  let (w, h) = (56, 24)
+  let descr = X.description l
+  let iconCacheDir = dir </> "icons" </> "cache"
+  let iconPath = iconCacheDir </> (quickHash descr ++ ".xpm")
+
+  let colors = [
+        "#cc9a9a", "#cc9999", "#cc8080", "#cc6666",
+        "#cc4c4c", "#cc3232", "#cc1818", "#cc0000" ]
+
+  (rects', _) <-
+    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)
+
+  X.liftIO $ do
+    exists <- doesFileExist iconPath
+    createDirectoryIfMissing True iconCacheDir
+
+    unless exists $ do
+      let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4
+      writeFile iconPath xpmText
+
+    return (exists, iconPath)
+
+--
+-- 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"
+    tell $ printf "\"%d %d %d 1 \",\n" w h (length rects + 1)
+
+    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] $ \y -> do
+      tell "\""
+      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 "};\n"
+
+  where
+    matches x y (_, (_, r)) = pointInRect (x, y) r
+    rects = map (second (shrink shrinkAmt)) rects'
+    guard a b = if a <= shrinkAmt then 1 else b
+    shrink amt (Rectangle x y w h) =
+      Rectangle
+        x
+        y
+        (guard w $ w - fromIntegral amt)
+        (guard h $ h - fromIntegral amt)
diff --git a/src/Rahm/Desktop/Layout/LayoutList.hs b/src/Rahm/Desktop/Layout/LayoutList.hs
new file mode 100644
index 0000000..3e72e99
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/LayoutList.hs
@@ -0,0 +1,295 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+{-
+ - This module provides a more powerful version of the "Choose" layout that can
+ - be bidirectionally navigated.
+ -
+ - The indexing uses a type-safe zipper to keep track of the currently-selected
+ - layout.
+ -}
+module Rahm.Desktop.Layout.LayoutList (
+  LayoutList,
+  layoutZipper,
+  LCons,
+  LNil,
+  toNextLayout,
+  toPreviousLayout,
+  toFirstLayout,
+  (|:),
+  nil
+  )where
+
+import Control.Applicative ((<|>))
+import Data.Void
+import Control.Monad.Identity (runIdentity)
+import Data.Maybe (fromMaybe, fromJust)
+import Control.Arrow (second)
+import XMonad
+import qualified XMonad.StackSet as W
+import Data.Proxy
+
+-- Type-level lists. LNil is the final of the list. LCons contains a layout and a
+-- tail.
+data LNil a = LNil deriving (Read, Show)
+data LCons l t a = LCons (l a) (t a) deriving (Read, Show)
+
+-- Sel - This defines a structure where either this selected, or some
+-- other element is selected.
+--
+-- 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 End)))
+--
+-- Such a type is equivalent to an integer bounded at 4, because this type can
+-- exist in no more than 4 states:
+--
+-- Sel
+-- Skip Sel
+-- Skip (Skip Sel)
+-- Skip (Skip (Skip Sel))
+--
+-- 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 End, just to keep the two separate, but End is for all
+-- intents and purposes Void.
+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 (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
+  -- incremented any farther. (This is helpful to facilitate modular
+  -- arithmatic)
+  increment :: c -> Maybe c
+
+  -- Decrements the selection to the previous state. Returns Nothing if the
+  -- state is already in its initial setting.
+  decrement :: c -> Maybe c
+
+  -- The initial state.
+  initial :: Maybe c
+
+  -- The final state.
+  final :: Maybe c
+
+--
+-- Is selelected can be in two states:
+--
+--   1. The current element is selected
+--   2. The current element is not selected and another element deeper in the
+--      structure is selected.
+instance (Selector t) => Selector (Sel t) where
+  -- If the current element is not selected, increment the tail.
+  increment (Skip l) = Skip <$> increment l
+  -- If the current element is selected, the increment is just the initial of
+  -- the tail.
+  increment Sel = Skip <$> initial 
+
+  -- For a selection, the initial is just this in the Sel state.
+  initial = Just Sel
+
+  -- Looks ahead at the tail, sees if it is selected, if so, select this one
+  -- instead, if the one ahead isn't selected, then decrement that one.
+  decrement (Skip t) = Just $ maybe Sel Skip (decrement t)
+  decrement Sel = Nothing
+
+  -- Navigates to the end of the structure to find the final form.
+  final = Just $ maybe Sel Skip final
+
+-- The End structure (which is equivalent to Void) is the "null" selector; the
+-- basecase that the Sel selector terminates at.
+instance Selector End where
+
+  -- Incrementing the End Selector doesn't do anything.
+  increment = const Nothing
+
+  -- Decrementing the End Selector doesn't do anythig
+  decrement = const Nothing
+
+  -- There is no initial value for the End selector.
+  initial = Nothing
+
+  -- There is not final state for the End selector.
+  final = Nothing
+
+-- 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 -> LayoutList 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 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 LayoutList cannot be constructed.
+layoutZipper :: (LayoutSelect l a, SelectorFor l ~ Sel n) =>
+  l a -> LayoutList l a
+layoutZipper = LayoutList Sel
+
+-- The termination of a layout zipper.
+nil :: LNil a
+nil = LNil
+
+-- Message to navigate to a layout.
+newtype NavigateLayout =
+          -- Sets the layout based on the given function.
+          NavigateLayout {
+            changeLayoutFn :: forall c. (Selector c) => c -> c
+          }
+          deriving (Typeable)
+
+-- NavigateLayout instance to move to the next layout, circularly.
+toNextLayout :: NavigateLayout
+toNextLayout = NavigateLayout $ addSelector (intToSelector 1)
+
+-- NavigateLayout instance to move to the previous layout, circularly.
+toPreviousLayout :: NavigateLayout
+toPreviousLayout = NavigateLayout $ \c -> fromMaybe c (decrement c <|> final)
+
+-- NavigateLayotu instance to move to the first layout.
+toFirstLayout :: NavigateLayout
+toFirstLayout = NavigateLayout (`fromMaybe` initial)
+
+instance Message NavigateLayout where
+
+-- LayoutSelect class Describes a type that can be used to select a layout using
+-- the associated type SelectorFor.
+--
+-- Instances of this class are LCons and LNil.
+class (Show (l a),
+       Read (l a),
+       Read (SelectorFor l),
+       Show (SelectorFor l),
+       Selector (SelectorFor l)) => LayoutSelect l a where
+
+  -- The selector that is used to update the layout corresponding to the
+  -- selector. This selector must be an instance of the Selector class.
+  type SelectorFor l :: *
+
+  -- Update applies a functor to the selected layout and maybe returns a result
+  -- and an updated layout.
+  update :: forall r m. (Monad m) =>
+    -- The selector for this type. Determines which layout the function is
+    -- applied to.
+    SelectorFor l ->
+    -- The LayoutSelect being modified.
+    l a ->
+    -- Higher-ordered function to generically apply to the Layout associated
+    -- with the Selector. Works on all LayoutClass's.
+    (forall l'. (LayoutClass l' a) => l' a -> m (r, Maybe (l' a))) ->
+
+    -- Returns a result r, and an updated LayoutSelect.
+    m (Maybe (r, l a))
+
+-- Instance for LayoutSelect for cons
+instance (Read (l a),
+          LayoutClass l a,
+          LayoutSelect t a,
+          Show (SelectorFor t),
+          Read (SelectorFor t)) =>
+    LayoutSelect (LCons l t) a where
+
+  -- The SelectorFor Cons is Sel (SelectorFor t). This creates the structure
+  -- 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)
+
+  -- The current layout in this Cons-list is selected.
+  update Sel (LCons layout t) fn = do
+    (r, layout') <- fn layout
+    return $ Just (r, LCons (fromMaybe layout layout') t)
+
+  -- The current layout is not selected. Move on to another layout.
+  update (Skip s) (LCons l t) fn =
+    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 End type.
+instance LayoutSelect LNil a where
+  type SelectorFor LNil = End -- LNil cannot be selected.
+  update _ _ _ = return Nothing
+
+-- 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 (LayoutList l) a where
+
+  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 (LayoutList idx la))
+
+  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 (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 (LayoutList idx la))
+
+  handleMessage (LayoutList idx l) (fromMessage -> Just (NavigateLayout fn)) =
+    return $ Just (LayoutList (fn idx) l)
+
+  handleMessage (LayoutList idx l) m = do
+    r <- update idx l $ \layout -> ((),) <$> handleMessage layout m
+    return $ LayoutList idx . snd <$> r
+
+  pureMessage (LayoutList idx l) m = runIdentity $ do
+    r <- update idx l $ \layout -> return ((), pureMessage layout m)
+    return $ LayoutList idx . snd <$> r
+
+  description (LayoutList idx l) = runIdentity $ do
+    r <- update idx l $ \l -> return (description l, Nothing)
+    return $
+      case r of
+        Nothing -> "No Layout"
+        Just (descr, _) -> descr
diff --git a/src/Rahm/Desktop/Layout/ReinterpretMessage.hs b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs
new file mode 100644
index 0000000..98bf779
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/ReinterpretMessage.hs
@@ -0,0 +1,48 @@
+module Rahm.Desktop.Layout.ReinterpretMessage where
+
+import XMonad (SomeMessage, X)
+import XMonad.Layout.LayoutModifier (LayoutModifier(..))
+import Data.Proxy (Proxy (..))
+
+-- 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)
+
+-- 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