1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
module Rahm.Desktop.BorderColors where
import Control.Monad (when)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
import Data.Foldable (forM_)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Void (absurd)
import Rahm.Desktop.Common (Xish (..), runMaybeT_)
import Rahm.Desktop.Hooks.WindowChange (StackChangeHook (StackChangeHook))
import Rahm.Desktop.Logger (LogLevel (Debug), logs)
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
mp <- gets mapped
(BorderColorsState s) <- XS.get
XS.put $
BorderColorsState $
Map.filterWithKey (\k _ -> k `Set.member` mp) s
(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
withBorderColor :: (Xish x, Monad x) => BorderColor -> [Window] -> x a -> x a
withBorderColor s ws fn = do
cleanup <- liftFromX (setBorderColor s ws)
finallyX fn $ liftFromX cleanup
|
