From fcea6ce1371de988deb2dd719263cb2c9c59dfd7 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 28 Apr 2022 18:15:34 -0600 Subject: 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. --- src/Rahm/Desktop/Common.hs | 2 + src/Rahm/Desktop/Keys.hs | 40 ++++++++ src/Rahm/Desktop/Layout.hs | 3 +- src/Rahm/Desktop/Layout/Bordering.hs | 194 +++++++++++++++++++++++++++++++++++ 4 files changed, 238 insertions(+), 1 deletion(-) create mode 100644 src/Rahm/Desktop/Layout/Bordering.hs (limited to 'src/Rahm/Desktop') 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) -- cgit