aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Layout/Decoration.hs
blob: ec095751a546e20551a24495d1029b3bd976a652 (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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Decoration
-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A layout modifier and a class for easily creating decorated
-- layouts.
-----------------------------------------------------------------------------

module XMonad.Layout.Decoration
    ( -- * Usage:
      -- $usage
      decoration
    , Theme (..), defaultTheme
    , Decoration
    , DecorationMsg (..)
    , DecorationStyle (..)
    , DefaultDecoration (..)
    , Shrinker (..), DefaultShrinker
    , shrinkText, CustomShrink ( CustomShrink ), shrinkWhile
    , isInStack, isVisible, isInvisible, isWithin, fi
    , findWindowByDecoration
    , module XMonad.Layout.LayoutModifier
    , DecorationState, OrigWin
    ) where

import Control.Monad (when)
import Data.Maybe
import Data.List
import Foreign.C.Types(CInt)

import XMonad
import qualified XMonad.StackSet as W
import XMonad.Hooks.UrgencyHook
import XMonad.Layout.LayoutModifier
import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList)
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Invisible
import XMonad.Util.XUtils
import XMonad.Util.Font
import XMonad.Util.Image

-- $usage
-- This module is intended for layout developers, who want to decorate
-- their layouts. End users will not find here very much for them.
--
-- For examples of 'DecorationStyle' instances you can have a look at
-- "XMonad.Layout.SimpleDecoration", "XMonad.Layout.Tabbed",
-- "XMonad.Layout.DwmStyle", or "XMonad.Layout.TabBarDecoration".

-- | A layout modifier that, with a 'Shrinker', a 'Theme', a
-- 'DecorationStyle', and a layout, will decorate this layout
-- according to the decoration style provided.
--
-- For some usage examples see "XMonad.Layout.DecorationMadness".
decoration :: (DecorationStyle ds a, Shrinker s) => s -> Theme -> ds a
           -> l a -> ModifiedLayout (Decoration ds s) l a
decoration s t ds = ModifiedLayout (Decoration (I Nothing) s t ds)

-- | A 'Theme' is a record of colors, font etc., to customize a
-- 'DecorationStyle'.
--
-- For a collection of 'Theme's see "XMonad.Util.Themes"
data Theme =
    Theme { activeColor        :: String                   -- ^ Color of the active window
          , inactiveColor       :: String                   -- ^ Color of the inactive window
          , urgentColor         :: String                   -- ^ Color of the urgent window
          , activeBorderColor   :: String                   -- ^ Color of the border of the active window
          , inactiveBorderColor :: String                   -- ^ Color of the border of the inactive window
          , urgentBorderColor   :: String                   -- ^ Color of the border of the urgent window
          , activeTextColor     :: String                   -- ^ Color of the text of the active window
          , inactiveTextColor   :: String                   -- ^ Color of the text of the inactive window
          , urgentTextColor     :: String                   -- ^ Color of the text of the urgent window
          , fontName            :: String                   -- ^ Font name
          , decoWidth           :: Dimension                -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle')
          , decoHeight          :: Dimension                -- ^ Height of the decorations
          , windowTitleAddons   :: [(String, Align)]       -- ^ Extra text to appear in a window's title bar.
                                                           --    Refer to for a use "XMonad.Layout.ImageButtonDecoration"
          , windowTitleIcons    :: [([[Bool]], Placement)] -- ^ Extra icons to appear in a window's title bar.
                                                           --    Inner @[Bool]@ is a row in a icon bitmap.
          } deriving (Show, Read)

-- | The default xmonad 'Theme'.
defaultTheme :: Theme
defaultTheme =
    Theme { activeColor         = "#999999"
          , inactiveColor       = "#666666"
          , urgentColor         = "#FFFF00"
          , activeBorderColor   = "#FFFFFF"
          , inactiveBorderColor = "#BBBBBB"
          , urgentBorderColor   = "##00FF00"
          , activeTextColor     = "#FFFFFF"
          , inactiveTextColor   = "#BFBFBF"
          , urgentTextColor     = "#FF0000"
          , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
          , decoWidth           = 200
          , decoHeight          = 20
          , windowTitleAddons   = []
          , windowTitleIcons    = []
          }

-- | A 'Decoration' layout modifier will handle 'SetTheme', a message
-- to dynamically change the decoration 'Theme'.
data DecorationMsg = SetTheme Theme deriving ( Typeable )
instance Message DecorationMsg

-- | The 'Decoration' state component, where the list of decorated
-- window's is zipped with a list of decoration. A list of decoration
-- is a list of tuples, a 'Maybe' 'Window' and a 'Maybe Rectangle'.
-- The 'Window' will be displayed only if the rectangle is of type
-- 'Just'.
data DecorationState =
    DS { decos :: [(OrigWin,DecoWin)]
       , font  :: XMonadFont
       }
type DecoWin = (Maybe Window, Maybe Rectangle)
type OrigWin = (Window,Rectangle)

-- | The 'Decoration' 'LayoutModifier'. This data type is an instance
-- of the 'LayoutModifier' class. This data type will be passed,
-- together with a layout, to the 'ModifiedLayout' type constructor
-- to modify the layout by adding decorations according to a
-- 'DecorationStyle'.
data Decoration ds s a =
    Decoration (Invisible Maybe DecorationState) s Theme (ds a)
    deriving (Show, Read)

-- | The 'DecorationStyle' class, defines methods used in the
-- implementation of the 'Decoration' 'LayoutModifier' instance. A
-- type instance of this class is passed to the 'Decoration' type in
-- order to decorate a layout, by using these methods.
class (Read (ds a), Show (ds a), Eq a) => DecorationStyle ds a where

    -- | The description that the 'Decoration' modifier will display.
    describeDeco :: ds a -> String
    describeDeco ds = show ds

    -- | Shrink the window's rectangle when applying a decoration.
    shrink :: ds a -> Rectangle -> Rectangle -> Rectangle
    shrink _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh)

    -- | The decoration event hook
    decorationEventHook :: ds a -> DecorationState -> Event -> X ()
    decorationEventHook ds s e = handleMouseFocusDrag ds s e

    -- | A hook that can be used to catch the cases when the user
    -- clicks on the decoration. If you return True here, the click event
    -- will be considered as dealt with and no further processing will take place.
    decorationCatchClicksHook :: ds a
                              -> Window
                              -> Int    -- ^ distance from the left where the click happened on the decoration
                              -> Int    -- ^ distance from the right where the click happened on the decoration
                              -> X Bool
    decorationCatchClicksHook _ _ _ _ = return False

    -- | This hook is called while a window is dragged using the decoration.
    -- The hook can be overwritten if a different way of handling the dragging
    -- is required.
    decorationWhileDraggingHook :: ds a -> CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
    decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleDraggingInProgress ex ey (mainw, r) x y

    -- | This hoook is called after a window has been dragged using the decoration.
    decorationAfterDraggingHook :: ds a -> (Window, Rectangle) -> Window -> X ()
    decorationAfterDraggingHook _ds (mainw, _r) _decoWin = focus mainw

    -- | The pure version of the main method, 'decorate'.
    pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
                   -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
    pureDecoration _ _ ht _ s _ (w,Rectangle x y wh ht') = if isInStack s w && (ht < ht')
                                                             then Just $ Rectangle x y wh ht
                                                             else Nothing

    -- | Given the theme's decoration width and height, the screen
    -- rectangle, the windows stack, the list of windows and
    -- rectangles returned by the underlying layout and window to be
    -- decorated, tupled with its rectangle, produce a 'Just'
    -- 'Rectangle' or 'Nothing' if the window is not to be decorated.
    decorate :: ds a -> Dimension -> Dimension -> Rectangle
             -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle)
    decorate ds w h r s wrs wr = return $ pureDecoration ds w h r s wrs wr

-- | The default 'DecorationStyle', with just the default methods'
-- implementations.
data DefaultDecoration a = DefaultDecoration deriving ( Read, Show )
instance Eq a => DecorationStyle DefaultDecoration a

-- | The long 'LayoutModifier' instance for the 'Decoration' type.
--
-- In 'redoLayout' we check the state: if there is no state we
-- initialize it.
--
-- The state is 'diff'ed against the list of windows produced by the
-- underlying layout: removed windows get deleted and new ones
-- decorated by 'createDecos', which will call 'decorate' to decide if
-- a window must be given a 'Rectangle', in which case a decoration
-- window will be created.
--
-- After that we resync the updated state with the windows' list and
-- then we process the resynced stated (as we do with a new state).
--
-- First we map the decoration windows, we update each decoration to
-- reflect any decorated window's change, and we insert, in the list
-- of windows and rectangles returned by the underlying layout, the
-- decoration for each window. This way xmonad will restack the
-- decorations and their windows accordingly. At the end we remove
-- invisible\/stacked windows.
--
-- Message handling is quite simple: when needed we release the state
-- component of the 'Decoration' 'LayoutModifier'. Otherwise we call
-- 'handleEvent', which will call the appropriate 'DecorationStyle'
-- methods to perform its tasks.
instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where
    redoLayout (Decoration (I (Just s)) sh t ds) _ Nothing _ = do
        releaseResources s
        return ([], Just $ Decoration (I Nothing) sh t ds)
    redoLayout _                                 _ Nothing _  = return ([], Nothing)

    redoLayout (Decoration st sh t ds) sc (Just stack) wrs
        | I Nothing  <- st = initState t ds sc stack wrs >>= processState
        | I (Just s) <- st = do let dwrs  = decos s
                                    (d,a) = curry diff (get_ws dwrs) ws
                                    toDel = todel d dwrs
                                    toAdd = toadd a wrs
                                deleteDecos (map snd toDel)
                                let ndwrs = zip toAdd $ repeat (Nothing,Nothing)
                                ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs
                                processState (s {decos = ndecos })
        | otherwise        = return (wrs, Nothing)

        where
          ws        = map fst wrs
          get_w     = fst . fst
          get_ws    = map get_w
          del_dwrs  = listFromList get_w notElem
          find_dw i = fst . snd . flip (!!) i
          todel   d = filter (flip elem d . get_w)
          toadd   a = filter (flip elem a . fst  )

          check_dwr dwr = case dwr of
                            (Nothing, Just dr) -> do dw <- createDecoWindow t dr
                                                     return (Just dw, Just dr)
                            _                 -> return dwr

          resync _         [] = return []
          resync d ((w,r):xs) = case  w `elemIndex` get_ws d of
                                  Just i  -> do dr   <- decorate ds (decoWidth t) (decoHeight t) sc stack wrs (w,r)
                                                dwr  <- check_dwr (find_dw i d, dr)
                                                dwrs <- resync d xs
                                                return $ ((w,r),dwr) : dwrs
                                  Nothing -> resync d xs

          -- We drop any windows that are *precisely* stacked underneath
          -- another window: these must be intended to be tabbed!
          remove_stacked rs ((w,r):xs)
              | r `elem` rs   = remove_stacked rs xs
              | otherwise     = (w,r) : remove_stacked (r:rs) xs
          remove_stacked _ [] = []

          insert_dwr ((w,r),(Just dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs
          insert_dwr (x    ,(     _ ,     _ )) xs = x:xs

          dwrs_to_wrs    = remove_stacked [] . foldr insert_dwr []

          processState s = do let ndwrs = decos s
                              showDecos (map snd ndwrs)
                              updateDecos sh t (font s) ndwrs
                              return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds))

    handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh t ds) m
        | Just e <- fromMessage m                = do decorationEventHook ds s e
                                                      handleEvent sh t s e
                                                      return Nothing
        | Just Hide             <- fromMessage m = do hideDecos (map snd dwrs)
                                                      return Nothing
        | Just (SetTheme nt)    <- fromMessage m = do releaseResources s
                                                      return $ Just $ Decoration (I Nothing) sh nt ds
        | Just ReleaseResources <- fromMessage m = do releaseResources s
                                                      return $ Just $ Decoration (I Nothing) sh t  ds
    handleMess _ _ = return Nothing

    modifierDescription (Decoration _ _ _ ds) = describeDeco ds

-- | By default 'Decoration' handles 'PropertyEvent' and 'ExposeEvent'
-- only.
handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X ()
handleEvent sh t (DS dwrs fs) e
    | PropertyEvent {ev_window = w} <- e
    , Just i <- w `elemIndex`             (map (fst . fst) dwrs) = updateDeco sh t fs (dwrs !! i)
    | ExposeEvent   {ev_window = w} <- e
    , Just i <- w `elemIndex` (catMaybes $ map (fst . snd) dwrs) = updateDeco sh t fs (dwrs !! i)
handleEvent _ _ _ _ = return ()

-- | Mouse focus and mouse drag are handled by the same function, this
-- way we can start dragging unfocused windows too.
handleMouseFocusDrag :: (DecorationStyle ds a) => ds a -> DecorationState -> Event -> X ()
handleMouseFocusDrag ds (DS dwrs _) ButtonEvent { ev_window     = ew
                                                , ev_event_type = et
                                                , ev_x_root     = ex
                                                , ev_y_root     = ey }
    | et == buttonPress
    , Just ((mainw,r), (_, decoRectM)) <- lookFor ew dwrs = do
        let Just (Rectangle dx _ dwh _) = decoRectM
            distFromLeft = ex - fi dx
            distFromRight = fi dwh - (ex - fi dx)
        dealtWith <- decorationCatchClicksHook ds mainw (fi distFromLeft) (fi distFromRight)
        when (not dealtWith) $ do
            mouseDrag (\x y -> focus mainw >> decorationWhileDraggingHook ds ex ey (mainw, r) x y)
                        (decorationAfterDraggingHook ds (mainw, r) ew)
handleMouseFocusDrag _ _ _ = return ()

handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress ex ey (_, r) x y = do
    let rect = Rectangle (x - (fi ex - rect_x r))
                         (y - (fi ey - rect_y r))
                         (rect_width  r)
                         (rect_height r)
    sendMessage $ SetGeometry rect

-- | Given a window and the state, if a matching decoration is in the
-- state return it with its ('Maybe') 'Rectangle'.
lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle))
lookFor w ((wr,(Just dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr))
                                   | otherwise = lookFor w dwrs
lookFor w ((_, (Nothing, _)):dwrs) = lookFor w dwrs
lookFor _ [] = Nothing

findWindowByDecoration :: Window -> DecorationState -> Maybe (OrigWin,(Window,Maybe Rectangle))
findWindowByDecoration w ds = lookFor w (decos ds)

-- | Initialize the 'DecorationState' by initializing the font
-- structure and by creating the needed decorations.
initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle
          -> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState
initState t ds sc s wrs = do
  fs   <- initXMF (fontName t)
  dwrs <- createDecos t ds sc s wrs wrs
  return $ DS dwrs fs

-- | Delete windows stored in the state and release the font structure.
releaseResources :: DecorationState -> X ()
releaseResources s = do
  deleteDecos (map snd $ decos s)
  releaseXMF  (font s)

-- | Create the decoration windows of a list of windows and their
-- rectangles, by calling the 'decorate' method of the
-- 'DecorationStyle' received.
createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window
            -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)]
createDecos t ds sc s wrs ((w,r):xs) = do
  deco <- decorate ds (decoWidth t) (decoHeight t) sc s wrs (w,r)
  case deco of
    Just dr -> do dw   <- createDecoWindow t dr
                  dwrs <- createDecos t ds sc s wrs xs
                  return $ ((w,r), (Just dw, Just dr)) : dwrs
    Nothing -> do dwrs <- createDecos t ds sc s wrs xs
                  return $ ((w,r), (Nothing, Nothing)) : dwrs
createDecos _ _ _ _ _ [] = return []

createDecoWindow :: Theme -> Rectangle -> X Window
createDecoWindow t r = let mask = Just (exposureMask .|. buttonPressMask) in
                       createNewWindow r mask (inactiveColor t) True

showDecos :: [DecoWin] -> X ()
showDecos = showWindows . catMaybes . map fst . filter (isJust . snd)

hideDecos :: [DecoWin] -> X ()
hideDecos = hideWindows . catMaybes . map fst

deleteDecos :: [DecoWin] -> X ()
deleteDecos = deleteWindows . catMaybes . map fst

updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X ()
updateDecos s t f = mapM_ $ updateDeco s t f

-- | Update a decoration window given a shrinker, a theme, the font
-- structure and the needed 'Rectangle's
updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X ()
updateDeco sh t fs ((w,_),(Just dw,Just (Rectangle _ _ wh ht))) = do
  nw  <- getName w
  ur  <- readUrgents
  dpy <- asks display
  let focusColor win ic ac uc = (maybe ic (\focusw -> case () of
                                                       _ | focusw == win -> ac
                                                         | win `elem` ur -> uc
                                                         | otherwise     -> ic) . W.peek)
                                `fmap` gets windowset
  (bc,borderc,tc) <- focusColor w (inactiveColor t, inactiveBorderColor t, inactiveTextColor t)
                                  (activeColor   t, activeBorderColor   t, activeTextColor   t)
                                  (urgentColor   t, urgentBorderColor   t, urgentTextColor   t)
  let s = shrinkIt sh
  name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n
                                  return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
  let als = AlignCenter : map snd (windowTitleAddons t)
      strs = name : map fst (windowTitleAddons t)
      i_als = map snd (windowTitleIcons t)
      icons = map fst (windowTitleIcons t)
  paintTextAndIcons dw fs wh ht 1 bc borderc tc bc als strs i_als icons
updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w
updateDeco _ _ _ _ = return ()

-- | True if the window is in the 'Stack'. The 'Window' comes second
-- to facilitate list processing, even though @w \`isInStack\` s@ won't
-- work...;)
isInStack :: Eq a => W.Stack a -> a -> Bool
isInStack s = flip elem (W.integrate s)

-- | Given a 'Rectangle' and a list of 'Rectangle's is True if the
-- 'Rectangle' is not completely contained by any 'Rectangle' of the
-- list.
isVisible :: Rectangle -> [Rectangle] -> Bool
isVisible r = and . foldr f []
    where f x xs = if r `isWithin` x then False : xs else True : xs

-- | The contrary of 'isVisible'.
isInvisible :: Rectangle -> [Rectangle] -> Bool
isInvisible r = not . isVisible r

-- | True is the first 'Rectangle' is totally within the second
-- 'Rectangle'.
isWithin :: Rectangle -> Rectangle -> Bool
isWithin (Rectangle x y w h) (Rectangle rx ry rw rh)
    | x >= rx, x <= rx + fi rw
    , y >= ry, y <= ry + fi rh
    , x + fi w <= rx + fi rw
    , y + fi h <= ry + fi rh = True
    | otherwise              = False

shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile sh p x = sw $ sh x
    where sw [n] = return n
          sw [] = return ""
          sw (n:ns) = do
                        cond <- p n
                        if cond
                          then sw ns
                          else return n

data CustomShrink = CustomShrink
instance Show CustomShrink where show _ = ""
instance Read CustomShrink where readsPrec _ s = [(CustomShrink,s)]

class (Read s, Show s) => Shrinker s where
    shrinkIt :: s -> String -> [String]

data DefaultShrinker = DefaultShrinker
instance Show DefaultShrinker where show _ = ""
instance Read DefaultShrinker where readsPrec _ s = [(DefaultShrinker,s)]
instance Shrinker DefaultShrinker where
    shrinkIt _ "" = [""]
    shrinkIt s cs = cs : shrinkIt s (init cs)

shrinkText :: DefaultShrinker
shrinkText = DefaultShrinker