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
|
module Wetterhorn.Foreign.ForeignInterface
( getForeignInterface,
ForeignInterface (..),
ForeignDemarshal (..),
runForeignDemarshal,
demarshal,
doShellExec,
)
where
import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
import Data.Void (Void)
import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
import Foreign.C (CChar, CInt (..))
import Foreign.C.String
import GHC.Exts (FunPtr)
import Wetterhorn.Foreign.WlRoots
newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a
runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p)
demarshal :: (Storable a) => ForeignDemarshal a
demarshal = do
ptr <- get
val <- ForeignDemarshal $ lift $ peek $ castPtr ptr
put (plusPtr ptr (sizeOf val))
return val
type CtxT = Ptr Void
type ForeignCallGetPtr = CtxT -> IO (Ptr ())
type ForeignCall = CtxT -> IO ()
type ForeignCallStr = CtxT -> CString -> IO ()
type ForeignCallInt = CtxT -> CInt -> IO ()
foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ())
foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall
foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr
foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt
foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr
foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO ()
data ForeignInterface = ForeignInterface
{ requestHotReload :: IO (),
requestLog :: String -> IO (),
requestExit :: Int -> IO (),
getSeat :: IO (Ptr WlrSeat)
}
doShellExec :: String -> IO ()
doShellExec str = withCString str shellExec
getForeignInterface :: IO ForeignInterface
getForeignInterface = do
ptr <- foreignInterfacePtr
runForeignDemarshal ptr $ do
ctx <- demarshal
requestHotReloadFn <- demarshal
doLogFn <- demarshal
doRequestExit <- demarshal
getSeatFn <- demarshal
return $
ForeignInterface
{ requestHotReload = toForeignCall requestHotReloadFn ctx,
requestLog = \str ->
withCString str $ \cs -> toForeignCallStr doLogFn ctx cs,
requestExit = toForeignCallInt doRequestExit ctx . fromIntegral,
getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx
}
|
