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/15] 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/15] 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/15] 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/15] 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/15] 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/15] 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/15] 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/15] 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/15] 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/15] 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.

From 553519556c9ec93386bc9aa06a76280f2cc1b905 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Fri, 19 Jun 2020 17:53:50 +0530
Subject: [PATCH 11/15] Trying eff

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

diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index c354b77..8fcee5d 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -23,12 +23,8 @@ discharge ::
 discharge handler (Widget w) = case resume w of
   Right _ -> pure Nothing
   Left x -> case x of
-    WidgetStepEff eff -> do
-      w' <- eff
-      discharge handler (Widget w')
-    WidgetStepStuck -> pure Nothing
     WidgetStepView f ->
-      Just <$> f \y -> handler (Right (Widget y))
+      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 0c61944..ab88533 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, resume', wrap)
+import Control.Monad.Free (Free, hoistFree, liftF, 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,28 +14,20 @@ 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)
 
-type WithHandler b a = ((a -> Effect Unit)) -> Effect b
+type WithHandler b a = ((a -> Effect Unit)) -> Effect (Maybe 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)
-  | WidgetStepView (WithHandler v a)
-  -- TODO
-  -- | WidgetStepViewStuck v
-  | WidgetStepStuck
+newtype WidgetStep v a = WidgetStepView (WithHandler v a)
 
 -- derive instance widgetStepFunctor :: Functor (WidgetStep v)
 instance functorWidgetStep :: Functor (WidgetStep v) where
-  map f (WidgetStepEff e) = WidgetStepEff (map f e)
   map f (WidgetStepView v) = WidgetStepView $ mapWithHandler f v
-  map _ WidgetStepStuck = WidgetStepStuck
 
 newtype Widget v a
   = Widget (Free (WidgetStep v) a)
@@ -77,12 +69,7 @@ combine wfs =
     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.
@@ -107,11 +94,7 @@ combineInnerGo vs freeArr = case A.uncons freeArr of
   Just x -> case resume (unWidget x.head) of
     Right a -> Left $ pure a
     Left xx -> case xx of
-      WidgetStepEff eff -> Left $ wrap $ WidgetStepEff do
-        w <- eff
-        pure $ combineInner vs $ A.cons (Widget w) x.tail
       WidgetStepView c -> Right $ Tuple (NEA.snoc vs c) x.tail
-      WidgetStepStuck -> Right $ Tuple vs x.tail
 
 combineConts ::
   forall v' a.
@@ -186,23 +169,21 @@ mapView :: forall a v. (v -> v) -> Widget v a -> Widget v a
 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 WidgetStepStuck = WidgetStepStuck
-
-stuck :: forall v a. Widget v a
-stuck = Widget $ liftF WidgetStepStuck
+mapViewStep f (WidgetStepView v) = WidgetStepView (map (map f) <$> v)
 
 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 -> pure v
+display v = Widget $ wrap $ WidgetStepView \cb -> pure (Just v)
 
 -- Sync eff
 effAction ::
   forall a v.
   Effect a ->
   Widget v a
-effAction = Widget <<< liftF <<< WidgetStepEff
+effAction eff = Widget $ liftF $ WidgetStepView \cb -> do
+  a <- eff
+  cb a
+  pure Nothing
 
 -- Async aff
 affAction ::
@@ -229,13 +210,9 @@ mkNodeWidget :: forall v a. ((Free (WidgetStep v) a -> Effect Unit) -> v -> v) -
 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
+    WidgetStepView g -> Widget $ wrap $ WidgetStepView \cb -> map (f cb) <$> g cb
 
 mkLeafWidget :: forall v a. ((Free (WidgetStep v) a -> Effect Unit) -> v) -> Widget v a
 mkLeafWidget = Widget <<< wrap <<< WidgetStepView <<< adapter
   where
-  adapter h cb = pure (h cb)
+  adapter h cb = pure $ Just $ h cb

From b3444460b9d3961bd28dc2a16006859b25a19fda Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Fri, 19 Jun 2020 23:14:44 +0530
Subject: [PATCH 12/15] Trying something else

---
 src/Concur/Core/Types.purs | 89 ++++++++++++++------------------------
 1 file changed, 33 insertions(+), 56 deletions(-)

diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index ab88533..d544be1 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -3,20 +3,20 @@ 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)
 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.Either (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)
+import Unsafe.Coerce (unsafeCoerce)
 
 type WithHandler b a = ((a -> Effect Unit)) -> Effect (Maybe b)
 
@@ -25,6 +25,15 @@ mapWithHandler f g = \cb -> g (cb <<< f)
 
 newtype WidgetStep v a = WidgetStepView (WithHandler v a)
 
+unWidgetStep :: forall v a. WidgetStep v a -> WithHandler v a
+unWidgetStep (WidgetStepView f) = f
+
+unWidgetStepArray :: forall v a. Array (WidgetStep v a) -> Array (WithHandler v a)
+unWidgetStepArray arr = unsafeCoerce arr
+
+mkWidgetStepArray :: forall v a. Array (WithHandler v a) -> Array (WidgetStep v a)
+mkWidgetStepArray arr = unsafeCoerce arr
+
 -- derive instance widgetStepFunctor :: Functor (WidgetStep v)
 instance functorWidgetStep :: Functor (WidgetStep v) where
   map f (WidgetStepView v) = WidgetStepView $ mapWithHandler f v
@@ -35,6 +44,12 @@ newtype Widget v a
 unWidget :: forall v a. Widget v a -> Free (WidgetStep v) a
 unWidget (Widget w) = w
 
+unWidgetArray :: forall v a. Array (Widget v a) -> Array (Free (WidgetStep v) a)
+unWidgetArray arr = unsafeCoerce arr
+
+mkWidgetArray :: forall v a. Array (Free (WidgetStep v) a) -> Array (Widget v a)
+mkWidgetArray arr = unsafeCoerce arr
+
 derive newtype instance widgetFunctor :: Functor (Widget v)
 
 derive newtype instance widgetBind :: Bind (Widget v)
@@ -54,71 +69,33 @@ instance widgetMultiAlternative ::
   ( Monoid v
   ) =>
   MultiAlternative (Widget v) where
-  orr wss = case NEA.fromArray wss of
-    Just wsne -> Widget $ combine wsne
-    Nothing -> empty
+  orr wss = Widget $ combine $ unWidgetArray wss
 
 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
-      WidgetStepView o -> combineInner (NEA.singleton o) 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 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 -> Left $ pure a
-    Left xx -> case xx of
-      WidgetStepView c -> Right $ Tuple (NEA.snoc vs c) 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
+  forall v a.
+  Monoid v =>
+  Array (Free (WidgetStep v) a) ->
+  Free (WidgetStep v) a
+combine wfs = either pure (wrap <<< WidgetStepView <<< merge <<< unWidgetStepArray) (traverse myResume wfs)
+
+myResume :: forall f a . Functor f => Free f a -> Either a (f (Free f a))
+myResume = resume' (\g i -> Right (i <$> g)) Left
 
 merge ::
   forall v' a.
   Monoid v' =>
-  NonEmptyArray (WithHandler v' (Free (WidgetStep v') a)) ->
+  Array (WithHandler v' (Free (WidgetStep v') a)) ->
   WithHandler v' (Free (WidgetStep v') a)
-merge ws = mapWithHandler (\nea -> combine (map Widget nea)) $ mergeWithHandlers (wrap <<< WidgetStepView) ws
-
+merge ws = mapWithHandler combine $ mergeWithHandlers (wrap <<< WidgetStepView) ws
 
 mergeWithHandlers
   :: forall v a
    . Monoid v
   => (WithHandler v a -> a)
-  -> NonEmptyArray (WithHandler v a)
-  -> WithHandler v (NEA.NonEmptyArray a)
+  -> Array (WithHandler v a)
+  -> WithHandler v (Array a)
 mergeWithHandlers mkh vs = \cb ->
-  let mkCb i = \val -> cb (fromMaybe vs' (NEA.updateAt i val vs'))
+  let mkCb i = \val -> cb (fromMaybe vs' (A.updateAt i val vs'))
   in foldMapWithIndex (\i f -> f (mkCb i)) vs
   where vs' = map mkh vs
 

From 2124466aae08736cf967c84b52cc6355886f0c2c Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Sat, 20 Jun 2020 02:58:18 +0530
Subject: [PATCH 13/15] No mo free

---
 spago.dhall                    |   1 -
 src/Concur/Core.purs           |   8 +-
 src/Concur/Core/Discharge.purs |  36 ++---
 src/Concur/Core/FRP.purs       | 194 -------------------------
 src/Concur/Core/Gen.purs       | 169 ---------------------
 src/Concur/Core/Types.purs     | 213 +++++++++++++--------------
 src/Control/Cofree.purs        | 258 ---------------------------------
 7 files changed, 118 insertions(+), 761 deletions(-)
 delete mode 100644 src/Concur/Core/FRP.purs
 delete mode 100644 src/Concur/Core/Gen.purs
 delete mode 100644 src/Control/Cofree.purs

diff --git a/spago.dhall b/spago.dhall
index 01ba2c5..6d8daff 100644
--- a/spago.dhall
+++ b/spago.dhall
@@ -8,7 +8,6 @@ You can edit this file as you like.
     [ "arrays"
     , "console"
     , "foldable-traversable"
-    , "free"
     , "nonempty"
     , "profunctor-lenses"
     , "tailrec"
diff --git a/src/Concur/Core.purs b/src/Concur/Core.purs
index 98917e1..061bee2 100644
--- a/src/Concur/Core.purs
+++ b/src/Concur/Core.purs
@@ -6,15 +6,9 @@ module Concur.Core
 )
 where
 
-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)
-import Control.Category ((<<<))
-import Control.Monad.Free (Free, resume, wrap)
-import Data.Either (Either(..))
-import Effect (Effect)
-import Prelude (Unit, bind, pure, ($))
+import Concur.Core.Types (Widget(..), unWidget)
 
 -- Helpers for some very common use of unsafe blocking io
 
diff --git a/src/Concur/Core/Discharge.purs b/src/Concur/Core/Discharge.purs
index 8fcee5d..2633ef4 100644
--- a/src/Concur/Core/Discharge.purs
+++ b/src/Concur/Core/Discharge.purs
@@ -2,29 +2,29 @@ module Concur.Core.Discharge where
 
 import Prelude
 
-import Concur.Core.Types (Widget(..), WidgetStep(..))
-import Control.Monad.Free (resume)
+-- import Concur.Core.Types (Widget(..), WidgetStep(..))
+-- import Control.Monad.Free (resume)
 import Data.Either (Either(..))
 import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Exception (Error)
 
--- Widget discharge strategies
--- | Discharge a widget.
--- | 1. Runs the Effect action
--- | 2. Forks the Aff action
--- | 3. Extracts and returns the view
-discharge ::
-  forall a v.
-  Monoid v =>
-  (Either Error (Widget v a) -> Effect Unit) ->
-  Widget v a ->
-  Effect (Maybe v)
-discharge handler (Widget w) = case resume w of
-  Right _ -> pure Nothing
-  Left x -> case x of
-    WidgetStepView f ->
-      f \y -> handler (Right (Widget y))
+-- -- Widget discharge strategies
+-- -- | Discharge a widget.
+-- -- | 1. Runs the Effect action
+-- -- | 2. Forks the Aff action
+-- -- | 3. Extracts and returns the view
+-- discharge ::
+--   forall a v.
+--   Monoid v =>
+--   (Either Error (Widget v a) -> Effect Unit) ->
+--   Widget v a ->
+--   Effect (Maybe v)
+-- discharge handler (Widget w) = case resume w of
+--   Right _ -> pure Nothing
+--   Left x -> case x of
+--     WidgetStepView f ->
+--       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/FRP.purs b/src/Concur/Core/FRP.purs
deleted file mode 100644
index 9887cfc..0000000
--- a/src/Concur/Core/FRP.purs
+++ /dev/null
@@ -1,194 +0,0 @@
-module Concur.Core.FRP where
-
-import Prelude
-
-import Concur.Core.Types (Widget)
-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 Effect (Effect)
-import Effect.Class (class MonadEffect, liftEffect)
-
-----------
--- SIGNALS
-----------
--- | Poor man's FRP implementation for Concur.
--- | I am experimenting with the smallest possible amount of FRP which can still be useful.
--- | A Widget can be considered to be a one-shot Event. (There is no stream of events in Concur).
--- | Signals then are never-ending widget loops that allow access to their last return value.
--- | This last produced value allows composition with other widgets even for never-ending widgets.
-type SignalT m a = Cofree m a
-
--- | A Signal specific to Widgets
-type Signal v a = SignalT (Widget v) a
-
--- | Construct a signal from an initial value, and a step widget
-step ::
-  forall m a.
-  a ->
-  m (SignalT m a) ->
-  SignalT m a
-step = mkCofree
-
--- | Display a widget which returns a continuation
-display :: forall m. m (SignalT m Unit) -> SignalT m Unit
-display w = step unit w
-
--- | Fires a widget once then stop. This will reflow when a parent signal reflows
--- | Starts as Nothing. Then switches to `Just returnVal` after the Widget is done
-fireOnce :: forall m a. Monad m => Plus m => m a -> SignalT m (Maybe a)
-fireOnce w = step Nothing do
-  a <- w
-  pure (step (Just a) empty)
-
--- | Similar to `fireOnce`, but discards the return value
-fireOnce_ :: forall m. Monad m => Plus m => m Unit -> SignalT m Unit
-fireOnce_ w = display do w *> empty
-
--- | Wait until we get a `Just` value from a signal
-justWait :: forall m a b.
-            Monad m =>
-            Alternative m =>
-            b -> SignalT m (Maybe a) -> (a -> SignalT m b) -> SignalT m b
-justWait b s f = do
-  m <- s
-  case m of
-    Nothing -> pure b
-    Just a -> f a
-
--- | Run an effectful computation, and do something with the result
-justEffect :: forall m a b. MonadEffect m => Monad m => Alternative m => b -> Effect a -> (a -> SignalT m b) -> SignalT m b
-justEffect b e f = justWait b (fireOnce do liftEffect e) f
-
--- | A constant signal
-always ::
-  forall m a.
-  Monad m =>
-  Alternative m =>
-  a ->
-  SignalT m a
-always = pure
-
--- | Update signal to a new value
-update ::
-  forall m a.
-  SignalT m a ->
-  m (SignalT m a)
-update = tail
-
--- | Construct a signal by polling a signal with a nested widget for values
-poll ::
-  forall m a.
-  Monad m =>
-  SignalT m (m a) ->
-  m (SignalT m a)
-poll b = step <$> extract b <*> (map poll (update b))
-
--- | Create a signal which repeatedly invokes a widget for values.
--- | E.g. `signal False checkbox` will return a signal which reflects the current value of the checkbox.
-hold ::
-  forall m a.
-  Monad m =>
-  a ->
-  m a ->
-  SignalT m a
-hold a w = step a do
-  a' <- w
-  pure (hold a' w)
-
--- | Create a signal which repeatedly invokes a widget function for values, looping in the prev value.
-loopW ::
-  forall m a.
-  Monad m =>
-  a ->
-  (a -> m a) ->
-  SignalT m a
-loopW a f = step a (go <$> f a)
-  where
-  go x = loopW x f
-
--- | Loop a signal so that the return value is passed to the beginning again.
-loopS ::
-  forall m a.
-  Monad m =>
-  a ->
-  (a -> SignalT m a) ->
-  SignalT m a
-loopS a f = step (extract this) do
-  s <- update this
-  pure (loopS (extract s) f)
-  where
-  this = f a
-
--- | Loop a signal so that the return value is passed to the beginning again.
--- loop :: forall m a. Monoid v => (a -> SignalT m (Maybe a)) -> SignalT m a
--- loop f = step (extract this) do
---   s <- update this
---   pure (loopS (extract s) f)
---   where this = f Nothing
--- | Folding signals. Similar to how signals used to work in Elm.
--- | This can be used to implement simple stateful Signals.
--- | e.g. `counter = fold (\n _ -> n+1) 0 clicks`
-foldp ::
-  forall m a b.
-  Functor m =>
-  (a -> b -> a) ->
-  a ->
-  SignalT m b ->
-  SignalT m a
-foldp f a sb = step a' (map (foldp f a') (update sb))
-  where
-  a' = f a (extract sb)
-
--- | Consume a closed signal to make a widget
--- dyn :: forall v. (forall x. SignalT m x) ~> (forall x. m x)
-dyn ::
-  forall m a b.
-  Monad m =>
-  SignalT m a ->
-  m b
-dyn s = update s >>= dyn
-
--- | Run a signal *once* and return its value
-oneShot ::
-  forall m a.
-  Monad m =>
-  SignalT m (Maybe a) ->
-  m a
-oneShot s = case extract s of
-  Nothing -> update s >>= oneShot
-  Just a -> pure a
-
--- Very useful to embed a signal in the middle of a widget
-demand ::
-  forall m a.
-  Monad m =>
-  SignalT m (Maybe a) ->
-  m a
-demand = oneShot
-
-demand' :: forall m a. Monad m => (Maybe a -> SignalT m (Maybe a)) -> m a
-demand' f = oneShot (f Nothing)
-
--- A Common pattern is demand + stateLoopS
-demandLoop ::
-  forall m a s.
-  Monad m =>
-  Alternative m =>
-  s ->
-  (s -> SignalT m (Either s a)) ->
-  m a
-demandLoop def w = demand (stateLoopS def w)
-
--- A generalisation of `loopS` where, you have an inner loop state `s` and a final result `a`
--- The loop continues as long as `Left s` is returned. And ends when `Right a` is returned.
-stateLoopS ::
-  forall m a s.
-  Monad m =>
-  Alternative m =>
-  s ->
-  (s -> SignalT m (Either s a)) ->
-  SignalT m (Maybe a)
-stateLoopS def w = map hush $ loopS (Left def) $ either w (pure <<< Right)
diff --git a/src/Concur/Core/Gen.purs b/src/Concur/Core/Gen.purs
deleted file mode 100644
index 8137e2b..0000000
--- a/src/Concur/Core/Gen.purs
+++ /dev/null
@@ -1,169 +0,0 @@
-module Concur.Core.Gen where
-
-import Prelude
-
-import Concur.Core.Types (Widget)
-import Control.Alt ((<|>))
-import Control.Monad.Free (Free, hoistFree, liftF, resume, wrap)
-import Data.Array (foldr, snoc)
-import Data.Either (Either(..))
-import Data.Maybe (Maybe(..))
-import Data.Tuple (Tuple(..))
-
--- Internal data types
-newtype GenStep v x a
-  = GenStep (GenWidget v x a)
-
-type GenWidget v x a
-  = Widget v {yield :: Maybe x, cont :: a}
-
-instance functorGenStep :: Functor (GenStep v x) where
-  map f (GenStep w) = GenStep (mapContGenWidget f w)
-
--- | A Gen is a widget that also generates things
-type Gen v x a
-  = Free (GenStep v x) a
-
--- | Sometimes it's useful to have Generators that generate Widgets
-type WidgetGen v b a
-  = Gen v (Widget v b) a
-
--- | Yield a value
-yield ::
-  forall v x.
-  x ->
-  Gen v x Unit
-yield = liftF <<< pureYield
-
--- | Run a Widget
-runWidget ::
-  forall v x a.
-  Widget v a ->
-  Gen v x a
-runWidget = liftF <<< widgetYield Nothing
-
--- | Yield a value, and then continue
-yieldAndThen ::
-  forall v x a.
-  x ->
-  Widget v (Gen v x a) ->
-  Gen v x a
-yieldAndThen x = wrap <<< widgetYield (Just x)
-
--- | A map over yielded values (of type X)
--- | The usual map is over the return value
-mapYield ::
-  forall v x y a.
-  (x -> y) ->
-  Gen v x a ->
-  Gen v y a
-mapYield f = hoistFree (\(GenStep w) ->
-  GenStep (mapYieldGenWidget f w))
-
--- | Convert a generator into one that tags its output with successive unique integers
-zipYield ::
-  forall v x a.
-  Gen v x a ->
-  Gen v (Tuple Int x) a
-zipYield = go 0
-  where
-  go n g = case resume g of
-    Right b -> pure b
-    Left (GenStep gw) -> do
-      r <- runWidget gw
-      case r.yield of
-        Nothing -> go n r.cont
-        Just x -> yieldAndThen (Tuple n x) $ pure $ go (n + 1) r.cont
-
--- | Convert a monadic generator into one that tags its output with successive unique integers
--- | Can also be specialised to :: WidgetGen v x a -> WidgetGen v (Tuple Int x) a
-zipWidgetYield ::
-  forall a v m x.
-  Functor m =>
-  Gen v (m x) a ->
-  Gen v (m (Tuple Int x)) a
-zipWidgetYield g = mapYield (\(Tuple x w) ->
-  Tuple x <$> w) $ zipYield g
-
--- TODO: A Widget when generated and injected into a container by a generator,
---       should have some mechanism to dictate its position.
--- TODO: Actually, we need a monad independent layout format.
---       An idea is - view = mapping from { selector -> Widget },
---         where type of selector depends on type of view.
--- | Collapse a Generator into one widget. For containers with dynamic children.
--- | Any new widgets generated are immediately inserted into the parent widget
--- | Returns either (Left b) when Gen ends, or Right a, when one of the children end.
-genOrr ::
-  forall v a b.
-  Monoid v =>
-  WidgetGen v a b ->
-  Widget v (Either b a)
-genOrr wg = case resume wg of
-  Right b -> pure (Left b)
-  Left (GenStep gw) -> do
-    r <- gw
-    case r.yield of
-      Nothing -> genOrr r.cont
-      Just x -> genOrr r.cont <|> (Right <$> x)
-
--- | Like `genOrr`, collapses a Generator into one widget.
--- | However, any values returned by the children are tagged with an id (unique to this generator)
--- | Any new widgets generated are immediately inserted into the parent widget
--- | Returns either (Left b) when Gen ends, or (Tuple Int a), when one of the children end.
-zipGenOrr ::
-  forall v a b.
-  Monoid v =>
-  WidgetGen v a b ->
-  Widget v (Either b (Tuple Int a))
-zipGenOrr = genOrr <<< zipWidgetYield
-
--- | Array to Generator conversion
--- | Sequentially generates all values in the list
-listToGen ::
-  forall v x.
-  Array x ->
-  Gen v x Unit
-listToGen = foldr (bthen <<< yield) (pure unit)
-  where
-  bthen m1 m2 = m1 >>= \_ ->
-    m2
-
--- | Generator to Array conversion. Runs until generator ends, then returns all generated values in an array.
--- | Use it when you want to generate values, and then operate on them in one go
-genToList ::
-  forall v x a.
-  Gen v x a ->
-  Widget v (Array x)
-genToList g = case resume g of
-  Right _ -> pure []
-  Left (GenStep gw) -> do
-    r <- gw
-    rs <- genToList r.cont
-    pure case r.yield of
-      Nothing -> rs
-      Just x -> snoc rs x
-
--- Util
-mapYieldGenWidget ::
-  forall v x y a.
-  (x -> y) ->
-  GenWidget v x a ->
-  GenWidget v y a
-mapYieldGenWidget f = map (\r ->
-  r { yield = map f r.yield })
-
-mapContGenWidget ::
-  forall v x a b.
-  (a -> b) ->
-  GenWidget v x a ->
-  GenWidget v x b
-mapContGenWidget f = map (\r ->
-  r { cont = f r.cont })
-
-pureYield :: forall v x. x -> GenStep v x Unit
-pureYield x = GenStep (pure { yield: Just x, cont: unit })
-
-widgetYield :: forall v x a. Maybe x -> Widget v a -> GenStep v x a
-widgetYield mx w = GenStep do
-  a <- w
-  pure { yield: mx, cont: a }
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index d544be1..101c257 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -3,101 +3,119 @@ module Concur.Core.Types where
 import Prelude
 
 import Control.Alternative (class Alternative)
-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)
 import Control.ShiftMap (class ShiftMap)
+import Data.Array (fold)
 import Data.Array as A
-import Data.Either (Either(..), either)
-import Data.FoldableWithIndex (foldMapWithIndex, foldrWithIndex)
-import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
-import Data.Traversable (traverse)
+import Data.Either (Either(..))
+import Data.FoldableWithIndex (foldrWithIndex)
+import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
+import Data.Traversable (sequence)
+import Data.TraversableWithIndex (traverseWithIndex)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
+import Effect.Ref as Ref
 import Unsafe.Coerce (unsafeCoerce)
 
-type WithHandler b a = ((a -> Effect Unit)) -> Effect (Maybe b)
+-- FAQ: What's stopping the widget from calling the handler again after having returned a value (Right a)?
+-- Ans: Discipline.
+type WithHandler v a = (Either v a -> Effect Unit) -> Effect (Maybe v)
 
-mapWithHandler :: forall a b c. (a -> b) -> WithHandler c a -> WithHandler c b
-mapWithHandler f g = \cb -> g (cb <<< f)
+mapViewWithHandler :: forall v1 v2 a. (v1 -> v2) -> WithHandler v1 a -> WithHandler v2 a
+mapViewWithHandler f w1 = \cb -> do
+  v <- w1 \eval -> case eval of
+    Left v -> cb (Left (f v))
+    Right a -> cb (Right a)
+  pure $ f <$> v
 
-newtype WidgetStep v a = WidgetStepView (WithHandler v a)
+-- A Widget is an initial view, followed by a series of async views
+newtype Widget v a = Widget (WithHandler v a)
 
-unWidgetStep :: forall v a. WidgetStep v a -> WithHandler v a
-unWidgetStep (WidgetStepView f) = f
+unWidget :: forall v a. Widget v a -> WithHandler v a
+unWidget (Widget f) = f
 
-unWidgetStepArray :: forall v a. Array (WidgetStep v a) -> Array (WithHandler v a)
-unWidgetStepArray arr = unsafeCoerce arr
-
-mkWidgetStepArray :: forall v a. Array (WithHandler v a) -> Array (WidgetStep v a)
-mkWidgetStepArray arr = unsafeCoerce arr
-
--- derive instance widgetStepFunctor :: Functor (WidgetStep v)
-instance functorWidgetStep :: Functor (WidgetStep v) where
-  map f (WidgetStepView v) = WidgetStepView $ mapWithHandler f v
-
-newtype Widget v a
-  = Widget (Free (WidgetStep v) a)
-
-unWidget :: forall v a. Widget v a -> Free (WidgetStep v) a
-unWidget (Widget w) = w
-
-unWidgetArray :: forall v a. Array (Widget v a) -> Array (Free (WidgetStep v) a)
+unWidgetArray :: forall v a. Array (Widget v a) -> Array (WithHandler v a)
 unWidgetArray arr = unsafeCoerce arr
 
-mkWidgetArray :: forall v a. Array (Free (WidgetStep v) a) -> Array (Widget v a)
+mkWidgetArray :: forall v a. Array (WithHandler v a) -> Array (Widget v a)
 mkWidgetArray arr = unsafeCoerce arr
 
-derive newtype instance widgetFunctor :: Functor (Widget v)
-
-derive newtype instance widgetBind :: Bind (Widget v)
-
-derive newtype instance widgetApplicative :: Applicative (Widget v)
-
-derive newtype instance widgetApply :: Apply (Widget v)
+instance functorWidget :: Functor (Widget v) where
+  map f (Widget g) = Widget \cb -> g (cb <<< map f)
+
+instance widgetBind :: Bind (Widget v) where
+  bind (Widget f) h = Widget \cb ->
+    let fing eva = case eva of
+          Left v -> cb (Left v)
+          Right a -> do
+            mv <- unWidget (h a) cb
+            case mv of
+              Nothing -> pure unit
+              Just v -> cb (Left v)
+    in f fing
+
+instance widgetApplicative :: Applicative (Widget v) where
+  pure a = Widget \cb -> cb (Right a) *> pure Nothing
+
+instance widgetApply :: Apply (Widget v) where
+  apply x y = do
+    a <- x
+    b <- y
+    pure (a b)
 
 instance widgetMonad :: Monad (Widget v)
 
-derive newtype instance widgetMonadRec :: MonadRec (Widget v)
+-- derive newtype instance widgetMonadRec :: MonadRec (Widget v)
 
 instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where
   shiftMap f = f identity
 
-instance widgetMultiAlternative ::
-  ( Monoid v
-  ) =>
-  MultiAlternative (Widget v) where
-  orr wss = Widget $ combine $ unWidgetArray wss
+instance widgetMultiAlternative :: (Monoid v) => MultiAlternative (Widget v) where
+  orr wss = Widget \cb -> do
+    -- Oh the mutation!
+    doneRef <- Ref.new false
+    viewsRef <- Ref.new [Nothing]
+    let
+      -- mkCb :: Int -> Either v a -> Effect Unit
+      mkCb i = \eval -> case eval of
+        Right a -> do
+          isDone <- Ref.read doneRef
+          Ref.write true doneRef
+          when (not isDone) $ cb (Right a)
+        Left v -> do
+          isDone <- Ref.read doneRef
+          when (not isDone) do
+            vs <- Ref.read viewsRef
+            let mvs' = A.updateAt i (Just v) vs
+            case mvs' of
+              Nothing -> pure unit
+              Just vs' -> do
+                Ref.write vs' viewsRef
+                case sequence vs of
+                  Nothing -> pure unit
+                  Just arr -> cb $ Left $ fold arr
+    vs <- traverseWithIndex (\i f -> f (mkCb i)) (unWidgetArray wss)
+    Ref.write vs viewsRef
+    case sequence vs of
+      Nothing -> pure Nothing
+      Just arr -> pure $ Just $ fold arr
 
-combine ::
-  forall v a.
-  Monoid v =>
-  Array (Free (WidgetStep v) a) ->
-  Free (WidgetStep v) a
-combine wfs = either pure (wrap <<< WidgetStepView <<< merge <<< unWidgetStepArray) (traverse myResume wfs)
-
-myResume :: forall f a . Functor f => Free f a -> Either a (f (Free f a))
-myResume = resume' (\g i -> Right (i <$> g)) Left
-
-merge ::
-  forall v' a.
-  Monoid v' =>
-  Array (WithHandler v' (Free (WidgetStep v') a)) ->
-  WithHandler v' (Free (WidgetStep v') a)
-merge ws = mapWithHandler combine $ mergeWithHandlers (wrap <<< WidgetStepView) ws
-
-mergeWithHandlers
-  :: forall v a
-   . Monoid v
-  => (WithHandler v a -> a)
-  -> Array (WithHandler v a)
-  -> WithHandler v (Array a)
-mergeWithHandlers mkh vs = \cb ->
-  let mkCb i = \val -> cb (fromMaybe vs' (A.updateAt i val vs'))
-  in foldMapWithIndex (\i f -> f (mkCb i)) vs
-  where vs' = map mkh vs
+
+instance widgetSemigroup :: (Monoid v) => Semigroup (Widget v a) where
+  append w1 w2 = orr [w1, w2]
+
+instance widgetMonoid :: (Monoid v) => Monoid (Widget v a) where
+  mempty = empty
+
+instance widgetAlt :: (Monoid v) => Alt (Widget v) where
+  alt = append
+
+instance widgetPlus :: (Monoid v) => Plus (Widget v) where
+  empty = Widget \cb -> pure Nothing
+
+instance widgetAlternative :: (Monoid v) => Alternative (Widget v)
 
 -- | Run multiple widgets in parallel until *all* finish, and collect their outputs
 -- | Contrast with `orr`
@@ -116,50 +134,21 @@ andd ws = do
       rest <- andd ws'
       pure $ fromMaybe [] $ A.insertAt i e rest
 
-instance widgetSemigroup :: (Monoid v) => Semigroup (Widget v a) where
-  append w1 w2 = orr [w1, w2]
-
-instance widgetMonoid :: (Monoid v) => Monoid (Widget v a) where
-  mempty = empty
-
-instance widgetAlt :: (Monoid v) => Alt (Widget v) where
-  alt = append
-
-instance widgetPlus :: (Monoid v) => Plus (Widget v) where
-  empty = display mempty
-
-instance widgetAlternative :: (Monoid v) => Alternative (Widget v)
-
--- Pause for a negligible amount of time. Forces continuations to pass through the trampoline.
--- (Somewhat similar to calling `setTimeout` of zero in Javascript)
--- Avoids stack overflows in (pathological) cases where a widget calls itself repeatedly without any intervening widgets or effects.
--- E.g. -
---   BAD  `counter n = if n < 10000 then counter (n+1) else pure n`
---   GOOD `counter n = if n < 10000 then (do pulse; counter (n+1)) else pure n`
-pulse ::
-  forall v.
-  Monoid v =>
-  Widget v Unit
-pulse = effAction (pure unit)
-
-mapView :: forall a v. (v -> v) -> Widget v a -> Widget v a
-mapView f (Widget w) = Widget (hoistFree (mapViewStep f) w)
 
-mapViewStep :: forall v a. (v -> v) -> WidgetStep v a -> WidgetStep v a
-mapViewStep f (WidgetStepView v) = WidgetStepView (map (map f) <$> v)
+mapView :: forall a v1 v2. (v1 -> v2) -> Widget v1 a -> Widget v2 a
+mapView f (Widget w) = Widget (mapViewWithHandler f w)
 
 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 -> pure (Just v)
+display v = Widget \cb -> pure (Just v)
 
 -- Sync eff
 effAction ::
   forall a v.
   Effect a ->
   Widget v a
-effAction eff = Widget $ liftF $ WidgetStepView \cb -> do
+effAction eff = Widget \cb -> do
   a <- eff
-  cb a
+  cb (Right a)
   pure Nothing
 
 -- Async aff
@@ -167,7 +156,7 @@ affAction ::
   forall a v.
   WithHandler v a ->
   Widget v a
-affAction = Widget <<< liftF <<< WidgetStepView
+affAction = Widget
 
 -- Async callback
 -- asyncAction
@@ -183,13 +172,9 @@ instance widgetMonadEff :: (Monoid v) => MonadEffect (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
-    WidgetStepView g -> Widget $ wrap $ WidgetStepView \cb -> map (f cb) <$> g cb
+mkNodeWidget :: forall v1 v2 a. ((a -> Effect Unit) -> v1 -> v2) -> Widget v1 a -> Widget v2 a
+mkNodeWidget h (Widget f) = Widget \cb ->
+  mapViewWithHandler (h \a -> cb (Right a)) f cb
 
-mkLeafWidget :: forall v a. ((Free (WidgetStep v) a -> Effect Unit) -> v) -> Widget v a
-mkLeafWidget = Widget <<< wrap <<< WidgetStepView <<< adapter
-  where
-  adapter h cb = pure $ Just $ h cb
+mkLeafWidget :: forall v a. ((a -> Effect Unit) -> v) -> Widget v a
+mkLeafWidget h = Widget \cb -> pure $ Just $ h \a -> cb (Right a)
diff --git a/src/Control/Cofree.purs b/src/Control/Cofree.purs
deleted file mode 100644
index e70414b..0000000
--- a/src/Control/Cofree.purs
+++ /dev/null
@@ -1,258 +0,0 @@
--- | AJ: This is the same as `Control.Comonad.Cofree` from the `purescript-free` package.
--- | However, we need to override the applicative and monad instance, and "probably" due to a Purescript bug it's not working.
--- | The _cofree comonad_ for a `Functor`.
--- | This version also adds `lazyCofree`, `lazyHead`, `lazyTail`, and `mfix`
-module Control.Cofree
-  ( Cofree
-  , (:<)
-  , buildCofree
-  , lazyCofree
-  , deferCofree
-  , explore
-  , exploreM
-  , head
-  , lazyHead
-  , hoistCofree
-  , mkCofree
-  , tail
-  , lazyTail
-  , mfix
-  , unfoldCofree
-  ) where
-
-import Prelude
-
-import Concur.Core.Types (Widget)
-import Control.Alternative (class Alternative, (<|>), empty)
-import Control.Comonad (class Comonad, extract)
-import Control.Extend (class Extend)
-import Control.Lazy as Z
-import Control.Monad.Free (Free, runFreeM)
-import Control.Monad.Rec.Class (class MonadRec)
-import Control.Monad.State (State, StateT(..), runState, runStateT, state)
-import Control.ShiftMap (class ShiftMap)
-import Data.Eq (class Eq1, eq1)
-import Data.Foldable (class Foldable, foldr, foldl, foldMap)
-import Data.Lazy (Lazy, defer, force)
-import Data.Ord (class Ord1, compare1)
-import Data.Traversable (class Traversable, traverse)
-import Data.Tuple (Tuple(..), fst, snd)
-
--- | The `Cofree` `Comonad` for a functor.
--- |
--- | A value of type `Cofree f a` consists of an `f`-branching
--- | tree, annotated with labels of type `a`.
--- |
--- | The `Comonad` instance supports _redecoration_, recomputing
--- | labels from the local context.
-newtype Cofree f a
-  = Cofree (Lazy (Tuple a (f (Cofree f a))))
-
--- | Lazily creates a value of type `Cofree f a` from a label and a
--- | functor-full of "subtrees".
-lazyCofree ::
-  forall f a.
-  Lazy (Tuple a (f (Cofree f a))) ->
-  Cofree f a
-lazyCofree = Cofree
-
--- | Lazily creates a value of type `Cofree f a` from a label and a
--- | functor-full of "subtrees".
-deferCofree ::
-  forall f a.
-  (Unit -> Tuple a (f (Cofree f a))) ->
-  Cofree f a
-deferCofree = Cofree <<< defer
-
--- | Create a value of type `Cofree f a` from a label and a
--- | functor-full of "subtrees".
-mkCofree ::
-  forall f a.
-  a ->
-  f (Cofree f a) ->
-  Cofree f a
-mkCofree a t = Cofree (defer \_ ->
-  Tuple a t)
-
-infixr 5 mkCofree as :<
-
--- | Returns the label for a tree.
-head ::
-  forall f a.
-  Cofree f a ->
-  a
-head (Cofree c) = fst (force c)
-
--- | Returns the "subtrees" of a tree.
-tail ::
-  forall f a.
-  Cofree f a ->
-  f (Cofree f a)
-tail (Cofree c) = snd (force c)
-
--- | Like `head`, but returns a lazy value
-lazyHead ::
-  forall f a.
-  Cofree f a ->
-  (Lazy a)
-lazyHead (Cofree c) = map fst c
-
--- | Like `tail`, but returns a lazy value
-lazyTail ::
-  forall f a.
-  Cofree f a ->
-  (Lazy (f (Cofree f a)))
-lazyTail (Cofree c) = map snd c
-
-
-hoistCofree :: forall f g. Functor f => (f ~> g) -> Cofree f ~> Cofree g
-hoistCofree nat (Cofree c) = Cofree (map (nat <<< map (hoistCofree nat)) <$> c)
-
--- | This signature is deprecated and will be replaced by `buildCofree` in a
--- | future release.
-unfoldCofree ::
-  forall f s a.
-  Functor f =>
-  (s -> a) ->
-  (s -> f s) ->
-  s ->
-  Cofree f a
-unfoldCofree e n = buildCofree (\s ->
-  Tuple (e s) (n s))
-
--- | Recursively unfolds a `Cofree` structure given a seed.
-buildCofree ::
-  forall f s a.
-  Functor f =>
-  (s -> Tuple a (f s)) ->
-  s ->
-  Cofree f a
-buildCofree k s = Cofree (defer \_ ->
-  map (buildCofree k) <$> k s)
-
--- | Explore a value in the cofree comonad by using an expression in a
--- | corresponding free monad.
--- |
--- | The free monad should be built from a functor which pairs with the
--- | functor underlying the cofree comonad.
-explore ::
-  forall f g a b.
-  Functor f =>
-  Functor g =>
-  (forall x y. f (x -> y) -> g x -> y) ->
-  Free f (a -> b) ->
-  Cofree g a ->
-  b
-explore pair m w = case runState (runFreeM step m) w of
-  Tuple f cof -> f (extract cof)
-  where
-  step ::
-    f (Free f (a -> b)) ->
-    State (Cofree g a) (Free f (a -> b))
-  step ff = state \cof ->
-    pair (map Tuple ff) (tail cof)
-
-exploreM ::
-  forall f g a b m.
-  Functor f =>
-  Functor g =>
-  MonadRec m =>
-  (forall x y. f (x -> y) -> g x -> m y) ->
-  Free f (a -> b) ->
-  Cofree g a ->
-  m b
-exploreM pair m w = eval <$> runStateT (runFreeM step m) w
-  where
-  step ::
-    f (Free f (a -> b)) ->
-    StateT (Cofree g a) m (Free f (a -> b))
-  step ff = StateT \cof ->
-    pair (map Tuple ff) (tail cof)
-  eval ::
-    forall x y.
-    Tuple (x -> y) (Cofree g x) ->
-    y
-  eval (Tuple f cof) = f (extract cof)
-
-instance eqCofree :: (Eq1 f, Eq a) => Eq (Cofree f a) where
-  eq x y = head x == head y && tail x `eq1` tail y
-
-instance eq1Cofree :: (Eq1 f) => Eq1 (Cofree f) where
-  eq1 = eq
-
-instance ordCofree :: (Ord1 f, Ord a) => Ord (Cofree f a) where
-  compare x y = case compare (head x) (head y) of
-    EQ -> compare1 (tail x) (tail y)
-    r -> r
-
-instance ord1Cofree :: (Ord1 f) => Ord1 (Cofree f) where
-  compare1 = compare
-
-instance functorCofree :: (Functor f) => Functor (Cofree f) where
-  map f = loop
-    where
-    loop (Cofree fa) = Cofree ((\(Tuple a b) ->
-      Tuple (f a) (loop <$> b)) <$> fa)
-
-instance foldableCofree :: (Foldable f) => Foldable (Cofree f) where
-  foldr f = flip go
-    where
-    go fa b = f (head fa) (foldr go b (tail fa))
-  foldl f = go
-    where
-    go b fa = foldl go (f b (head fa)) (tail fa)
-  foldMap f = go
-    where
-    go fa = f (head fa) <> (foldMap go (tail fa))
-
-instance traversableCofree :: (Traversable f) => Traversable (Cofree f) where
-  sequence = traverse identity
-  traverse f = loop
-    where
-    loop ta = mkCofree <$> f (head ta) <*> (traverse loop (tail ta))
-
-instance extendCofree :: (Functor f) => Extend (Cofree f) where
-  extend f = loop
-    where
-    loop (Cofree fa) = Cofree ((\(Tuple a b) ->
-      Tuple (f (Cofree fa)) (loop <$> b)) <$> fa)
-
-instance comonadCofree :: (Functor f) => Comonad (Cofree f) where
-  extract = head
-
-instance applyCofree :: (Alternative f) => Apply (Cofree f) where
-  apply = ap
-
-instance applicativeCofree :: (Alternative f) => Applicative (Cofree f) where
-  pure a = mkCofree a empty
-
-instance bindCofree :: (Alternative f) => Bind (Cofree f) where
-  -- bind :: forall a b. Signal v a -> (a -> Signal v b) -> Signal v b
-  bind sa' f = go sa'
-    where
-    go sa = go' sa (f (head sa))
-    go' sa sb = let mrestart = go <$> tail sa
-                    msplit = go' sa <$> tail sb
-                in mkCofree (head sb) (mrestart <|> msplit)
-
--- instance bindCofree :: Alternative f => Bind (Cofree f) where
---   bind fa f = loop fa
---     where
---     loop fa' =
---       let fh = f (head fa')
---       in mkCofree (head fh) ((tail fh) <|> (loop <$> tail fa'))
-instance monadCofree :: (Alternative f) => Monad (Cofree f)
-
-instance isLazyCofree :: Z.Lazy (Cofree f a) where
-  defer k = Cofree (defer \_ ->
-    let (Cofree t) = k unit
-    in force t)
-
-instance shiftMapCofree :: Monoid v => ShiftMap (Widget v) (Cofree (Widget v)) where
-  shiftMap f (Cofree l) = deferCofree \_ ->
-    let Tuple a rest = force l
-    in Tuple a (f pure rest)
-
-mfix :: forall f a. (Lazy a -> Cofree f a) -> Cofree f a
-mfix f = Z.fix \res -> f $ lazyHead res
-

From 770c2c78d523bc57c6a71f011514defd34905236 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Tue, 23 Jun 2020 00:46:48 +0530
Subject: [PATCH 14/15] Use EffectFn1

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

diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 101c257..79744b1 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -17,17 +17,18 @@ import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Class (class MonadEffect)
 import Effect.Ref as Ref
+import Effect.Uncurried (EffectFn1, mkEffectFn1, runEffectFn1)
 import Unsafe.Coerce (unsafeCoerce)
 
 -- FAQ: What's stopping the widget from calling the handler again after having returned a value (Right a)?
 -- Ans: Discipline.
-type WithHandler v a = (Either v a -> Effect Unit) -> Effect (Maybe v)
+type WithHandler v a = (EffectFn1 (Either v a) Unit) -> Effect (Maybe v)
 
 mapViewWithHandler :: forall v1 v2 a. (v1 -> v2) -> WithHandler v1 a -> WithHandler v2 a
 mapViewWithHandler f w1 = \cb -> do
-  v <- w1 \eval -> case eval of
-    Left v -> cb (Left (f v))
-    Right a -> cb (Right a)
+  v <- w1 $ mkEffectFn1 \eval -> case eval of
+    Left v -> runEffectFn1 cb (Left (f v))
+    Right a -> runEffectFn1 cb (Right a)
   pure $ f <$> v
 
 -- A Widget is an initial view, followed by a series of async views
@@ -43,21 +44,21 @@ mkWidgetArray :: forall v a. Array (WithHandler v a) -> Array (Widget v a)
 mkWidgetArray arr = unsafeCoerce arr
 
 instance functorWidget :: Functor (Widget v) where
-  map f (Widget g) = Widget \cb -> g (cb <<< map f)
+  map f (Widget g) = Widget \cb -> g $ mkEffectFn1 \val -> runEffectFn1 cb $ map f val
 
 instance widgetBind :: Bind (Widget v) where
   bind (Widget f) h = Widget \cb ->
-    let fing eva = case eva of
-          Left v -> cb (Left v)
+    let fing = mkEffectFn1 $ case _ of
+          Left v -> runEffectFn1 cb (Left v)
           Right a -> do
             mv <- unWidget (h a) cb
             case mv of
               Nothing -> pure unit
-              Just v -> cb (Left v)
+              Just v -> runEffectFn1 cb (Left v)
     in f fing
 
 instance widgetApplicative :: Applicative (Widget v) where
-  pure a = Widget \cb -> cb (Right a) *> pure Nothing
+  pure a = Widget \cb -> runEffectFn1 cb (Right a) *> pure Nothing
 
 instance widgetApply :: Apply (Widget v) where
   apply x y = do
@@ -79,11 +80,12 @@ instance widgetMultiAlternative :: (Monoid v) => MultiAlternative (Widget v) whe
     viewsRef <- Ref.new [Nothing]
     let
       -- mkCb :: Int -> Either v a -> Effect Unit
-      mkCb i = \eval -> case eval of
+      mkCb i = mkEffectFn1 \eval -> case eval of
         Right a -> do
           isDone <- Ref.read doneRef
-          Ref.write true doneRef
-          when (not isDone) $ cb (Right a)
+          when (not isDone) do
+            Ref.write true doneRef
+            runEffectFn1 cb (Right a)
         Left v -> do
           isDone <- Ref.read doneRef
           when (not isDone) do
@@ -95,7 +97,7 @@ instance widgetMultiAlternative :: (Monoid v) => MultiAlternative (Widget v) whe
                 Ref.write vs' viewsRef
                 case sequence vs of
                   Nothing -> pure unit
-                  Just arr -> cb $ Left $ fold arr
+                  Just arr -> runEffectFn1 cb $ Left $ fold arr
     vs <- traverseWithIndex (\i f -> f (mkCb i)) (unWidgetArray wss)
     Ref.write vs viewsRef
     case sequence vs of
@@ -148,7 +150,7 @@ effAction ::
   Widget v a
 effAction eff = Widget \cb -> do
   a <- eff
-  cb (Right a)
+  runEffectFn1 cb (Right a)
   pure Nothing
 
 -- Async aff
@@ -174,7 +176,7 @@ instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
 
 mkNodeWidget :: forall v1 v2 a. ((a -> Effect Unit) -> v1 -> v2) -> Widget v1 a -> Widget v2 a
 mkNodeWidget h (Widget f) = Widget \cb ->
-  mapViewWithHandler (h \a -> cb (Right a)) f cb
+  mapViewWithHandler (h \a -> runEffectFn1 cb (Right a)) f cb
 
 mkLeafWidget :: forall v a. ((a -> Effect Unit) -> v) -> Widget v a
-mkLeafWidget h = Widget \cb -> pure $ Just $ h \a -> cb (Right a)
+mkLeafWidget h = Widget \cb -> pure $ Just $ h \a -> runEffectFn1 cb (Right a)

From 7adb7830a6eb6d58380be1cc2b7368ef27d10688 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Mon, 12 Oct 2020 11:11:14 +0530
Subject: [PATCH 15/15] Some random old code

---
 src/Concur/Core/Event.js.bak    | 108 +++++++++++++++
 src/Concur/Core/HostConfig.purs |  22 ++++
 src/Concur/Core/Types.purs      |  63 ++++++---
 src/Concur/Core/delme.purs.bak  | 227 ++++++++++++++++++++++++++++++++
 test/Test/WidgetSpec.purs       |  62 +++++++++
 5 files changed, 464 insertions(+), 18 deletions(-)
 create mode 100644 src/Concur/Core/Event.js.bak
 create mode 100644 src/Concur/Core/HostConfig.purs
 create mode 100644 src/Concur/Core/delme.purs.bak
 create mode 100644 test/Test/WidgetSpec.purs

diff --git a/src/Concur/Core/Event.js.bak b/src/Concur/Core/Event.js.bak
new file mode 100644
index 0000000..9fbfbeb
--- /dev/null
+++ b/src/Concur/Core/Event.js.bak
@@ -0,0 +1,108 @@
+"use strict";
+
+exports.random = function() {
+  return "" + Math.floor(Math.random() * 1000);
+};
+
+/*
+// foreign import mkObserver ::
+//   forall a. Effect
+//     { push :: a -> Effect Unit
+//     , subscribe :: (a -> Effect Unit) -> Effect (Effect Unit)
+//     }
+exports.mkObserver = function() {
+    var saveda;
+    var callback;
+    return { push: function(a) {
+               return function() {
+                 if(callback) callback(a)();
+                 else saveda = a;
+               };
+             }
+           , subscribe: function(cb) {
+               return function() {
+                 if(saveda !== null && saveda !== undefined) {
+                   // TODO: Wrap this in a setTimeout???
+                   cb(saveda)();
+                   return function() {};
+                 } else {
+                   callback = cb;
+                   return function() {
+                     console.log("NO MORE CALLBACK", callback);
+                     callback = null;
+                   };
+                 }
+               };
+             }
+           };
+};
+
+
+// foreign import parIndex :: forall a. Array (Observer a) -> Observer ({i::Int, val::a})
+exports.parIndex = function(arr) {
+    return function(cb) {
+      return function() {
+        // Cancelers
+        var cancelers = [];
+        // register all callbacks
+        for(var i=0; i<arr.length;i++) {
+          var f = arr[i];
+          var c = f(function(val) {
+            return function() {
+              // Call the successful one
+              cb({i, val})();
+              // Cancel all others
+              console.log("THERE CAN BE ONLY ONE", cancelers);
+              for(var j=0; j<cancelers.length; j++) {
+                if (j !== i) cancelers[j]();
+              }
+              cancelers = [];
+            };
+          })();
+          // register canceler
+          cancelers.push(c);
+        };
+        return function() {
+         // cancel
+          for(var j=0; j<cancelers.length; j++) {
+            cancelers[j]();
+          }
+        };
+      };
+    };
+};
+
+// foreign import par :: forall a. Array (Observer a) -> Observer a
+exports.par = function(arr) {
+    return function(cb) {
+        return function() {
+            // Cancelers
+            var cancelers = [];
+            // register all callbacks
+            for(var i=0; i<arr.length;i++) {
+                var f = arr[i];
+                var c = f(function(val) {
+                  return function() {
+                    // Call the successful one
+                    cb(val)();
+                    // Cancel all others
+                    console.log("THERE CAN BE ONLY ONE", cancelers);
+                    for(var j=0; j<cancelers.length; j++) {
+                        if (j !== i) cancelers[j]();
+                    }
+                    cancelers = [];
+                  };
+                })();
+                // register canceler
+                cancelers.push(c);
+            };
+            return function() {
+              // cancel
+              for(var j=0; j<cancelers.length; j++) {
+                  cancelers[j]();
+              }
+            };
+        };
+    };
+};
+*/
diff --git a/src/Concur/Core/HostConfig.purs b/src/Concur/Core/HostConfig.purs
new file mode 100644
index 0000000..5d68ec4
--- /dev/null
+++ b/src/Concur/Core/HostConfig.purs
@@ -0,0 +1,22 @@
+module Concur.Core.HostConfig where
+
+import Data.Unit (Unit)
+
+data Props
+
+data ClassInst a
+data FragInst a
+data TextInst a
+
+{-
+class ConcurHost m i f t where
+  createInstance :: String -> Props -> i
+  createDocumentFragment :: f
+  createTextNode :: String -> t
+  createNumberNode :: Number -> t
+  insertBefore :: i -> i -> i -> m Unit
+  appendChild :: i -> Array i -> m Unit
+  removeSelf :: i -> m Unit
+  removeAllChild :: i -> m Unit
+  updateProps :: i -> Props -> Props -> m Unit
+-}
diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs
index 79744b1..f5666a7 100644
--- a/src/Concur/Core/Types.purs
+++ b/src/Concur/Core/Types.purs
@@ -3,12 +3,12 @@ module Concur.Core.Types where
 import Prelude
 
 import Control.Alternative (class Alternative)
+import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM) as Rec
 import Control.MultiAlternative (class MultiAlternative, orr)
 import Control.Plus (class Alt, class Plus, alt, empty)
 import Control.ShiftMap (class ShiftMap)
 import Data.Array (fold)
 import Data.Array as A
-import Data.Either (Either(..))
 import Data.FoldableWithIndex (foldrWithIndex)
 import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
 import Data.Traversable (sequence)
@@ -20,15 +20,34 @@ import Effect.Ref as Ref
 import Effect.Uncurried (EffectFn1, mkEffectFn1, runEffectFn1)
 import Unsafe.Coerce (unsafeCoerce)
 
+data Change a
+class Patch a d where
+  patch :: a -> d -> a
+fromChange :: forall a d. Patch a d => Change a -> d
+fromChange = unsafeCoerce
+toChange :: forall a d. Patch a d => d -> Change a
+toChange = unsafeCoerce
+
+data Step v a
+  = View v
+  | Finish a
+  | Change (Change v)
+
+instance functorStep :: Functor (Step v) where
+  map f (View v) = View v
+  map f (Finish a) = Finish (f a)
+  map f (Change d) = Change d
+
 -- FAQ: What's stopping the widget from calling the handler again after having returned a value (Right a)?
 -- Ans: Discipline.
-type WithHandler v a = (EffectFn1 (Either v a) Unit) -> Effect (Maybe v)
+type WithHandler v a = (EffectFn1 (Step v a) Unit) -> Effect (Maybe v)
 
 mapViewWithHandler :: forall v1 v2 a. (v1 -> v2) -> WithHandler v1 a -> WithHandler v2 a
 mapViewWithHandler f w1 = \cb -> do
   v <- w1 $ mkEffectFn1 \eval -> case eval of
-    Left v -> runEffectFn1 cb (Left (f v))
-    Right a -> runEffectFn1 cb (Right a)
+    Change d -> pure unit
+    View v -> runEffectFn1 cb (View (f v))
+    Finish a -> runEffectFn1 cb (Finish a)
   pure $ f <$> v
 
 -- A Widget is an initial view, followed by a series of async views
@@ -48,17 +67,17 @@ instance functorWidget :: Functor (Widget v) where
 
 instance widgetBind :: Bind (Widget v) where
   bind (Widget f) h = Widget \cb ->
-    let fing = mkEffectFn1 $ case _ of
-          Left v -> runEffectFn1 cb (Left v)
-          Right a -> do
+    f $ mkEffectFn1 $ case _ of
+          View v -> runEffectFn1 cb (View v)
+          Change d -> pure unit
+          Finish a -> do
             mv <- unWidget (h a) cb
             case mv of
               Nothing -> pure unit
-              Just v -> runEffectFn1 cb (Left v)
-    in f fing
+              Just v -> runEffectFn1 cb (View v)
 
 instance widgetApplicative :: Applicative (Widget v) where
-  pure a = Widget \cb -> runEffectFn1 cb (Right a) *> pure Nothing
+  pure a = Widget \cb -> runEffectFn1 cb (Finish a) *> pure Nothing
 
 instance widgetApply :: Apply (Widget v) where
   apply x y = do
@@ -68,7 +87,13 @@ instance widgetApply :: Apply (Widget v) where
 
 instance widgetMonad :: Monad (Widget v)
 
--- derive newtype instance widgetMonadRec :: MonadRec (Widget v)
+-- Passthrough instance of monadrec.
+-- The Widget monad is already stack safe since it depends on callbacks
+instance widgetMonadRec :: Rec.MonadRec (Widget v) where
+  tailRecM f a = go =<< f a
+    where
+      go (Rec.Loop a') = Rec.tailRecM f a'
+      go (Rec.Done b) = pure b
 
 instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where
   shiftMap f = f identity
@@ -81,12 +106,14 @@ instance widgetMultiAlternative :: (Monoid v) => MultiAlternative (Widget v) whe
     let
       -- mkCb :: Int -> Either v a -> Effect Unit
       mkCb i = mkEffectFn1 \eval -> case eval of
-        Right a -> do
+        Finish a -> do
           isDone <- Ref.read doneRef
           when (not isDone) do
             Ref.write true doneRef
-            runEffectFn1 cb (Right a)
-        Left v -> do
+            runEffectFn1 cb (Finish a)
+        Change d -> do
+          pure unit
+        View v -> do
           isDone <- Ref.read doneRef
           when (not isDone) do
             vs <- Ref.read viewsRef
@@ -97,7 +124,7 @@ instance widgetMultiAlternative :: (Monoid v) => MultiAlternative (Widget v) whe
                 Ref.write vs' viewsRef
                 case sequence vs of
                   Nothing -> pure unit
-                  Just arr -> runEffectFn1 cb $ Left $ fold arr
+                  Just arr -> runEffectFn1 cb $ View $ fold arr
     vs <- traverseWithIndex (\i f -> f (mkCb i)) (unWidgetArray wss)
     Ref.write vs viewsRef
     case sequence vs of
@@ -150,7 +177,7 @@ effAction ::
   Widget v a
 effAction eff = Widget \cb -> do
   a <- eff
-  runEffectFn1 cb (Right a)
+  runEffectFn1 cb (Finish a)
   pure Nothing
 
 -- Async aff
@@ -176,7 +203,7 @@ instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
 
 mkNodeWidget :: forall v1 v2 a. ((a -> Effect Unit) -> v1 -> v2) -> Widget v1 a -> Widget v2 a
 mkNodeWidget h (Widget f) = Widget \cb ->
-  mapViewWithHandler (h \a -> runEffectFn1 cb (Right a)) f cb
+  mapViewWithHandler (h \a -> runEffectFn1 cb (Finish a)) f cb
 
 mkLeafWidget :: forall v a. ((a -> Effect Unit) -> v) -> Widget v a
-mkLeafWidget h = Widget \cb -> pure $ Just $ h \a -> runEffectFn1 cb (Right a)
+mkLeafWidget h = Widget \cb -> pure $ Just $ h \a -> runEffectFn1 cb (Finish a)
diff --git a/src/Concur/Core/delme.purs.bak b/src/Concur/Core/delme.purs.bak
new file mode 100644
index 0000000..9506fc9
--- /dev/null
+++ b/src/Concur/Core/delme.purs.bak
@@ -0,0 +1,227 @@
+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)
+import Control.MultiAlternative (class MultiAlternative, orr)
+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 (foldrWithIndex)
+import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
+import Data.Tuple (Tuple(..))
+import Effect (Effect)
+import Effect.Class (class MonadEffect)
+
+data WidgetStep v a
+  = WidgetStepSync (Effect a)
+  | WidgetStepAsync (Observer a)
+  | WidgetStepView ((a -> Effect Unit) -> v)
+  | WidgetStepHalt
+
+-- derive instance widgetStepFunctor :: Functor (WidgetStep v)
+instance functorWidgetStep :: Functor (WidgetStep v) where
+  map f (WidgetStepSync e) = WidgetStepSync (map f e)
+  map f (WidgetStepView g) = WidgetStepView \h -> g (h <<< f)
+  map f (WidgetStepAsync o) = WidgetStepAsync (map f o)
+  map _ WidgetStepHalt = WidgetStepHalt
+
+newtype Widget v a
+  = Widget (Free (WidgetStep v) a)
+
+unWidget :: forall v a. Widget v a -> Free (WidgetStep v) a
+unWidget (Widget w) = w
+
+derive newtype instance widgetFunctor :: Functor (Widget v)
+
+derive newtype instance widgetBind :: Bind (Widget v)
+
+derive newtype instance widgetApplicative :: Applicative (Widget v)
+
+derive newtype instance widgetApply :: Apply (Widget v)
+
+instance widgetMonad :: Monad (Widget v)
+
+derive newtype instance widgetMonadRec :: MonadRec (Widget v)
+
+instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where
+  shiftMap f = f identity
+
+instance widgetMultiAlternative ::
+  ( Monoid v
+  ) =>
+  MultiAlternative (Widget v) where
+  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
+          WidgetStepSync eff -> wrap $ WidgetStepSync do
+            w <- eff
+            pure $ combine $ NEA.cons' (Widget w) x.tail
+
+          WidgetStepView f -> wrap $ WidgetStepView \h -> combine $ NEA.cons' (Widget w) x.tail
+          WidgetStepAsync o -> combineInnerAsync (NEA.singleton o) x.tail
+          WidgetStepHalt -> unWidget (orr x.tail)
+
+    -- combineInnerAsyncViews ::
+    --   forall v' a.
+    --   Monoid v' =>
+    --   NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+    --   Array (Widget v' a) ->
+    --   Free (WidgetStep v') a
+
+    combineInnerAsync ::
+      forall v' a.
+      Monoid v' =>
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      Array (Widget v' a) ->
+      Free (WidgetStep v') a
+    combineInnerAsync ws freeArr = case NEA.fromArray freeArr of
+      -- We have collected all the inner conts
+      Nothing -> combineAsyncs ws --wrap $ WidgetStep $ Right wsr
+      Just freeNarr -> combineInnerAsync1 ws freeNarr
+
+    combineInnerAsync1 ::
+      forall v' a.
+      Monoid v' =>
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      NonEmptyArray (Widget v' a) ->
+      Free (WidgetStep v') a
+    combineInnerAsync1 ws freeNarr =
+      let x = NEA.uncons freeNarr
+      in case resume (unWidget x.head) of
+        Right a -> pure a
+        Left (WidgetStepSync eff) -> wrap $ WidgetStepSync do
+            w <- eff
+            pure $ combineInnerAsync1 ws $ NEA.cons' (Widget w) x.tail
+        Left (WidgetStepView v w) -> wrap $ WidgetStepView v $ combineInnerAsync1 ws (NEA.cons' (Widget w) x.tail)
+        Left (WidgetStepAsync c) -> combineInnerAsync (NEA.snoc ws c) x.tail
+        Left WidgetStepHalt -> combineInnerAsync ws x.tail
+
+    combineAsyncs ::
+      forall v' a.
+      Monoid v' =>
+      NonEmptyArray (Observer (Free (WidgetStep v') a)) ->
+      Free (WidgetStep v') a
+    combineAsyncs ws = wrap $ WidgetStepAsync $ 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 <<< WidgetStepAsync) 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))
+
+
+-- | Run multiple widgets in parallel until *all* finish, and collect their outputs
+-- | Contrast with `orr`
+-- TODO: Performance? Don't orr with `empty`.
+andd ::
+  forall v a.
+  Monoid v =>
+  Array (Widget v a) ->
+  Widget v (Array a)
+andd ws = do
+  Tuple i e <- foldrWithIndex (\i w r -> alt (map (Tuple i) w) r) empty ws
+  let ws' = fromMaybe ws $ A.deleteAt i ws
+  if A.length ws' <= 0
+    then pure [e]
+    else do
+      rest <- andd ws'
+      pure $ fromMaybe [] $ A.insertAt i e rest
+
+instance widgetSemigroup :: (Monoid v) => Semigroup (Widget v a) where
+  append w1 w2 = orr [w1, w2]
+
+instance widgetMonoid :: (Monoid v) => Monoid (Widget v a) where
+  mempty = empty
+
+instance widgetAlt :: (Monoid v) => Alt (Widget v) where
+  alt = append
+
+instance widgetPlus :: (Monoid v) => Plus (Widget v) where
+  empty = display mempty
+
+instance widgetAlternative :: (Monoid v) => Alternative (Widget v)
+
+-- Pause for a negligible amount of time. Forces continuations to pass through the trampoline.
+-- (Somewhat similar to calling `setTimeout` of zero in Javascript)
+-- Avoids stack overflows in (pathological) cases where a widget calls itself repeatedly without any intervening widgets or effects.
+-- E.g. -
+--   BAD  `counter n = if n < 10000 then counter (n+1) else pure n`
+--   GOOD `counter n = if n < 10000 then (do pulse; counter (n+1)) else pure n`
+pulse ::
+  forall v.
+  Monoid v =>
+  Widget v Unit
+pulse = effAction (pure unit)
+
+mapView :: forall a v. (v -> v) -> Widget v a -> Widget v a
+mapView f (Widget w) = Widget (hoistFree (mapViewStep f) w)
+
+mapViewStep :: forall v a. (v -> v) -> WidgetStep v a -> WidgetStep v a
+mapViewStep f (WidgetStepSync e) = WidgetStepSync e
+mapViewStep f (WidgetStepAsync c) = WidgetStepAsync c
+mapViewStep f (WidgetStepView v a) = WidgetStepView (f v) a
+mapViewStep f WidgetStepHalt = WidgetStepHalt
+
+halt :: forall v a. Widget v a
+halt = Widget $ liftF WidgetStepHalt
+
+display :: forall v a. v -> Widget v a
+display v = Widget $ wrap $ WidgetStepView v $ unWidget halt
+
+-- Sync eff
+effAction ::
+  forall a v.
+  Effect a ->
+  Widget v a
+effAction = Widget <<< liftF <<< WidgetStepSync
+
+-- Async aff
+affAction ::
+  forall a v.
+  Observer a ->
+  Widget v a
+affAction = Widget <<< liftF <<< WidgetStepAsync
+
+-- Async callback
+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
+
+-- instance widgetMonadObserver :: (Monoid v) => MonadObserver (Widget v) where
+--   liftObserver = affAction mempty
+    -- Widget $ liftF $ WidgetStep $ Right { view: mempty, cont: aff }
diff --git a/test/Test/WidgetSpec.purs b/test/Test/WidgetSpec.purs
new file mode 100644
index 0000000..f7059b6
--- /dev/null
+++ b/test/Test/WidgetSpec.purs
@@ -0,0 +1,62 @@
+module Test.WidgetSpec where
+
+import Prelude
+
+import Concur.Core.Types (affAction)
+import Control.MultiAlternative (orr)
+import Data.Time.Duration (Milliseconds(..))
+import Effect.Aff (delay, never)
+import Effect.Class (liftEffect)
+import Effect.Ref as Ref
+import Test.Spec (Spec, describe, it)
+import Test.Spec.Assertions (shouldEqual, shouldReturn)
+import Test.Utils (runWidgetAsAff)
+import Control.Parallel.Class (parallel, sequential)
+import Control.Plus (class Alt, class Plus, alt, empty)
+
+widgetSpec :: Spec Unit
+widgetSpec =
+  describe "Widget" do
+    describe "Aff" do
+      it "Aff cancels running effects" do
+        ref <- liftEffect $ Ref.new ""
+        sequential $ alt
+          (parallel do
+             delay (Milliseconds 100.0)
+             liftEffect $ Ref.write "a" ref)
+          (parallel do
+             delay (Milliseconds 150.0)
+             liftEffect $ Ref.write "b" ref)
+        liftEffect (Ref.read ref) `shouldReturn` "a"
+        delay (Milliseconds 500.0)
+        liftEffect (Ref.read ref) `shouldReturn` "a"
+    describe "orr" do
+      it "should cancel running effects when the widget returns a value" do
+        ref <- liftEffect $ Ref.new ""
+        { views } <- runWidgetAsAff $ orr
+          [ affAction "a" do
+               delay (Milliseconds 100.0)
+               liftEffect $ Ref.write "a" ref
+          , affAction "b" do
+               delay (Milliseconds 150.0)
+               liftEffect $ Ref.write "b" ref
+          ]
+        views `shouldEqual` [ "ab" ]
+        liftEffect (Ref.read ref) `shouldReturn` "a"
+        delay (Milliseconds 100.0)
+        liftEffect (Ref.read ref) `shouldReturn` "a"
+
+      it "should start all the widgets only once" do
+        ref <- liftEffect (Ref.new 0)
+        { result, views } <- runWidgetAsAff $ orr
+          [ do
+               affAction "a0" $ delay (Milliseconds 100.0)
+               affAction "a1" $ delay (Milliseconds 100.0)
+               pure "a"
+          , affAction "b" do
+               liftEffect $ Ref.modify_ (_ + 1) ref
+               never
+          ]
+        result `shouldEqual` "a"
+        views `shouldEqual` [ "a0b", "a1b" ]
+        liftEffect (Ref.read ref) `shouldReturn` 1