From 78b1ba125ec327512deb4c4c481cdf875d6c7339 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Tue, 12 Apr 2022 11:09:19 -0600 Subject: Clean up Poppable so it's a proper proxy to the underlying layout rather than a LayoutModifier. --- src/Rahm/Desktop/Keys.hs | 8 +-- src/Rahm/Desktop/Layout.hs | 2 +- src/Rahm/Desktop/Layout/LayoutDraw.hs | 4 +- src/Rahm/Desktop/Layout/Pop.hs | 122 ++++++++++++++++------------------ 4 files changed, 64 insertions(+), 72 deletions(-) (limited to 'src/Rahm/Desktop') diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 0ff8da3..5284a9d 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -55,7 +55,7 @@ import Rahm.Desktop.Logger import Rahm.Desktop.RebindKeys import Rahm.Desktop.Swallow import Rahm.Desktop.Layout.Hole (toggleHole) -import Rahm.Desktop.Layout.Pop (PopMessage(..)) +import Rahm.Desktop.Layout.Pop (togglePop) import Rahm.Desktop.Layout.Flip (flipHorizontally, flipVertically) import Rahm.Desktop.Layout.Rotate (rotateLayout) import Rahm.Desktop.ScreenRotate (screenRotateForward, screenRotateBackward) @@ -534,7 +534,7 @@ keymap = runKeys $ do bind xK_z $ do noMod -|- justMod $ doc "Toggle zoom on the current window." $ - sendMessage TogglePop + sendMessage togglePop -- Z is reserved to create sub keybindings to do various things. -- I don't really use these at the moment. @@ -546,7 +546,7 @@ keymap = runKeys $ do -- modifier. shiftMod $ doc "Toggle zoom on the current window." $ - sendMessage TogglePop + sendMessage togglePop bind xF86XK_Calculator $ do noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" @@ -636,7 +636,7 @@ mouseMap = runButtons $ do bind button14 $ do - noMod $ noWindow $ click >> sendMessage TogglePop + noMod $ noWindow $ click >> sendMessage togglePop bind button15 $ do noMod $ noWindow $ spawnX "pavucontrol" diff --git a/src/Rahm/Desktop/Layout.hs b/src/Rahm/Desktop/Layout.hs index fcf7d25..aeceff9 100644 --- a/src/Rahm/Desktop/Layout.hs +++ b/src/Rahm/Desktop/Layout.hs @@ -39,7 +39,7 @@ import qualified XMonad.StackSet as W withSpacing = spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True mods = - withSpacing . reinterpretResize . poppable . flippable . rotateable . hole + withSpacing . poppable . flippable . rotateable . hole myLayout = fullscreenFull $ diff --git a/src/Rahm/Desktop/Layout/LayoutDraw.hs b/src/Rahm/Desktop/Layout/LayoutDraw.hs index c3a1918..7e628fc 100644 --- a/src/Rahm/Desktop/Layout/LayoutDraw.hs +++ b/src/Rahm/Desktop/Layout/LayoutDraw.hs @@ -11,7 +11,7 @@ import Control.Monad.Writer (execWriter, tell) import Data.Foldable (find) import Data.Maybe (fromMaybe) import Rahm.Desktop.Hash (quickHash) -import Rahm.Desktop.Layout.Pop (PopMessage(..)) +import Rahm.Desktop.Layout.Pop (setPop) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (()) import Text.Printf (printf) @@ -49,7 +49,7 @@ drawLayout = do -- Gotta reset the layout to a consistent state. layout' <- foldM (flip ($)) layout $ [ handleMessage' $ ModifyWindowBorder $ const $ Border 0 0 0 0, - handleMessage' Unpop + handleMessage' $ setPop $ const False ] -- Add some changes for the Mosaic layout to handle so it get's a -- unique looking icon. (The default state is pretty boring). diff --git a/src/Rahm/Desktop/Layout/Pop.hs b/src/Rahm/Desktop/Layout/Pop.hs index 037e664..7e3dbd1 100644 --- a/src/Rahm/Desktop/Layout/Pop.hs +++ b/src/Rahm/Desktop/Layout/Pop.hs @@ -8,7 +8,9 @@ module Rahm.Desktop.Layout.Pop ( Poppable(..), PopMessage(..), poppable, - reinterpretResize) where + resizePop, + togglePop, + setPop) where import XMonad import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) @@ -17,7 +19,7 @@ import qualified XMonad.StackSet as W import Rahm.Desktop.Layout.ReinterpretMessage -data Poppable a = Poppable { +data Poppable (l :: * -> *) (a :: *) = Poppable { -- True if the current window is popped out or not. isPopped :: Bool @@ -26,79 +28,69 @@ data Poppable a = Poppable { -- Fraction of the screen height around the window. , yFrac :: Float + + , wrap :: l a } deriving (Show, Read, Eq, Ord) -instance Default (Poppable a) where - def = Poppable { - isPopped = False - , xFrac = 0.05 - , yFrac = 0.05 - } - --- Returns a modified layout that converts Resize (Shrink/Expand) into ResizePop --- messages. Unfortunately this is required because a LayoutModifier has no way --- to intercept messages and block them from propegating, which is pretty silly. --- --- So, reinterpretResize will turn a Shrink/Expand into a ResizePop, this will --- be consumed by the Poppable layout modifier. If the Poppable LayoutModifier --- is not active, it will turn the ResizePop back into a Shrink/Expand and --- forward it to the underlying layout. -reinterpretResize :: - l a -> ModifiedLayout (ReinterpretMessage "ForPop") l a -reinterpretResize = ModifiedLayout ReinterpretMessage - -poppable :: l a -> ModifiedLayout Poppable l a -poppable = ModifiedLayout def - --- Message to control the state of the popped layouts modifier. -data PopMessage = TogglePop | Pop | Unpop | ResizePop Float - deriving (Typeable, Show, Eq, Ord, Message) - -instance DoReinterpret "ForPop" where - reinterpretMessage _ (fromMessage -> Just mess) = - return $ Just $ SomeMessage $ - case mess of - Shrink -> ResizePop (-0.05) - Expand -> ResizePop 0.05 - - reinterpretMessage _ _ = return Nothing - -instance (Eq a) => LayoutModifier Poppable a where +data PopMessage where + PopMessage :: (forall l a. Poppable l a -> Poppable l a) -> PopMessage + deriving (Message) + +resizePop :: Float -> PopMessage +resizePop f = PopMessage $ \(Poppable b x y l) -> + Poppable b (g $ x + f) (g $ y + f) l + where + g = max 0 . min 0.45 + +setPop :: (Bool -> Bool) -> PopMessage +setPop f = PopMessage $ \(Poppable b x y l) -> Poppable (f b) x y l + +togglePop :: PopMessage +togglePop = setPop not + +poppable :: l a -> Poppable l a +poppable = Poppable False 0.05 0.05 +instance (LayoutClass l a, Eq a) => LayoutClass (Poppable l) a where + -- If the current layout is not popped, then just return what the underlying -- layout returned. - redoLayout Poppable { isPopped = False } _ _ returned = - return (returned, Nothing) - -- Can't do anything with an empty stack. - redoLayout _ _ Nothing returned = return (returned, Nothing) - - redoLayout self (Rectangle x y w h) (Just (W.focus -> focused)) returned = - return ((focused, newRect) : remaining, Nothing) + runLayout (W.Workspace + t + (Poppable True xs ys l) + a@(Just (W.focus -> focused))) + rect@(Rectangle x y w h) = do + (returned, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return + ((focused, newRect) : filter ((/=focused) . fst) returned, + Poppable True xs ys <$> maybeNewLayout) where - remaining = filter ((/=focused) . fst) returned - wp = floor $ fromIntegral w * xFrac self - hp = floor $ fromIntegral h * yFrac self + wp = floor $ fromIntegral w * xs + hp = floor $ fromIntegral h * ys newRect = Rectangle (x + wp) (y + hp) (w - fromIntegral (wp * 2)) (h - fromIntegral (hp * 2)) - -- Handle the Pop messages associated with this layout. - handleMessOrMaybeModifyIt self (fromMessage -> Just mess) = - return $ Just $ case mess of - TogglePop -> Left $ self { isPopped = not (isPopped self) } - Pop -> Left $ self { isPopped = True } - Unpop -> Left $ self { isPopped = False } - ResizePop amt | isPopped self -> - Left $ self { - xFrac = guard (xFrac self + amt), - yFrac = guard (yFrac self + amt) - } - ResizePop amt -> Right $ SomeMessage $ - if amt > 0 then Expand else Shrink - where - guard = min 0.45 . max 0 - - handleMessOrMaybeModifyIt _ _ = return Nothing + -- If the pop is not active, just delegate to the underlying layout. + runLayout (W.Workspace t (Poppable b x y l) a) rect = do + (rects, maybeNewLayout) <- runLayout (W.Workspace t l a) rect + return (rects, Poppable b x y <$> maybeNewLayout) + + -- If the message is a PopMessage, handle that here. + handleMessage p (fromMessage -> Just (PopMessage f)) = + return $ Just $ f p + + -- Intercept Shrink/Expand message if the pop is active, and resize the + -- pop size. + handleMessage p (fromMessage -> Just mess) | isPopped p = + case mess of + Shrink -> handleMessage p (SomeMessage $ resizePop 0.025) + Expand -> handleMessage p (SomeMessage $ resizePop (-0.025)) + + -- By default just pass the message to the underlying layout. + handleMessage (Poppable b x y l) mess = do + maybeNewLayout <- handleMessage l mess + return (Poppable b x y <$> maybeNewLayout) -- cgit