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.

4 files changed, 238 insertions, 1 deletions

diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 8790d84..3e6d54c 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -112,6 +112,8 @@ withBorderWidth width ws fn = do
   forM_ ws $ \window ->
     io $ setWindowBorderWidth d window 2
 
+  refresh
+
   return ret
 
 gotoWorkspace :: WorkspaceId -> X ()
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 50b7104..26021bb 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -14,6 +14,7 @@ import Data.List.Safe ((!!))
 import Data.Map (Map)
 import Data.Maybe (isJust, fromMaybe, mapMaybe)
 import Data.Monoid (Endo(..))
+import Data.Proxy
 import Debug.Trace
 import Graphics.X11.ExtraTypes.XF86;
 import Graphics.X11.ExtraTypes.XorgDefault
@@ -44,6 +45,7 @@ import qualified Data.Map as Map
 import Rahm.Desktop.DMenu
 import Rahm.Desktop.Keys.Dsl
 import Rahm.Desktop.Layout
+import Rahm.Desktop.Layout.Bordering
 import Rahm.Desktop.Layout.ConsistentMosaic
 import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically)
 import Rahm.Desktop.Layout.Hole (toggleHole)
@@ -294,6 +296,44 @@ keymap = runKeys $ do
           moveLocationToWorkspaceFn ws loc
           gotoWorkspaceFn ws
 
+  bind xK_n $ do
+    justMod $
+      doc "Banish the current window to the border" $
+        withFocused $ sendMessage . toggleBanish
+
+    shiftMod $
+      doc "Rotate border windows" $ repeatable $ do
+       
+        bind xK_h $ do
+          
+          (justMod -|- noMod) $ 
+            withFocused $ sendMessage . moveForward
+
+          shiftMod $
+            sendMessage (rotateBorderForward (Proxy :: Proxy Window))
+       
+        bind xK_l $ do
+          
+          (justMod -|- noMod) $ 
+            withFocused $ sendMessage . moveBackward
+
+          shiftMod $
+            sendMessage (rotateBorderBackward (Proxy :: Proxy Window))
+
+        bind xK_plus $ do
+          
+          (justMod -|- noMod) $
+            sendMessage $
+              changeWidth Proxy (1/24) <>
+              changeHeight (Proxy :: Proxy Window) (1/24)
+
+        bind xK_minus $ do
+          
+          (justMod -|- noMod) $
+            sendMessage $
+              changeWidth Proxy (-1/24) <>
+              changeHeight (Proxy :: Proxy Window) (-1/24)
+
   bind xK_d $
     justMod $
     doc "Record (define) macros." $
diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs
index ad54d4a..08bd8d1 100644
--- a/src/Rahm/Desktop/Layout.hs
+++ b/src/Rahm/Desktop/Layout.hs
@@ -33,6 +33,7 @@ import Rahm.Desktop.Layout.Rotate
 import Rahm.Desktop.Layout.Redescribe
 import Rahm.Desktop.Layout.Hole
 import Rahm.Desktop.Layout.ConsistentMosaic
+import Rahm.Desktop.Layout.Bordering
 
 import qualified Data.Map as M
 import qualified Rahm.Desktop.StackSet as W
@@ -45,7 +46,7 @@ mySpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True
 
 
 mods =
-  mySpacing . poppable . flippable . rotateable . hole
+  bordering . mySpacing . poppable . flippable . rotateable . hole
 
 myLayoutList =
         layoutList $
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)