aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop')
-rw-r--r--src/Rahm/Desktop/Common.hs2
-rw-r--r--src/Rahm/Desktop/Keys.hs40
-rw-r--r--src/Rahm/Desktop/Layout.hs3
-rw-r--r--src/Rahm/Desktop/Layout/Bordering.hs194
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)
generated by cgit (git 2.34.1) at 2026-02-22 23:10:05 +0000