From e3335f998e1ef3289c6ad909d45d501c45428659 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Fri, 5 Jun 2020 02:36:11 +0530
Subject: [PATCH 01/10] Trying to remove Aff. Replace with callbacks [WIP]

---
 src/Concur/Core/Discharge.purs |  5 +-
 src/Concur/Core/Types.purs     | 85 +++++++++++++++++++---------------
 2 files changed, 50 insertions(+), 40 deletions(-)

diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index 4475d82..5301418 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -2,12 +2,11 @@ module Concur.Core.Discharge where
 
 import Prelude
 
-import Concur.Core.Types (Widget(..), WidgetStep(..), unWidget)
+import Concur.Core.Types (Widget(..), WidgetStep(..), observe, unWidget)
 import Control.Monad.Free (resume, wrap)
 import Data.Either (Either(..))
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
-import Effect.Aff (runAff_)
 import Effect.Exception (Error)
 
 -- Widget discharge strategies
@@ -27,7 +26,7 @@ discharge handler (Widget w) = case resume w of
       w' <- eff
       discharge handler (Widget w')
   Left (WidgetStepView ws) -> do
-      runAff_ (handler <<< map Widget) ws.cont
+      _ <- observe ws.cont (\x -> handler $ Right $ Widget x)
       pure ws.view
 
 -- | Discharge only the top level blocking effect of a widget (if any) to get access to the view
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 814552b..c2de352 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -6,28 +6,52 @@ import Control.Alternative (class Alternative)
 import Control.Monad.Free (Free, hoistFree, liftF, resume, wrap)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.MultiAlternative (class MultiAlternative, orr)
-import Control.Parallel.Class (parallel, sequential)
 import Control.Plus (class Alt, class Plus, alt, empty)
 import Control.ShiftMap (class ShiftMap)
 import Data.Array as A
 import Data.Array.NonEmpty (NonEmptyArray)
 import Data.Array.NonEmpty as NEA
 import Data.Either (Either(..))
-import Data.FoldableWithIndex (foldlWithIndex, foldrWithIndex)
+import Data.Foldable (sequence_)
+import Data.FoldableWithIndex (foldrWithIndex)
 import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
 import Data.Semigroup.Foldable (foldMap1)
+import Data.TraversableWithIndex (traverseWithIndex)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
-import Effect.AVar (empty, tryPut, tryTake) as EVar
-import Effect.Aff (Aff, effectCanceler, makeAff, never, runAff_)
-import Effect.Aff.AVar (take) as AVar
-import Effect.Aff.Class (class MonadAff)
 import Effect.Class (class MonadEffect)
-import Effect.Console (log)
-import Effect.Exception (Error)
+
+-- Returns a canceller
+newtype Observe a = Observe ((a -> Effect Unit) -> Effect (Effect Unit))
+-- derive instance observeFunctor :: Functor Observe
+instance observeFunctor :: Functor Observe where
+  map f (Observe g) = Observe \cb -> g (cb <<< f)
+
+observe :: forall a. Observe a -> (a -> Effect Unit) -> Effect (Effect Unit)
+observe (Observe f) = f
+
+never :: forall a. Observe a
+never = Observe \_ -> pure (pure unit)
+
+dont :: forall a. Pusher a
+dont a = pure unit
+
+type Pusher a = a -> Effect Unit
+
+par :: forall a. NonEmptyArray (Observe a) -> Observe (Tuple Int a)
+par os = Observe $ \cb -> do
+  cs <- traverseWithIndex (\i (Observe f) -> f (\a -> cb (Tuple i a))) os
+  pure $ sequence_ cs
+
+-- TODO TODO TODO
+mkObserve :: forall a. Effect { push :: Pusher a, subscribe :: Observe a }
+mkObserve = pure
+  { push: dont
+  , subscribe: never
+  }
 
 type WidgetStepRecord v a
-  = {view :: v, cont :: Aff a}
+  = {view :: v, cont :: Observe a}
 
 data WidgetStep v a
   = WidgetStepEff (Effect a)
@@ -138,16 +162,14 @@ instance widgetMultiAlternative ::
       forall v' a.
       Monoid v' =>
       NonEmptyArray (WidgetStepRecord v' (Free (WidgetStep v') a)) ->
-      NonEmptyArray (Aff (Free (WidgetStep v') a)) ->
-      Aff (Free (WidgetStep v') a)
-    merge ws wscs = do
+      NonEmptyArray (Observe (Free (WidgetStep v') a)) ->
+      Observe (Free (WidgetStep v') a)
+    merge ws wscs =
       let wsm = map (wrap <<< WidgetStepView) ws
       -- TODO: We know the array is non-empty. We need something like foldl1WithIndex.
-      Tuple i e <- sequential (foldlWithIndex (\i r w ->
-        alt (parallel (map (Tuple i) w)) r) empty wscs)
-      -- TODO: All the Aff in ws is already discharged. Use a more efficient way than combine to process it
+      -- TODO: All the Observe in ws is already discharged. Use a more efficient way than combine to process it
       -- TODO: Also, more importantly, we would like to not have to cancel running fibers unless one of them returns a result
-      pure $ combine (fromMaybe wsm (NEA.updateAt i e wsm))
+      in (\(Tuple i e) -> combine (fromMaybe wsm (NEA.updateAt i e wsm))) <$> (par wscs)
 
 
 -- | Run multiple widgets in parallel until *all* finish, and collect their outputs
@@ -214,32 +236,21 @@ effAction = Widget <<< liftF <<< WidgetStepEff
 affAction ::
   forall a v.
   v ->
-  Aff a ->
+  Observe a ->
   Widget v a
-affAction v aff = Widget $ wrap $ WidgetStepEff do
-  var <- EVar.empty
-  runAff_ (handler var) aff
-  -- Detect synchronous resolution
-  ma <- EVar.tryTake var
-  pure case ma of
-    Just a -> pure a
-    Nothing -> liftF $ WidgetStepView { view: v, cont: AVar.take var }
-  where
-  -- TODO: allow client code to handle aff failures
-  handler _ (Left e) = log ("Aff failed - " <> show e)
-  handler var (Right a) = void (EVar.tryPut a var)
+affAction v cb = Widget $ liftF $ WidgetStepView { view: v, cont: cb }
 
 -- Async callback
-asyncAction ::
-  forall v a.
-  v ->
-  ((Either Error a -> Effect Unit) -> Effect (Effect Unit)) ->
-  Widget v a
-asyncAction v handler = affAction v (makeAff (map effectCanceler <<< handler))
+-- asyncAction ::
+--   forall v a.
+--   v ->
+--   ((Either Error a -> Effect Unit) -> Effect (Effect Unit)) ->
+--   Widget v a
+-- asyncAction v handler = affAction v (?asd handler)
 
 instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
   liftEffect = effAction
 
-instance widgetMonadAff :: (Monoid v) => MonadAff (Widget v) where
-  liftAff = affAction mempty
+-- instance widgetMonadObserve :: (Monoid v) => MonadObserve (Widget v) where
+--   liftObserve = affAction mempty
     -- Widget $ liftF $ WidgetStep $ Right { view: mempty, cont: aff }

From f654427110a711a28741aebeefada561fd8fdbd8 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Sat, 6 Jun 2020 12:29:12 +0530
Subject: [PATCH 02/10] Compiles. Had to remove some useful functions (they
 will be back).

---
 spago.dhall                    |  4 +-
 src/Concur/Core.purs           | 32 ++++++--------
 src/Concur/Core/DevTools.js    | 62 --------------------------
 src/Concur/Core/DevTools.purs  | 69 -----------------------------
 src/Concur/Core/Discharge.purs |  3 +-
 src/Concur/Core/Event.purs     | 80 ++++++++++++++++++++++++++++++++++
 src/Concur/Core/FRP.purs       | 24 ----------
 src/Concur/Core/Patterns.purs  | 65 ++-------------------------
 src/Concur/Core/Types.purs     | 66 +++++++---------------------
 9 files changed, 114 insertions(+), 291 deletions(-)
 delete mode 100644 src/Concur/Core/DevTools.js
 delete mode 100644 src/Concur/Core/DevTools.purs
 create mode 100644 src/Concur/Core/Event.purs

diff --git a/spago.dhall b/spago.dhall
index 8877b37..c491eb9 100644
--- a/spago.dhall
+++ b/spago.dhall
@@ -5,9 +5,7 @@ You can edit this file as you like.
 { name =
     "concur-core"
 , dependencies =
-    [ "aff"
-    , "arrays"
-    , "avar"
+    [ "arrays"
     , "console"
     , "foldable-traversable"
     , "free"
diff --git a/src/Concur/Core.purs b/src/Concur/Core.purs
index 8dedb05..366ec5d 100644
--- a/src/Concur/Core.purs
+++ b/src/Concur/Core.purs
@@ -6,18 +6,15 @@ module Concur.Core
 )
 where
 
+import Concur.Core.Event (mkObserver, par)
 import Concur.Core.IsWidget (class IsWidget)
 import Concur.Core.LiftWidget (class LiftWidget, liftWidget)
 import Concur.Core.Types (Widget(..), WidgetStep(..), unWidget)
-import Control.Monad.Free (Free, wrap, resume)
-import Control.Parallel.Class (parallel, sequential)
-import Control.Plus (alt)
+import Control.Category ((<<<))
+import Control.Monad.Free (Free, resume, wrap)
 import Data.Either (Either(..))
 import Effect (Effect)
-import Effect.AVar (empty, tryPut) as EVar
-import Effect.Aff.AVar (take) as AVar
-import Effect.Aff.Class (liftAff)
-import Prelude (Unit, bind, map, pure, void, ($))
+import Prelude (Unit, bind, pure, ($))
 
 -- Helpers for some very common use of unsafe blocking io
 
@@ -37,23 +34,20 @@ mkNodeWidget' mkView w = case resume w of
       w' <- eff
       pure $ mkNodeWidget' mkView w'
   Left (WidgetStepView wsr) -> wrap $ WidgetStepEff do
-      var <- EVar.empty
-      let eventHandler = (\a -> void (EVar.tryPut (pure a) var))
-      let cont' = sequential (alt (parallel (liftAff (AVar.take var)))
-                                  (parallel (map (mkNodeWidget' mkView) wsr.cont))
-                             )
-      pure $ wrap $ WidgetStepView
-        { view: mkView eventHandler wsr.view
-        , cont: cont'
-        }
+    ob <- mkObserver
+    pure $ wrap $ WidgetStepView
+      { view: mkView (ob.push <<< pure) wsr.view
+      , cont: par [ob.subscribe, wsr.cont]
+      }
+
 -- | Construct a widget with just props
 mkLeafWidget ::
   forall a v.
   ((a -> Effect Unit) -> v) ->
   Widget v a
 mkLeafWidget mkView = Widget $ wrap $ WidgetStepEff do
-  var <- EVar.empty
+  ob <- mkObserver
   pure $ wrap $ WidgetStepView
-    { view: mkView (\a -> void (EVar.tryPut (pure a) var))
-    , cont: liftAff (AVar.take var)
+    { view: mkView (ob.push <<< pure)
+    , cont: ob.subscribe
     }
diff --git a/src/Concur/Core/DevTools.js b/src/Concur/Core/DevTools.js
deleted file mode 100644
index 204b670..0000000
--- a/src/Concur/Core/DevTools.js
+++ /dev/null
@@ -1,62 +0,0 @@
-"use strict";
-
-function hasDevTools() {
-  return (process.env.NODE_ENV === 'development' && window.__REDUX_DEVTOOLS_EXTENSION__);
-}
-
-exports.connectDevTools = function() {
-  if(hasDevTools()) {
-    return window.__REDUX_DEVTOOLS_EXTENSION__.connect();
-  } else {
-    // ??
-    return null;
-  }
-};
-
-exports.disconnectDevTools = function() {
-  if(hasDevTools()) {
-    return window.__REDUX_DEVTOOLS_EXTENSION__.disconnect();
-  } else {
-    // ??
-    return null;
-  }
-};
-
-exports.sendToDevTools = function(connection) {
-  return function(action) {
-    return function(state) {
-      return function() {
-        if(hasDevTools()) {
-          return connection.send(action, state);
-        } else {
-          // ??
-          return null;
-        }
-      };
-    };
-  };
-};
-
-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();
-  };
-};
diff --git a/src/Concur/Core/DevTools.purs b/src/Concur/Core/DevTools.purs
deleted file mode 100644
index 450a05e..0000000
--- a/src/Concur/Core/DevTools.purs
+++ /dev/null
@@ -1,69 +0,0 @@
-module Concur.Core.DevTools where
-
-import Prelude
-
-import Control.Alt (class Alt, (<|>))
-import Data.Either (Either(..))
-import Effect (Effect)
-import Effect.Aff (Aff)
-import Effect.Aff.Class (class MonadAff, liftAff)
-import Effect.Class (liftEffect)
-import Effect.Exception (error)
-
-import Effect.AVar as EVar
-import Effect.Aff.AVar as AVar
-
-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
diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index 5301418..6a9e444 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -2,7 +2,8 @@ module Concur.Core.Discharge where
 
 import Prelude
 
-import Concur.Core.Types (Widget(..), WidgetStep(..), observe, unWidget)
+import Concur.Core.Event (observe)
+import Concur.Core.Types (Widget(..), WidgetStep(..), unWidget)
 import Control.Monad.Free (resume, wrap)
 import Data.Either (Either(..))
 import Data.Tuple (Tuple(..))
diff --git a/src/Concur/Core/Event.purs b/src/Concur/Core/Event.purs
new file mode 100644
index 0000000..4c6ca71
--- /dev/null
+++ b/src/Concur/Core/Event.purs
@@ -0,0 +1,80 @@
+module Concur.Core.Event where
+
+import Control.Applicative (pure)
+import Control.Bind (bind, discard, (=<<))
+import Control.Monad (when)
+import Data.Eq ((/=))
+import Data.FoldableWithIndex (traverseWithIndex_)
+import Data.Function (($))
+import Data.Functor (class Functor)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Traversable (sequence_)
+import Data.TraversableWithIndex (traverseWithIndex)
+import Data.Unit (Unit, unit)
+import Effect (Effect)
+import Effect.Ref as Ref
+
+-- TODO: Generalise monad to m
+-- TODO: This is basically ContT, apart from the canceller
+-- Returns a canceller
+newtype Observer a = Observer ((a -> Effect Unit) -> Effect (Effect Unit))
+-- derive instance observeFunctor :: Functor Observer
+instance observeFunctor :: Functor Observer where
+  map f (Observer g) = Observer \cb -> g \a -> cb $ f a
+
+-- Chain an effect onto an observer
+effMap :: forall a b. Observer a -> (a -> Effect b) -> Observer b
+effMap (Observer g) f = Observer \cb -> g \a -> cb =<< f a
+
+-- TODO: Monadic chaining for observer
+-- instance observeApply :: Apply Observer where
+--   -- apply :: forall a b. f (a -> b) -> f a -> f b
+--   apply (Observer f) (Observer a) = Observer \cb -> f \cf' ->
+
+observe :: forall a. Observer a -> (a -> Effect Unit) -> Effect (Effect Unit)
+observe (Observer f) = f
+
+never :: forall a. Observer a
+never = Observer \_ -> pure (pure unit)
+
+dont :: forall a. Pusher a
+dont a = pure unit
+
+-- Push data
+type Pusher a = a -> Effect Unit
+
+
+-----------------------------------------------------------------------
+----------------------- LOOK FOR BUGS HERE ----------------------------
+--- WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ---
+-- BELOW ARE THE ONLY MUTABLE, STATEFUL BITS IN THE ENTIRE FRAMEWORK --
+-----------------------------------------------------------------------
+
+parIndex :: forall a. Array (Observer a) -> Observer ({i::Int, val::a})
+parIndex = par' \i val -> {i, val}
+
+par :: forall a. Array (Observer a) -> Observer a
+par = par' \_ val -> val
+
+par' :: forall a b. (Int -> a -> b) -> Array (Observer a) -> Observer b
+par' g os = Observer \cb -> do
+  ref <- Ref.new []
+  cs <- traverseWithIndex (\i (Observer f) -> f \a -> do
+          cs <- Ref.read ref
+          Ref.write [] ref
+          traverseWithIndex_ (\j -> when (j /= i)) cs
+          cb $ g i a
+    ) os
+  Ref.write cs ref
+  pure do
+    sequence_ cs
+    Ref.write [] ref
+
+mkObserver :: forall a. Effect { push :: Pusher a, subscribe :: Observer a }
+mkObserver = do
+  ref <- Ref.new Nothing
+  let push a = maybe (pure unit) (_ $ a) =<< Ref.read ref
+  let subscribe = Observer \cb -> do
+        Ref.write (Just cb) ref
+        pure do Ref.write Nothing ref
+  pure { push, subscribe}
diff --git a/src/Concur/Core/FRP.purs b/src/Concur/Core/FRP.purs
index d0a15c3..9887cfc 100644
--- a/src/Concur/Core/FRP.purs
+++ b/src/Concur/Core/FRP.purs
@@ -3,16 +3,12 @@ module Concur.Core.FRP where
 import Prelude
 
 import Concur.Core.Types (Widget)
-import Control.Alt (class Alt, (<|>))
 import Control.Alternative (class Alternative, class Plus, empty)
 import Control.Cofree (Cofree, mkCofree, tail)
 import Control.Comonad (extract)
 import Data.Either (Either(..), either, hush)
 import Data.Maybe (Maybe(..))
-import Data.Time.Duration (Milliseconds(..))
 import Effect (Effect)
-import Effect.Aff (delay)
-import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (class MonadEffect, liftEffect)
 
 ----------
@@ -196,23 +192,3 @@ stateLoopS ::
   (s -> SignalT m (Either s a)) ->
   SignalT m (Maybe a)
 stateLoopS def w = map hush $ loopS (Left def) $ either w (pure <<< Right)
-
-
--- Debounced output from a widget
--- wrapped into a signal
-debounce :: forall m a. Monad m => Alt m => MonadAff m =>
-            Number -> a -> (a -> m a) -> SignalT m a
-debounce timeoutMs ainit winit = go ainit winit
-  where
-    go a w = step a do
-      -- Wait until we have a user input
-      -- before starting the timer
-      a' <- w a
-      go' a' w
-    go' a w = do
-      res <- (Just <$> w a) <|> (Nothing <$ liftAff (delay (Milliseconds timeoutMs)))
-      case res of
-        -- Timeout fired
-        Nothing -> pure (go a w)
-        -- Events fired, but we are still in timeout
-        Just a' -> go' a' w
diff --git a/src/Concur/Core/Patterns.purs b/src/Concur/Core/Patterns.purs
index 903fc3f..d8697a2 100644
--- a/src/Concur/Core/Patterns.purs
+++ b/src/Concur/Core/Patterns.purs
@@ -1,17 +1,7 @@
 module Concur.Core.Patterns where
 
 import Prelude
-
-import Control.Alt (class Alt)
-import Control.Plus (class Plus, empty, (<|>))
-import Data.Either (Either(..), either)
-import Data.Lens (Lens')
-import Data.Lens as L
-import Data.Tuple (Tuple(..))
-import Effect.AVar as EVar
-import Effect.Aff.AVar as AVar
-import Effect.Aff.Class (class MonadAff, liftAff)
-import Effect.Class (class MonadEffect, liftEffect)
+import Data.Either (Either(..))
 
 -- | A very useful combinator for widgets with localised state
 loopState ::
@@ -44,59 +34,9 @@ tea s render update = go s
   where
   go st = render st >>= (flip update st >>> go)
 
--- | Separate the effect of the widget from its result
-remoteWidget ::
-  forall m n a void.
-  MonadEffect n =>
-  MonadAff m =>
-  MonadEffect m =>
-  Plus m =>
-  m a ->
-  n (Tuple (m a) (m void))
-remoteWidget axn = do
-  var <- liftEffect $ EVar.empty
-  pure $ Tuple (liftAff (AVar.take var)) do
-    f <- axn
-    _ <- liftEffect $ EVar.tryPut f var
-    empty
-
--- | A common pattern - running a long running action and keeping the GUI responsive
--- | Because the action can't be restarted on every gui event, we must *fork* it off in the beginning
-forkAction ::
-  forall m a b.
-  MonadEffect m =>
-  MonadAff m =>
-  Plus m =>
-  m a ->
-  (m a -> m b) ->
-  m b
-forkAction axn rest = do
-  Tuple axn' background <- remoteWidget axn
-  background <|> rest axn'
-
--- | Another common variant on the `forkAction` pattern.
--- |   The action `m (s->s)` may take a while (should not be restarted) and returns a state modification function
--- |   The gui `s -> m s` takes in the current state, and modifies it on events
--- | Note that `forkActionState axn` has the shape `(s -> m s) -> (s -> m s)`. So it can be "stacked" to fork multiple actions.
--- | e.g. `forkActionState axn1 $ forkActionState axn2 $ forkActionState axn3 $ render initialState`.
-forkActionState ::
-  forall m s.
-  Plus m =>
-  MonadAff m =>
-  m (s -> s) ->
-  (s -> m s) ->
-  (s -> m s)
-forkActionState axn render st = forkAction axn (go st)
-  where
-  go st' axn' = do
-    e <- (Left <$> render st') <|> (Right <$> axn')
-    case e of
-      Left st'' -> go st'' axn'
-      Right f -> render (f st')
-
-
 -- WORKING WITH LOCAL ENVIRONMENTS
 
+{-
 -- | A wire can send values up into a local environment
 type Wire m a = { value :: a, send :: a -> m Void, receive :: m a }
 
@@ -121,3 +61,4 @@ local a f = do
   go wire = do
     res <- (Left <$> f wire) <|> (Right <$> wire.receive)
     either pure (go <<< updateWire wire) res
+-}
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index c2de352..18092f5 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -2,6 +2,7 @@ module Concur.Core.Types where
 
 import Prelude
 
+import Concur.Core.Event (Observer(..), never, parIndex)
 import Control.Alternative (class Alternative)
 import Control.Monad.Free (Free, hoistFree, liftF, resume, wrap)
 import Control.Monad.Rec.Class (class MonadRec)
@@ -12,57 +13,20 @@ import Data.Array as A
 import Data.Array.NonEmpty (NonEmptyArray)
 import Data.Array.NonEmpty as NEA
 import Data.Either (Either(..))
-import Data.Foldable (sequence_)
 import Data.FoldableWithIndex (foldrWithIndex)
 import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
 import Data.Semigroup.Foldable (foldMap1)
-import Data.TraversableWithIndex (traverseWithIndex)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
 
--- Returns a canceller
-newtype Observe a = Observe ((a -> Effect Unit) -> Effect (Effect Unit))
--- derive instance observeFunctor :: Functor Observe
-instance observeFunctor :: Functor Observe where
-  map f (Observe g) = Observe \cb -> g (cb <<< f)
-
-observe :: forall a. Observe a -> (a -> Effect Unit) -> Effect (Effect Unit)
-observe (Observe f) = f
-
-never :: forall a. Observe a
-never = Observe \_ -> pure (pure unit)
-
-dont :: forall a. Pusher a
-dont a = pure unit
-
-type Pusher a = a -> Effect Unit
-
-par :: forall a. NonEmptyArray (Observe a) -> Observe (Tuple Int a)
-par os = Observe $ \cb -> do
-  cs <- traverseWithIndex (\i (Observe f) -> f (\a -> cb (Tuple i a))) os
-  pure $ sequence_ cs
-
--- TODO TODO TODO
-mkObserve :: forall a. Effect { push :: Pusher a, subscribe :: Observe a }
-mkObserve = pure
-  { push: dont
-  , subscribe: never
-  }
-
 type WidgetStepRecord v a
-  = {view :: v, cont :: Observe a}
+  = {view :: v, cont :: Observer a}
 
 data WidgetStep v a
   = WidgetStepEff (Effect a)
   | WidgetStepView (WidgetStepRecord v a)
 
--- unWidgetStep ::
---   forall v a.
---   WidgetStep v a ->
---   Either (Effect a) (WidgetStepRecord v a)
--- unWidgetStep (WidgetStep x) = x
-
 -- derive instance widgetStepFunctor :: Functor (WidgetStep v)
 instance functorWidgetStep :: Functor (WidgetStep v) where
   map f (WidgetStepEff e) = WidgetStepEff (map f e)
@@ -162,14 +126,14 @@ instance widgetMultiAlternative ::
       forall v' a.
       Monoid v' =>
       NonEmptyArray (WidgetStepRecord v' (Free (WidgetStep v') a)) ->
-      NonEmptyArray (Observe (Free (WidgetStep v') a)) ->
-      Observe (Free (WidgetStep v') a)
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      Observer (Free (WidgetStep v') a)
     merge ws wscs =
       let wsm = map (wrap <<< WidgetStepView) ws
       -- TODO: We know the array is non-empty. We need something like foldl1WithIndex.
-      -- TODO: All the Observe in ws is already discharged. Use a more efficient way than combine to process it
+      -- TODO: All the Observer in ws is already discharged. Use a more efficient way than combine to process it
       -- TODO: Also, more importantly, we would like to not have to cancel running fibers unless one of them returns a result
-      in (\(Tuple i e) -> combine (fromMaybe wsm (NEA.updateAt i e wsm))) <$> (par wscs)
+      in (\ {i, val:e} -> combine (fromMaybe wsm (NEA.updateAt i e wsm))) <$> (parIndex (NEA.toArray wscs))
 
 
 -- | Run multiple widgets in parallel until *all* finish, and collect their outputs
@@ -236,21 +200,21 @@ effAction = Widget <<< liftF <<< WidgetStepEff
 affAction ::
   forall a v.
   v ->
-  Observe a ->
+  Observer a ->
   Widget v a
 affAction v cb = Widget $ liftF $ WidgetStepView { view: v, cont: cb }
 
 -- Async callback
--- asyncAction ::
---   forall v a.
---   v ->
---   ((Either Error a -> Effect Unit) -> Effect (Effect Unit)) ->
---   Widget v a
--- asyncAction v handler = affAction v (?asd handler)
+asyncAction
+  :: forall v a
+   . v
+  -> ((a -> Effect Unit) -> Effect (Effect Unit))
+  -> Widget v a
+asyncAction v handler = affAction v (Observer handler)
 
 instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
   liftEffect = effAction
 
--- instance widgetMonadObserve :: (Monoid v) => MonadObserve (Widget v) where
---   liftObserve = affAction mempty
+-- instance widgetMonadObserver :: (Monoid v) => MonadObserver (Widget v) where
+--   liftObserver = affAction mempty
     -- Widget $ liftF $ WidgetStep $ Right { view: mempty, cont: aff }

From ef3e45458d5927ae94cd3b81fa81bfefc3f0ce9a Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Tue, 16 Jun 2020 13:08:51 +0530
Subject: [PATCH 03/10] Better views

---
 spago.dhall                    |   2 +-
 src/Concur/Core.purs           |  41 ++++++++---
 src/Concur/Core/DOM.purs       |  43 -----------
 src/Concur/Core/Discharge.purs |  41 +++++++----
 src/Concur/Core/Types.purs     | 127 ++++++++++++++++++---------------
 5 files changed, 132 insertions(+), 122 deletions(-)
 delete mode 100644 src/Concur/Core/DOM.purs

diff --git a/spago.dhall b/spago.dhall
index c491eb9..01ba2c5 100644
--- a/spago.dhall
+++ b/spago.dhall
@@ -18,5 +18,5 @@ You can edit this file as you like.
 , packages =
     ./packages.dhall
 , sources =
-    [ "src/**/*.purs", "test/**/*.purs" ]
+    [ "src/**/*.purs" ]
 }
diff --git a/src/Concur/Core.purs b/src/Concur/Core.purs
index 366ec5d..98917e1 100644
--- a/src/Concur/Core.purs
+++ b/src/Concur/Core.purs
@@ -6,7 +6,7 @@ module Concur.Core
 )
 where
 
-import Concur.Core.Event (mkObserver, par)
+import Concur.Core.Event (Observer(..), mkObserver, par)
 import Concur.Core.IsWidget (class IsWidget)
 import Concur.Core.LiftWidget (class LiftWidget, liftWidget)
 import Concur.Core.Types (Widget(..), WidgetStep(..), unWidget)
@@ -18,6 +18,11 @@ import Prelude (Unit, bind, pure, ($))
 
 -- Helpers for some very common use of unsafe blocking io
 
+-- TODO: THIS SHOULD NOT BE EXTRACTED OUT OF THE BACKEND CODE.
+-- EXTRACTING THIS OUT OF THE BACKEND IS CAUSING A RIGID mkNodeWidget TO BE USED
+-- THAT mkNodeWidget IF FORCING "spooky action at a distance". GET RID OF!
+
+{-
 -- | Construct a widget, by wrapping an existing widget in a view event
 mkNodeWidget ::
   forall a v.
@@ -30,15 +35,34 @@ mkNodeWidget mkView (Widget w) = Widget (mkNodeWidget' mkView w)
 mkNodeWidget' :: forall a v. ((a -> Effect Unit) -> v -> v) -> Free (WidgetStep v) a -> Free (WidgetStep v) a
 mkNodeWidget' mkView w = case resume w of
   Right a -> pure a
-  Left (WidgetStepEff eff) -> wrap $ WidgetStepEff do
+  Left x -> case x of
+    WidgetStepEff eff -> wrap $ WidgetStepEff do
       w' <- eff
       pure $ mkNodeWidget' mkView w'
-  Left (WidgetStepView wsr) -> wrap $ WidgetStepEff do
-    ob <- mkObserver
-    pure $ wrap $ WidgetStepView
-      { view: mkView (ob.push <<< pure) wsr.view
-      , cont: par [ob.subscribe, wsr.cont]
-      }
+    WidgetStepView v w' -> do
+-}
+
+  -- Left (WidgetStepCont (Observer f)) -> wrap $ WidgetStepCont $ Observer \cb ->
+  --   f \w' -> cb (mkNodeWidgetInner cb w')
+
+  -- At this point, we don't have a wrapping observer. Create one
+  -- Left (WidgetStepView v a) -> wrap $ WidgetStepCont $ Observer \cb ->
+  --   ob <- mkObserver
+  --   pure $ wrap $ WidgetStepView
+  --     { view: mkView (ob.push <<< pure) wsr.view
+  --     , cont: par [ob.subscribe, wsr.cont]
+  --     }
+
+  -- where
+    -- Special case, view wrapped inside callback
+    -- mkNodeWidgetInner cb w' = case resume w' of
+    --   Right a -> pure a
+    --   Left (WidgetStepEff eff) -> wrap $ WidgetStepEff do
+    --     w'' <- eff
+    --     pure $ mkNodeWidgetInner cb w''
+    --   Left (WidgetStepView v w'') -> wrap $ WidgetStepView (mkView cb v) (mkNodeWidget' mkView w'')
+
+{-
 
 -- | Construct a widget with just props
 mkLeafWidget ::
@@ -51,3 +75,4 @@ mkLeafWidget mkView = Widget $ wrap $ WidgetStepEff do
     { view: mkView (ob.push <<< pure)
     , cont: ob.subscribe
     }
+-}
diff --git a/src/Concur/Core/DOM.purs b/src/Concur/Core/DOM.purs
deleted file mode 100644
index aed5709..0000000
--- a/src/Concur/Core/DOM.purs
+++ /dev/null
@@ -1,43 +0,0 @@
-module Concur.Core.DOM where
-
-import Concur.Core (mkLeafWidget, mkNodeWidget)
-import Concur.Core.LiftWidget (class LiftWidget, liftWidget)
-import Concur.Core.Props (Props, mkProp)
-import Concur.Core.Types (Widget)
-import Control.MultiAlternative (class MultiAlternative, orr)
-import Control.ShiftMap (class ShiftMap, shiftMap)
-import Data.Function (($), (<<<))
-import Data.Functor (class Functor, map)
-
--- | Wrap a single widget with a node that can have eventHandlers attached
-el
-  :: forall f p v m a
-  .  ShiftMap (Widget v) m
-  => Functor f
-  => (f p -> v -> v)
-  -> f (Props p a)
-  -> m a
-  -> m a
-el e props = shiftMap (\f w -> mkNodeWidget (\h v -> (e (map (mkProp h <<< map f) props) v)) w)
-
--- | Promote a leaf node to a widget
-elLeaf
-  :: forall f p v m a
-  .  LiftWidget v m
-  => Functor f
-  => (f p -> v)
-  -> f (Props p a)
-  -> m a
-elLeaf e props = liftWidget $ mkLeafWidget \h -> e (map (mkProp h) props)
-
--- | Wrap some widgets with a node that can have eventHandlers attached
-el'
-  :: forall f p v m a
-  .  ShiftMap (Widget v) m
-  => MultiAlternative m
-  => Functor f
-  => (f p -> v -> v)
-  -> f (Props p a)
-  -> Array (m a)
-  -> m a
-el' e props = el e props <<< orr
diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index 6a9e444..c5f5fe0 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -2,10 +2,11 @@ module Concur.Core.Discharge where
 
 import Prelude
 
-import Concur.Core.Event (observe)
+import Concur.Core.Event (Observer(..))
 import Concur.Core.Types (Widget(..), WidgetStep(..), unWidget)
-import Control.Monad.Free (resume, wrap)
+import Control.Monad.Free (resume)
 import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Exception (Error)
@@ -20,29 +21,43 @@ discharge ::
   Monoid v =>
   (Either Error (Widget v a) -> Effect Unit) ->
   Widget v a ->
-  Effect v
+  Effect (Maybe v)
 discharge handler (Widget w) = case resume w of
-  Right _ -> pure mempty
-  Left (WidgetStepEff eff) -> do
+  Right _ -> pure Nothing
+  Left x -> case x of
+    WidgetStepEff eff -> do
       w' <- eff
       discharge handler (Widget w')
-  Left (WidgetStepView ws) -> do
-      _ <- observe ws.cont (\x -> handler $ Right $ Widget x)
-      pure ws.view
+    WidgetStepCont (Observer o) -> do
+      _ <- o \y -> handler (Right (Widget y))
+      pure Nothing
+    WidgetStepHalt -> pure Nothing
+    WidgetStepView v w' ->
+      -- Successive views overwrite previous views
+      (Just <<< fromMaybe v) <$> discharge handler (Widget w')
+    WidgetStepMapView f w' ->
+      map f <$> discharge handler (Widget w')
 
 -- | Discharge only the top level blocking effect of a widget (if any) to get access to the view
--- | Returns the view, and the remaining widget
+-- | Returns the view if any, and the remaining widget, which could be the same widget.
 dischargePartialEffect ::
   forall a v.
   Monoid v =>
   Widget v a ->
-  Effect (Tuple (Widget v a) v)
+  Effect (Tuple (Widget v a) (Maybe v))
 dischargePartialEffect w = case resume (unWidget w) of
-  Right _ -> pure (Tuple w mempty)
-  Left (WidgetStepEff eff) -> do
+  Right _ -> pure (Tuple w Nothing)
+  Left x -> case x of
+    WidgetStepEff eff -> do
       w' <- eff
       dischargePartialEffect (Widget w')
-  Left (WidgetStepView ws) -> pure (Tuple (Widget (wrap (WidgetStepView ws))) ws.view)
+    WidgetStepCont _ -> pure (Tuple w Nothing)
+    WidgetStepHalt -> pure (Tuple w Nothing)
+    WidgetStepView v w' ->
+      -- Successive views overwrite previous views
+      map (Just <<< fromMaybe v) <$> dischargePartialEffect (Widget w')
+    WidgetStepMapView f w' ->
+      map (map f) <$> dischargePartialEffect (Widget w')
 
 {-
 -- | Discharge a widget, forces async resolution of the continuation.
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 18092f5..ed79c6d 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -2,7 +2,7 @@ module Concur.Core.Types where
 
 import Prelude
 
-import Concur.Core.Event (Observer(..), never, parIndex)
+import Concur.Core.Event (Observer(..), parIndex)
 import Control.Alternative (class Alternative)
 import Control.Monad.Free (Free, hoistFree, liftF, resume, wrap)
 import Control.Monad.Rec.Class (class MonadRec)
@@ -15,25 +15,30 @@ import Data.Array.NonEmpty as NEA
 import Data.Either (Either(..))
 import Data.FoldableWithIndex (foldrWithIndex)
 import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
-import Data.Semigroup.Foldable (foldMap1)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
 
-type WidgetStepRecord v a
-  = {view :: v, cont :: Observer a}
-
 data WidgetStep v a
   = WidgetStepEff (Effect a)
-  | WidgetStepView (WidgetStepRecord v a)
+  | WidgetStepCont (Observer a)
+  -- The expectation is that these views will never be sequenced in a row
+  -- However, if they are sequenced in a row, only the last view will take effect
+  -- TODO: Perhaps the views should be concatenated??
+  | WidgetStepView v a
+  -- This modifies all views inside it
+  | WidgetStepMapView (v -> v) a
+  -- TODO: This modifies all views inside it, but can also add handlers
+  -- TODO: | WidgetStepNestedView ((b -> Effect Unit) -> v -> v) a
+  | WidgetStepHalt
 
 -- derive instance widgetStepFunctor :: Functor (WidgetStep v)
 instance functorWidgetStep :: Functor (WidgetStep v) where
   map f (WidgetStepEff e) = WidgetStepEff (map f e)
-  map f (WidgetStepView w) = WidgetStepView (w { cont = map f w.cont })
-
-displayStep :: forall a v. v -> WidgetStep v a
-displayStep v = WidgetStepView { view: v, cont: never }
+  map f (WidgetStepView v a) = WidgetStepView v (f a)
+  map f (WidgetStepMapView g a) = WidgetStepMapView g (f a)
+  map f (WidgetStepCont o) = WidgetStepCont (map f o)
+  map _ WidgetStepHalt = WidgetStepHalt
 
 newtype Widget v a
   = Widget (Free (WidgetStep v) a)
@@ -56,84 +61,88 @@ derive newtype instance widgetMonadRec :: MonadRec (Widget v)
 instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where
   shiftMap f = f identity
 
--- Util
-flipEither ::
-  forall a b.
-  Either a b ->
-  Either b a
-flipEither (Left a) = Right a
-flipEither (Right b) = Left b
-
 instance widgetMultiAlternative ::
   ( Monoid v
   ) =>
   MultiAlternative (Widget v) where
   orr wss = case NEA.fromArray wss of
-    Just wsne -> Widget $ combine $ map unWidget wsne
+    Just wsne -> Widget $ combine wsne
     Nothing -> empty
     where
+
     combine ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (Free (WidgetStep v') a) ->
+      NonEmptyArray (Widget v' a) ->
       Free (WidgetStep v') a
     combine wfs =
       let x = NEA.uncons wfs
-      in case resume x.head of
+      in case resume (unWidget x.head) of
         Right a -> pure a
-        Left (WidgetStepEff eff) -> wrap $ WidgetStepEff do
+        -- TODO: This wrap probably cannot be wished away
+        Left xx -> case xx of
+          WidgetStepEff eff -> wrap $ WidgetStepEff do
             w <- eff
-            pure $ combine $ NEA.cons' w x.tail
-        Left (WidgetStepView wsr) -> combineInner (NEA.singleton wsr) x.tail
+            pure $ combine $ NEA.cons' (Widget w) x.tail
+
+          -- TODO: Instead of using wrap here, maybe collapse views
+          --       This may be important for performance
+          WidgetStepView v w -> wrap $ WidgetStepView v $ combine $ NEA.cons' (Widget w) x.tail
+          WidgetStepMapView f w -> wrap $ WidgetStepMapView f $ combine $ NEA.cons' (Widget w) x.tail
+          WidgetStepCont o -> combineInner (NEA.singleton o) x.tail
+          WidgetStepHalt -> unWidget (orr x.tail)
 
     combineInner ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (WidgetStepRecord v' (Free (WidgetStep v') a)) ->
-      Array (Free (WidgetStep v') a) ->
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      Array (Widget v' a) ->
       Free (WidgetStep v') a
     combineInner ws freeArr = case NEA.fromArray freeArr of
-      -- We have collected all the inner views/conts
-      Nothing -> combineViewsConts ws --wrap $ WidgetStep $ Right wsr
+      -- We have collected all the inner conts
+      Nothing -> combineConts ws --wrap $ WidgetStep $ Right wsr
       Just freeNarr -> combineInner1 ws freeNarr
 
-    combineViewsConts ::
-      forall v' a.
-      Monoid v' =>
-      NonEmptyArray (WidgetStepRecord v' (Free (WidgetStep v') a)) ->
-      Free (WidgetStep v') a
-    combineViewsConts ws = wrap $ WidgetStepView
-      { view: foldMap1 _.view ws
-      , cont: merge ws (map _.cont ws)
-      }
-
     combineInner1 ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (WidgetStepRecord v' (Free (WidgetStep v') a)) ->
-      NonEmptyArray (Free (WidgetStep v') a) ->
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      NonEmptyArray (Widget v' a) ->
       Free (WidgetStep v') a
     combineInner1 ws freeNarr =
       let x = NEA.uncons freeNarr
-      in case resume x.head of
+      in case resume (unWidget x.head) of
         Right a -> pure a
         Left (WidgetStepEff eff) -> wrap $ WidgetStepEff do
             w <- eff
-            pure $ combineInner1 ws $ NEA.cons' w x.tail
-        Left (WidgetStepView wsr) -> combineInner (NEA.snoc ws wsr) x.tail
+            pure $ combineInner1 ws $ NEA.cons' (Widget w) x.tail
+        Left (WidgetStepView v w) -> wrap $ WidgetStepView v $ combineInner1 ws (NEA.cons' (Widget w) x.tail)
+        Left (WidgetStepMapView f w) -> wrap $ WidgetStepMapView f $ combineInner1 ws (NEA.cons' (Widget w) x.tail)
+        Left (WidgetStepCont c) -> combineInner (NEA.snoc ws c) x.tail
+        Left WidgetStepHalt -> combineInner ws x.tail
+
+    combineConts ::
+      forall v' a.
+      Monoid v' =>
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      Free (WidgetStep v') a
+    combineConts ws = wrap $ WidgetStepCont $ merge ws
 
     merge ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (WidgetStepRecord v' (Free (WidgetStep v') a)) ->
       NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
       Observer (Free (WidgetStep v') a)
-    merge ws wscs =
-      let wsm = map (wrap <<< WidgetStepView) ws
+    merge ws = map func obs
+      where
+      wsm = map (Widget <<< wrap <<< WidgetStepCont) ws
+
       -- TODO: We know the array is non-empty. We need something like foldl1WithIndex.
       -- TODO: All the Observer in ws is already discharged. Use a more efficient way than combine to process it
       -- TODO: Also, more importantly, we would like to not have to cancel running fibers unless one of them returns a result
-      in (\ {i, val:e} -> combine (fromMaybe wsm (NEA.updateAt i e wsm))) <$> (parIndex (NEA.toArray wscs))
+      -- MAP OVER OBSERVER. SEE IF WE CAN OPTIMISE THIS (COYONEDA).
+      obs = parIndex (NEA.toArray ws)
+      func {i, val:e} = combine (fromMaybe wsm (NEA.updateAt i (Widget e) wsm))
 
 
 -- | Run multiple widgets in parallel until *all* finish, and collect their outputs
@@ -179,15 +188,21 @@ pulse ::
   Widget v Unit
 pulse = effAction (pure unit)
 
-mapView :: forall a v1 v2. (v1 -> v2) -> Widget v1 a -> Widget v2 a
+mapView :: forall a v. (v -> v) -> Widget v a -> Widget v a
 mapView f (Widget w) = Widget (hoistFree (mapViewStep f) w)
 
-mapViewStep :: forall v1 v2 a. (v1 -> v2) -> WidgetStep v1 a -> WidgetStep v2 a
+mapViewStep :: forall v a. (v -> v) -> WidgetStep v a -> WidgetStep v a
 mapViewStep f (WidgetStepEff e) = WidgetStepEff e
-mapViewStep f (WidgetStepView ws) = WidgetStepView ( ws { view = f ws.view })
+mapViewStep f (WidgetStepCont c) = WidgetStepCont c
+mapViewStep f (WidgetStepView v a) = WidgetStepView (f v) a
+mapViewStep f (WidgetStepMapView g a) = WidgetStepMapView (f <<< g) a
+mapViewStep f WidgetStepHalt = WidgetStepHalt
+
+halt :: forall v a. Widget v a
+halt = Widget $ liftF WidgetStepHalt
 
-display :: forall a v. v -> Widget v a
-display v = Widget (liftF (displayStep v))
+display :: forall v a. v -> Widget v a
+display v = Widget $ wrap $ WidgetStepView v $ unWidget halt
 
 -- Sync eff
 effAction ::
@@ -199,18 +214,16 @@ effAction = Widget <<< liftF <<< WidgetStepEff
 -- Async aff
 affAction ::
   forall a v.
-  v ->
   Observer a ->
   Widget v a
-affAction v cb = Widget $ liftF $ WidgetStepView { view: v, cont: cb }
+affAction = Widget <<< liftF <<< WidgetStepCont
 
 -- Async callback
 asyncAction
   :: forall v a
-   . v
-  -> ((a -> Effect Unit) -> Effect (Effect Unit))
+  .  ((a -> Effect Unit) -> Effect (Effect Unit))
   -> Widget v a
-asyncAction v handler = affAction v (Observer handler)
+asyncAction handler = affAction (Observer handler)
 
 instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
   liftEffect = effAction

From 249d279f7a17f4b71962d805e06b0fbed07624d3 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Wed, 17 Jun 2020 15:43:48 +0530
Subject: [PATCH 04/10] Excellent comment for ShiftMap!

---
 src/Control/ShiftMap.purs | 21 +++++++++++++++++++++
 1 file changed, 21 insertions(+)

diff --git a/src/Control/ShiftMap.purs b/src/Control/ShiftMap.purs
index 3356ce5..4f44449 100644
--- a/src/Control/ShiftMap.purs
+++ b/src/Control/ShiftMap.purs
@@ -10,6 +10,27 @@ import Control.Monad.Writer.Trans (WriterT(..))
 import Data.Either (Either(..))
 import Data.Tuple (Tuple(..))
 
+-- Say you have a function `f` that accepts a value `m a`.
+-- Now you pass it a value `m b` instead. We need to figure
+-- out the various ways in which we can still get the function to
+-- work, by either constraining things, or by passing extra information.
+--
+-- Let's consider functions which combine the passed in value with other
+-- values in some way. For example, if it's a semigroup, then it can
+-- append the `m a` with other `m a`s.
+--
+-- Now that we actually passed in a `m b`, it's not possible to combine it.
+-- But, what if we have a way to convert a `m a` into an `m b`. Then the
+-- function can just convert its internal `m a` into an `m b` and combine them.
+-- For this, it's enough to have an `a -> b` transformation and `map` it
+-- over the `m a`.
+--
+-- This class of functions is captured by the `shiftMap` class.
+--
+-- For Concur, the UIs are monoidal, and shiftMap is used to apply
+-- UI transformations, as long as they only do monoidal operations,
+-- to things other than raw widgets.
+
 -- | Avoiding monad-control for as long as possible
 class ShiftMap s t where
   shiftMap :: forall a. (forall b. (a -> b) -> s b -> s b) -> t a -> t a

From 104871e23ed88b9f35c1e3c53376c0cf524dc6ac Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Wed, 17 Jun 2020 15:44:17 +0530
Subject: [PATCH 05/10] Mucked

---
 src/Concur/Core/Types.purs | 23 +++++++++++++++++++++++
 1 file changed, 23 insertions(+)

diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index ed79c6d..eb2aef7 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -198,6 +198,29 @@ mapViewStep f (WidgetStepView v a) = WidgetStepView (f v) a
 mapViewStep f (WidgetStepMapView g a) = WidgetStepMapView (f <<< g) a
 mapViewStep f WidgetStepHalt = WidgetStepHalt
 
+mapViewHandler :: forall v a. ((a -> Effect Unit) -> v -> v) -> Widget v a -> Widget v a
+mapViewHandler h (Widget w) = case resume w of
+  Right _ -> Widget w
+  Left x -> case x of
+    WidgetStepHalt -> Widget w
+    WidgetStepEff eff -> Widget $ wrap $ WidgetStepEff do
+      w' <- eff
+      pure $ unWidget $ mapViewHandler h (Widget w')
+    WidgetStepView v w' -> mapViewHandlerInnerView v w'
+    WidgetStepCont o -> Widget $ wrap $ WidgetStepCont $ map func o
+
+
+  where
+  func w'' = mapViewHandler h (Widget w'')
+
+  mapViewHandlerInnerView v w' = case resume w' of
+    Right _ -> Widget w'
+    Left y -> case y of
+      WidgetStepHalt -> Widget w'
+      WidgetStepEff eff -> Widget $ wrap $ WidgetStepEff do
+        w'' <- eff
+        pure $ mapViewHandlerInnerView v w''
+
 halt :: forall v a. Widget v a
 halt = Widget $ liftF WidgetStepHalt
 

From ce37e71aa5be4ff381284730c527ab7ed41add40 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Thu, 18 Jun 2020 19:42:34 +0530
Subject: [PATCH 06/10] Unmucked

---
 bower.json                     |  27 -------
 src/Concur/Core/Discharge.purs |  23 ++----
 src/Concur/Core/Types.purs     | 141 +++++++++++++++------------------
 3 files changed, 70 insertions(+), 121 deletions(-)
 delete mode 100644 bower.json

diff --git a/bower.json b/bower.json
deleted file mode 100644
index 193f164..0000000
--- a/bower.json
+++ /dev/null
@@ -1,27 +0,0 @@
-{
-    "name": "purescript-concur-core",
-    "license": [
-        "MIT"
-    ],
-    "repository": {
-        "type": "git",
-        "url": "https://github.com/purescript-concur/purescript-concur-core"
-    },
-    "ignore": [
-        "**/.*",
-        "node_modules",
-        "bower_components",
-        "output"
-    ],
-    "dependencies": {
-        "purescript-aff": "^v5.1.2",
-        "purescript-arrays": "^v5.3.1",
-        "purescript-avar": "^v3.0.0",
-        "purescript-console": "^v4.2.0",
-        "purescript-foldable-traversable": "^v4.1.1",
-        "purescript-free": "^v5.2.0",
-        "purescript-nonempty": "^v5.0.0",
-        "purescript-profunctor-lenses": "^v6.2.0",
-        "purescript-tailrec": "^v4.1.0"
-    }
-}
diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index c5f5fe0..a1eb2e1 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -28,16 +28,11 @@ discharge handler (Widget w) = case resume w of
     WidgetStepEff eff -> do
       w' <- eff
       discharge handler (Widget w')
-    WidgetStepCont (Observer o) -> do
-      _ <- o \y -> handler (Right (Widget y))
-      pure Nothing
-    WidgetStepHalt -> pure Nothing
-    WidgetStepView v w' ->
-      -- Successive views overwrite previous views
-      (Just <<< fromMaybe v) <$> discharge handler (Widget w')
-    WidgetStepMapView f w' ->
-      map f <$> discharge handler (Widget w')
+    WidgetStepStuck -> pure Nothing
+    WidgetStepView f ->
+      pure $ Just $ f \y -> handler (Right (Widget y))
 
+{-
 -- | Discharge only the top level blocking effect of a widget (if any) to get access to the view
 -- | Returns the view if any, and the remaining widget, which could be the same widget.
 dischargePartialEffect ::
@@ -51,13 +46,11 @@ dischargePartialEffect w = case resume (unWidget w) of
     WidgetStepEff eff -> do
       w' <- eff
       dischargePartialEffect (Widget w')
-    WidgetStepCont _ -> pure (Tuple w Nothing)
-    WidgetStepHalt -> pure (Tuple w Nothing)
-    WidgetStepView v w' ->
-      -- Successive views overwrite previous views
+    -- WidgetStepCont _ -> pure (Tuple w Nothing)
+    WidgetStepStuck -> pure (Tuple w Nothing)
+    WidgetStepView f ->
       map (Just <<< fromMaybe v) <$> dischargePartialEffect (Widget w')
-    WidgetStepMapView f w' ->
-      map (map f) <$> dischargePartialEffect (Widget w')
+-}
 
 {-
 -- | Discharge a widget, forces async resolution of the continuation.
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index eb2aef7..0bfd98b 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -2,7 +2,6 @@ module Concur.Core.Types where
 
 import Prelude
 
-import Concur.Core.Event (Observer(..), parIndex)
 import Control.Alternative (class Alternative)
 import Control.Monad.Free (Free, hoistFree, liftF, resume, wrap)
 import Control.Monad.Rec.Class (class MonadRec)
@@ -13,32 +12,29 @@ import Data.Array as A
 import Data.Array.NonEmpty (NonEmptyArray)
 import Data.Array.NonEmpty as NEA
 import Data.Either (Either(..))
-import Data.FoldableWithIndex (foldrWithIndex)
+import Data.FoldableWithIndex (foldMapWithIndex, foldrWithIndex)
 import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
 
+type WithHandler b a = ((a -> Effect Unit)) -> b
+
+mapWithHandler :: forall a b c. (a -> b) -> WithHandler c a -> WithHandler c b
+mapWithHandler f g = \cb -> g (cb <<< f)
+
 data WidgetStep v a
   = WidgetStepEff (Effect a)
-  | WidgetStepCont (Observer a)
-  -- The expectation is that these views will never be sequenced in a row
-  -- However, if they are sequenced in a row, only the last view will take effect
-  -- TODO: Perhaps the views should be concatenated??
-  | WidgetStepView v a
-  -- This modifies all views inside it
-  | WidgetStepMapView (v -> v) a
-  -- TODO: This modifies all views inside it, but can also add handlers
-  -- TODO: | WidgetStepNestedView ((b -> Effect Unit) -> v -> v) a
-  | WidgetStepHalt
+  | WidgetStepView (WithHandler v a)
+  -- TODO
+  -- | WidgetStepViewStuck v
+  | WidgetStepStuck
 
 -- derive instance widgetStepFunctor :: Functor (WidgetStep v)
 instance functorWidgetStep :: Functor (WidgetStep v) where
   map f (WidgetStepEff e) = WidgetStepEff (map f e)
-  map f (WidgetStepView v a) = WidgetStepView v (f a)
-  map f (WidgetStepMapView g a) = WidgetStepMapView g (f a)
-  map f (WidgetStepCont o) = WidgetStepCont (map f o)
-  map _ WidgetStepHalt = WidgetStepHalt
+  map f (WidgetStepView v) = WidgetStepView $ mapWithHandler f v
+  map _ WidgetStepStuck = WidgetStepStuck
 
 newtype Widget v a
   = Widget (Free (WidgetStep v) a)
@@ -87,26 +83,24 @@ instance widgetMultiAlternative ::
 
           -- TODO: Instead of using wrap here, maybe collapse views
           --       This may be important for performance
-          WidgetStepView v w -> wrap $ WidgetStepView v $ combine $ NEA.cons' (Widget w) x.tail
-          WidgetStepMapView f w -> wrap $ WidgetStepMapView f $ combine $ NEA.cons' (Widget w) x.tail
-          WidgetStepCont o -> combineInner (NEA.singleton o) x.tail
-          WidgetStepHalt -> unWidget (orr x.tail)
+          WidgetStepView o -> combineInner (NEA.singleton o) x.tail
+          WidgetStepStuck -> unWidget (orr x.tail)
 
     combineInner ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
       Array (Widget v' a) ->
       Free (WidgetStep v') a
-    combineInner ws freeArr = case NEA.fromArray freeArr of
+    combineInner vs freeArr = case NEA.fromArray freeArr of
       -- We have collected all the inner conts
-      Nothing -> combineConts ws --wrap $ WidgetStep $ Right wsr
-      Just freeNarr -> combineInner1 ws freeNarr
+      Nothing -> combineConts vs --wrap $ WidgetStep $ Right wsr
+      Just freeNarr -> combineInner1 vs freeNarr
 
     combineInner1 ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
       NonEmptyArray (Widget v' a) ->
       Free (WidgetStep v') a
     combineInner1 ws freeNarr =
@@ -116,34 +110,34 @@ instance widgetMultiAlternative ::
         Left (WidgetStepEff eff) -> wrap $ WidgetStepEff do
             w <- eff
             pure $ combineInner1 ws $ NEA.cons' (Widget w) x.tail
-        Left (WidgetStepView v w) -> wrap $ WidgetStepView v $ combineInner1 ws (NEA.cons' (Widget w) x.tail)
-        Left (WidgetStepMapView f w) -> wrap $ WidgetStepMapView f $ combineInner1 ws (NEA.cons' (Widget w) x.tail)
-        Left (WidgetStepCont c) -> combineInner (NEA.snoc ws c) x.tail
-        Left WidgetStepHalt -> combineInner ws x.tail
+        Left (WidgetStepView c) -> combineInner (NEA.snoc ws c) x.tail
+        Left WidgetStepStuck -> combineInner ws x.tail
 
     combineConts ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
       Free (WidgetStep v') a
-    combineConts ws = wrap $ WidgetStepCont $ merge ws
+    combineConts ws = wrap $ WidgetStepView $ merge ws
 
     merge ::
       forall v' a.
       Monoid v' =>
-      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
-      Observer (Free (WidgetStep v') a)
-    merge ws = map func obs
-      where
-      wsm = map (Widget <<< wrap <<< WidgetStepCont) ws
+      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
+      WithHandler v' (Free (WidgetStep v') a)
+    merge ws = mapWithHandler (\nea -> combine (map Widget nea)) $ mergeWithHandlers (wrap <<< WidgetStepView) ws
 
-      -- TODO: We know the array is non-empty. We need something like foldl1WithIndex.
-      -- TODO: All the Observer in ws is already discharged. Use a more efficient way than combine to process it
-      -- TODO: Also, more importantly, we would like to not have to cancel running fibers unless one of them returns a result
-      -- MAP OVER OBSERVER. SEE IF WE CAN OPTIMISE THIS (COYONEDA).
-      obs = parIndex (NEA.toArray ws)
-      func {i, val:e} = combine (fromMaybe wsm (NEA.updateAt i (Widget e) wsm))
 
+mergeWithHandlers
+  :: forall v a
+   . Monoid v
+  => (WithHandler v a -> a)
+  -> NonEmptyArray (WithHandler v a)
+  -> WithHandler v (NEA.NonEmptyArray a)
+mergeWithHandlers mkh vs = \cb ->
+  let mkCb i = \val -> cb (fromMaybe vs' (NEA.updateAt i val vs'))
+  in foldMapWithIndex (\i f -> f (mkCb i)) vs
+  where vs' = map mkh vs
 
 -- | Run multiple widgets in parallel until *all* finish, and collect their outputs
 -- | Contrast with `orr`
@@ -193,39 +187,15 @@ mapView f (Widget w) = Widget (hoistFree (mapViewStep f) w)
 
 mapViewStep :: forall v a. (v -> v) -> WidgetStep v a -> WidgetStep v a
 mapViewStep f (WidgetStepEff e) = WidgetStepEff e
-mapViewStep f (WidgetStepCont c) = WidgetStepCont c
-mapViewStep f (WidgetStepView v a) = WidgetStepView (f v) a
-mapViewStep f (WidgetStepMapView g a) = WidgetStepMapView (f <<< g) a
-mapViewStep f WidgetStepHalt = WidgetStepHalt
-
-mapViewHandler :: forall v a. ((a -> Effect Unit) -> v -> v) -> Widget v a -> Widget v a
-mapViewHandler h (Widget w) = case resume w of
-  Right _ -> Widget w
-  Left x -> case x of
-    WidgetStepHalt -> Widget w
-    WidgetStepEff eff -> Widget $ wrap $ WidgetStepEff do
-      w' <- eff
-      pure $ unWidget $ mapViewHandler h (Widget w')
-    WidgetStepView v w' -> mapViewHandlerInnerView v w'
-    WidgetStepCont o -> Widget $ wrap $ WidgetStepCont $ map func o
-
+mapViewStep f (WidgetStepView v) = WidgetStepView (map f v)
+mapViewStep f WidgetStepStuck = WidgetStepStuck
 
-  where
-  func w'' = mapViewHandler h (Widget w'')
-
-  mapViewHandlerInnerView v w' = case resume w' of
-    Right _ -> Widget w'
-    Left y -> case y of
-      WidgetStepHalt -> Widget w'
-      WidgetStepEff eff -> Widget $ wrap $ WidgetStepEff do
-        w'' <- eff
-        pure $ mapViewHandlerInnerView v w''
-
-halt :: forall v a. Widget v a
-halt = Widget $ liftF WidgetStepHalt
+stuck :: forall v a. Widget v a
+stuck = Widget $ liftF WidgetStepStuck
 
 display :: forall v a. v -> Widget v a
-display v = Widget $ wrap $ WidgetStepView v $ unWidget halt
+-- TODO: Instead of carrying around a callback which will never be called, use a special constructor WidgetStepViewStuck
+display v = Widget $ wrap $ WidgetStepView \cb -> v
 
 -- Sync eff
 effAction ::
@@ -237,16 +207,16 @@ effAction = Widget <<< liftF <<< WidgetStepEff
 -- Async aff
 affAction ::
   forall a v.
-  Observer a ->
+  WithHandler v a ->
   Widget v a
-affAction = Widget <<< liftF <<< WidgetStepCont
+affAction = Widget <<< liftF <<< WidgetStepView
 
 -- Async callback
-asyncAction
-  :: forall v a
-  .  ((a -> Effect Unit) -> Effect (Effect Unit))
-  -> Widget v a
-asyncAction handler = affAction (Observer handler)
+-- asyncAction
+--   :: forall v a
+--   .  ((a -> Effect Unit) -> Effect (Effect Unit))
+--   -> Widget v a
+-- asyncAction handler = affAction (Observer handler)
 
 instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
   liftEffect = effAction
@@ -254,3 +224,16 @@ instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
 -- instance widgetMonadObserver :: (Monoid v) => MonadObserver (Widget v) where
 --   liftObserver = affAction mempty
     -- Widget $ liftF $ WidgetStep $ Right { view: mempty, cont: aff }
+
+mkNodeWidget :: forall v a. ((Free (WidgetStep v) a -> Effect Unit) -> v -> v) -> Widget v a -> Widget v a
+mkNodeWidget f (Widget w) = case resume w of
+  Right _ -> Widget w
+  Left x -> case x of
+    WidgetStepStuck -> Widget w
+    WidgetStepEff eff -> Widget $ wrap $ WidgetStepEff do
+      w' <- eff
+      pure $ unWidget $ mkNodeWidget f $ Widget w'
+    WidgetStepView g -> Widget $ wrap $ WidgetStepView \cb -> f cb (g cb)
+
+mkLeafWidget :: forall v a. ((Free (WidgetStep v) a -> Effect Unit) -> v) -> Widget v a
+mkLeafWidget = Widget <<< wrap <<< WidgetStepView

From 749895a52fec9498d96fcaa4f3b0f0de97ea343d Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Thu, 18 Jun 2020 21:49:57 +0530
Subject: [PATCH 07/10] Prevent one too much recursion error. There is still a
 call to itself here

---
 src/Concur/Core/Types.purs | 27 ++++++++-------------------
 1 file changed, 8 insertions(+), 19 deletions(-)

diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 0bfd98b..173f3e7 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -81,8 +81,6 @@ instance widgetMultiAlternative ::
             w <- eff
             pure $ combine $ NEA.cons' (Widget w) x.tail
 
-          -- TODO: Instead of using wrap here, maybe collapse views
-          --       This may be important for performance
           WidgetStepView o -> combineInner (NEA.singleton o) x.tail
           WidgetStepStuck -> unWidget (orr x.tail)
 
@@ -92,26 +90,17 @@ instance widgetMultiAlternative ::
       NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
       Array (Widget v' a) ->
       Free (WidgetStep v') a
-    combineInner vs freeArr = case NEA.fromArray freeArr of
+    combineInner vs freeArr = case A.uncons freeArr of
       -- We have collected all the inner conts
-      Nothing -> combineConts vs --wrap $ WidgetStep $ Right wsr
-      Just freeNarr -> combineInner1 vs freeNarr
-
-    combineInner1 ::
-      forall v' a.
-      Monoid v' =>
-      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
-      NonEmptyArray (Widget v' a) ->
-      Free (WidgetStep v') a
-    combineInner1 ws freeNarr =
-      let x = NEA.uncons freeNarr
-      in case resume (unWidget x.head) of
+      Nothing -> combineConts vs
+      Just x -> case resume (unWidget x.head) of
         Right a -> pure a
-        Left (WidgetStepEff eff) -> wrap $ WidgetStepEff do
+        Left xx -> case xx of
+          WidgetStepEff eff -> wrap $ WidgetStepEff do
             w <- eff
-            pure $ combineInner1 ws $ NEA.cons' (Widget w) x.tail
-        Left (WidgetStepView c) -> combineInner (NEA.snoc ws c) x.tail
-        Left WidgetStepStuck -> combineInner ws x.tail
+            pure $ combineInner vs $ A.cons (Widget w) x.tail
+          WidgetStepView c -> combineInner (NEA.snoc vs c) x.tail
+          WidgetStepStuck -> combineInner vs x.tail
 
     combineConts ::
       forall v' a.

From 79ce615a2af65136f3eff1e2a5abbe46b8485892 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Thu, 18 Jun 2020 22:09:01 +0530
Subject: [PATCH 08/10] Add monadic view resolution

---
 src/Concur/Core/Discharge.purs |  8 +++-----
 src/Concur/Core/Types.purs     | 12 +++++++-----
 2 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index a1eb2e1..c354b77 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -2,12 +2,10 @@ module Concur.Core.Discharge where
 
 import Prelude
 
-import Concur.Core.Event (Observer(..))
-import Concur.Core.Types (Widget(..), WidgetStep(..), unWidget)
+import Concur.Core.Types (Widget(..), WidgetStep(..))
 import Control.Monad.Free (resume)
 import Data.Either (Either(..))
-import Data.Maybe (Maybe(..), fromMaybe)
-import Data.Tuple (Tuple(..))
+import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Exception (Error)
 
@@ -30,7 +28,7 @@ discharge handler (Widget w) = case resume w of
       discharge handler (Widget w')
     WidgetStepStuck -> pure Nothing
     WidgetStepView f ->
-      pure $ Just $ f \y -> handler (Right (Widget y))
+      Just <$> f \y -> handler (Right (Widget y))
 
 {-
 -- | Discharge only the top level blocking effect of a widget (if any) to get access to the view
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 173f3e7..1f82e84 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -18,7 +18,7 @@ import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
 
-type WithHandler b a = ((a -> Effect Unit)) -> b
+type WithHandler b a = ((a -> Effect Unit)) -> Effect b
 
 mapWithHandler :: forall a b c. (a -> b) -> WithHandler c a -> WithHandler c b
 mapWithHandler f g = \cb -> g (cb <<< f)
@@ -176,7 +176,7 @@ mapView f (Widget w) = Widget (hoistFree (mapViewStep f) w)
 
 mapViewStep :: forall v a. (v -> v) -> WidgetStep v a -> WidgetStep v a
 mapViewStep f (WidgetStepEff e) = WidgetStepEff e
-mapViewStep f (WidgetStepView v) = WidgetStepView (map f v)
+mapViewStep f (WidgetStepView v) = WidgetStepView (map f <$> v)
 mapViewStep f WidgetStepStuck = WidgetStepStuck
 
 stuck :: forall v a. Widget v a
@@ -184,7 +184,7 @@ stuck = Widget $ liftF WidgetStepStuck
 
 display :: forall v a. v -> Widget v a
 -- TODO: Instead of carrying around a callback which will never be called, use a special constructor WidgetStepViewStuck
-display v = Widget $ wrap $ WidgetStepView \cb -> v
+display v = Widget $ wrap $ WidgetStepView \cb -> pure v
 
 -- Sync eff
 effAction ::
@@ -222,7 +222,9 @@ mkNodeWidget f (Widget w) = case resume w of
     WidgetStepEff eff -> Widget $ wrap $ WidgetStepEff do
       w' <- eff
       pure $ unWidget $ mkNodeWidget f $ Widget w'
-    WidgetStepView g -> Widget $ wrap $ WidgetStepView \cb -> f cb (g cb)
+    WidgetStepView g -> Widget $ wrap $ WidgetStepView \cb -> f cb <$> g cb
 
 mkLeafWidget :: forall v a. ((Free (WidgetStep v) a -> Effect Unit) -> v) -> Widget v a
-mkLeafWidget = Widget <<< wrap <<< WidgetStepView
+mkLeafWidget = Widget <<< wrap <<< WidgetStepView <<< adapter
+  where
+  adapter h cb = pure (h cb)

From 4019eb32baaf362118e2eb8e12f56e7ec5b3dc86 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Fri, 19 Jun 2020 00:34:15 +0530
Subject: [PATCH 09/10] Make functions top level

---
 src/Concur/Core/Types.purs | 117 ++++++++++++++++++++-----------------
 1 file changed, 65 insertions(+), 52 deletions(-)

diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 1f82e84..630ce83 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -3,7 +3,7 @@ module Concur.Core.Types where
 import Prelude
 
 import Control.Alternative (class Alternative)
-import Control.Monad.Free (Free, hoistFree, liftF, resume, wrap)
+import Control.Monad.Free (Free, hoistFree, liftF, resume, resume', wrap)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.MultiAlternative (class MultiAlternative, orr)
 import Control.Plus (class Alt, class Plus, alt, empty)
@@ -14,6 +14,7 @@ import Data.Array.NonEmpty as NEA
 import Data.Either (Either(..))
 import Data.FoldableWithIndex (foldMapWithIndex, foldrWithIndex)
 import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
+import Data.Traversable (traverse)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
@@ -64,57 +65,69 @@ instance widgetMultiAlternative ::
   orr wss = case NEA.fromArray wss of
     Just wsne -> Widget $ combine wsne
     Nothing -> empty
-    where
-
-    combine ::
-      forall v' a.
-      Monoid v' =>
-      NonEmptyArray (Widget v' a) ->
-      Free (WidgetStep v') a
-    combine wfs =
-      let x = NEA.uncons wfs
-      in case resume (unWidget x.head) of
-        Right a -> pure a
-        -- TODO: This wrap probably cannot be wished away
-        Left xx -> case xx of
-          WidgetStepEff eff -> wrap $ WidgetStepEff do
-            w <- eff
-            pure $ combine $ NEA.cons' (Widget w) x.tail
-
-          WidgetStepView o -> combineInner (NEA.singleton o) x.tail
-          WidgetStepStuck -> unWidget (orr x.tail)
-
-    combineInner ::
-      forall v' a.
-      Monoid v' =>
-      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
-      Array (Widget v' a) ->
-      Free (WidgetStep v') a
-    combineInner vs freeArr = case A.uncons freeArr of
-      -- We have collected all the inner conts
-      Nothing -> combineConts vs
-      Just x -> case resume (unWidget x.head) of
-        Right a -> pure a
-        Left xx -> case xx of
-          WidgetStepEff eff -> wrap $ WidgetStepEff do
-            w <- eff
-            pure $ combineInner vs $ A.cons (Widget w) x.tail
-          WidgetStepView c -> combineInner (NEA.snoc vs c) x.tail
-          WidgetStepStuck -> combineInner vs x.tail
-
-    combineConts ::
-      forall v' a.
-      Monoid v' =>
-      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
-      Free (WidgetStep v') a
-    combineConts ws = wrap $ WidgetStepView $ merge ws
-
-    merge ::
-      forall v' a.
-      Monoid v' =>
-      NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
-      WithHandler v' (Free (WidgetStep v') a)
-    merge ws = mapWithHandler (\nea -> combine (map Widget nea)) $ mergeWithHandlers (wrap <<< WidgetStepView) ws
+
+combine ::
+  forall v' a.
+  Monoid v' =>
+  NonEmptyArray (Widget v' a) ->
+  Free (WidgetStep v') a
+combine wfs =
+  let x = NEA.uncons wfs
+  in case resume (unWidget x.head) of
+    Right a -> pure a
+    -- TODO: This wrap probably cannot be wished away
+    Left xx -> case xx of
+      WidgetStepEff eff -> wrap $ WidgetStepEff do
+        w <- eff
+        pure $ combine $ NEA.cons' (Widget w) x.tail
+
+      WidgetStepView o -> combineInner (NEA.singleton o) x.tail
+      WidgetStepStuck -> unWidget (orr x.tail)
+
+combineInner ::
+  forall v' a.
+  Monoid v' =>
+  NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
+  Array (Widget v' a) ->
+  Free (WidgetStep v') a
+combineInner vs freeArr = case A.uncons freeArr of
+  -- case traverse (map pure <<< myResume) freeArr of
+  --   Left a -> pure a
+  --   Right xx -> do
+  --     ls <- traverse extractView xx
+  -- We have collected all the inner conts
+  Nothing -> combineConts vs
+  Just x -> case resume (unWidget x.head) of
+    Right a -> pure a
+    Left xx -> case xx of
+      WidgetStepEff eff -> wrap $ WidgetStepEff do
+        w <- eff
+        pure $ combineInner vs $ A.cons (Widget w) x.tail
+      WidgetStepView c -> combineInner (NEA.snoc vs c) x.tail
+      WidgetStepStuck -> combineInner vs x.tail
+
+
+-- myResume = resume' (\g i -> Right (i <$> g)) Left
+--
+-- extractView (WidgetStepEff eff) = do
+--   w' <- eff
+--   extractView w'
+-- extractView (WidgetStepView c) = pure [c]
+-- extractView WidgetStepStuck = pure []
+
+combineConts ::
+  forall v' a.
+  Monoid v' =>
+  NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
+  Free (WidgetStep v') a
+combineConts ws = wrap $ WidgetStepView $ merge ws
+
+merge ::
+  forall v' a.
+  Monoid v' =>
+  NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
+  WithHandler v' (Free (WidgetStep v') a)
+merge ws = mapWithHandler (\nea -> combine (map Widget nea)) $ mergeWithHandlers (wrap <<< WidgetStepView) ws
 
 
 mergeWithHandlers

From 8bd8108e4e28aa00fa8c2e6a991c952f942ed7e8 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Fri, 19 Jun 2020 11:34:07 +0530
Subject: [PATCH 10/10] Extract `combineInnerGo` to allow `combineInner` to get
 Tail Call Optimisation

---
 src/Concur/Core/Types.purs | 38 ++++++++++++++++++--------------------
 1 file changed, 18 insertions(+), 20 deletions(-)

diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 630ce83..0c61944 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -90,30 +90,28 @@ combineInner ::
   NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
   Array (Widget v' a) ->
   Free (WidgetStep v') a
-combineInner vs freeArr = case A.uncons freeArr of
-  -- case traverse (map pure <<< myResume) freeArr of
-  --   Left a -> pure a
-  --   Right xx -> do
-  --     ls <- traverse extractView xx
-  -- We have collected all the inner conts
-  Nothing -> combineConts vs
+combineInner vs freeArr =
+  case combineInnerGo vs freeArr of
+    Left w -> w
+    Right (Tuple v f) -> combineInner v f
+
+-- Extracted `combineInnerGo` to allow `combineInner` to get Tail Call Optimisation
+combineInnerGo ::
+  forall v' a.
+  Monoid v' =>
+  NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
+  Array (Widget v' a) ->
+  Either (Free (WidgetStep v') a) (Tuple (NonEmptyArray (WithHandler v' (Free (WidgetStep v') a))) (Array (Widget v' a)))
+combineInnerGo vs freeArr = case A.uncons freeArr of
+  Nothing -> Left $ combineConts vs
   Just x -> case resume (unWidget x.head) of
-    Right a -> pure a
+    Right a -> Left $ pure a
     Left xx -> case xx of
-      WidgetStepEff eff -> wrap $ WidgetStepEff do
+      WidgetStepEff eff -> Left $ wrap $ WidgetStepEff do
         w <- eff
         pure $ combineInner vs $ A.cons (Widget w) x.tail
-      WidgetStepView c -> combineInner (NEA.snoc vs c) x.tail
-      WidgetStepStuck -> combineInner vs x.tail
-
-
--- myResume = resume' (\g i -> Right (i <$> g)) Left
---
--- extractView (WidgetStepEff eff) = do
---   w' <- eff
---   extractView w'
--- extractView (WidgetStepView c) = pure [c]
--- extractView WidgetStepStuck = pure []
+      WidgetStepView c -> Right $ Tuple (NEA.snoc vs c) x.tail
+      WidgetStepStuck -> Right $ Tuple vs x.tail
 
 combineConts ::
   forall v' a.