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
|
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-}
module MetaTile.Layout.Floating (
Floating, floating,
float, sink, mouseMoveWindow, mouseResizeWindow
) where
import Prelude hiding (Floating)
import MetaTile.Core
import MetaTile.Layout.LayoutModifier
import MetaTile.Operations
import qualified MetaTile.StackSet as W
import qualified MetaTile.Util.ExtensibleState as XS
import Control.Arrow ((&&&), first)
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor
import qualified Data.Map as M
import Data.Maybe
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
data FloatingStorage = FloatingStorage {
floatingWindows :: M.Map Window Rectangle
} deriving (Show, Read, Typeable)
instance ExtensionClass FloatingStorage where
initialValue = FloatingStorage M.empty
extensionType = PersistentExtension
data Floating a = Floating deriving (Show, Read)
instance LayoutModifier Floating Window where
modifyLayout _ (w@W.Workspace { W.stack = stack }) r = do
bw <- asks (defaultBorderWidth . config)
ws <- gets windowset
FloatingStorage { floatingWindows = fw } <- XS.get
let fw' = M.filterWithKey (\k _ -> k `W.member` ws) fw
tiled = stack >>= W.filter (`M.notMember` fw')
fwLayout = [(a, ar, bw) | (a, ar) <- catMaybes . map (maybeSecond . (id &&& flip M.lookup fw')) $ W.integrate' stack]
XS.put $ FloatingStorage fw'
first (fwLayout ++) <$> runBorderLayout (w { W.stack = tiled }) r
where
maybeSecond :: (a, Maybe b) -> Maybe (a, b)
maybeSecond (a, Just b) = Just (a, b)
maybeSecond (_, Nothing) = Nothing
floating :: l Window -> ModifiedLayout Floating l Window
floating = ModifiedLayout Floating
------------------------------------------------------------------------
-- | Floating layer support
-- | Given a window, find the screen it is located on, and compute
-- the geometry of that window wrt. that screen.
floatLocation :: Window -> X (ScreenId, Rectangle)
floatLocation w = withDisplay $ \d -> do
ws <- gets windowset
frame <- getsWindowState wsFrame w
wa <- io $ getWindowAttributes d frame
sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)
let sr = screenRect . W.screenDetail $ sc
rr = Rectangle ((fi $ wa_x wa) - (fi $ rect_x sr)) ((fi $ wa_y wa) - (fi $ rect_y sr)) (fi $ wa_width wa) (fi $ wa_height wa)
return (W.screen sc, rr)
where fi x = fromIntegral x
-- | Make a tiled window floating, using its suggested rectangle
float :: Window -> X ()
float w = do
(_, r) <- floatLocation w
XS.modify $ \(FloatingStorage fw) -> FloatingStorage (M.insert w r fw)
refresh
-- | Clear the floating status of a window
sink :: Window -> X ()
sink w = do
XS.modify $ \(FloatingStorage fw) -> FloatingStorage (M.delete w fw)
refresh
-- | XXX comment me
mouseMoveWindow :: Window -> X ()
mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do
frame <- getsWindowState wsFrame w
io $ raiseWindow d frame
Just (Rectangle x y width height) <- getsFrameState fsBounds frame
(_, _, _, ox', oy', _, _, _) <- io $ queryPointer d frame
let ox = fromIntegral ox'
oy = fromIntegral oy'
mouseDrag (\ex ey -> tileWindow w (Rectangle (fromIntegral (fromIntegral x + (ex - ox))) (fromIntegral (fromIntegral y + (ey - oy))) width height) >> configure w) (float w)
-- | XXX comment me
mouseResizeWindow :: Window -> X ()
mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
frame <- getsWindowState wsFrame w
io $ raiseWindow d frame
Just (Rectangle x y width height) <- getsFrameState fsBounds frame
sh <- io $ getWMNormalHints d w
io $ warpPointer d none frame 0 0 0 0 (fromIntegral width) (fromIntegral height)
mouseDrag (\ex ey -> tileWindow w (Rectangle x y `uncurry` applySizeHintsContents sh (ex - fromIntegral x, ey - fromIntegral y)) >> configure w) (float w)
|
