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
|
-- | This module does not export anything. It exists simply to provide C-symbols
-- for the plugin.
module Wetterhorn.FFI () 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 System.Posix.Types (CIno)
import Wetterhorn.Core
import Wetterhorn.Core.ForeignInterface
runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
runForeign fn stblptr = do
(ctx, st) <- deRefStablePtr stblptr
freeStablePtr stblptr
(_, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
newStablePtr (ctx, state')
runForeignWithReturn :: (Storable a) => (WConfig -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
runForeignWithReturn fn ptr stableptr = do
(ctx, st) <- deRefStablePtr stableptr
freeStablePtr stableptr
(val, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
poke ptr val
newStablePtr (ctx, state')
runForeignWithReturn2 :: (Storable a, Storable b) => (WConfig -> 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') <- runW (fn $ 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)
wtrPtr <- wetterhorn
(conf, _) <- deRefStablePtr wtrPtr
freeStablePtr wtrPtr
newStablePtr . (conf,) =<< readWState 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 = wetterhorn
-- | 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 (show 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 () ->
Word32 ->
Word32 ->
Ptr CInt ->
Wetterhorn ->
IO Wetterhorn
pluginHandleKeybinding ::
Ptr () ->
Word32 ->
Word32 ->
Ptr CInt ->
Wetterhorn ->
IO Wetterhorn
pluginHandleKeybinding eventPtr mods sym =
runForeignWithReturn $ \config -> do
event <- 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
(\b -> if b then 1 else 0) <$> keybindingHandler config event
foreign export ccall "plugin_handle_surface_map"
pluginHandleSurfaceMap ::
Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceMap :: Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceMap p = runForeign (\c -> surfaceHandler c Map p)
foreign export ccall "plugin_handle_surface_unmap"
pluginHandleSurfaceUnmap ::
Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceUnmap :: Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceUnmap p = runForeign (\c -> surfaceHandler c Unmap p)
foreign export ccall "plugin_handle_surface_destroy"
pluginHandleSurfaceDestroy ::
Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceDestroy :: Ptr () -> Wetterhorn -> IO Wetterhorn
pluginHandleSurfaceDestroy p = runForeign (\c -> surfaceHandler c Destroy p)
|
