1 files changed, 326 insertions, 0 deletions
diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs
new file mode 100644
index 0000000..95854b8
--- /dev/null
+++ b/src/Rahm/Desktop/Layout.hs
@@ -0,0 +1,326 @@
+{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-}
+module Rahm.Desktop.Layout where
+
+import GHC.TypeLits
+
+import Data.Proxy (Proxy(..))
+import Rahm.Desktop.CornerLayout (Corner(..))
+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.LayoutList
+import Rahm.Desktop.Windows
+
+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
+
+-- 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)
+
+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.
+--
+-- 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
+
+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