Remove Props. Add elArr'

Author: ajnsit

src/Concur/Core/DOM.purs

@@ -10,7 +10,6 @@ import Data.Functor (class Functor, map)
 import Data.Unit (Unit)
 import Effect (Effect)
 
--- A view adapter for when the view is an array
 viewAdapter
   :: forall ps vs res
    . (ps -> vs -> res)
@@ -29,7 +28,7 @@ el
   -> m a
 el e props = shiftMap (\f w -> mkNodeWidget (\h v -> (e (map (map (h <<< f)) props) v)) w)
 
--- | el, but for array views
+-- | el for array views
 elArr
   :: forall f p v m a
    . ShiftMap (Widget (Array v)) m
@@ -52,7 +51,7 @@ elLeaf
   -> m a
 elLeaf e props = liftWidget $ mkLeafWidget \h -> e (map (map h) props)
 
--- | elLeaf but for array views
+-- | elLeaf for array views
 elLeafArr
   :: forall f p v m a
    . LiftWidget (Array v) m
@@ -65,6 +64,19 @@ elLeafArr e props = liftWidget $ mkLeafWidget \h -> [ e (map (map 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
+  => Functor p
+  => (f (p (Effect Unit)) -> v -> v)
+  -> f (p a)
+  -> Array (m a)
+  -> m a
+el' e props = el e props <<< orr
+
+-- | el' for array views
+elArr'
   :: forall f p v m a
    . ShiftMap (Widget (Array v)) m
   => MultiAlternative m
@@ -74,4 +86,5 @@ el'
   -> f (p a)
   -> Array (m a)
   -> m a
-el' e props = el (viewAdapter e) props <<< orr
+elArr' e props = el (viewAdapter e) props <<< orr
+

src/Concur/Core/LiftWidget.purs

@@ -2,39 +2,14 @@ module Concur.Core.LiftWidget where
 
 import Concur.Core.Types (Widget)
 import Control.Monad (class Monad)
-import Control.Monad.Except.Trans (ExceptT)
-import Control.Monad.RWS.Trans (RWST)
-import Control.Monad.Reader.Trans (ReaderT)
-import Control.Monad.State.Trans (StateT)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Writer.Trans (WriterT)
+import Control.Monad.Trans.Class (class MonadTrans, lift)
 import Data.Function (identity, (<<<))
-import Data.Monoid (class Monoid)
 
--- | A way to lift widgets into higher monads
 class LiftWidget v m where
   liftWidget :: forall a. Widget v a -> m a
 
--- TODO: LiftWidget instance for all transformers
--- instance liftWidgetTrans :: (Monad m, MonadTrans t, LiftWidget v m) => LiftWidget v (t m) where
---   liftWidget = lift <<< liftWidget
-
--- Trivial self instance
-instance widgetLiftWidget :: LiftWidget v (Widget v) where
+instance LiftWidget v (Widget v) where
   liftWidget = identity
-
--- Instances for common transformers
-instance exceptLiftWidget :: (Monad m, LiftWidget v m) => LiftWidget v (ExceptT e m) where
+else instance (Monad m, MonadTrans t, LiftWidget v m) => LiftWidget v (t m) where
   liftWidget = lift <<< liftWidget
 
-instance rwsLiftWidget :: (Monoid w, Monad m, LiftWidget v m) => LiftWidget v (RWST r w s m) where
-  liftWidget = lift <<< liftWidget
-
-instance readerLiftWidget :: (Monad m, LiftWidget v m) => LiftWidget v (ReaderT r m) where
-  liftWidget = lift <<< liftWidget
-
-instance stateLiftWidget :: (Monad m, LiftWidget v m) => LiftWidget v (StateT s m) where
-  liftWidget = lift <<< liftWidget
-
-instance writerLiftWidget :: (Monoid s, Monad m, LiftWidget v m) => LiftWidget v (WriterT s m) where
-  liftWidget = lift <<< liftWidget

src/Concur/Core/Patterns.purs

@@ -37,7 +37,9 @@ retryUntilLoop :: forall m a. Monad m => (a -> Boolean) -> (a -> m a) -> a -> m
 retryUntilLoop p w a = w a >>= \a' -> if p a' then pure a' else retryUntilLoop p w a'
 
 -- | The Elm Architecture
-tea :: forall a s m x. Monad m
+tea
+  :: forall a s m x
+   . Monad m
   => s
   -> (s -> m a)
   -> (a -> s -> s)
@@ -54,7 +56,7 @@ type RemoteInterface v a =
 -- | Separate the UI from the widget result
 remoteWidget
   :: forall m v a
-  .  Monoid v
+   . Monoid v
   => MonadEffect m
   => Widget v a
   -> m (RemoteInterface v a)
@@ -63,20 +65,20 @@ remoteWidget axn = do
   pure { yield: yield remoteCb, render: render remoteCb }
   where
   yield remoteCb = mkWidget \cb -> do
-    Ref.modify_ (_ <> [cb]) remoteCb
+    Ref.modify_ (_ <> [ cb ]) remoteCb
     pure do
       Ref.modify_ (Array.deleteBy unsafeRefEq cb) remoteCb
   render remoteCb = do
     val <- axn
     liftEffect do
-       Ref.read remoteCb >>= traverse_ \cb -> cb (Completed val)
+      Ref.read remoteCb >>= traverse_ \cb -> cb (Completed val)
 
 -- | Internalise state
 -- The resulting widget can be rescheduled multiple
 -- times and will retain its state internally
 internalise
   :: forall m v a b
-  .  Monoid v
+   . Monoid v
   => MonadEffect m
   => (a -> Widget v a)
   -> a
@@ -106,28 +108,32 @@ derive instance newtypeWire :: Newtype (Wire m a) _
 -- | Map a Lens over a Wire
 mapWire :: forall m s a. Alt m => MonadEffect m => Plus m => Lens' s a -> Wire m s -> Wire m a
 mapWire lens wire =
-  let wirerec = un Wire wire
-  in Wire { value: L.view lens <$> wirerec.value
-          , send: \a -> wirerec.value >>= (wirerec.send <<< L.set lens a)
-          , receive: L.view lens <$> wirerec.receive
-          }
+  let
+    wirerec = un Wire wire
+  in
+    Wire
+      { value: L.view lens <$> wirerec.value
+      , send: \a -> wirerec.value >>= (wirerec.send <<< L.set lens a)
+      , receive: L.view lens <$> wirerec.receive
+      }
 
 -- | Setup a local environment with a wire
 local :: forall v r a. Monoid v => a -> (Wire (Widget v) a -> Widget v r) -> Widget v r
 local ainit f = do
   currentVal <- liftEffect $ Ref.new ainit
   remoteCb <- liftEffect $ Ref.new $ pure $ case _ of
-     Completed a -> Ref.write a currentVal
-     _ -> pure unit
-  let wire = Wire
-       { value: Ref.read currentVal
-       , send: \a -> do
-           Ref.read remoteCb >>= traverse_ \cb -> cb (Completed a)
-       , receive: mkWidget \cb -> do
-           Ref.modify_ (_ <> [cb]) remoteCb
-           pure do 
-              Ref.modify_ (Array.deleteBy unsafeRefEq cb) remoteCb
-       }
+    Completed a -> Ref.write a currentVal
+    _ -> pure unit
+  let
+    wire = Wire
+      { value: Ref.read currentVal
+      , send: \a -> do
+          Ref.read remoteCb >>= traverse_ \cb -> cb (Completed a)
+      , receive: mkWidget \cb -> do
+          Ref.modify_ (_ <> [ cb ]) remoteCb
+          pure do
+            Ref.modify_ (Array.deleteBy unsafeRefEq cb) remoteCb
+      }
   f wire
 
 send :: forall m a. MonadEffect m => Plus m => Wire m a -> a -> m Unit

src/Concur/Core/Props.purs

@@ -24,7 +24,6 @@ import Effect (Effect)
 import Effect.Class (class MonadEffect)
 import Effect.Ref as Ref
 
--- | Callback -> Effect Canceler (returns the unused effect)
 newtype Callback a = Callback (Callback' a)
 
 derive instance Newtype (Callback a) _
@@ -39,7 +38,7 @@ result f g = case _ of
   View v -> f v
   Completed a -> g a
 
-instance functorResult :: Functor (Result v) where
+instance Functor (Result v) where
   map _ (View v) = View v
   map f (Completed a) = Completed (f a)
 
@@ -54,7 +53,7 @@ mkCallback = Callback
 runCallback :: forall a. Callback a -> Callback' a
 runCallback (Callback f) = f
 
-instance functorCallback :: Functor Callback where
+instance Functor Callback where
   map f c = mkCallback \cb -> runCallback c (cb <<< f)
 
 -- | A callback that will never be resolved
@@ -64,7 +63,7 @@ never = mkCallback mempty
 -- NOTE: We currently have no monadic instance for callbacks
 -- Remember: The monadic instance *must* agree with the applicative instance
 
-instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where
+instance ShiftMap (Widget v) (Widget v) where
   shiftMap f = f identity
 
 -- A Widget is basically a callback that returns a view or a return value
@@ -86,20 +85,20 @@ mkWidget e = Widget (Callback e)
 mapView :: forall u v a. (u -> v) -> Widget u a -> Widget v a
 mapView f (Widget w) = Widget (map (mapViewResult f) w)
 
-instance applyWidget :: Apply (Widget v) where
+instance Apply (Widget v) where
   apply = ap
 
-instance widgetMonad :: Monad (Widget v)
+instance Monad (Widget v)
 
-instance applicativeWidget :: Applicative (Widget v) where
+instance Applicative (Widget v) where
   pure a = mkWidget \cb -> cb (Completed a) $> pure mempty
 
-instance monadRecWidget :: MonadRec (Widget v) where
+instance MonadRec (Widget v) where
   tailRecM k a = k a >>= case _ of
     Loop x -> tailRecM k x
     Done y -> pure y
 
-instance bindWidget :: Bind (Widget v) where
+instance Bind (Widget v) where
   bind m f = mkWidget \cb -> do
     -- CancelerRef starts out as a canceler for A, then becomes canceler for B
     cancelerRef <- Ref.new mempty
@@ -140,7 +139,7 @@ initialised = case _ of
   Initialising -> Initialised
   a -> a
 
-instance widgetMultiAlternative :: Monoid v => MultiAlternative (Widget v) where
+instance Monoid v => MultiAlternative (Widget v) where
   orr :: forall a. Array (Widget v a) -> Widget v a
   orr widgets = mkWidget \cb -> do
     viewsRef <- Ref.new (A.replicate (A.length widgets) mempty)
@@ -169,22 +168,21 @@ instance widgetMultiAlternative :: Monoid v => MultiAlternative (Widget v) where
     cb (View (fold views))
     pure runCancelers
 
-instance widgetSemigroup :: (Monoid v) => Semigroup (Widget v a) where
+instance (Monoid v) => Semigroup (Widget v a) where
   append w1 w2 = orr [ w1, w2 ]
 
-instance widgetMonoid :: (Monoid v) => Monoid (Widget v a) where
+instance (Monoid v) => Monoid (Widget v a) where
   mempty = empty
 
-instance widgetAlt :: (Monoid v) => Alt (Widget v) where
+instance (Monoid v) => Alt (Widget v) where
   alt = append
 
-instance widgetPlus :: (Monoid v) => Plus (Widget v) where
+instance (Monoid v) => Plus (Widget v) where
   empty = display mempty
 
-instance widgetAlternative :: (Monoid v) => Alternative (Widget v)
+instance (Monoid v) => Alternative (Widget v)
 
--- Sync eff
-instance widgetMonadEff :: (Monoid v) => MonadEffect (Widget v) where
+instance (Monoid v) => MonadEffect (Widget v) where
   liftEffect eff = mkWidget \cb -> do
     a <- eff
     cb (Completed a)