From b8428f25d0beeb9ee08fdb51d35d6c912d24f72a Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sat, 9 Apr 2022 15:09:55 -0600 Subject: Change mosaic to respond to multiple different kinds of messages --- src/Internal/Layout.hs | 81 +++++++++++++++++++++++++++++++++++++++++--- src/Internal/LayoutZipper.hs | 3 ++ src/Internal/Windows.hs | 6 +++- 3 files changed, 85 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Internal/Layout.hs b/src/Internal/Layout.hs index a1aeb17..fba1254 100644 --- a/src/Internal/Layout.hs +++ b/src/Internal/Layout.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, FlexibleInstances, KindSignatures, DataKinds, GADTs, RankNTypes, PolyKinds #-} module Internal.Layout where import GHC.TypeLits +import Data.Proxy (Proxy(..)) import Internal.CornerLayout (Corner(..)) import Control.Arrow (second) import XMonad.Hooks.ManageDocks @@ -25,19 +26,20 @@ import XMonad.Core import XMonad.Layout.NoBorders (smartBorders, noBorders) import Internal.LayoutZipper +import Internal.Windows import qualified Data.Map as M import qualified XMonad.StackSet as W +myLayout :: _ myLayout = fullscreenFull $ avoidStruts $ spacingRaw True (Border 5 5 5 5) True (Border 5 5 5 5) True $ layoutZipper $ mods (spiral (6/7)) |: - mods (MosaicAlt M.empty :: MosaicAlt Window) |: - mods ((Corner (3/4) (3/100) :: Corner Window)) |: - + mods (modifyMosaic (MosaicAlt M.empty :: MosaicAlt Window)) |: + mods (Corner (3/4) (3/100)) |: mods (ModifyDescription TallDescriptionModifier (Tall 1 (3/100) (1/2))) |: mods (ModifyDescription ThreeColDescMod (ThreeCol 1 (3/100) (1/2))) |: mods Grid |: @@ -45,6 +47,76 @@ myLayout = mods (D.Dwindle D.R D.CW 1.5 1.1) |: nil +-- This is a type class that defines how to reinterpret a message. One can think +-- of this as a kind of type-level function. It lets one associate a function +-- (reinterpretMessage) with a type construct, which for the case below is a +-- Symbol. +-- +-- It would be nice to attach this function to the LayoutModifier directly as a +-- value, however LayoutModifiers must be Show-able and Read-able and functions +-- are not. However encoding in the typesystem itsef which function is to be +-- called is the best alternative I have. +class DoReinterpret (k :: t) where + reinterpretMessage :: + Proxy k -> SomeMessage -> X (Maybe SomeMessage) + +-- Mosaic doesn't have the concept of a "Master Space", so reinterpret messages +-- intended to modify the master space and instead have those messages expand +-- and shrink the current window. +-- +-- "ForMosaic" is an instance of the Symbol kind. This is some neat type-system +-- hacking one can do in Haskell. +instance DoReinterpret "ForMosaic" where + + -- IncMaster message + reinterpretMessage _ (fromMessage -> Just (IncMasterN n)) = do + (fmap $ SomeMessage . + (if n > 0 + then expandWindowAlt + else shrinkWindowAlt)) <$> getFocusedWindow + + -- ResizeMaster message + reinterpretMessage _ (fromMessage -> Just m) = do + (fmap $ SomeMessage . + (case m of + Expand -> expandWindowAlt + Shrink -> shrinkWindowAlt)) <$> getFocusedWindow + + -- Messages that don't match the above, just leave it unmodified. + reinterpretMessage _ m = return (Just m) + +-- Data construct for association a DoReinterpret function with a concrete +-- construct that can be used in the LayoutModifier instance. +-- +-- It wolud be nice to have ReinterpretMessage hold the function as a value +-- rather than delegate to this kind-instance, however, it won't work because +-- LayoutModifiers have to be Read-able and Show-able, and functions are neither +-- of those, so a value-level function may not be a member of a LayoutModifier, +-- thus I have to settle for delegating to a hard-coded instance using +-- type-classes. +data ReinterpretMessage k a = ReinterpretMessage + deriving (Show, Read) + +-- Instance for ReinterpretMessage as a Layout modifier. +instance (DoReinterpret k) => + LayoutModifier (ReinterpretMessage k) a where + + handleMessOrMaybeModifyIt self message = do + + -- Delegates to the reinterpretMessage function associatied with the + -- type-variable k. + newMessage <- reinterpretMessage (ofProxy self) message + case newMessage of + Just m -> return $ Just $ Right m + Nothing -> return $ Just $ Left self + where + -- ofProxy just provides reifies the phantom type k so the type system can + -- figure out what instance to go to. + ofProxy :: ReinterpretMessage k a -> Proxy k + ofProxy _ = Proxy + +modifyMosaic :: l a -> ModifiedLayout (ReinterpretMessage "ForMosaic") l a +modifyMosaic = ModifiedLayout ReinterpretMessage mods = ModifiedLayout (Zoomable False 0.05 0.05) . @@ -52,6 +124,7 @@ mods = ModifiedLayout (HFlippable False) . ModifiedLayout (Rotateable False) + data ModifyDescription m l a = ModifyDescription m (l a) deriving (Show, Read) diff --git a/src/Internal/LayoutZipper.hs b/src/Internal/LayoutZipper.hs index 136b913..e34a078 100644 --- a/src/Internal/LayoutZipper.hs +++ b/src/Internal/LayoutZipper.hs @@ -42,12 +42,15 @@ data NavigateLayout = } deriving (Typeable) +-- NavigateLayout instance to move to the next layout, circularly. toNextLayout :: NavigateLayout toNextLayout = SetLayout (+1) True +-- NavigateLayout instance to move to the previous layout, circularly. toPreviousLayout :: NavigateLayout toPreviousLayout = SetLayout (\x -> x - 1) True +-- NavigateLayotu instance to move to the first layout. toFirstLayout :: NavigateLayout toFirstLayout = SetLayout (const 0) True diff --git a/src/Internal/Windows.hs b/src/Internal/Windows.hs index 98baa51..45fea95 100644 --- a/src/Internal/Windows.hs +++ b/src/Internal/Windows.hs @@ -3,7 +3,7 @@ module Internal.Windows where import XMonad (windowset, X, Window, get) import Control.Applicative ((<|>)) -import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), integrate, integrate', allWindows) +import XMonad.StackSet (Stack(..), StackSet(..), Screen(..), Workspace(..), peek, integrate, integrate', allWindows) import Data.Maybe (listToMaybe, catMaybes) import qualified Data.Map as Map @@ -52,6 +52,10 @@ forAllWindows fn = do stackSet <- windowset <$> get mapM_ fn (allWindows stackSet) +getFocusedWindow :: X (Maybe Window) +getFocusedWindow = do + (peek . windowset) <$> get + {- Finds a Window and returns the screen its on and the workspace its on. - Returns nothing if the window doesn't exist. - -- cgit