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
|
-- | This module does not export anything. It exists simply to provide C-symbols
-- for the plugin.
module Wetterhorn.Foreign.Export () where
import Config
import Control.Arrow (Arrow (first))
import Control.Monad (forM_)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CH
import Foreign
( Ptr,
Storable (poke, pokeByteOff),
Word32,
Word8,
deRefStablePtr,
freeStablePtr,
mallocBytes,
newStablePtr,
)
import Foreign.C (CChar, CInt (..))
import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased))
import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
import Wetterhorn.Core.W (W, Wetterhorn)
import qualified Wetterhorn.Core.W as W
import Wetterhorn.Foreign.ForeignInterface
import Wetterhorn.Foreign.WlRoots
type Wetter = (W.Config W.WindowLayout, W.State)
toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State)
toWetter = first W.ctxConfig
runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn
runForeign fn stblptr = do
w@(ctx, st) <- deRefStablePtr stblptr
freeStablePtr stblptr
(_, state') <- W.runW (fn $ toWetter w) (ctx, st)
newStablePtr (ctx, state')
runForeignWithReturn ::
(Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn fn ptr stableptr = do
w@(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
(val, state') <- W.runW (fn $ toWetter w) (ctx, st)
poke ptr val
newStablePtr (ctx, state')
runForeignWithReturn2 ::
(Storable a, Storable b) =>
(Wetter -> W (a, b)) ->
Ptr a ->
Ptr b ->
Wetterhorn ->
IO Wetterhorn
runForeignWithReturn2 fn ptrA ptrB stableptr = do
w@(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st)
poke ptrA vA
poke ptrB vB
newStablePtr (ctx, state')
-- | This function is the implementation of the "hotstart" mechanism. It gives a
-- pointer to the previously marshalled state and the length of that array and
-- this function returns a Wetterhorn instance.
foreign export ccall "plugin_hot_start"
pluginHotStart ::
Ptr CChar -> Word32 -> IO Wetterhorn
pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
pluginHotStart chars len = do
bs <- BS.packCStringLen (chars, fromIntegral len)
foreignInterface <- getForeignInterface
wtr <-
newStablePtr
( W.Context foreignInterface config,
W.demarshalState config (CH.unpack bs)
)
runForeign (\(conf, _) -> W.resetHook conf) wtr
-- | This function is called when a "coldstart" request is receieved. It just
-- calles the function "wetterhorn". This function should be defined in the main
-- code as it's sort-of the equivalent of XMonad's "main" function.
foreign export ccall "plugin_cold_start"
pluginColdStart :: IO Wetterhorn
pluginColdStart :: IO Wetterhorn
pluginColdStart = do
foreignInterface <- getForeignInterface
state <- W.initColdState config
wtr <- newStablePtr (W.Context foreignInterface config, state)
runForeign (\(conf, _) -> W.resetHook conf) wtr
-- | Marshals the opaque state to a C-style byte array and size pointer.
foreign export ccall "plugin_marshal_state"
pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
pluginMarshalState stblptr outlen = do
(_, st) <- deRefStablePtr stblptr
let bs = CH.pack (W.marshalState st)
ret <- mallocBytes (BS.length bs)
poke outlen (fromIntegral $ BS.length bs)
forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do
pokeByteOff ret off w8
return ret
foreign export ccall "plugin_handle_button"
pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn
pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn
pluginHandleButton eventPtr modifiers = do
runForeign $
\( _,
W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}}
) -> do
event <- W.wio $
runForeignDemarshal eventPtr $ do
ButtonEvent
<$> demarshal
<*> demarshal
<*> demarshal
<*> pure modifiers
<*> ( ( \u8 ->
if (u8 :: Word8) == 0
then ButtonReleased
else ButtonPressed
)
<$> demarshal
)
buttonHook event
foreign export ccall "plugin_handle_keybinding"
pluginHandleKeybinding ::
Ptr WlrInputDevice ->
Ptr WlrEventKeyboardKey ->
Word32 ->
Word32 ->
Word32 ->
Ptr CInt ->
Wetterhorn ->
IO Wetterhorn
pluginHandleKeybinding ::
Ptr WlrInputDevice ->
Ptr WlrEventKeyboardKey ->
Word32 ->
Word32 ->
Word32 ->
Ptr CInt ->
Wetterhorn ->
IO Wetterhorn
pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
runForeignWithReturn $
\( _,
W.State {W.currentHooks = W.Hooks {keyHook = keyHook}}
) -> do
event <- W.wio $
runForeignDemarshal eventPtr $ do
tMs <- demarshal
kc <- demarshal
_ <- (demarshal :: ForeignDemarshal Word32)
keyState <- demarshal
return $
KeyEvent
tMs
kc
(if keyState == (0 :: Word8) then KeyReleased else KeyPressed)
mods
sym
(toEnum $ fromIntegral cp)
inputDevicePtr
keyHook event
return 1
-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XDG surface.
foreign export ccall "plugin_handle_surface"
pluginHandleSurface ::
Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleSurface p t =
runForeign
( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) ->
surfaceHook $
SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
)
-- | Function exported to the harness to handle the mapping/unmapping/deletion
-- of an XWayland surface.
foreign export ccall "plugin_handle_xwayland_surface"
pluginHandleXWaylandSurface ::
Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleXWaylandSurface ::
Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
pluginHandleXWaylandSurface p t =
runForeign
( \( _,
W.State
{ currentHooks = W.Hooks {surfaceHook = surfaceHook}
}
) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
)
|
