Added ability to exit the program via a back-interface.

6 files changed, 71 insertions, 17 deletions

diff --git a/harness/include/foreign_intf.h b/harness/include/foreign_intf.h
index fc079e2..e0d178c 100644
--- a/harness/include/foreign_intf.h
+++ b/harness/include/foreign_intf.h
@@ -21,6 +21,8 @@ typedef struct FOREIGN_INTERFACE {
   /* Requests the harness hot reload the current plugin. */
   EXPORT(void (*do_log)(ctx_t ctx, const char* str));
 
+  /* Requestes that the whole system exit. Exits with the given return code. */
+  EXPORT(void (*request_exit)(ctx_t ctx, int rc));
 } foreign_interface_t;
 
 #undef EXPORT
diff --git a/harness/include/plugin.h b/harness/include/plugin.h
index 1e4a161..145fe52 100644
--- a/harness/include/plugin.h
+++ b/harness/include/plugin.h
@@ -33,7 +33,11 @@ struct PLUGIN;
 typedef struct {
   int (*action)(struct PLUGIN *requester, void* arg);
   void (*arg_dtor)(void* arg);
-  void* arg;
+  union {
+    void* ptr_arg;
+    int int_arg;
+    char* str_arg;
+  };
 } requested_action_t;
 
 /*
diff --git a/harness/src/plugin.c b/harness/src/plugin.c
index f1cc361..1d7c992 100644
--- a/harness/src/plugin.c
+++ b/harness/src/plugin.c
@@ -86,11 +86,29 @@ void do_request_log(void *plugv, const char* str)
   size_t n = plugin->n_requested_actions++;
   if (n < 8) {
     plugin->requested_actions[n].action = plugin_do_log;
-    plugin->requested_actions[n].arg = strdup(str);
+    plugin->requested_actions[n].str_arg = strdup(str);
     plugin->requested_actions[n].arg_dtor = free;
   }
 }
 
+static int plugin_do_exit(void* plugv, int ec)
+{
+  exit(ec);
+  return 0;
+}
+
+void do_request_exit(void *plugv, int ec)
+{
+  plugin_t *plugin = plugv;
+
+  size_t n = plugin->n_requested_actions++;
+  if (n < 8) {
+    plugin->requested_actions[n].action = (int(*)(plugin_t*,void*)) plugin_do_exit;
+    plugin->requested_actions[n].int_arg = ec;
+    plugin->requested_actions[n].arg_dtor = NULL;
+  }
+}
+
 static int load_plugin_from_file_(int argc, char **argv, const char *filename,
                                   plugin_t *plugin)
 {
@@ -117,6 +135,7 @@ static int load_plugin_from_file_(int argc, char **argv, const char *filename,
   plugin->foreign_intf.ctx = plugin;
   plugin->foreign_intf.request_hot_reload = do_request_hot_reload;
   plugin->foreign_intf.do_log = do_request_log;
+  plugin->foreign_intf.request_exit = do_request_exit;
 
   plugin->plugin_load(plugin->argc, plugin->argv, &plugin->foreign_intf);
 end:
@@ -206,9 +225,9 @@ void plugin_run_requested_actions(plugin_t *plugin)
 
   size_t i;
   for (i = 0; i < n_requested_actions; ++i) {
-    requested_actions[i].action(plugin, requested_actions[i].arg);
+    requested_actions[i].action(plugin, requested_actions[i].str_arg);
     if (requested_actions[i].arg_dtor) {
-      requested_actions[i].arg_dtor(requested_actions[i].arg);
+      requested_actions[i].arg_dtor(requested_actions[i].ptr_arg);
     }
   }
 }
diff --git a/package.yaml b/package.yaml
index 1232b90..b559bd7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -45,6 +45,7 @@ ghc-options:
 - -Wredundant-constraints
 - -XTupleSections
 - -XViewPatterns
+- -XGeneralizedNewtypeDeriving
 - -fPIC
 
 executables:
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
+        }