Rewrite fell.error to higher order.

project.clj

@@ -4,4 +4,4 @@
   :license {:name "Eclipse Public License"
             :url "http://www.eclipse.org/legal/epl-v10.html"}
   :dependencies [[org.clojure/clojure "1.10.0" :scope "provided"]
-                 [funcool/cats "2.0.0"]])
+                 [funcool/cats "2.2.0"]])

src/fell/core.cljc

@@ -1,8 +1,8 @@
 (ns fell.core
   "The Eff a.k.a. Freer Monad."
   (:require [cats.core :refer [extract]]
-            [fell.eff :refer [#?@(:cljs [Pure Impure]) ->Pure ->Impure]]
-            [fell.queue :refer [singleton-queue append-handler]])
+            [fell.eff :as eff :refer [#?@(:cljs [Pure Impure]) ->Pure ->Impure]]
+            [fell.queue :as q :refer [singleton-queue append-handler]])
   #?(:clj (:import [fell.eff Pure Impure])))
 
 (def pure
@@ -19,6 +19,11 @@
   [request]
   (Impure. request (singleton-queue pure)))
 
+;; TODO: Improve `weave` nomenclature:
+(defn weave [^Impure eff, state handler]
+  (impure (eff/weave (.-request eff) state handler)
+          (q/weave (.-cont eff) state handler)))
+
 (defn handle-relay
   "A generic effect handler that calls `(ret (extract eff))` when `eff` has
   no effects and handles requests tagged with `tag` by calling `(handle request cont)`.

src/fell/error.cljc

@@ -1,24 +1,46 @@
 (ns fell.error
   "Error effect."
-  (:require [cats.monad.either :refer [left right]]
-            [fell.core :refer [pure request-eff handle-relay]]))
+  (:require [cats.core :refer [mlet fmap extract]]
+            [cats.monad.either :as either :refer [left right #?@(:cljs [Left Right])]]
+            [fell.eff :refer [Effect weave #?@(:cljs [Pure Impure])]]
+            [fell.queue :as q :refer [singleton-queue apply-queue]]
+            [fell.core :refer [pure impure request-eff]])
+  #?(:clj (:import [cats.monad.either Left Right]
+                   [fell.eff Pure Impure])))
 
-(defn make
-  "Given the request keyword `tag`, return {:raise [[raise]]-for-`tag`, :run [[run-error]]-for-`tag`}."
-  [tag]
-  {:raise (fn [err] (request-eff [tag err]))
-   :run (fn [eff]
-          (handle-relay tag
-                        (comp pure right)
-                        (fn [[_ err] _] (pure (left err)))
-                        eff))})
+(defrecord Raise [error]
+  Effect
+  (weave [self _ _] self))
 
-(let [{:keys [raise run]} (make ::error)]
-  (def raise
-    "`(raise err)` is an Eff that raises an Error effect `err`."
-    raise)
+(defrecord Handle [body on-error]
+  Effect
+  (weave [_ suspension handler]
+    (Handle. (handler (fmap (constantly body) suspension))
+             (fn [error] (handler (fmap (constantly (on-error error)) suspension))))))
 
-  (def run-error
-    "`(run-error eff)` runs the Error effect in `eff`, returning [[cats.monad.either/left]]
-    if there was an error and [[cats.monad.either/right]] otherwise."
-    run))
+(defn raise [error] (request-eff (Raise. error)))
+
+(defn handle [body on-error] (request-eff (Handle. body on-error)))
+
+(declare run-error)
+
+(defn- resume-error [suspension]
+  (condp instance? suspension
+    Left (pure suspension)
+    Right (run-error (extract suspension))))
+
+(defn run-error [eff]
+  (condp instance? eff
+    Pure (pure (right (extract eff)))
+    Impure (let [request (.-request eff)
+                 cont (.-cont eff)]
+             (condp instance? request
+               Raise (pure (left (.-error request)))
+               Handle (mlet [status (run-error (.-body request))]
+                        (condp instance? status
+                          Left (mlet [status (run-error ((.-on_error request) (extract status)))]
+                                 (condp instance? status
+                                   Left (pure status)
+                                   Right (run-error (apply-queue cont (extract status)))))
+                          Right (run-error (apply-queue cont (extract status)))))
+               (fell.core/weave eff (right nil) resume-error)))))

src/fell/queue.cljc

@@ -30,4 +30,4 @@
   (comp handle (partial apply-queue queue)))
 
 (defn weave [queue state handler]
-  (fn [x] (handler (fmap (constantly (apply-queue queue x)) state))))
+  (singleton-queue (fn [x] (handler (fmap (constantly (apply-queue queue x)) state)))))

src/fell/state.cljc

@@ -1,7 +1,7 @@
 (ns fell.state
   "State effect."
   (:refer-clojure :exclude [get set])
-  (:require [cats.core :refer [extract fmap]]
+  (:require [cats.core :refer [extract]]
             [cats.data :refer [pair]]
             [fell.eff :refer [Effect weave #?@(:cljs [Pure Impure])]]
             [fell.queue :as q :refer [apply-queue]]
@@ -35,12 +35,10 @@
   [eff state]
   (loop [state state, eff eff]
     (condp instance? eff
-      Pure (pair state (extract eff))
+      Pure (pure (pair state (extract eff)))
       Impure (let [request (.-request eff)
                    cont (.-cont eff)]
                (condp instance? request
                  Get (recur state (apply-queue cont state))
                  Set (recur (.-new_value request) (apply-queue cont nil))
-                 (let [suspension (pair state nil)]
-                   (impure (weave request suspension resume-state)
-                           (singleton-queue (q/weave cont suspension resume-state)))))))))
+                 (fell.core/weave eff (pair state nil) resume-state))))))