aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJosh Rahm <rahm@google.com>2024-02-16 13:29:17 -0700
committerJosh Rahm <rahm@google.com>2024-02-16 13:29:17 -0700
commitc7a0945ffcb5f17953109a6b4ac77a5c64980f4f (patch)
treeb5a4c26127720045a9a0babc9feff0e01304acfb /src
parentf4ed2dd61b53ea45b05f3e8f4ebcce24188d32bd (diff)
downloadwetterhorn-c7a0945ffcb5f17953109a6b4ac77a5c64980f4f.tar.gz
wetterhorn-c7a0945ffcb5f17953109a6b4ac77a5c64980f4f.tar.bz2
wetterhorn-c7a0945ffcb5f17953109a6b4ac77a5c64980f4f.zip
Added ability to exit the program via a back-interface.
Diffstat (limited to 'src')
-rw-r--r--src/Wetterhorn/Core.hs8
-rw-r--r--src/Wetterhorn/Core/ForeignInterface.hs46
2 files changed, 41 insertions, 13 deletions
diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index 8d4e6b7..5a9d9e5 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -48,6 +48,11 @@ requestLog str = do
fi <- ctxForeignInterface <$> getWContext
wio $ ForeignInterface.requestLog fi str
+requestExit :: Int -> W ()
+requestExit ec = do
+ fi <- ctxForeignInterface <$> getWContext
+ wio $ ForeignInterface.requestExit fi ec
+
initWetterhorn :: WConfig -> IO Wetterhorn
initWetterhorn conf = do
foreignInterface <- ForeignInterface.getForeignInterface
@@ -73,7 +78,8 @@ defaultConfig =
i <- incrementState
wio (printf "[%d] Got key: %d\n" i sym)
when (sym == 111) requestHotReload
- when (sym == 112) (requestLog "Hey daddy ths is a log statement.\n"),
+ when (sym == 112) (requestLog "Hey daddy ths is a log statement.\n")
+ when (sym == 0x71) (requestExit 0),
surfaceHandler = \state ptr -> wio (printf "Surface %s is %s\n" (showHex (ptrToIntPtr ptr) "") (show state))
}
diff --git a/src/Wetterhorn/Core/ForeignInterface.hs b/src/Wetterhorn/Core/ForeignInterface.hs
index de4779b..0b763b0 100644
--- a/src/Wetterhorn/Core/ForeignInterface.hs
+++ b/src/Wetterhorn/Core/ForeignInterface.hs
@@ -4,39 +4,61 @@ module Wetterhorn.Core.ForeignInterface
)
where
+import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
import Data.Void (Void)
-import Foreign (Ptr, Storable (peekByteOff, sizeOf))
+import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
+import Foreign.C (CInt (..))
import Foreign.C.String
import GHC.Exts (FunPtr)
+newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
+ deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
+
+runForeignDemarshal :: Ptr () -> ForeignDemarshal a -> IO a
+runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm 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 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
+
data ForeignInterface = ForeignInterface
{ requestHotReload :: IO (),
- requestLog :: String -> IO ()
+ requestLog :: String -> IO (),
+ requestExit :: Int -> IO ()
}
getForeignInterface :: IO ForeignInterface
getForeignInterface = do
ptr <- foreignInterfacePtr
+ runForeignDemarshal ptr $ do
+ ctx <- demarshal
+ requestHotReloadFn <- demarshal
+ doLogFn <- demarshal
+ doRequestExit <- demarshal
- ctx <- peekByteOff ptr 0
- requestHotReloadFn <- peekByteOff ptr (sizeOf ctx)
- doLogFn <- peekByteOff ptr (sizeOf ctx + sizeOf requestHotReloadFn)
-
- return $
- ForeignInterface
- { requestHotReload = toForeignCall requestHotReloadFn ctx,
- requestLog = \str ->
- withCString str $ \cs -> toForeignCallStr doLogFn ctx cs
- }
+ return $
+ ForeignInterface
+ { requestHotReload = toForeignCall requestHotReloadFn ctx,
+ requestLog = \str ->
+ withCString str $ \cs -> toForeignCallStr doLogFn ctx cs,
+ requestExit = toForeignCallInt doRequestExit ctx . fromIntegral
+ }