Framework for plugin to call into harness.

This is done by passing an interface to the plugin from the harness. The
plugin can then request the harness do some things (such as reload), and
the harness will do that.

4 files changed, 41 insertions, 19 deletions

diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index d3b3f56..8d4e6b7 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -15,14 +15,16 @@ module Wetterhorn.Core
     readWState,
     defaultConfig,
     requestHotReload,
+    ctxConfig,
   )
 where
 
 import Control.Arrow (first)
 import Control.Exception
+import Control.Monad (when)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as CH
-import Foreign (Ptr, StablePtr, Word32, newStablePtr, ptrToIntPtr)
+import Foreign (Ptr, StablePtr, Word32, newStablePtr, ptrToIntPtr, castForeignPtr)
 import Numeric (showHex)
 import Text.Printf
 import Wetterhorn.Core.ForeignInterface (ForeignInterface)
@@ -41,6 +43,11 @@ requestHotReload = do
   fi <- ctxForeignInterface <$> getWContext
   wio $ ForeignInterface.requestHotReload fi
 
+requestLog :: String -> W ()
+requestLog str = do
+  fi <- ctxForeignInterface <$> getWContext
+  wio $ ForeignInterface.requestLog fi str
+
 initWetterhorn :: WConfig -> IO Wetterhorn
 initWetterhorn conf = do
   foreignInterface <- ForeignInterface.getForeignInterface
@@ -64,7 +71,9 @@ defaultConfig =
   WConfig
     { keybindingHandler = \sym -> do
         i <- incrementState
-        wio (printf "[%d] Got key %d\n" i sym),
+        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"),
       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 acd98d6..de4779b 100644
--- a/src/Wetterhorn/Core/ForeignInterface.hs
+++ b/src/Wetterhorn/Core/ForeignInterface.hs
@@ -6,18 +6,24 @@ where
 
 import Data.Void (Void)
 import Foreign (Ptr, Storable (peekByteOff, sizeOf))
+import Foreign.C.String
 import GHC.Exts (FunPtr)
 
 type CtxT = Ptr Void
 
 type ForeignCall = CtxT -> IO ()
 
+type ForeignCallStr = CtxT -> CString -> 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
+
 data ForeignInterface = ForeignInterface
-  { requestHotReload :: IO ()
+  { requestHotReload :: IO (),
+    requestLog :: String -> IO ()
   }
 
 getForeignInterface :: IO ForeignInterface
@@ -26,11 +32,11 @@ getForeignInterface = do
 
   ctx <- peekByteOff ptr 0
   requestHotReloadFn <- peekByteOff ptr (sizeOf ctx)
-
-  let _ = (ctx :: CtxT)
-  let _ = (requestHotReloadFn :: FunPtr ForeignCall)
+  doLogFn <- peekByteOff ptr (sizeOf ctx + sizeOf requestHotReloadFn)
 
   return $
     ForeignInterface
-      { requestHotReload = toForeignCall requestHotReloadFn ctx
+      { requestHotReload = toForeignCall requestHotReloadFn ctx,
+        requestLog = \str ->
+          withCString str $ \cs -> toForeignCallStr doLogFn ctx cs
       }
diff --git a/src/Wetterhorn/FFI.hs b/src/Wetterhorn/FFI.hs
index 1d74248..3221903 100644
--- a/src/Wetterhorn/FFI.hs
+++ b/src/Wetterhorn/FFI.hs
@@ -21,27 +21,27 @@ import Wetterhorn.Core
 
 runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
 runForeign fn stblptr = do
-  (conf, st) <- deRefStablePtr stblptr
+  (ctx, st) <- deRefStablePtr stblptr
   freeStablePtr stblptr
-  (_, state') <- runW (fn conf) (conf, st)
-  newStablePtr (conf, state')
+  (_, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+  newStablePtr (ctx, state')
 
 runForeignWithReturn :: (Storable a) => (WConfig -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
 runForeignWithReturn fn ptr stableptr = do
-  (conf, st) <- deRefStablePtr stableptr
+  (ctx, st) <- deRefStablePtr stableptr
   freeStablePtr stableptr
-  (val, state') <- runW (fn conf) (conf, st)
+  (val, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
   poke ptr val
-  newStablePtr (conf, state')
+  newStablePtr (ctx, state')
 
 runForeignWithReturn2 :: (Storable a, Storable b) => (WConfig -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
 runForeignWithReturn2 fn ptrA ptrB stableptr = do
-  (conf, st) <- deRefStablePtr stableptr
+  (ctx, st) <- deRefStablePtr stableptr
   freeStablePtr stableptr
-  ((vA, vB), state') <- runW (fn conf) (conf, st)
+  ((vA, vB), state') <- runW (fn $ ctxConfig ctx) (ctx, st)
   poke ptrA vA
   poke ptrB vB
-  newStablePtr (conf, state')
+  newStablePtr (ctx, state')
 
 -- | This function is the implementation of the "hotstart" mechanism. It gives a
 -- pointer to the previously marshalled state and the length of that array and
diff --git a/src/harness_adapter.c b/src/harness_adapter.c
index aa45ce6..8585d7e 100644
--- a/src/harness_adapter.c
+++ b/src/harness_adapter.c
@@ -5,7 +5,7 @@
 
 #include "HsFFI.h"
 #include "plugin_interface.h"
-#include <stdio.h>
+#include <unistd.h>
 
 const char *plugin_name = "Wetterhorn";
 
@@ -16,11 +16,18 @@ void* get_foreign_interface()
   return foreign_interface;
 }
 
-void plugin_load(int argc, char **argv, void* fintf) {
+void plugin_load(int argc, char **argv, foreign_interface_t* fintf) {
   hs_init(&argc, &argv);
   foreign_interface = fintf;
 }
-void plugin_teardown(opqst_t st) { hs_exit(); }
+void plugin_teardown(opqst_t st) {
+  hs_exit();
+
+  // There's a race condition between when this shared library is unloaded and
+  // when the haskell runtime actually exits. Don't have a good solution for
+  // this at the moment, so just sleep for a second.
+  sleep(1);
+}
 
 static const char msg[] =
     "Wetterhorn Plugin v 0.01\n\n"