1 files changed, 194 insertions, 0 deletions
diff --git a/src/Rahm/Desktop/Layout/Bordering.hs b/src/Rahm/Desktop/Layout/Bordering.hs
new file mode 100644
index 0000000..0a06319
--- /dev/null
+++ b/src/Rahm/Desktop/Layout/Bordering.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module Rahm.Desktop.Layout.Bordering
+  (Bordering(..), banishToBorder, unbanish, rotateBorderForward,
+    rotateBorderBackward, bordering, toggleBanish,
+    changeWidth, changeHeight, moveForward, moveBackward) where
+
+import XMonad
+
+import Control.Monad
+import Data.Tuple (swap)
+import Control.Arrow
+import Data.Map (Map)
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+import Data.List (partition, find)
+import qualified Data.Set as Set
+import Data.Typeable (cast)
+import Data.Proxy (Proxy)
+
+import Rahm.Desktop.Logger
+import qualified Rahm.Desktop.StackSet as W
+
+data BorderPosition =
+  North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest
+  deriving (Eq, Show, Read, Ord, Enum, Bounded)
+
+data BorderingData a =
+  BorderingData {
+    extraWindows :: Map BorderPosition a
+  , borderingWidth :: Rational
+  , borderingHeight :: Rational
+  , borderingPadding :: Int
+  } deriving (Eq, Ord, Show, Read)
+
+data Bordering (l :: * -> *) (a :: *) =
+  Bordering {
+    borderingData :: BorderingData a,
+    wrappedLayout :: l a
+  } deriving (Eq, Ord, Show, Read)
+
+data ModifyBordering a =
+  ModifyBordering (BorderingData a -> BorderingData a)
+  deriving (Message)
+
+enumNext :: (Eq a, Enum a, Bounded a) => a -> a
+enumNext a
+  | a == maxBound = minBound
+  | otherwise = succ a
+
+enumPrev :: (Eq a, Enum a, Bounded a) => a -> a
+enumPrev a
+  | a == minBound = maxBound
+  | otherwise = pred a
+
+bordering :: l a -> Bordering l a
+bordering = Bordering (BorderingData mempty (1/6) (1/6) 10) 
+
+banishToBorder :: a -> ModifyBordering a
+banishToBorder win =
+  let allPositions =
+        (\(a, b) -> b ++ a) $ break (==SouthEast) [minBound .. maxBound]
+      in
+      ModifyBordering $ \dat ->
+        maybe
+          dat
+          (\pos ->
+            dat { extraWindows = Map.insert pos win (extraWindows dat)}) $
+              find (not . (`Map.member`extraWindows dat)) allPositions
+
+toggleBanish :: (Eq a) => a -> ModifyBordering a
+toggleBanish win = ModifyBordering $ \dat ->
+  let (ModifyBordering fn) = 
+        if elem win $ Map.elems $ extraWindows dat
+          then unbanish win
+          else banishToBorder win
+     in fn dat
+  
+
+unbanish :: (Eq a) => a -> ModifyBordering a
+unbanish win =
+  ModifyBordering $ \dat ->
+    maybe
+      dat
+      (\pos -> dat { extraWindows = Map.delete pos (extraWindows dat) }) $
+      (fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat))
+
+rotateBorder :: (BorderPosition -> BorderPosition) -> ModifyBordering a
+rotateBorder next = ModifyBordering $ \dat ->
+  dat { extraWindows = Map.mapKeys next (extraWindows dat) }
+
+rotateBorderForward :: Proxy a -> ModifyBordering a
+rotateBorderForward _ = rotateBorder enumNext
+
+rotateBorderBackward :: Proxy a -> ModifyBordering a
+rotateBorderBackward _ = rotateBorder enumPrev
+
+changeWidth :: Proxy a -> Rational -> ModifyBordering a
+changeWidth _ amt = ModifyBordering $ \dat ->
+  dat { borderingWidth = guard $ borderingWidth dat + amt }
+  where guard x | x < 1/12 = 1/12
+                | x > 4/12 = 4/12
+                | otherwise = x
+
+changeHeight :: Proxy a -> Rational -> ModifyBordering a
+changeHeight _ amt = ModifyBordering $ \dat ->
+  dat { borderingHeight = guard $ borderingHeight dat + amt }
+  where guard x | x < 1/12 = 1/12
+                | x > 4/12 = 4/12
+                | otherwise = x
+
+instance Semigroup (ModifyBordering a) where
+  (<>) = mappend
+
+instance Monoid (ModifyBordering a) where
+  
+  mempty = ModifyBordering id
+  mappend (ModifyBordering f1) (ModifyBordering f2) = ModifyBordering (f2 . f1)
+    
+
+move :: (Eq a) => (BorderPosition -> BorderPosition) -> a -> ModifyBordering a
+move fn win = ModifyBordering $ \dat ->
+  let mKey = fst <$> find ((==win) . snd) (Map.toList $ extraWindows dat) in
+  case mKey of
+    Nothing -> dat
+    Just key ->
+      let newKey = until (\k -> not (Map.member k (extraWindows dat) && k /= key))
+                      fn (fn key)
+          wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat
+          in 
+          dat { extraWindows = wins' }
+
+moveForward :: (Eq a) => a -> ModifyBordering a
+moveForward = move enumNext
+
+moveBackward :: (Eq a) => a -> ModifyBordering a
+moveBackward = move enumPrev
+    
+
+instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering l) a where
+  runLayout (W.Workspace t (Bordering dat l) as) rect = do
+    let (out, rest) = filterStack as
+    (rects, maybeNewLayout) <- runLayout (W.Workspace t l rest) rect
+    return (layoutRest out ++ rects, Bordering dat <$> maybeNewLayout)
+    where
+      filterStack Nothing = ([], Nothing)
+      filterStack (Just (W.Stack f h t)) = do
+        let elSet = Set.fromList (Map.elems $ extraWindows dat)
+            ((hp, h'), (tp, t')) = dbl (partition (`Set.member`elSet)) (h, t)
+            in case (Set.member f elSet, h', t', hp ++ tp) of
+                 (False, _, _, r) -> (r, Just $ W.Stack f h' t')
+                 (True, (a:h''), _, r) ->  (f:r, Just $ W.Stack a h'' t')
+                 (True, [], (a:t''), r) ->  (f:r, Just $ W.Stack a [] t'')
+                 (True, [], [], r) ->  (f:r, Nothing)
+
+      layoutRest windows =
+        map (second (scaleRationalRect (padRect rect) . loc2Rect) . swap) $
+          filter ((`elem`windows) . snd) $
+            Map.toList (extraWindows dat)
+
+      padRect (Rectangle x y w h) =
+        let p :: (Integral a) => a
+            p = fromIntegral (borderingPadding dat) in
+            Rectangle (x + p) (y + p) (w - p*2) (h - p*2)
+
+      loc2Rect loc = case loc of
+        North -> W.RationalRect (1/2 - (bw / 2)) 0 bw bh
+        NorthEast -> W.RationalRect (1 - bw) 0 bw bh
+        East -> W.RationalRect (1 - bw) (1/2 - (bh / 2)) bw bh
+        SouthEast -> W.RationalRect (1 - bw) (1 - bh) bw bh
+        South -> W.RationalRect (1/2 - (bw / 2)) (1 - bh) bw bh
+        SouthWest -> W.RationalRect 0 (1 - bh) bw bh
+        West -> W.RationalRect 0 (1/2 - (bh / 2)) bw bh
+        NorthWest -> W.RationalRect 0 0 bw bh
+
+        where
+
+          bw = borderingWidth dat
+          bh = borderingHeight dat
+
+      dbl f = f *** f
+
+  handleMessage (Bordering d l) m@(fromMessage -> Just e@DestroyWindowEvent {ev_window = w}) = do
+    maybeNewLayout <- handleMessage l m
+    return $ Just $ Bordering (f d) (fromMaybe l maybeNewLayout)
+    where
+      f e@BorderingData{ extraWindows = ws } =
+        e { extraWindows = Map.filter (maybe True (/=w) . cast) ws }
+    
+  handleMessage (Bordering d l) (fromMessage -> Just (ModifyBordering fn)) =
+    return (Just $ Bordering (fn d) l)
+
+  handleMessage (Bordering d l) a = do
+    maybeNewLayout <- handleMessage l a
+    return (Bordering d <$> maybeNewLayout)