blob: f81ef06cc7cab6a6b765251015f18fe01f4982c4 (
plain) (
blame)
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
116
117
118
119
120
|
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 Data.Set (Set)
import qualified Data.Set as Set
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
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
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))
|
