Async performAction

bower.json

@@ -16,6 +16,10 @@
     "url": "git://github.com/paf31/purescript-thermite.git"
   },
   "dependencies": {
+    "purescript-aff": "*",
+    "purescript-bifunctors": "*",
+    "purescript-freet": "*",
+    "purescript-coroutines": "*",
     "purescript-dom": "^0.2.6",
     "purescript-profunctor-lenses": "~0.5.0",
     "purescript-react": "^0.6.0",

src/Thermite.purs

@@ -11,7 +11,9 @@
 -- | Thermite also provides type class instances and lens combinators for composing `Spec`s.
 
 module Thermite
-  ( PerformAction()
+  ( Thermite
+  , Query
+  , PerformAction()
   , defaultPerformAction
   , EventHandler()
   , Render()
@@ -28,33 +30,73 @@ module Thermite
   , match
   , split
   , foreach
+  , get
+  , modify
+  , mapQuery
   ) where
 
 import Prelude
 
+import Data.Bifunctor (bimap)
+import Data.Bifunctor as B
 import Data.Lens
 import Data.List
 import Data.Tuple
 import Data.Either
+import Data.Identity
 import Data.Maybe
 import Data.Monoid
 import Data.Foldable (for_)
 
+import Control.Coroutine
+import Control.Monad.Aff (Aff, later, makeAff, launchAff)
 import Control.Monad.Eff
-import Control.Monad.Eff.Unsafe
+import Control.Monad.Eff.Class (liftEff)
+import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
+import Control.Monad.Free.Trans
+import Control.Monad.Rec.Class
+
+import Debug.Trace
+
+data Query s a = Get (s -> a) | Modify (s -> s) a
+
+mapQuery :: forall st1 st2 a. (st1 -> st2) -> ((st2 -> st2) -> (st1 -> st1)) -> Query st2 a -> Query st1 a
+mapQuery get _ (Get k) = Get (k <<< get)
+mapQuery _ set (Modify k c) = Modify (set k) c
+
+instance queryFunctor :: Functor (Query s) where
+  map f (Get k) = Get (f <<< k)
+  map f (Modify g next) = Modify g (f next)
+
+type Thermite s = Co (Query s)
+
+runThermite :: forall s m a. (MonadRec m) => Thermite s m a -> m s -> ((s -> s) -> m Unit) -> m a
+runThermite th get modify = runFreeT eval th
+  where
+    eval (Get k) = do
+      st <- get
+      return (k st)
+    eval (Modify k next) = do
+      modify k
+      return next
+
+get :: forall s m. (Monad m) => Thermite s m s
+get = liftFreeT (Get id)
+
+modify :: forall s m. (Monad m) => (s -> s) -> Thermite s m Unit
+modify f = liftFreeT (Modify f unit)
 
 -- | A type synonym for action handlers, which take an action, the current properties
 -- | for the component, and a state update function, and return a computation in the `Eff` monad.
 type PerformAction eff state props action =
   action ->
   props ->
   state ->
-  ((state -> state) -> Eff eff Unit) ->
-  Eff eff Unit
+  Thermite state (Aff eff) Unit
 
 -- | A default `PerformAction` action implementation which ignores all actions.
 defaultPerformAction :: forall eff state props action. PerformAction eff state props action
-defaultPerformAction _ _ _ _ = pure unit
+defaultPerformAction _ _ _ = pure unit
 
 -- | A type synonym for an event handler which can be used to construct
 -- | `purescript-react`'s event attributes.
@@ -142,13 +184,13 @@ simpleSpec performAction render =
 
 instance semigroupSpec :: Semigroup (Spec eff state props action) where
   append (Spec spec1) (Spec spec2) =
-    Spec { performAction:       \a p s k -> do spec1.performAction a p s k
-                                               spec2.performAction a p s k
+    Spec { performAction:       \a p s -> do spec1.performAction a p s
+                                             spec2.performAction a p s
          , render:              \k p s   -> spec1.render k p s       <> spec2.render k p s
          }
 
 instance monoidSpec :: Monoid (Spec eff state props action) where
-  mempty = simpleSpec (\_ _ _ _ -> pure unit)
+  mempty = simpleSpec (\_ _ _ -> pure unit)
                       (\_ _ _ _ -> [])
 
 -- | Create a React component class from a Thermite component `Spec`.
@@ -176,7 +218,16 @@ createReactSpec (Spec spec) state =
   dispatch this action = do
     props <- React.getProps this
     state <- React.readState this
-    unsafeInterleaveEff $ spec.performAction action props state (void <<< unsafeInterleaveEff <<< React.transformState this)
+
+    let forgetEff :: forall eff1 a. Eff eff1 a -> Eff eff a
+        forgetEff = unsafeInterleaveEff
+
+        get = liftEff $ forgetEff $ React.readState this
+        modify' k = makeAff \_ success -> unsafeInterleaveEff $ do
+          st <- React.readState this
+          void $ React.writeStateWithCallback this (k st) (unsafeInterleaveEff $ success unit)
+
+    unsafeInterleaveEff $ launchAff $ runThermite (spec.performAction action props state) get modify'
 
   render :: React.Render props state eff
   render this = map React.DOM.div' $
@@ -227,10 +278,10 @@ focus lens prism (Spec spec) = Spec
   }
   where
   performAction :: PerformAction eff state2 props action2
-  performAction a p st k =
+  performAction a p st =
     case matching prism a of
       Left _ -> pure unit
-      Right a' -> spec.performAction a' p (view lens st) (k <<< over lens)
+      Right a' -> bimapFreeT (mapQuery (view lens) (over lens)) id $ spec.performAction a' p (view lens st)
 
   render :: Render state2 props action2
   render k p st = spec.render (k <<< review prism) p (view lens st)
@@ -252,6 +303,7 @@ match prism = focus id prism
 
 -- | Create a component which renders an optional subcomponent.
 split :: forall eff props state1 state2 action.
+  Monoid state2 =>
   PrismP state1 state2 ->
   Spec eff state2 props action ->
   Spec eff state1 props action
@@ -261,10 +313,10 @@ split prism (Spec spec) = Spec
   }
   where
   performAction :: PerformAction eff state1 props action
-  performAction a p st k =
+  performAction a p st =
     case matching prism st of
       Left _ -> pure unit
-      Right st' -> spec.performAction a p st' (k <<< over prism)
+      Right st' -> bimapFreeT (mapQuery (view prism) (over prism)) id $ spec.performAction a p st'
 
   render :: Render state1 props action
   render k p st children =
@@ -286,8 +338,8 @@ foreach f = Spec
   }
   where
   performAction :: PerformAction eff (List state) props (Tuple Int action)
-  performAction (Tuple i a) p sts k =
-    for_ (sts !! i) \st -> case f i of Spec s -> s.performAction a p st (k <<< modifying i)
+  performAction (Tuple i a) p sts =
+    for_ (sts !! i) \st -> case f i of Spec s -> bimapFreeT (mapQuery (const st) (modifying i)) id $ s.performAction a p st
     where
     modifying :: Int -> (state -> state) -> List state -> List state
     modifying i f sts' = fromMaybe sts' (modifyAt i f sts')