Implement withStateful. WIP.

Author: ajnsit

examples/Test/Hello.purs

@@ -3,7 +3,7 @@ module Test.Hello where
 import Prelude
 
 import Concur.Core (Widget)
-import Concur.Core.DevTools (connectDevTools, sendToDevTools)
+import Concur.Core.DevTools (StateSubscription, connectDevTools, subscribe, withStateful)
 import Concur.React (HTML)
 import Concur.React.DOM (button, text, div')
 import Concur.React.Props (onClick)
@@ -15,19 +15,21 @@ import Effect.Class (liftEffect)
 import Effect.Console (log)
 
 helloWidget :: Widget HTML Int
-helloWidget = snd <$> runStateT helloWidgetS 0
-
-helloWidgetS :: forall a. StateT Int (Widget HTML) a
-helloWidgetS = do
+helloWidget = do
   conn <- liftEffect connectDevTools
+  subs <- liftEffect $ subscribe conn
+  snd <$> runStateT (helloWidgetS subs) 0
+
+helloWidgetS :: forall a. StateSubscription Int -> StateT Int (Widget HTML) a
+helloWidgetS subs = do
   count <- get
-  liftEffect $ sendToDevTools conn "Increment" count
-  e <- lift $ div'
+  -- liftEffect $ sendState subs "Increment" count
+  newCount <- lift $ withStateful subs "Increment" $ map (const (count + 1)) $ div'
     [ but "Say Hello!"
     , but $ "For the " <> show count <> " time, hello sailor!"
     ]
-  put (count + 1)
+  put newCount -- (count + 1)
   liftEffect (log "You said Hello!")
-  helloWidgetS
+  helloWidgetS subs
   where
     but s = button [onClick] [text s]

src/Concur/Core/DevTools.js

@@ -27,7 +27,7 @@ exports.sendToDevTools = function(connection) {
     return function(state) {
       return function() {
         if(hasDevTools()) {
-          return window.__REDUX_DEVTOOLS_EXTENSION__.send(action, state);
+          return connection.send(action, state);
         } else {
           // ??
           return null;
@@ -36,3 +36,27 @@ exports.sendToDevTools = function(connection) {
     };
   };
 };
+
+exports.subscribeDevTools = function(connection) {
+  return function(handler) {
+    return function() {
+      if(hasDevTools()) {
+        return connection.subscribe(function(message) {
+          if (message.type === 'DISPATCH' && message.state) {
+            // Extra () due to handler being a State -> Effect
+            handler(message.state)();
+          }
+        });
+      } else {
+        // ??
+        return null;
+      }
+    };
+  };
+};
+
+exports.unsubscribeDevTools = function(connection) {
+  return function() {
+    connection.unsubscribe();
+  };
+};

src/Concur/Core/DevTools.purs

@@ -1,9 +1,54 @@
 module Concur.Core.DevTools where
 
-import Data.Unit (Unit)
+import Prelude
+
+import Control.Alt (class Alt, (<|>))
+import Data.Either (Either(..))
 import Effect (Effect)
+import Effect.AVar as EVar
+import Effect.Aff (Aff)
+import Effect.Aff.AVar as AVar
+import Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Class (liftEffect)
+import Effect.Exception (error)
 
 data DevToolsConnection
 foreign import connectDevTools :: Effect DevToolsConnection
 foreign import disconnectDevTools :: Effect Unit
 foreign import sendToDevTools :: forall action state. DevToolsConnection -> action -> state -> Effect Unit
+
+data DevToolsSubscription
+foreign import subscribeDevTools :: forall state. DevToolsConnection -> (state -> Effect Unit) -> Effect DevToolsSubscription
+foreign import unsubscribeDevTools :: DevToolsSubscription -> Effect Unit
+
+data StateSubscription a = StateSubscription DevToolsConnection DevToolsSubscription (EVar.AVar a)
+
+subscribe :: forall a. DevToolsConnection -> Effect (StateSubscription a)
+subscribe conn = do
+  v <- EVar.empty
+  subs <- subscribeDevTools conn \st -> do
+    _ <- EVar.tryPut st v
+    pure unit
+  pure (StateSubscription conn subs v)
+
+unsubscribe :: forall a. StateSubscription a -> Effect Unit
+unsubscribe (StateSubscription _ subs v) = do
+  unsubscribeDevTools subs
+  EVar.kill (error "Unsubscribed") v
+
+awaitState :: forall a. StateSubscription a -> Aff a
+awaitState (StateSubscription _ _ v) = AVar.take v
+
+sendState :: forall a. StateSubscription a -> String -> a -> Effect Unit
+sendState (StateSubscription conn _ _) label st = sendToDevTools conn label st
+
+-- Wrap a state getter, so that all outputs from the getter are sent to the devtools
+--   And also, any state sent back from the devtools overrides the local state
+withStateful :: forall m a. MonadAff m => Alt m => StateSubscription a -> String -> m a -> m a
+withStateful subs label axn = do
+  est <- map Left axn <|> map Right (liftAff (awaitState subs))
+  case est of
+    Left st -> do
+      liftEffect $ sendState subs label st
+      pure st
+    Right st -> pure st