From bbcac714355cc0e182da304d565ff19a85feca0a Mon Sep 17 00:00:00 2001 From: Maynard Date: Wed, 14 Sep 2022 02:17:26 -0700 Subject: [PATCH 1/7] XMonad.WorkspaceLayouts: init --- XMonad/Util/OneState.hs | 142 ++++++++++++++ XMonad/WorkspaceLayout/Core.hs | 60 ++++++ XMonad/WorkspaceLayout/Cycle.hs | 113 +++++++++++ XMonad/WorkspaceLayout/Grid.hs | 326 ++++++++++++++++++++++++++++++++ XMonad/WorkspaceLayout/Util.hs | 11 ++ 5 files changed, 652 insertions(+) create mode 100644 XMonad/Util/OneState.hs create mode 100644 XMonad/WorkspaceLayout/Core.hs create mode 100644 XMonad/WorkspaceLayout/Cycle.hs create mode 100644 XMonad/WorkspaceLayout/Grid.hs create mode 100644 XMonad/WorkspaceLayout/Util.hs diff --git a/XMonad/Util/OneState.hs b/XMonad/Util/OneState.hs new file mode 100644 index 0000000000..9d1502d380 --- /dev/null +++ b/XMonad/Util/OneState.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module XMonad.Util.OneState + ( OneState (..) + , get + , put + , modify + , add + , once + , onceM + ) where + +import Control.Monad ((>=>)) +import Data.Maybe (fromMaybe) +import XMonad hiding (config, get, modify, put, + state, trace) +import qualified XMonad.Util.ExtensibleConf as XC +import qualified XMonad.Util.ExtensibleState as XS + + +{- | + +OneState is a replacement for both @XMonad.Util.ExtensibleState@ and @XMonad.Util.ExtensibleConf@ + +A comparison of these three modules is as follows: + +- @ExtensibleConf@ allows the programmer to accept a user-supplied value at config-time. + However, this value cannot be changed during runtime. + +- @ExtensibleState@ allows the programmer to keep mutable state. + However, the initial value for this state must be known at compile-time and is not + configurable at config-time. + +- @OneState@ proves an API which matches the power of both @ExtensibleConf@ and @ExtensibleState@, + allowing the programmer to keep mutable state *and* allowing this mutable state to be configured + at config-time. + +-} + + +class Typeable state => OneState state where + + -- | Associated type of config-time modifications to state + type Mod state + + -- | + -- + -- How to apply a modification + -- + -- This operation may have effects in the X monad. However, no strong + -- guarantees are made about its evaluation, such as guarantees about + -- timing or multiplicity. Beware! + merge :: Mod state -> (state -> X state) + + -- | Default value for the state + defaultState :: state + + +-- hook into ExtensibleState +newtype State state = State (Maybe state) + deriving (Typeable) + +instance OneState state => ExtensionClass (State state) where + initialValue = State Nothing + +-- hook into ExtensibleConf +newtype Config state = Config [Mod state] + deriving newtype (Typeable, Semigroup) + +trivialConfig :: Config state +trivialConfig = Config [] + + +-- | +-- +-- Like @ExtensibleState.get@ +-- +-- Retrieve the current state value +-- +-- * If the state has been explicitly set during runtime, then the most recent +-- set value will be returned +-- +-- * Otherwise, if the state was configured during config-time, then all the +-- config-time @Mod state@ values will be applied to @defaultState@, and +-- that will be returned +-- +-- * Otherwise, @default@ is returned +get :: forall state. OneState state => X state +get = XS.get >>= \case + State (Just state) -> pure state + State Nothing -> foldConfig + + where + + foldConfig :: X state + foldConfig = do + Config deltas :: Config state <- fromMaybe trivialConfig <$> XC.ask + let bigDelta = foldr (>=>) pure $ merge <$> deltas + result <- bigDelta defaultState + put result -- modifications are monadic; ensure we only perform them once + pure result + + +-- | Like @ExtensibleState.put@ +put :: OneState state => state -> X () +put = XS.put . State . Just + +-- | Like @ExtensibleState.modify@ +modify :: OneState state => (state -> state) -> X () +modify f = put =<< (f <$> get) + + +-- | Like @ExtensibleConf.onceM@ +onceM + :: forall state m l + . (OneState state, Applicative m) + => (XConfig l -> m (XConfig l)) + -> Mod state + -> (XConfig l -> m (XConfig l)) +onceM modX modState = XC.onceM modX (Config @state . one $ modState) + where one x = [x] + +-- | Like @ExtensibleConf.once@ +once + :: forall state l + . OneState state + => (XConfig l -> XConfig l) + -> Mod state + -> (XConfig l -> XConfig l) +once modX modState = XC.once modX (Config @state . one $ modState) + where one x = [x] + +-- | Like @ExtensibleConf.add@ +add :: forall state l. OneState state => Mod state -> (XConfig l -> XConfig l) +add = once @state id diff --git a/XMonad/WorkspaceLayout/Core.hs b/XMonad/WorkspaceLayout/Core.hs new file mode 100644 index 0000000000..0f98e57f00 --- /dev/null +++ b/XMonad/WorkspaceLayout/Core.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module XMonad.WorkspaceLayout.Core where + +import Prelude hiding (span) + +import Control.Category ((>>>)) +import Data.Function (on) +import Data.List (elemIndex) +import GHC.Generics (Generic) +import XMonad hiding (config, modify, state, + trace, workspaces) +import XMonad.Hooks.StatusBar.PP (PP (..)) +import XMonad.StackSet (tag) +import XMonad.Util.WorkspaceCompare (mkWsSort) + + +-- | +-- +-- Encompasses information needed to render a workspace layout +data WorkspaceLayoutView = WSLView + { label :: String + , neighborhood :: [WorkspaceId] + , toName :: WorkspaceId -> String + } deriving (Generic) + + +render :: WorkspaceLayoutView -> PP +render (WSLView { neighborhood, toName, label }) = + + withLabel . withNameTransform . withNeighborhood $ def + + where + + withNameTransform pp = pp + { ppCurrent = toName + , ppHidden = toName + , ppHiddenNoWindows = toName + } + + withNeighborhood pp = pp + { ppSort = do + sort <- (mkWsSort . pure) (compare `on` flip elemIndex neighborhood) + pure $ filter (tag >>> (`elem` neighborhood)) >>> sort + } + + withLabel pp = pp + { ppOrder = \(workspaces : rest) -> (label <> workspaces) : rest + } + diff --git a/XMonad/WorkspaceLayout/Cycle.hs b/XMonad/WorkspaceLayout/Cycle.hs new file mode 100644 index 0000000000..740e09363b --- /dev/null +++ b/XMonad/WorkspaceLayout/Cycle.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +module XMonad.WorkspaceLayout.Cycle + ( Coord (..) + , Config (..) + , BoundsMode (..) + , move + , swap + , hook + , getView + ) where + +import Prelude + +import Control.Monad.State (execState) +import GHC.Generics (Generic) +import qualified XMonad +import XMonad hiding (config, state, trace, + workspaces) +import XMonad.StackSet (greedyView, shift) + +import qualified XMonad.Util.OneState as St +import XMonad.Util.OneState (OneState (..)) +import XMonad.WorkspaceLayout.Core (WorkspaceLayoutView (..)) +import XMonad.WorkspaceLayout.Util (affineMod, (!%)) + + + +data Coord = Coord + { offset :: Int + , position :: Int + } + deriving (Show, Eq, Ord, Generic) + +data Config = Config + { width :: Int + , workspaces :: [WorkspaceId] + } + deriving (Show, Generic) + +data State = State + { coord :: Coord + , config :: Config + } + deriving (Show, Generic) + +instance OneState State where + type Mod State = State -> State + merge ma s = pure (ma s) + defaultState = State + { coord = Coord 0 0 + , config = Config 5 (single <$> ['a' .. 'j']) + } + where single = (:[]) + + +data BoundsMode = Clamp | Wrap + +move :: BoundsMode -> (Coord -> Coord) -> X () +move mode f = do + (coord', wid') <- calc mode f + St.modify $ \st -> st { coord = coord' } + windows (greedyView wid') + +swap :: BoundsMode -> (Coord -> Coord) -> X () +swap mode f = do + (_, wid') <- calc mode f + windows (shift wid') + +calc :: BoundsMode -> (Coord -> Coord) -> X (Coord, WorkspaceId) +calc mode f = do + State coord (Config { width, workspaces }) <- St.get + let coord' = flip execState coord $ do + modify f + offset' <- offset <$> get + modify $ + let updatePosition = + (let lo = offset' - width `div` 2 + hi = offset' + width `div` 2 + in case mode of + Clamp -> max lo . min hi + Wrap -> affineMod (lo, hi)) + in \st -> st { position = updatePosition (position st) } + let wid = workspaces !% (position coord') + pure (coord', wid) + + +hook :: Config -> XConfig l -> XConfig l +hook config = St.once @State + (\xc -> xc { XMonad.workspaces = workspaces config }) + (\state -> state { config = config }) + +getView :: X WorkspaceLayoutView +getView = do + State (Coord { offset }) (Config { width, workspaces }) <- St.get + pure $ WSLView + { toName = id + , label = "" + , neighborhood = + (do pos <- [offset - width `div` 2 .. offset + width `div` 2] + pure $ workspaces !% (pos `mod` length workspaces) + ) + } + diff --git a/XMonad/WorkspaceLayout/Grid.hs b/XMonad/WorkspaceLayout/Grid.hs new file mode 100644 index 0000000000..c75dbb6d1f --- /dev/null +++ b/XMonad/WorkspaceLayout/Grid.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +{- | Two-dimensional workspaces for XMonad -} + +module XMonad.WorkspaceLayout.Grid + ( Formatted (..) + , IsFormatted (..) + , unsafeChangeFormatting + , Mapping (..) + , SomeMapping (..) + , Dims(..) + , fromMap + , fromFunction + , grid + , grid' + , group + , column + , Coord (..) + , Wrapping (..) + , State (..) + , move + , swap + , update + , Init (..) + , hook + , getView + ) where + +import Prelude hiding (span) + +import Control.Category ((>>>)) +import Data.Foldable (fold, toList) +import Data.Function ((&)) +import Data.List (intercalate, nub) +import Data.List.Split (splitOn) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (Endo (..), appEndo) +import GHC.Generics (Generic) +import XMonad hiding (config, state, trace) +import XMonad.StackSet (greedyView, shift) + +import qualified XMonad.Util.OneState as St +import XMonad.WorkspaceLayout.Core (WorkspaceLayoutView (..)) +import XMonad.WorkspaceLayout.Util (affineMod) + + + +data Formatted + + = Unformatted + -- ^ + -- + -- Workspace IDs are left untouched + + | Formatted + -- ^ + -- Workspace IDs are formatted + -- + -- This means *specifically* that workspace IDs are of the format + -- : + -- Where + -- * contains a uniquely-identifying string + -- * contains the workspace name + -- * may not contain colons + -- + -- (Editor's note: ideally, I'd like to allow custom formats beyond + -- just this specific one. Such a desire is, however, in tension with + -- retaining the static guarantee that formats are not mixed. Achieving + -- this might be possible, but I'm judging it not worth the effort.) + + +doFormat :: forall ftd. IsFormatted ftd => Coord -> String -> WorkspaceId +doFormat (XY x y) name = + case demoteFormatted @ftd of + Formatted -> show y <> "/" <> show x <> ":" <> name + Unformatted -> name + + +doToName :: forall ftd. IsFormatted ftd => WorkspaceId -> String +doToName = + case demoteFormatted @ftd of + Unformatted -> id + Formatted -> splitOn ":" >>> drop 1 >>> intercalate ":" + + +class IsFormatted (ftd :: Formatted) where + demoteFormatted :: Formatted + +instance IsFormatted 'Unformatted where + demoteFormatted = Unformatted + +instance IsFormatted 'Formatted where + demoteFormatted = Formatted + + +newtype Mapping (ftd :: Formatted) = Mapping { unMapping :: Map Coord WorkspaceId } + deriving (Show, Generic) + +unsafeChangeFormatting :: forall old (ftd :: Formatted). Mapping old -> Mapping ftd +unsafeChangeFormatting (Mapping mp) = Mapping mp + +instance Semigroup (Mapping ftd) where + Mapping ma <> Mapping mb = Mapping (mb <> ma) -- right-biased + +instance Monoid (Mapping ftd) where + mempty = Mapping mempty + + +data SomeMapping = forall ftd. IsFormatted ftd => SomeMapping (Mapping ftd) + +-- onTheMap :: (Map Coord WorkspaceId -> Map Coord WorkspaceId) -> (SomeMapping -> SomeMapping) +-- onTheMap f (SomeMapping (Mapping mp :: Mapping ftd)) = (SomeMapping (Mapping @ftd (f mp))) + +getTheMap :: SomeMapping -> Map Coord WorkspaceId +getTheMap (SomeMapping (Mapping mp)) = mp + +range :: Ord x => (Coord -> x) -> SomeMapping -> Maybe (x, x) +range proj (getTheMap -> mapping) = + let xs = proj <$> Map.keys mapping + in case xs of + [] -> Nothing + _ -> Just (minimum xs, maximum xs) + +span :: (Ord x, Enum x) => (Coord -> x) -> SomeMapping -> [x] +span proj (getTheMap -> mapping) = + let xs = proj <$> Map.keys mapping + in case xs of + [] -> [] + _ -> [minimum xs .. maximum xs] + + + +data Dims = Dims { width :: Int, height :: Int } + + +-- | Construct a Mapping from a Map +fromMap :: Map Coord WorkspaceId -> Mapping 'Unformatted +fromMap = Mapping + + +-- | Construct a Mapping from a function +fromFunction :: Dims -> (Coord -> WorkspaceId) -> Mapping 'Unformatted +fromFunction (Dims { width, height }) = + let domain = XY <$> [0 .. width - 1] <*> [0 .. height - 1] + in fromMap . funToMap domain + + where + funToMap :: Ord k => [k] -> (k -> v) -> Map k v + funToMap xs f = Map.fromList $ (\k -> (k, f k)) <$> xs + + +-- | +-- +-- Construct a 2d grid +-- +-- Each coordinate (x, y) will be given the name @show (x + 1)@ +grid :: Dims -> Mapping 'Formatted +grid = grid' (\(XY x _) -> show $ x + 1) + + +-- | +-- +-- Construct a 2d grid +-- +-- Each coordinate will be assigned a name according to the supplied function +grid' :: (Coord -> String) -> Dims -> Mapping 'Formatted +grid' toName (Dims { width, height }) = + Mapping . fold $ do + y <- [0 .. height - 1] + x <- [0 .. width - 1] + let coord = XY x y + pure $ Map.singleton coord (doFormat @'Formatted coord $ toName coord) + + +-- | Glue together a group of workspaces +group :: forall f ftd. (IsFormatted ftd, Foldable f) => f Coord -> String -> Mapping ftd +group (toList -> xs) name = case xs of + [] -> Mapping mempty + (x0:_) -> Mapping $ xs & foldMap (\x -> Map.singleton x (doFormat @ftd x0 name)) + + +-- | Glue together a column of workspaces +column :: forall ftd. IsFormatted ftd => Dims -> Int -> String -> Mapping ftd +column (Dims { height }) x name = + Mapping . fold $ do + y <- [0 .. height - 1] + let topLeft = XY x 0 + pure $ Map.singleton (XY x y) (doFormat @ftd topLeft name) + + + + +data Coord = XY { x :: Int, y :: Int } + deriving (Show, Ord, Eq, Generic) + +data Wrapping = Wrapping + { wrapX :: Bool + , wrapY :: Bool + } + deriving (Show, Generic) + +data State = State + { mapping :: SomeMapping + -- ^ Coordinate -> WorkspaceId mapping + , labelf :: Coord -> Maybe String + -- ^ Labels + , wrapping :: Wrapping + -- ^ Wrapping mode + , coord :: Coord + -- ^ Current coordinate + } deriving (Generic) + +instance St.OneState State where + type Mod State = State -> State + merge ma s = pure (ma s) + defaultState = State + { mapping = SomeMapping (grid $ Dims 5 5) + , wrapping = Wrapping False False + , coord = XY 0 0 + , labelf = const Nothing + } + +-- Wrap a coordinate around the x/y axes according to the configured wrapping mode +wrap :: State -> (Coord -> Coord) +wrap state = + + appEndo . fromMaybe (Endo id) $ do + xRange <- range x (mapping state) + yRange <- range y (mapping state) + + pure $ guard (state & wrapping & wrapX) (Endo $ \c -> c { x = affineMod xRange (x c) }) + <> guard (state & wrapping & wrapY) (Endo $ \c -> c { y = affineMod yRange (y c) }) + + where + + guard :: Monoid m => Bool -> m -> m + guard = \case { True -> id; False -> const mempty } + + + +-- | +-- +-- The call @move f@ replaces the current coordinate to @f currentCoord@ +-- +-- If @f currentCoord@ is out-of-bounds, do nothing +-- +-- Use this to move around workspaces +move :: (Coord -> Coord) -> X () +move = update $ \coord wid -> do + St.modify $ \st -> st { coord = coord } + windows (greedyView wid) + + +-- | +-- +-- The call @swap f@ moves the selected window to @f currentCoord@ +-- +-- If @f currentCoord@ is out-of-bounds, do nothing +swap :: (Coord -> Coord) -> X () +swap = update $ \_ wid -> windows (shift wid) + +update :: (Coord -> WorkspaceId -> X ()) -> (Coord -> Coord) -> X () +update act f = do + state@State { coord, mapping } <- St.get + let coord' = coord & f & wrap state + case Map.lookup coord' (getTheMap mapping) of + Nothing -> pure () + Just wid -> do + act coord' wid + + +data Init = Init + { initMapping :: SomeMapping + -- ^ Physical layout + , initWrapping :: Wrapping + -- ^ Wrapping mode + , initLabelf :: Coord -> Maybe String + -- ^ + -- Displayed to the left of the axis workspaces + -- When Nothing is returned, uses a fallback + } + +-- | Hook the grid layout into XMonad +hook :: Init -> XConfig l -> XConfig l +hook Init { initMapping, initWrapping, initLabelf } = + St.once @State + (\xc -> xc { XMonad.workspaces = workspaces }) + (\state -> state + { mapping = initMapping + , wrapping = initWrapping + , labelf = initLabelf + }) + + where + workspaces = toList (getTheMap initMapping) + & nub -- account for two coordinates pointing to the same workspace + +getView :: X WorkspaceLayoutView +getView = do + State { coord, mapping, labelf } <- St.get + let XY _ y = coord + pure $ WSLView + { neighborhood = + let coords = (flip XY y) <$> span x mapping + in coords & fmap (flip Map.lookup (getTheMap mapping)) & catMaybes & nub + , toName = case mapping of SomeMapping (_ :: Mapping ftd) -> doToName @ftd + , label = labelf coord & fromMaybe (show (y + 1) <> " / ") + } + diff --git a/XMonad/WorkspaceLayout/Util.hs b/XMonad/WorkspaceLayout/Util.hs new file mode 100644 index 0000000000..6d8b8c211b --- /dev/null +++ b/XMonad/WorkspaceLayout/Util.hs @@ -0,0 +1,11 @@ +module XMonad.WorkspaceLayout.Util where + +(!%) :: [a] -> Int -> a +xs !% n = xs !! (n `mod` length xs) + +-- Doubly-inclusive +affineMod :: (Ord a, Num a) => (a, a) -> (a -> a) +affineMod range@(lo, hi) x + | x > hi = affineMod range (x - (hi - lo + 1)) + | x < lo = affineMod range (x + (hi - lo + 1)) + | otherwise = x From d0672a95b847c8c87fe3ec37ae471ff36637fced Mon Sep 17 00:00:00 2001 From: Maynard Date: Mon, 3 Oct 2022 13:50:27 -0700 Subject: [PATCH 2/7] XMonad.WorkspaceLayouts: actually compile --- XMonad/WorkspaceLayout/Grid.hs | 14 ++++++++------ xmonad-contrib.cabal | 5 +++++ 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/XMonad/WorkspaceLayout/Grid.hs b/XMonad/WorkspaceLayout/Grid.hs index c75dbb6d1f..f3b6ac7209 100644 --- a/XMonad/WorkspaceLayout/Grid.hs +++ b/XMonad/WorkspaceLayout/Grid.hs @@ -43,11 +43,9 @@ module XMonad.WorkspaceLayout.Grid import Prelude hiding (span) -import Control.Category ((>>>)) import Data.Foldable (fold, toList) import Data.Function ((&)) -import Data.List (intercalate, nub) -import Data.List.Split (splitOn) +import Data.List (nub) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) @@ -60,8 +58,6 @@ import qualified XMonad.Util.OneState as St import XMonad.WorkspaceLayout.Core (WorkspaceLayoutView (..)) import XMonad.WorkspaceLayout.Util (affineMod) - - data Formatted = Unformatted @@ -97,7 +93,13 @@ doToName :: forall ftd. IsFormatted ftd => WorkspaceId -> String doToName = case demoteFormatted @ftd of Unformatted -> id - Formatted -> splitOn ":" >>> drop 1 >>> intercalate ":" + Formatted -> dropThrough ':' + + where + + -- dropThrough '~' "aa~bb~cc" == "bb~cc" + dropThrough :: Char -> String -> String + dropThrough delim = drop 1 . dropWhile (/= delim) class IsFormatted (ftd :: Formatted) where diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 976498b0af..b45d81cffb 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -371,6 +371,7 @@ library XMonad.Util.NamedScratchpad XMonad.Util.NamedWindows XMonad.Util.NoTaskbar + XMonad.Util.OneState XMonad.Util.Parser XMonad.Util.Paste XMonad.Util.PositionStore @@ -396,6 +397,10 @@ library XMonad.Util.WorkspaceCompare XMonad.Util.XSelection XMonad.Util.XUtils + XMonad.WorkspaceLayout.Core + XMonad.WorkspaceLayout.Cycle + XMonad.WorkspaceLayout.Grid + XMonad.WorkspaceLayout.Util test-suite tests type: exitcode-stdio-1.0 From 2d8aff57a12a06104e16d5e9f3b7ef56fcb9db54 Mon Sep 17 00:00:00 2001 From: Maynard Date: Mon, 3 Oct 2022 14:29:17 -0700 Subject: [PATCH 3/7] XMonad.Workspaces: inline parts of Core (render) --- XMonad/WorkspaceLayout/Core.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/XMonad/WorkspaceLayout/Core.hs b/XMonad/WorkspaceLayout/Core.hs index 0f98e57f00..7f7ef74a1e 100644 --- a/XMonad/WorkspaceLayout/Core.hs +++ b/XMonad/WorkspaceLayout/Core.hs @@ -37,24 +37,18 @@ data WorkspaceLayoutView = WSLView render :: WorkspaceLayoutView -> PP render (WSLView { neighborhood, toName, label }) = - - withLabel . withNameTransform . withNeighborhood $ def - - where - - withNameTransform pp = pp + def + -- display the workspace names { ppCurrent = toName , ppHidden = toName , ppHiddenNoWindows = toName - } - withNeighborhood pp = pp - { ppSort = do + -- display only a subset of workspaces (the "neighborhood") of the current workspace + , ppSort = do sort <- (mkWsSort . pure) (compare `on` flip elemIndex neighborhood) pure $ filter (tag >>> (`elem` neighborhood)) >>> sort - } - withLabel pp = pp - { ppOrder = \(workspaces : rest) -> (label <> workspaces) : rest + -- display the label to the left + , ppOrder = \(workspaces : rest) -> (label <> workspaces) : rest } From c220f1d26e4c22bb44d77c299c37de7f6e1a1cb8 Mon Sep 17 00:00:00 2001 From: Maynard Date: Mon, 3 Oct 2022 16:10:04 -0700 Subject: [PATCH 4/7] XMonad.WorkspaceLayout: documentation --- XMonad/WorkspaceLayout/Core.hs | 27 +++- XMonad/WorkspaceLayout/Cycle.hs | 13 ++ XMonad/WorkspaceLayout/Grid.hs | 251 ++++++++++++++++++++++++++------ 3 files changed, 240 insertions(+), 51 deletions(-) diff --git a/XMonad/WorkspaceLayout/Core.hs b/XMonad/WorkspaceLayout/Core.hs index 7f7ef74a1e..dbaf9f2f63 100644 --- a/XMonad/WorkspaceLayout/Core.hs +++ b/XMonad/WorkspaceLayout/Core.hs @@ -10,6 +10,14 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} +{- | + +Generic operations for workspace layouts + +See 'XMonad.WorkspaceLayout.Grid' + +-} + module XMonad.WorkspaceLayout.Core where import Prelude hiding (span) @@ -35,13 +43,26 @@ data WorkspaceLayoutView = WSLView } deriving (Generic) +-- | +-- +-- Render a workspace layout to a 'PP' +-- +-- If you add additional modifications on top of this, take care not to overwrite +-- what's already been set. For instance, instead of doing: +-- +-- > (render view) { ppHidden = myHidden } +-- +-- prefer +-- +-- > let rendered = render view +-- > in rendered { ppHidden = myHidden . rendered } render :: WorkspaceLayoutView -> PP render (WSLView { neighborhood, toName, label }) = def -- display the workspace names - { ppCurrent = toName - , ppHidden = toName - , ppHiddenNoWindows = toName + { ppCurrent = ppCurrent def . toName + , ppHidden = ppHidden def . toName + , ppHiddenNoWindows = (map (const '.')) . toName -- display only a subset of workspaces (the "neighborhood") of the current workspace , ppSort = do diff --git a/XMonad/WorkspaceLayout/Cycle.hs b/XMonad/WorkspaceLayout/Cycle.hs index 740e09363b..0b7de46e57 100644 --- a/XMonad/WorkspaceLayout/Cycle.hs +++ b/XMonad/WorkspaceLayout/Cycle.hs @@ -9,6 +9,19 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall -Werror #-} +{- | + +Cyclic one-dimensional workspace layouts for XMonad + +This module is intended mostly to serve as another example workspace +layout other than 'XMonad.WorkspaceLayout.Grid'. + +However, a cyclic layout is not particularly useful, and so this +module isn't /really/ intended to be used. Feel free to if you want, +though. It should still work! + +-} + module XMonad.WorkspaceLayout.Cycle ( Coord (..) , Config (..) diff --git a/XMonad/WorkspaceLayout/Grid.hs b/XMonad/WorkspaceLayout/Grid.hs index f3b6ac7209..9f05fea993 100644 --- a/XMonad/WorkspaceLayout/Grid.hs +++ b/XMonad/WorkspaceLayout/Grid.hs @@ -15,30 +15,48 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wall -Werror #-} -{- | Two-dimensional workspaces for XMonad -} +{- | + +Two-dimensional workspaces for XMonad. + +This is like @XMonad.Util.Plane@, but more featureful and not hacky. +(This module does, however, have a more complex API.) + +-} module XMonad.WorkspaceLayout.Grid - ( Formatted (..) - , IsFormatted (..) - , unsafeChangeFormatting - , Mapping (..) - , SomeMapping (..) - , Dims(..) + + -- * Example + -- $example + + -- * Hooking into XMonad + ( hook + , getView + , Init (..) + , Wrapping (..) + + -- * Runtime interaction + , Coord (..) + , move + , swap + , update + + -- * 'Mapping's and ways to construct them + , Dims (..) , fromMap , fromFunction , grid , grid' , group , column - , Coord (..) - , Wrapping (..) - , State (..) - , move - , swap - , update - , Init (..) - , hook - , getView + , Mapping (..) + , SomeMapping (..) + + -- * Core module types + , Formatted (..) + , IsFormatted (..) + , unsafeChangeFormatting + ) where import Prelude hiding (span) @@ -58,25 +76,41 @@ import qualified XMonad.Util.OneState as St import XMonad.WorkspaceLayout.Core (WorkspaceLayoutView (..)) import XMonad.WorkspaceLayout.Util (affineMod) +-- | +-- +-- For the grid layout to work, it has to know of (and possibly have control +-- over) the names of the XMonad workspaces. +-- +-- The can either choose to give this module full control of the workspace +-- names (represented by 'Formatted'). In return, this module provides some +-- affordances for easily configuring the workspace grid (see e.g. 'grid'). +-- +-- Alternatively, the user may choose to retain control of their workspace +-- names (represented by 'Unfortmatted'). However, they will have to put +-- slightly more work into configuring the workspace layout. data Formatted = Unformatted -- ^ - -- -- Workspace IDs are left untouched | Formatted -- ^ -- Workspace IDs are formatted -- - -- This means *specifically* that workspace IDs are of the format - -- : - -- Where - -- * contains a uniquely-identifying string - -- * contains the workspace name - -- * may not contain colons + -- This means /specifically/ that workspace IDs are of the format + -- \:\ -- - -- (Editor's note: ideally, I'd like to allow custom formats beyond + -- where + -- + -- * \ contains a uniquely-identifying string + -- * \ contains the workspace name + -- * \ may not contain colons + -- + -- Note that workspace IDs will not be /displayed/ this way. This + -- is just what they will be stored as "under the hood". + + -- (note: ideally, I'd like to allow custom formats beyond -- just this specific one. Such a desire is, however, in tension with -- retaining the static guarantee that formats are not mixed. Achieving -- this might be possible, but I'm judging it not worth the effort.) @@ -102,6 +136,7 @@ doToName = dropThrough delim = drop 1 . dropWhile (/= delim) +-- | Provides type-to-value demotion on 'Formatted' class IsFormatted (ftd :: Formatted) where demoteFormatted :: Formatted @@ -112,9 +147,21 @@ instance IsFormatted 'Formatted where demoteFormatted = Formatted +-- | +-- +-- A 'Mapping' is a mapping from a grid coordinate to its associated workspace id. +-- +-- If two coordinates have the same workspace id, then they will share content! newtype Mapping (ftd :: Formatted) = Mapping { unMapping :: Map Coord WorkspaceId } deriving (Show, Generic) + +-- | +-- +-- Change the type of a 'Mapping' +-- +-- This is unsafe because it allows for having a value which is typed as 'Mapping' ''Formatted' +-- despite not following the prescribed formatting. unsafeChangeFormatting :: forall old (ftd :: Formatted). Mapping old -> Mapping ftd unsafeChangeFormatting (Mapping mp) = Mapping mp @@ -125,11 +172,9 @@ instance Monoid (Mapping ftd) where mempty = Mapping mempty +-- | Existential over 'Mapping' data SomeMapping = forall ftd. IsFormatted ftd => SomeMapping (Mapping ftd) --- onTheMap :: (Map Coord WorkspaceId -> Map Coord WorkspaceId) -> (SomeMapping -> SomeMapping) --- onTheMap f (SomeMapping (Mapping mp :: Mapping ftd)) = (SomeMapping (Mapping @ftd (f mp))) - getTheMap :: SomeMapping -> Map Coord WorkspaceId getTheMap (SomeMapping (Mapping mp)) = mp @@ -149,15 +194,16 @@ span proj (getTheMap -> mapping) = +-- | Grid dimensions data Dims = Dims { width :: Int, height :: Int } --- | Construct a Mapping from a Map +-- | Construct a 'Mapping' from a 'Map' fromMap :: Map Coord WorkspaceId -> Mapping 'Unformatted fromMap = Mapping --- | Construct a Mapping from a function +-- | Construct a 'Mapping' from a function fromFunction :: Dims -> (Coord -> WorkspaceId) -> Mapping 'Unformatted fromFunction (Dims { width, height }) = let domain = XY <$> [0 .. width - 1] <*> [0 .. height - 1] @@ -170,16 +216,16 @@ fromFunction (Dims { width, height }) = -- | -- --- Construct a 2d grid +-- Construct a 2d grid 'Mapping' -- --- Each coordinate (x, y) will be given the name @show (x + 1)@ +-- Each coordinate @(x, y)@ will be given the name @show (x + 1)@ grid :: Dims -> Mapping 'Formatted grid = grid' (\(XY x _) -> show $ x + 1) -- | -- --- Construct a 2d grid +-- Construct a 2d grid 'Mapping' -- -- Each coordinate will be assigned a name according to the supplied function grid' :: (Coord -> String) -> Dims -> Mapping 'Formatted @@ -191,27 +237,46 @@ grid' toName (Dims { width, height }) = pure $ Map.singleton coord (doFormat @'Formatted coord $ toName coord) --- | Glue together a group of workspaces +-- | +-- +-- Glue together a group of workspaces +-- +-- Inteded to be used alongside the 'Monoid' instance for 'Mapping'. For example, +-- to create a 4x4 grid with the right-hand column glued together, one could write +-- +-- > let dims = Dims { width = 4, height = 4 } +-- > in grid dims <> column dims 4 "my-workspace" group :: forall f ftd. (IsFormatted ftd, Foldable f) => f Coord -> String -> Mapping ftd group (toList -> xs) name = case xs of [] -> Mapping mempty (x0:_) -> Mapping $ xs & foldMap (\x -> Map.singleton x (doFormat @ftd x0 name)) --- | Glue together a column of workspaces +-- | +-- +-- Glue together a column of workspaces column :: forall ftd. IsFormatted ftd => Dims -> Int -> String -> Mapping ftd -column (Dims { height }) x name = - Mapping . fold $ do - y <- [0 .. height - 1] - let topLeft = XY x 0 - pure $ Map.singleton (XY x y) (doFormat @ftd topLeft name) - +column + (Dims { height }) -- ^ Grid dimension + x -- ^ The column coordinate + name -- ^ The name to give to workspaces in the column + = + Mapping . fold $ do + y <- [0 .. height - 1] + let topLeft = XY x 0 + pure $ Map.singleton (XY x y) (doFormat @ftd topLeft name) +-- | A grid coordinate. Grids are zero-indexed! data Coord = XY { x :: Int, y :: Int } deriving (Show, Ord, Eq, Generic) +-- | +-- +-- Whether or not moving out-of-bounds should wrap over +-- +-- If 'True', wrap. If 'False', refuse to move. data Wrapping = Wrapping { wrapX :: Bool , wrapY :: Bool @@ -259,11 +324,16 @@ wrap state = -- | -- --- The call @move f@ replaces the current coordinate to @f currentCoord@ +-- If @c@ is the current coordinate, calling @move f@ will move XMonad +-- to the coordinate @f c@. +-- +-- For instance, the following will move one workspace to the right: -- --- If @f currentCoord@ is out-of-bounds, do nothing +-- > move (\(XY x y) -> XY (x + 1) y) -- --- Use this to move around workspaces +-- And this will move to row 3: +-- +-- > move (\(XY x _) -> XY x 3) move :: (Coord -> Coord) -> X () move = update $ \coord wid -> do St.modify $ \st -> st { coord = coord } @@ -272,9 +342,7 @@ move = update $ \coord wid -> do -- | -- --- The call @swap f@ moves the selected window to @f currentCoord@ --- --- If @f currentCoord@ is out-of-bounds, do nothing +-- Like 'move', but for moving windows around swap :: (Coord -> Coord) -> X () swap = update $ \_ wid -> windows (shift wid) @@ -288,6 +356,7 @@ update act f = do act coord' wid +-- | Initialization options data Init = Init { initMapping :: SomeMapping -- ^ Physical layout @@ -296,10 +365,19 @@ data Init = Init , initLabelf :: Coord -> Maybe String -- ^ -- Displayed to the left of the axis workspaces - -- When Nothing is returned, uses a fallback + -- + -- When 'Nothing' is returned, uses a fallback } --- | Hook the grid layout into XMonad + +-- | +-- +-- Hook the grid layout into XMonad +-- +-- __Please note:__ if the 'initMapping' you supply contains a: +-- +-- - 'Mapping' ''Formatted', then your XMonad workspace names /will be overriden/. +-- - 'Mapping' ''Unfotmatted', then your XMonad workspace names will be deduplicated hook :: Init -> XConfig l -> XConfig l hook Init { initMapping, initWrapping, initLabelf } = St.once @State @@ -313,7 +391,13 @@ hook Init { initMapping, initWrapping, initLabelf } = where workspaces = toList (getTheMap initMapping) & nub -- account for two coordinates pointing to the same workspace + -- WANT: does deduplication need to happen on @Mapping 'Unformatted@s? +-- | +-- +-- Generate the layout view. +-- +-- Use this with 'XMonad.WorkspaceLayout.Core.render' to render to your status bar. getView :: X WorkspaceLayoutView getView = do State { coord, mapping, labelf } <- St.get @@ -326,3 +410,74 @@ getView = do , label = labelf coord & fromMaybe (show (y + 1) <> " / ") } + + + +{- $example + +Example usage of this module might look something like the following. + +Assume we've imported this module as @Grid@. First we create the config: + +> gridConfig :: Grid.Init +> gridConfig = +> let dims = Grid.Dims { Grid.width = 5, Grid.height = 3 } +> getName (Grid.XY x y) = show y <> "/" <> show (x + 1) +> mapping = Grid.grid' getName dims <> Grid.column dims 4 "gutter" +> in Grid.Init +> { Grid.initMapping = Grid.SomeMapping mapping +> , Grid.initWrapping = Grid.Wrapping True True +> , Grid.initLabelf = \(Grid.XY _ y) -> Just ("y=" <> show y <> ": ") +> } + +This configuration says the following: + +- We want a 5x3 grid +- Where a workspace at @(x, y)@ has the name @{y}/{x+1}@ +- Except for the column at @x=4@, which should all be one workspace called @gutter@ +- There should be a label with the format @y={y}@ + +Visually, our grid looks like this: + +@ +0\/1 0\/2 0\/3 0\/4 gutter + |||||| +1\/1 1\/2 1\/3 1\/4 gutter + |||||| +2\/1 2\/2 2\/3 2\/4 gutter + |||||| +3\/1 3\/2 3\/3 3\/4 gutter +@ + +Where the @||||||@ bars mean that the gutter on the right is all one workspace. + +For this config to actually be useful, we also need to: + +- Hook into XMonad with @Grid.hook gridConfig@ +- Set up keybindings for 'move' to move around the layout +- Set up the layout display by generating a 'XMonad.Hooks.StatusBar.PP.PP' with @XMonad.WorkspaceLayouts.Core.render \<$\> Grid.getView@ and displaying that @PP@ however we like + +I use XMobar to display my status bar, and with this configuration I get something that looks like this: + +<> + +In this screenshot: + +- On the left, the configured label displays @y=0@ +- Only the workspaces on the current row are displayed: @0\/1@, @0\/2@, @0\/3@, @0\/4@, and @gutter@ +- The workspace @0\/4@ is displayed as @...@ because it has no windows +- The workspace @0\/3@ is displayed with brackets because it is my current workspace. + +Using my configured keybindings, I can move around this row: + +<> + +<> + +Or move to other rows: + +<> + +Here, on row @y=1@, almost every workspace is displayed as @...@. The workspace @1/2@ is not because it is my current workspace, and the workspace @gutter@ is not because it isn't empty--recall that the @gutter@ workspace is the same on all rows, and that it was not empty on row @y=0@. + +-} From bda01fbd302d3f069c48f36ddb6acce6cd8ca66c Mon Sep 17 00:00:00 2001 From: Maynard Date: Mon, 3 Oct 2022 16:30:58 -0700 Subject: [PATCH 5/7] split `render` into minimal `render` and convenient `render'` --- XMonad/WorkspaceLayout/Core.hs | 20 ++++++++++++++++---- XMonad/WorkspaceLayout/Grid.hs | 4 ++-- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/XMonad/WorkspaceLayout/Core.hs b/XMonad/WorkspaceLayout/Core.hs index dbaf9f2f63..24de06402a 100644 --- a/XMonad/WorkspaceLayout/Core.hs +++ b/XMonad/WorkspaceLayout/Core.hs @@ -47,7 +47,11 @@ data WorkspaceLayoutView = WSLView -- -- Render a workspace layout to a 'PP' -- --- If you add additional modifications on top of this, take care not to overwrite +-- If you're just getting up-and-running, prefer 'render'' for now. +-- +-- The result @PP@ will not add any styling to differentiate focused/hidden/etc +-- windows. You will have to add additional modifications on top (or just +-- use 'render''). When doing so, take care not to overwrite -- what's already been set. For instance, instead of doing: -- -- > (render view) { ppHidden = myHidden } @@ -60,9 +64,9 @@ render :: WorkspaceLayoutView -> PP render (WSLView { neighborhood, toName, label }) = def -- display the workspace names - { ppCurrent = ppCurrent def . toName - , ppHidden = ppHidden def . toName - , ppHiddenNoWindows = (map (const '.')) . toName + { ppCurrent = toName + , ppHidden = toName + , ppHiddenNoWindows = toName -- display only a subset of workspaces (the "neighborhood") of the current workspace , ppSort = do @@ -73,3 +77,11 @@ render (WSLView { neighborhood, toName, label }) = , ppOrder = \(workspaces : rest) -> (label <> workspaces) : rest } +-- | Like 'render' but with some defaults for how to display focused/hidden/etc windows +render' :: WorkspaceLayoutView -> PP +render' wsl = + let pp = render wsl in pp + { ppCurrent = ppCurrent def . ppCurrent pp + , ppHidden = ppHidden def . ppHidden pp + , ppHiddenNoWindows = (map (const '.')) . ppHiddenNoWindows pp + } diff --git a/XMonad/WorkspaceLayout/Grid.hs b/XMonad/WorkspaceLayout/Grid.hs index 9f05fea993..e14f89f62a 100644 --- a/XMonad/WorkspaceLayout/Grid.hs +++ b/XMonad/WorkspaceLayout/Grid.hs @@ -397,7 +397,7 @@ hook Init { initMapping, initWrapping, initLabelf } = -- -- Generate the layout view. -- --- Use this with 'XMonad.WorkspaceLayout.Core.render' to render to your status bar. +-- Use this with 'XMonad.WorkspaceLayout.Core.render'' to render to your status bar. getView :: X WorkspaceLayoutView getView = do State { coord, mapping, labelf } <- St.get @@ -455,7 +455,7 @@ For this config to actually be useful, we also need to: - Hook into XMonad with @Grid.hook gridConfig@ - Set up keybindings for 'move' to move around the layout -- Set up the layout display by generating a 'XMonad.Hooks.StatusBar.PP.PP' with @XMonad.WorkspaceLayouts.Core.render \<$\> Grid.getView@ and displaying that @PP@ however we like +- Set up the layout display by generating a 'XMonad.Hooks.StatusBar.PP.PP' with @XMonad.WorkspaceLayouts.Core.render' \<$\> Grid.getView@ and displaying that @PP@ however we like I use XMobar to display my status bar, and with this configuration I get something that looks like this: From 94a93776dbc597565a373f7386e0d30288af0709 Mon Sep 17 00:00:00 2001 From: Maynard Date: Mon, 10 Oct 2022 18:01:17 -0700 Subject: [PATCH 6/7] WorkspaceLayout: use ppRename --- XMonad/WorkspaceLayout/Core.hs | 34 +++++++++++----------------------- XMonad/WorkspaceLayout/Grid.hs | 4 ++-- 2 files changed, 13 insertions(+), 25 deletions(-) diff --git a/XMonad/WorkspaceLayout/Core.hs b/XMonad/WorkspaceLayout/Core.hs index 24de06402a..f7fa8ca1c9 100644 --- a/XMonad/WorkspaceLayout/Core.hs +++ b/XMonad/WorkspaceLayout/Core.hs @@ -47,26 +47,23 @@ data WorkspaceLayoutView = WSLView -- -- Render a workspace layout to a 'PP' -- --- If you're just getting up-and-running, prefer 'render'' for now. +-- When modifying the result 'PP', be careful when overwriting any of -- --- The result @PP@ will not add any styling to differentiate focused/hidden/etc --- windows. You will have to add additional modifications on top (or just --- use 'render''). When doing so, take care not to overwrite --- what's already been set. For instance, instead of doing: +-- * 'ppRename' +-- * 'ppSort' +-- * 'ppOrder' -- --- > (render view) { ppHidden = myHidden } --- --- prefer --- --- > let rendered = render view --- > in rendered { ppHidden = myHidden . rendered } +-- as the provided implementations are designed to make the workspace +-- layout perform as expected render :: WorkspaceLayoutView -> PP render (WSLView { neighborhood, toName, label }) = def -- display the workspace names - { ppCurrent = toName - , ppHidden = toName - , ppHiddenNoWindows = toName + { ppRename = const . toName + + -- display hidden windows as ellipses because blanking out hidden + -- windows doesn't make as much sense in the grid paradigm + , ppHiddenNoWindows = map (const '.') -- display only a subset of workspaces (the "neighborhood") of the current workspace , ppSort = do @@ -76,12 +73,3 @@ render (WSLView { neighborhood, toName, label }) = -- display the label to the left , ppOrder = \(workspaces : rest) -> (label <> workspaces) : rest } - --- | Like 'render' but with some defaults for how to display focused/hidden/etc windows -render' :: WorkspaceLayoutView -> PP -render' wsl = - let pp = render wsl in pp - { ppCurrent = ppCurrent def . ppCurrent pp - , ppHidden = ppHidden def . ppHidden pp - , ppHiddenNoWindows = (map (const '.')) . ppHiddenNoWindows pp - } diff --git a/XMonad/WorkspaceLayout/Grid.hs b/XMonad/WorkspaceLayout/Grid.hs index e14f89f62a..9f05fea993 100644 --- a/XMonad/WorkspaceLayout/Grid.hs +++ b/XMonad/WorkspaceLayout/Grid.hs @@ -397,7 +397,7 @@ hook Init { initMapping, initWrapping, initLabelf } = -- -- Generate the layout view. -- --- Use this with 'XMonad.WorkspaceLayout.Core.render'' to render to your status bar. +-- Use this with 'XMonad.WorkspaceLayout.Core.render' to render to your status bar. getView :: X WorkspaceLayoutView getView = do State { coord, mapping, labelf } <- St.get @@ -455,7 +455,7 @@ For this config to actually be useful, we also need to: - Hook into XMonad with @Grid.hook gridConfig@ - Set up keybindings for 'move' to move around the layout -- Set up the layout display by generating a 'XMonad.Hooks.StatusBar.PP.PP' with @XMonad.WorkspaceLayouts.Core.render' \<$\> Grid.getView@ and displaying that @PP@ however we like +- Set up the layout display by generating a 'XMonad.Hooks.StatusBar.PP.PP' with @XMonad.WorkspaceLayouts.Core.render \<$\> Grid.getView@ and displaying that @PP@ however we like I use XMobar to display my status bar, and with this configuration I get something that looks like this: From 51ff8d00025991348c2b330b1a3aa601abd70374 Mon Sep 17 00:00:00 2001 From: Maynard Date: Mon, 10 Oct 2022 20:09:38 -0700 Subject: [PATCH 7/7] WorkspaceLayout: rename "render" and make it more compositional --- XMonad/WorkspaceLayout/Core.hs | 37 ++++++++++++---------------------- 1 file changed, 13 insertions(+), 24 deletions(-) diff --git a/XMonad/WorkspaceLayout/Core.hs b/XMonad/WorkspaceLayout/Core.hs index f7fa8ca1c9..c9cb8011d6 100644 --- a/XMonad/WorkspaceLayout/Core.hs +++ b/XMonad/WorkspaceLayout/Core.hs @@ -43,33 +43,22 @@ data WorkspaceLayoutView = WSLView } deriving (Generic) --- | --- --- Render a workspace layout to a 'PP' --- --- When modifying the result 'PP', be careful when overwriting any of --- --- * 'ppRename' --- * 'ppSort' --- * 'ppOrder' --- --- as the provided implementations are designed to make the workspace --- layout perform as expected -render :: WorkspaceLayoutView -> PP -render (WSLView { neighborhood, toName, label }) = - def +-- | Render a workspace layout onto an existing 'PP' +modPPWithWorkspaceLayout :: WorkspaceLayoutView -> (PP -> PP) +modPPWithWorkspaceLayout (WSLView { neighborhood, toName, label }) pp = + pp -- display the workspace names - { ppRename = const . toName - - -- display hidden windows as ellipses because blanking out hidden - -- windows doesn't make as much sense in the grid paradigm - , ppHiddenNoWindows = map (const '.') + { ppRename = (fmap . fmap) toName (ppRename pp) -- display only a subset of workspaces (the "neighborhood") of the current workspace , ppSort = do - sort <- (mkWsSort . pure) (compare `on` flip elemIndex neighborhood) - pure $ filter (tag >>> (`elem` neighborhood)) >>> sort + oldSort <- ppSort pp + newSort <- do + sortIt <- (mkWsSort . pure) (compare `on` flip elemIndex neighborhood) + let filterIt = filter (tag >>> (`elem` neighborhood)) + pure $ filterIt >>> sortIt + pure $ newSort . oldSort - -- display the label to the left - , ppOrder = \(workspaces : rest) -> (label <> workspaces) : rest + -- display label to the left + , ppOrder = ppOrder pp >>> (\(ws : rest) -> (label <> ws) : rest) }