Add Bordering layout.

The bordering layout can add windows along the border of the screen,
that way something like videos or something can be shown in the corner
of the screen.

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)