diff options
author | Josh Rahm <rahm@google.com> | 2024-02-16 13:29:17 -0700 |
---|---|---|
committer | Josh Rahm <rahm@google.com> | 2024-02-16 13:29:17 -0700 |
commit | c7a0945ffcb5f17953109a6b4ac77a5c64980f4f (patch) | |
tree | b5a4c26127720045a9a0babc9feff0e01304acfb /src | |
parent | f4ed2dd61b53ea45b05f3e8f4ebcce24188d32bd (diff) | |
download | wetterhorn-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.hs | 8 | ||||
-rw-r--r-- | src/Wetterhorn/Core/ForeignInterface.hs | 46 |
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 + } |