[refactor] Wetterhorn -> Montis

1 files changed, 81 insertions, 0 deletions

diff --git a/plug/src/Montis/Foreign/ForeignInterface.hs b/plug/src/Montis/Foreign/ForeignInterface.hs
new file mode 100644
index 0000000..c01e6b8
--- /dev/null
+++ b/plug/src/Montis/Foreign/ForeignInterface.hs
@@ -0,0 +1,81 @@
+module Montis.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 Montis.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
+        }