Huge refactor for the Haskell code.HEADmain

This adds new layout configuration, preparing for actually using the
layouts. This also restructures the code and tries to keep code
interfacing with the foreign structures together and rename them to more
sensible names.

1 files changed, 81 insertions, 0 deletions

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