Added BorderColors.hs

This module manager border colors for the windows and handles
automatically maintaining the colors across stack changes.

This also adds green borders to pinned windows to differentiate them
from normal windows.

8 files changed, 166 insertions, 113 deletions

diff --git a/src/Rahm/Desktop/BorderColors.hs b/src/Rahm/Desktop/BorderColors.hs
new file mode 100644
index 0000000..aced067
--- /dev/null
+++ b/src/Rahm/Desktop/BorderColors.hs
@@ -0,0 +1,113 @@
+module Rahm.Desktop.BorderColors where
+
+import Control.Monad (when)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
+import Data.Foldable (forM_)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Void (absurd)
+import Rahm.Desktop.Common (runMaybeT_)
+import Rahm.Desktop.Hooks.WindowChange (StackChangeHook (StackChangeHook))
+import qualified Rahm.Desktop.StackSet as W
+import XMonad
+import qualified XMonad.Util.ExtensibleState as XS
+import XMonad.Util.Font (pixelToString, stringToPixel)
+
+data BorderColor = BorderColor
+  { focusColor :: String,
+    normalColor :: String
+  }
+  deriving (Read, Show, Ord, Eq)
+
+newtype BorderColorsState = BorderColorsState (Map Window BorderColor)
+  deriving (Read, Show)
+
+instance ExtensionClass BorderColorsState where
+  initialValue = BorderColorsState mempty
+  extensionType = PersistentExtension
+
+stackChangeHook :: StackChangeHook
+stackChangeHook =
+  StackChangeHook
+    ( \_ _ -> do
+        (BorderColorsState s) <- XS.get
+        updateBorderColors $ Map.keys s
+    )
+
+updateBorderColors :: [Window] -> X ()
+updateBorderColors windows = do
+  (BorderColorsState mp) <- XS.get
+  foc <- withWindowSet $ return . W.peek
+
+  forM_ windows $ \win -> do
+    (BorderColorsState m) <- XS.get
+
+    dnc <- asks (normalBorderColor . config)
+    dfc <- asks (focusedBorderColor . config)
+
+    case Map.lookup win m of
+      Just (BorderColor fc nc) ->
+        let bc = if Just win == foc then fc else nc
+         in setBorderColorRaw bc win
+      Nothing ->
+        let bc = if Just win == foc then dfc else dnc
+         in setBorderColorRaw bc win
+
+-- Have to add a definition because Stack uses an ancient version of
+-- transformers for some reason.
+myFinallyE :: (Monad m) => ExceptT e m a -> ExceptT e m () -> ExceptT e m a
+myFinallyE m closer = catchE (m <* closer) (\e -> closer >> throwE e)
+
+-- Temporarily set the border color of the given windows.
+withBorderColorE :: BorderColor -> [Window] -> ExceptT e X a -> ExceptT e X a
+withBorderColorE color wins fn = do
+  cleanup <- lift (setBorderColor color wins)
+  myFinallyE fn (lift cleanup)
+
+-- Set the border color raw.
+setBorderColorRaw :: String -> Window -> X ()
+setBorderColorRaw color w = do
+  d <- asks display
+  px <- stringToPixel d color
+  colorName <- io $ pixelToString d px
+  setWindowBorderWithFallback d w colorName px
+
+-- Set the border color for the given windows. This function returns another
+-- function that should be used to clean up the border changes.
+setBorderColor :: BorderColor -> [Window] -> X (X ())
+setBorderColor border wins = do
+  (BorderColorsState oldMap) <- XS.get
+
+  XS.put $
+    BorderColorsState $
+      foldl (\m' win -> Map.insert win border m') oldMap wins
+  updateBorderColors wins
+
+  return $ do
+    XS.modify $ \(BorderColorsState cur) ->
+      BorderColorsState $
+        foldl
+          (flip $ Map.updateWithKey (\w _ -> Map.lookup w oldMap))
+          cur
+          wins
+    updateBorderColors wins
+
+resetBorderColor :: [Window] -> X ()
+resetBorderColor wins = do
+  XS.modify $ \(BorderColorsState mp) ->
+    BorderColorsState $
+      foldl (flip Map.delete) mp wins
+
+  updateBorderColors  wins
+
+withBorderColorM :: BorderColor -> [Window] -> MaybeT X a -> MaybeT X a
+withBorderColorM s ws fn = toMaybeT $ withBorderColorE s ws (toExceptT fn)
+  where
+    toExceptT (MaybeT fn) = ExceptT $ maybe (Left ()) Right <$> fn
+    toMaybeT (ExceptT fn) = MaybeT $ either (const Nothing) Just <$> fn
+
+withBorderColor :: BorderColor -> [Window] -> X a -> X a
+withBorderColor s ws fn =
+  either absurd id <$> runExceptT (withBorderColorE s ws (lift fn))
diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 307dd89..c10dd64 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -7,9 +7,6 @@ module Rahm.Desktop.Common
     getString,
     askWindowId,
     windowJump,
-    withBorderColor,
-    withBorderColorE,
-    withBorderColorM,
     withBorderWidth,
     getCurrentScreen,
     gotoWorkspace,
@@ -17,7 +14,6 @@ module Rahm.Desktop.Common
     getCurrentWorkspace,
     getCurrentLocation,
     runMaybeT_,
-    setBorderColor,
     click,
     pointerLocation,
     pointerWindow,
@@ -140,54 +136,6 @@ askWindowId = do
 windowJump :: X ()
 windowJump = mapM_ (focus . head) =<< askWindowId
 
--- Have to add a definition because Stack uses an ancient version of
--- transformers for some reason.
-myFinallyE :: (Monad m) => ExceptT e m a -> ExceptT e m () -> ExceptT e m a
-myFinallyE m closer = catchE (m <* closer) (\e -> closer >> throwE e)
-
--- Temporarily set the border color of the given windows.
-withBorderColorE :: String -> [Window] -> ExceptT e X a -> ExceptT e X a
-withBorderColorE color wins fn = do
-  cleanup <- lift (setBorderColor color wins)
-  myFinallyE fn (lift cleanup)
-
--- Set the border color for the given windows. This function returns another
--- function that should be used to clean up the border changes.
-setBorderColor :: String -> [Window] -> X (X ())
-setBorderColor color wins = do
-  d <- asks display
-  (px, oPx, fPx) <-
-    (,,)
-      <$> stringToPixel d color
-      <*> (stringToPixel d =<< asks (normalBorderColor . config))
-      <*> (stringToPixel d =<< asks (focusedBorderColor . config))
-
-  (colorName, oColorName, fColorName) <-
-    (,,)
-      <$> io (pixelToString d px)
-      <*> io (pixelToString d oPx)
-      <*> io (pixelToString d fPx)
-
-  forM_ wins $ \w ->
-    setWindowBorderWithFallback d w colorName px
-
-  return $ do
-    forM_ wins $ \w ->
-      setWindowBorderWithFallback d w oColorName oPx
-    withFocused $ \fw ->
-      when (fw `elem` wins) $
-        setWindowBorderWithFallback d fw fColorName fPx
-
-withBorderColorM :: String -> [Window] -> MaybeT X a -> MaybeT X a
-withBorderColorM s ws fn = toMaybeT $ withBorderColorE s ws (toExceptT fn)
-  where
-    toExceptT (MaybeT fn) = ExceptT $ maybe (Left ()) Right <$> fn
-    toMaybeT (ExceptT fn) = MaybeT $ either (const Nothing) Just <$> fn
-
-withBorderColor :: String -> [Window] -> X a -> X a
-withBorderColor s ws fn =
-  either absurd id <$> runExceptT (withBorderColorE s ws (lift fn))
-
 withBorderWidth :: Int -> [Window] -> X a -> X a
 withBorderWidth width ws fn = do
   d <- asks display
diff --git a/src/Rahm/Desktop/Dragging.hs b/src/Rahm/Desktop/Dragging.hs
index 4ec0edc..3bea2ad 100644
--- a/src/Rahm/Desktop/Dragging.hs
+++ b/src/Rahm/Desktop/Dragging.hs
@@ -5,7 +5,8 @@ import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
 import Data.IORef (newIORef, readIORef, writeIORef)
 import Data.Maybe (fromMaybe, isJust)
-import Rahm.Desktop.Common (pointerLocation, pointerWindow, runMaybeT_, setBorderColor)
+import Rahm.Desktop.BorderColors (setBorderColor, BorderColor (BorderColor))
+import Rahm.Desktop.Common (pointerLocation, pointerWindow, runMaybeT_)
 import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole)
 import Rahm.Desktop.Layout.PinWindow (isWindowPinned, pinWindow, unpinWindow)
 import Rahm.Desktop.Logger
@@ -28,6 +29,8 @@ instance Monoid AfterDragAction where
   mappend = (<>)
   mempty = AfterDragAction $ \_ _ -> return ()
 
+dragBorderColor = BorderColor "#00ffff" "#80a0a0"
+
 afterDrag :: X () -> X ()
 afterDrag action = do
   X.modify $ \case
@@ -172,7 +175,7 @@ dragWindow = do
   if isDockOrRoot
     then dragWorkspace
     else do
-      cleanup <- setBorderColor "#00ffff" [w]
+      cleanup <- setBorderColor dragBorderColor [w]
 
       ref <- io $ newIORef (w, return ())
 
@@ -186,7 +189,7 @@ dragWindow = do
                 cleanup' <-
                   if w' == 0 || w' == w
                     then return (return ())
-                    else setBorderColor "#80a0a0" [w']
+                    else setBorderColor dragBorderColor [w']
                 io $ writeIORef ref (w', cleanup')
               () -> return ()
 
diff --git a/src/Rahm/Desktop/History.hs b/src/Rahm/Desktop/History.hs
index ffcb10e..01f3761 100644
--- a/src/Rahm/Desktop/History.hs
+++ b/src/Rahm/Desktop/History.hs
@@ -133,32 +133,31 @@ data ScreenDiff = ScreenDiff
     newLocation :: Location
   }
 
-historyHook :: WindowStack -> WindowStack -> X ()
+historyHook :: StackChangeHook
 -- History hook where the 'from' location workspace does not match the 'to'
 -- location workspace.
-historyHook lastWindowSet currentWindowSet = do
+historyHook = StackChangeHook $ \lastWindowSet currentWindowSet -> do
   (History hist) <- XS.get
   forM_ (getScreenDiffs lastWindowSet currentWindowSet) $
     -- Read as "the screen <sid> went from <oloc> to <nloc>"
     \(ScreenDiff sid oloc nloc) ->
       let (ows, nws) = (locationWorkspace oloc, locationWorkspace nloc)
-
-       -- The goal here is to preserve history in as intuitive a way as possible
-       -- When the stackset changes, for each screen that changed in the last
-       -- windowchange, one of 2 situations are possibel:
-       --
-       --   1. The workspace on the screen was swapped with an already visible
-       --      screen
-       --
-       --   2. The workspace on the screen was swapped with a hidden workspace.
-       --
-       --   In the case of 1, we want to treat it as if the screen was
-       --   "reseated" to a different monitor, preserving the history for that
-       --   screen on its new screen.
-       --
-       --   In case of 2, we want to add the old workspace to the history of the
-       --   screen that changed.
-       in case () of
+       in -- The goal here is to preserve history in as intuitive a way as possible
+          -- When the stackset changes, for each screen that changed in the last
+          -- windowchange, one of 2 situations are possibel:
+          --
+          --   1. The workspace on the screen was swapped with an already visible
+          --      screen
+          --
+          --   2. The workspace on the screen was swapped with a hidden workspace.
+          --
+          --   In the case of 1, we want to treat it as if the screen was
+          --   "reseated" to a different monitor, preserving the history for that
+          --   screen on its new screen.
+          --
+          --   In case of 2, we want to add the old workspace to the history of the
+          --   screen that changed.
+          case () of
             () | nws `visibleIn` lastWindowSet,
                  (Just oscr) <- screenOf nws lastWindowSet ->
               -- The last workspace was on a different screen. Swap the current
@@ -180,7 +179,6 @@ historyHook lastWindowSet currentWindowSet = do
                       sid
                       byScreen
                   )
-
             -- This is typically not a possible case. It's only possible when a
             -- screen is unplugged. If that's the case, do nothing.
             _ -> return ()
diff --git a/src/Rahm/Desktop/Hooks/WindowChange.hs b/src/Rahm/Desktop/Hooks/WindowChange.hs
index 32c854b..b967495 100644
--- a/src/Rahm/Desktop/Hooks/WindowChange.hs
+++ b/src/Rahm/Desktop/Hooks/WindowChange.hs
@@ -14,6 +14,7 @@ import XMonad
     ScreenId,
     StateExtension (PersistentExtension),
     Window,
+    WindowSet,
     WorkspaceId,
     X,
     XConfig (logHook),
@@ -26,7 +27,16 @@ import qualified XMonad.Util.ExtensibleState as XS (get, put)
 type WindowStack = StackSet WorkspaceId () Window ScreenId ScreenDetail
 
 -- Type of hook. Takes the last WindowStack and the new WindowStack
-type StackChangeHook = WindowStack -> WindowStack -> X ()
+newtype StackChangeHook = StackChangeHook (WindowStack -> WindowStack -> X ())
+
+instance Semigroup StackChangeHook where
+  (StackChangeHook f1) <> (StackChangeHook f2) = StackChangeHook $ \o n -> do
+    f1 o n
+    n' <- gets (mapLayout (const ()) . windowset)
+    f2 o n'
+
+instance Monoid StackChangeHook where
+  mempty = StackChangeHook $ \_ _ -> return ()
 
 newtype LastState = LastState (Maybe WindowStack)
   deriving (Read, Show)
@@ -45,7 +55,7 @@ instance ExtensionClass LastState where
 --
 -- If the first window is Nothing, this is the first time XMonad started.
 withStackChangeHook :: StackChangeHook -> XConfig l -> XConfig l
-withStackChangeHook fn config =
+withStackChangeHook (StackChangeHook fn) config =
   config
     { logHook = do
         logHook config
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index ae293ee..e0b100a 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -50,9 +50,6 @@ import Rahm.Desktop.Common
     locationWorkspace,
     pointerWorkspace,
     runMaybeT_,
-    setBorderColor,
-    withBorderColor,
-    withBorderColorM,
   )
 import Rahm.Desktop.DMenu (runDMenu)
 import qualified Rahm.Desktop.Dragging as D
@@ -175,6 +172,7 @@ import XMonad.Layout.Spacing
 import XMonad.Util.Run (safeSpawn)
 import XMonad.Util.WindowProperties
 import Prelude hiding ((!!))
+import Rahm.Desktop.BorderColors (withBorderColorM, withBorderColor, BorderColor (BorderColor), BorderColor (BorderColor))
 
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
 
@@ -189,6 +187,8 @@ safeSpawnX = safeSpawn
 noWindow :: b -> Window -> b
 noWindow = const
 
+selectedWindowsColor = BorderColor "#00ffff" "#00ffff"
+
 decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%"
 
 increaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ +5%"
@@ -308,7 +308,7 @@ keymap = runKeys $ do
                 (h : _) -> lift (focusLocation h)
                 _ -> return ()
     shiftMod $
-      doc "Drag workspace to another." $ D.dragWindow
+      doc "Drag workspace to another." D.dragWindow
 
   bind xK_semicolon $
     justMod $
@@ -321,7 +321,7 @@ keymap = runKeys $ do
         pushPendingBuffer "w " $ do
           runMaybeT_ $ do
             l1 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
-            withBorderColorM "#00ffff" l1 $ do
+            withBorderColorM selectedWindowsColor l1 $ do
               lift $ addStringToPendingBuffer " "
               l2 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
               let (l1', l2') =
@@ -342,7 +342,7 @@ keymap = runKeys $ do
           runMaybeT_ $ do
             w1 <- readNextWorkspaceName
             wins <- lift $ W.windowsOnWorkspace w1 <$> gets windowset
-            withBorderColorM "#00ffff" wins $ do
+            withBorderColorM selectedWindowsColor wins $ do
               lift $ addStringToPendingBuffer " "
               w2 <- readNextWorkspaceName
               lift $ windows $ W.swapWorkspaces w1 w2
@@ -642,7 +642,7 @@ keymap = runKeys $ do
             locs <- fromMaybe [] <$> runMaybeT readNextLocationSet
             let wins = mapMaybe locationWindow locs
             unless (null wins) $ do
-              withBorderColor "#00ffff" wins $ do
+              withBorderColor selectedWindowsColor wins $ do
                 runMaybeT_ $ do
                   mapNextString $ \_ str -> lift $
                     case str of
@@ -699,7 +699,7 @@ keymap = runKeys $ do
                 stackset <- lift $ X.windowset <$> X.get
                 selection <- mapMaybe locationWindow <$> readNextLocationSet
 
-                withBorderColorM "#00ffff" selection $ do
+                withBorderColorM selectedWindowsColor selection $ do
                   lift $ addStringToPendingBuffer " "
                   ws <- readNextWorkspace
                   finalSwap <-
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 6555312..def3b27 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -43,7 +43,6 @@ module Rahm.Desktop.Keys.Wml
     locationSetForKeys,
     readNextWorkspaceName,
     workspaceName,
-    wmlLogHook,
   )
 where
 
@@ -79,7 +78,6 @@ import Rahm.Desktop.Common
     getCurrentWorkspace,
     gotoWorkspace,
     moveLocationToWorkspace,
-    setBorderColor,
     windowsInWorkspace,
   )
 import Rahm.Desktop.History
@@ -145,6 +143,7 @@ import XMonad
 import XMonad.Prompt.ConfirmPrompt (confirmPrompt)
 import qualified XMonad.Util.ExtensibleState as XS (get, modify, put)
 import Prelude hiding (head, last)
+import Rahm.Desktop.BorderColors (setBorderColor, BorderColor (BorderColor))
 
 type KeyString = [(KeyMask, KeySym, String)]
 
@@ -184,9 +183,8 @@ saveMacros = do
   macros <- getMacros
   io $ writeFile dataFile $ show macros
 
-selColor = "#b8b880"
 
-selFocusColor = "#ffff00"
+selColor = BorderColor "#ffff00" "#b8b880"
 
 insertWorkspaceMacroString :: (KeyMask, KeySym) -> KeyString -> X ()
 insertWorkspaceMacroString k ks = do
@@ -221,15 +219,7 @@ toggleWindowInSelection win = do
   (WindowSelect sel) <- XS.get
   case Map.lookup win sel of
     Nothing -> do
-      foc <- withWindowSet (return . W.peek)
-
-      cleanup <-
-        setBorderColor
-          ( if Just win == foc
-              then selFocusColor
-              else selColor
-          )
-          [win]
+      cleanup <- setBorderColor selColor [win]
 
       XS.put $ WindowSelect $ Map.insert win cleanup sel
     (Just cleanup) -> do
@@ -243,13 +233,7 @@ addWindowToSelection win = do
     Nothing -> do
       foc <- withWindowSet (return . W.peek)
 
-      cleanup <-
-        setBorderColor
-          ( if Just win == foc
-              then selFocusColor
-              else selColor
-          )
-          [win]
+      cleanup <- setBorderColor selColor [win]
 
       XS.put $ WindowSelect $ Map.insert win cleanup sel
     _ -> return ()
@@ -711,11 +695,3 @@ readNextLocationSet' =
   where
     mt :: (KeyFeeder m) => X a -> MaybeT m a
     mt = lift . fromX
-
-wmlLogHook :: X ()
-wmlLogHook = do
-  -- Reset the border colors for the selected window.
-  (WindowSelect (Map.keys -> sel)) <- XS.get
-  foc <- (withWindowSet (return . fromMaybe (0 :: Window) . W.peek) :: X Window)
-  void $ setBorderColor selColor (filter (/= foc) sel)
-  mapM_ (setBorderColor selFocusColor . (: [])) (find (== foc) sel)
diff --git a/src/Rahm/Desktop/Layout/PinWindow.hs b/src/Rahm/Desktop/Layout/PinWindow.hs
index f993eec..6ccf35a 100644
--- a/src/Rahm/Desktop/Layout/PinWindow.hs
+++ b/src/Rahm/Desktop/Layout/PinWindow.hs
@@ -22,6 +22,7 @@ import qualified Rahm.Desktop.StackSet as W
 import XMonad
 import qualified XMonad.StackSet as W (filter)
 import qualified XMonad.Util.ExtensibleState as XS
+import Rahm.Desktop.BorderColors (setBorderColor, BorderColor (BorderColor), resetBorderColor)
 
 newtype PinWindowState = PinWindowState (Map ScreenId [(Window, W.RationalRect)])
   deriving (Show, Read)
@@ -36,6 +37,8 @@ instance ExtensionClass PinWindowState where
 newtype PinWindowLayout (l :: * -> *) (a :: *) = PinWindowLayout (l a)
   deriving (Show, Read)
 
+pinnedWindowColor = BorderColor "#00ff00" "#408040"
+
 instance (LayoutClass l a, sid ~ ScreenId, a ~ Window) => LayoutClass (PinWindowLayout l) a where
   runLayout (W.Workspace t (PinWindowLayout l) stack) rect = do
     -- Clean up window id's thare should not be pinned anymore because the
@@ -100,6 +103,7 @@ pinWindow win = runMaybeT_ $ do
 
     -- Don't float the window anymore.
     modifyWindowSet $ W.sink win
+    setBorderColor pinnedWindowColor [win]
   where
     hoist = MaybeT . return
 
@@ -115,6 +119,7 @@ unpinWindow win = runMaybeT_ $ do
 
     -- refloat the window.
     modifyWindowSet $ W.float win rect
+    resetBorderColor [win]
   where
     hoist = MaybeT . return