[draft] workspace layouts

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

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
+    }
+

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)
+            )
+    }
+