Add some more interfaces to concur-core

Author: ajnsit

spago.dhall

@@ -15,6 +15,7 @@ You can edit this file as you like.
   , "maybe"
   , "newtype"
   , "prelude"
+  , "profunctor-lenses"
   , "refs"
   , "tailrec"
   , "transformers"

src/Concur/Core.purs

@@ -10,21 +10,16 @@ import Data.Monoid (mempty)
 import Effect (Effect)
 import Prelude (Unit, discard, pure, ($))
 
--- Helpers for some very common use of unsafe blocking io
-
 -- | Construct a widget, by wrapping an existing widget in a view event
 mkNodeWidget
   :: forall a v
    . ((a -> Effect Unit) -> v -> v)
   -> Widget v a
   -> Widget v a
-mkNodeWidget mkView w = mkWidget \cb -> do
-  runWidget w (f cb)
-  where
-  f cb = \x -> case x of
-    View vc -> cb (View $ vp vc cb)
+mkNodeWidget mkView w = mkWidget \cb ->
+  runWidget w $ case _ of
+    View v -> cb (View $ mkView (\a -> cb (Completed a)) v)
     Completed a -> cb (Completed a)
-  vp vc cb = mkView (\a -> cb (Completed a)) vc
 
 -- | Construct a widget with just props
 mkLeafWidget
@@ -36,3 +31,4 @@ mkLeafWidget mkView = mkWidget \cb -> do
   pure mempty
   where
   v cb = mkView (\a -> cb (Completed a))
+

src/Concur/Core/DOM.purs

@@ -2,42 +2,76 @@ 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)
+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)
+  -> (ps -> vs -> Array res)
+viewAdapter f = \ps vs -> [ f ps vs ]
 
 -- | 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)
+  => Functor p
+  => (f (p (Effect Unit)) -> v -> v)
+  -> f (p a)
+  -> m a
+  -> m a
+el e props = shiftMap (\f w -> mkNodeWidget (\h v -> (e (map (map (h <<< f)) props) v)) w)
+
+-- | el, but for array views
+elArr
+  :: forall f p v m a
+   . ShiftMap (Widget (Array v)) m
+  => Functor f
+  => Functor p
+  => (f (p (Effect Unit)) -> Array v -> v)
+  -> f (p a)
   -> m a
   -> m a
-el e props = shiftMap (\f w -> mkNodeWidget (\h v -> (e (map (mkProp h <<< map f) props) v)) w)
+elArr e props = shiftMap (\f w -> mkNodeWidget (\h v -> (viewAdapter e (map (map (h <<< 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)
+  => Functor p
+  => (f (p (Effect Unit)) -> v)
+  -> f (p a)
   -> m a
-elLeaf e props = liftWidget $ mkLeafWidget \h -> e (map (mkProp h) props)
+elLeaf e props = liftWidget $ mkLeafWidget \h -> e (map (map h) props)
+
+-- | elLeaf but for array views
+elLeafArr
+  :: forall f p v m a
+   . LiftWidget (Array v) m
+  => Functor f
+  => Functor p
+  => (f (p (Effect Unit)) -> v)
+  -> f (p a)
+  -> m a
+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
+   . ShiftMap (Widget (Array v)) m
   => MultiAlternative m
   => Functor f
-  => (f p -> v -> v)
-  -> f (Props p a)
+  => Functor p
+  => (f (p (Effect Unit)) -> Array v -> v)
+  -> f (p a)
   -> Array (m a)
   -> m a
-el' e props = el e props <<< orr
+el' e props = el (viewAdapter e) props <<< orr

src/Concur/Core/Types.purs

@@ -13,7 +13,7 @@ import Data.Array as A
 import Data.Either (Either(..))
 import Data.Foldable (fold)
 import Data.Function (identity, ($), (<<<))
-import Data.Functor (class Functor, void, ($>))
+import Data.Functor (class Functor, void, ($>), map)
 import Data.Maybe (Maybe(..))
 import Data.Monoid (class Monoid, mempty)
 import Data.Newtype (class Newtype)
@@ -26,15 +26,28 @@ import Effect.Ref as Ref
 
 -- | Callback -> Effect Canceler (returns the unused effect)
 newtype Callback a = Callback (Callback' a)
+
+derive instance Newtype (Callback a) _
+
 type Callback' a = (a -> Effect Unit) -> Effect Canceler
 type Canceler = Effect Unit
 
 data Result v a = View v | Completed a
 
+result :: forall v a r. (v -> r) -> (a -> r) -> Result v a -> r
+result f g = case _ of
+  View v -> f v
+  Completed a -> g a
+
 instance functorResult :: Functor (Result v) where
   map _ (View v) = View v
   map f (Completed a) = Completed (f a)
 
+mapViewResult :: forall u v a. (u -> v) -> Result u a -> Result v a
+mapViewResult f = case _ of
+  View u -> View (f u)
+  Completed a -> Completed a
+
 mkCallback :: forall a. Callback' a -> Callback a
 mkCallback = Callback
 
@@ -57,9 +70,9 @@ instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where
 -- A Widget is basically a callback that returns a view or a return value
 newtype Widget v a = Widget (Callback (Result v a))
 
-derive instance functorWidget :: Functor (Widget v)
+derive instance Functor (Widget v)
 
-instance newtypeWidget :: Newtype (Widget v a) (Callback (Result v a))
+derive instance Newtype (Widget v a) _
 
 unWid :: forall v a. Widget v a -> Callback (Result v a)
 unWid (Widget w) = w
@@ -70,6 +83,9 @@ runWidget (Widget (Callback e)) = e
 mkWidget :: forall v a. Callback' (Result v a) -> Widget v a
 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
   apply = ap
 

src/Control/ShiftMap.purs

@@ -19,17 +19,18 @@ class ShiftMap s t where
 -- Instances for common transformers
 -- It's not possible to use the `map*` functions anymore
 
-instance exceptShiftMap :: ShiftMap m (ExceptT e m) where
+instance ShiftMap m (ExceptT e m) where
   shiftMap f (ExceptT m) = ExceptT do f Right m
 
-instance rwsShiftMap :: Monoid w => ShiftMap m (RWST r w s m) where
+instance Monoid w => ShiftMap m (RWST r w s m) where
   shiftMap f (RWST g) = RWST \r s -> f (\a -> RWSResult s a mempty) (g r s)
 
-instance readerShiftMap :: ShiftMap m (ReaderT r m) where
+instance ShiftMap m (ReaderT r m) where
   shiftMap f (ReaderT m) = ReaderT \r -> f identity (m r)
 
-instance stateShiftMap :: Monad m => ShiftMap m (StateT s m) where
+instance Monad m => ShiftMap m (StateT s m) where
   shiftMap f (StateT g) = StateT \s -> f (\a -> Tuple a s) (g s)
 
-instance writerShiftMap :: Monoid w => ShiftMap m (WriterT w m) where
+instance Monoid w => ShiftMap m (WriterT w m) where
   shiftMap f (WriterT m) = WriterT do f (\a -> Tuple a mempty) m
+