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
|
-- | 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.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.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
runForeign :: (forall l. W.Config l -> W ()) -> Wetterhorn -> IO Wetterhorn
runForeign fn stblptr = do
(ctx, st) <- deRefStablePtr stblptr
freeStablePtr stblptr
(_, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
newStablePtr (ctx, state')
runForeignWithReturn :: (Storable a) => (forall l. W.Config l -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn fn ptr stableptr = do
(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
(val, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
poke ptr val
newStablePtr (ctx, state')
runForeignWithReturn2 :: (Storable a, Storable b) => (forall l. W.Config l -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn2 fn ptrA ptrB stableptr = do
(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
((vA, vB), state') <- W.runW (fn $ W.ctxConfig ctx) (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
newStablePtr
( W.Context foreignInterface config,
W.demarshalState (W.layout config) (CH.unpack bs)
)
-- | 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 (W.layout config)
newStablePtr (W.Context foreignInterface config, state)
-- | 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_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 $ \config -> 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
W.keyHook config 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
( \c ->
W.surfaceHook
c
$ 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 (\c -> W.surfaceHook c $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))
|
