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
|
module Montis.Standard.Drag
( DragConfig(..),
startDragging,
stopDragging,
windowMove,
windowResize,
startWindowResize,
startWindowMove,
)
where
import Data.Data (Typeable)
import Montis.Core
import Montis.Core.Runtime
import Montis.Core.State
( Config (startingHooks),
ConfigModule (..),
Hooks (motionHook),
StateExtension (..),
)
import Montis.Standard.Mouse (CursorPosition (CursorPosition))
import Control.Monad.Cont (MonadIO(liftIO))
data DragConfig where
DragConfig :: DragConfig
deriving (Typeable)
instance ConfigModule Montis DragConfig where
alterConfig _ c =
let ohm = motionHook (startingHooks c)
obtn = buttonHook (startingHooks c)
in c
{ startingHooks =
(startingHooks c)
{ motionHook = \ev -> onMotion ev >> ohm ev,
buttonHook = \ev -> onButton ev >> obtn ev
}
}
data DragAction where
DragAction ::
{ onMotionAction :: MotionEvent -> Montis (),
_onButtonReleaseAction :: ButtonEvent -> Montis ()
} ->
DragAction
newtype Dragging = Dragging (Maybe DragAction)
deriving (Typeable)
instance StateExtension Dragging where
initialValue = Dragging Nothing
marshalExtension _ = Nothing
demarshalExtension _ = Nothing
startWindowResize :: Montis ()
startWindowResize = do
f <- windowResize
startDragging f (const stopDragging)
startWindowMove :: Montis ()
startWindowMove = do
f <- windowMove
startDragging f (const stopDragging)
windowMove :: Montis (MotionEvent -> Montis ())
windowMove = do
CursorPosition (x0, y0) <- xStateGet
mtl <- toplevelAt x0 y0
case mtl of
Nothing -> return (const $ return ())
Just tl -> do
(tx, ty, _tw, _th) <- getToplevelGeometry tl
let offsetX = x0 - tx
offsetY = y0 - ty
return $ \ev -> do
let (x1, y1) = motionEvent_absolute ev
setToplevelPosition tl (x1 - offsetX) (y1 - offsetY)
windowResize :: Montis (MotionEvent -> Montis ())
windowResize = do
CursorPosition (startX, startY) <- xStateGet
mtl <- toplevelAt startX startY
case mtl of
Nothing -> return (const $ return ())
Just tl -> do
(tx, ty, startW, startH) <- getToplevelGeometry tl
let warpX = tx + startW
warpY = ty + startH
warpCursor warpX warpY
xStatePut (CursorPosition (warpX, warpY))
return $ \ev -> do
let (x, y) = motionEvent_absolute ev
newW = max 1 (startW + (x - warpX))
newH = max 1 (startH + (y - warpY))
setToplevelGeometry
tl
tx
ty
newW
newH
startDragging :: (MotionEvent -> Montis ()) -> (ButtonEvent -> Montis ()) -> Montis ()
startDragging dragFn endFn =
xStatePut $
Dragging
(Just (DragAction dragFn endFn))
stopDragging :: Montis ()
stopDragging = xStatePut (Dragging Nothing)
onButton :: ButtonEvent -> Montis ()
onButton bev = do
case buttonEvent_state bev of
ButtonReleased -> do
liftIO $ putStrLn "!! Button Released."
xStateGet
>>= ( \case
(Dragging (Just (DragAction _ stopFn))) -> stopFn bev
_ -> return ()
)
ButtonPressed -> return ()
onMotion :: MotionEvent -> Montis ()
onMotion ev = do
(Dragging act) <- xStateGet
case act of
Nothing -> return ()
Just action -> onMotionAction action ev
|
