Skip to content

Commit

Permalink
Reduce label boilerplate with ML functor emulation.
Browse files Browse the repository at this point in the history
  • Loading branch information
Pauli Jaakkola committed Sep 4, 2020
1 parent 1b8ee7e commit 9a2c44b
Show file tree
Hide file tree
Showing 6 changed files with 130 additions and 158 deletions.
10 changes: 7 additions & 3 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,11 +12,15 @@ Don't.
(ns fell.example
(:require [cats.core :refer [mlet return]]
[fell.core :as fell :refer [request-eff]]
[fell.reader :as r :refer [ask]]
[fell.reader :as r]
[fell.state :as state]))

;; Workaround for lack of parametric modules.
;; Could use singletons instead, but fn usages would be more verbose.
(let [{ask :ask, run-reader :run} (r/make ::reader)]
(def ask ask)
(def run-reader run-reader))

(let [{get-counter :get, set-counter :set, run-counter :run} (state/make ::counter)]
(def get-counter get-counter)
(def set-counter set-counter)
Expand All @@ -38,9 +42,9 @@ Don't.

(-> stateful-computation
(run-counter 8)
(r/run 17)
(run-reader 17)
(run-status "Asleep")
fell/run) ;=> [["Asleep" 25] "Energy: 8"]
fell/run) ;=> #<Pair ["Energy: 8" #<Pair [25 "Asleep"]>]>
```

## TODO
Expand Down
62 changes: 28 additions & 34 deletions src/fell/error.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,40 +20,34 @@
(fn [error] (resume (fmap (constantly (on-error error)) suspension))))]
(comp resume (partial fmap cont)))))

(defn raise
"An Eff which raises `error`."
[label error]
(request-eff [label (Raise. error)]))
(defn make [label]
(letfn [(raise [error] (request-eff [label (Raise. error)]))

(defn handle
"An Eff which handles Errors in `body` with `on-error` a fn from the error to an Eff."
[label body on-error]
(request-eff [label (Handle. body on-error)]))
(handle [body on-error] (request-eff [label (Handle. body on-error)]))

(declare run)
(resume [suspension]
(condp instance? suspension
Left (pure suspension)
Right (run (extract suspension))))

(defn- resume [label suspension]
(condp instance? suspension
Left (pure suspension)
Right (run (extract suspension) label)))

(defn run
"Run the Error effect in the Eff `eff`."
[eff label]
(condp instance? eff
Pure (pure (right (extract eff)))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Raise (pure (left (.-error ^Raise op)))
Handle (mlet [:let [^Handle request op]
status (run (.-body request) label)]
(condp instance? status
Left (mlet [status (run ((.-on_error request) (extract status)) label)]
(condp instance? status
Left (pure status)
Right (run (k (extract status)) label)))
Right (run (k (extract status)) label))))
(fell.core/weave eff (right nil) (partial resume label))))))
(run [eff]
(condp instance? eff
Pure (pure (right (extract eff)))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Raise (pure (left (.-error ^Raise op)))
Handle (mlet [:let [^Handle request op]
status (run (.-body request))]
(condp instance? status
Left (mlet [status (run ((.-on_error request) (extract status)))]
(condp instance? status
Left (pure status)
Right (run (k (extract status)))))
Right (run (k (extract status))))))
(fell.core/weave eff (right nil) resume)))))]
{:raise raise #_"An Eff which raises `error`."
:handle handle #_"An Eff which handles Errors in `body` with `on-error` a fn from the error to an Eff."
:run run})) #_"Run the Error effect in the Eff `eff`."
42 changes: 19 additions & 23 deletions src/fell/lift.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,28 +16,24 @@
Effect
(weave [_ labeled cont suspension resume] (first-order-weave labeled cont suspension resume)))

(defn lift
"Lift the monadic value `mv` into Eff."
[label mv]
(request-eff [label (Lift. mv)]))
(defn make [label]
(letfn [(lift [mv] (request-eff [label (Lift. mv)]))

(declare run)
(resume [^Pair suspension] (run (.-snd suspension) (.-fst suspension)))

(defn- resume [label ^Pair suspension] (run (.-snd suspension) label (.-fst suspension)))

(defn run
"Handle the Lift effect in the Cats Monad determined by the [[cats.protocols.Context] `context`.
All other effects must already be handled."
[eff label context]
(condp instance? eff
Pure (return context (extract eff))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Lift (-mbind context
(.-lifted_mv ^Lift op)
(cont/weave k (pair context nil) (partial resume label))))
(throw (#?(:clj RuntimeException., :cljs js/Error.)
(str "unhandled effect " (pr-str (.-request eff)))))))))
(run [eff context]
(condp instance? eff
Pure (return context (extract eff))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Lift (-mbind context
(.-lifted_mv ^Lift op)
(cont/weave k (pair context nil) resume)))
(throw (#?(:clj RuntimeException., :cljs js/Error.)
(str "unhandled effect " (pr-str (.-request eff)))))))))]
{:lift lift #_"Lift the monadic value `mv` into Eff."
:run run})) #_"Handle the Lift effect in the Cats Monad determined by the [[cats.protocols.Context] `context`.
All other effects must already be handled."
49 changes: 21 additions & 28 deletions src/fell/reader.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,33 +18,26 @@
(impure [label (Local. f (resume (fmap (constantly body) suspension)))]
(comp resume (partial fmap cont)))))

(defn ask
"An Eff which gets the Reader value."
[label]
(request-eff [label (Ask.)]))
(defn make [label]
(let [ask (request-eff [label (Ask.)])]
(letfn [(local [f body] (request-eff [label (Local. f body)]))

(defn local
"An Eff which uses `(f old-reader-value)` as the Reader value in `body`."
[label f body]
(request-eff [label (Local. f body)]))
(resume [^Pair suspension] (run (.-snd suspension) (.-fst suspension)))

(declare run)

(defn- resume [label ^Pair suspension] (run (.-fst suspension) label (.-snd suspension)))

(defn run
"Handle Reader effects in `eff` using `env` as the Reader value."
[eff label env]
(loop [eff eff]
(condp instance? eff
Pure eff
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Ask (recur (k env))
Local (mlet [:let [^Local request op]
v (run (.-body request) label ((.-f request) env))]
(run (k v) label env)))
(fell.core/weave eff (pair env nil) (partial resume label)))))))
(run [eff env]
(loop [eff eff]
(condp instance? eff
Pure eff
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Ask (recur (k env))
Local (mlet [:let [^Local request op]
v (run (.-body request) ((.-f request) env))]
(run (k v) env)))
(fell.core/weave eff (pair env nil) resume))))))]
{:ask ask #_"An Eff which gets the Reader value."
:local local #_"An Eff which uses `(f old-reader-value)` as the Reader value in `body`."
:run run}))) #_"Handle Reader effects in `eff` using `env` as the Reader value."
45 changes: 19 additions & 26 deletions src/fell/state.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,31 +17,24 @@
Effect
(weave [_ labeled cont suspension resume] (first-order-weave labeled cont suspension resume)))

(defn get
"An Eff that gets the State state value."
[label]
(request-eff [label (Get.)]))
(defn make [label]
(let [get (request-eff [label (Get.)])]
(letfn [(set [value*] (request-eff [label (Set. value*)]))

(defn set
"`(set value*)` is an Eff that sets the State state value to `value*`."
[label value*]
(request-eff [label (Set. value*)]))
(resume [^Pair suspension] (run (.-snd suspension) (.-fst suspension)))

(declare run)

(defn- resume [label ^Pair suspension] (run (.-snd suspension) label (.-fst suspension)))

(defn run
"Handle State effects in the Eff `eff` using `state` as the initial state value."
[eff label state]
(loop [state state, eff eff]
(condp instance? eff
Pure (pure (pair state (extract eff)))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Get (recur state (k state))
Set (recur (.-new_value ^Set op) (k nil)))
(fell.core/weave eff (pair state nil) (partial resume label)))))))
(run [eff state]
(loop [state state, eff eff]
(condp instance? eff
Pure (pure (pair state (extract eff)))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Get (recur state (k state))
Set (recur (.-new_value ^Set op) (k nil)))
(fell.core/weave eff (pair state nil) resume))))))]
{:get get #_"An Eff that gets the State state value."
:set set #_"`(set value*)` is an Eff that sets the State state value to `value*`."
:run run}))) #_"Handle State effects in the Eff `eff` using `state` as the initial state value."
80 changes: 36 additions & 44 deletions src/fell/writer.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,47 +25,39 @@
(impure [label (Pass. (resume (fmap (constantly suspension) body)))]
(q/singleton-queue (comp resume (partial fmap cont))))))

(defn tell
"An Eff which outputs `message`."
[label message]
(request-eff [label (Tell. message)]))

(defn listen
"An Eff that pairs the result value of `body` with the Writer output from `body`."
[label body]
(request-eff [label (Listen. body)]))

(defn pass
"An Eff which maps the first field of the [[cats.data.Pair]] result value of `body` over
Writer messages from `body`."
[label body]
(request-eff [label (Pass. body)]))

(declare resume run)

(defn- resume* [label output eff]
(condp instance? eff
Pure (pure (pair output (extract eff)))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Tell (recur label (mappend output (.-message ^Tell op)) (k nil))
Listen (mlet [^Pair result (run (.-body ^Listen op) label (ctx/infer output))
:let [output* (.-fst result)]]
(resume* label (mappend output output*) (k result)))
Pass (mlet [^Pair result (run (.-body ^Pass op) label (ctx/infer output))
:let [output* (.-fst result)
^Pair vs (.-snd result)
f (.-fst vs)
v (.-snd vs)]]
(resume* label (mappend output (f output*)) (k v))))
(fell.core/weave eff (pair output nil) (partial resume label))))))

(defn- resume [label ^Pair suspension] (resume* label (.-fst suspension) (.-snd suspension)))

(defn run
"Handle Writer effects in `body` using the Cats Monoid [[cats.protocols.Context]] `context`."
[eff label context]
(resume* label (mempty context) eff))
(defn make [label]
(letfn [(tell [message] (request-eff [label (Tell. message)]))

(listen [body] (request-eff [label (Listen. body)]))

(pass [body] (request-eff [label (Pass. body)]))

(resume* [output eff]
(condp instance? eff
Pure (pure (pair output (extract eff)))
Impure (let [^Impure eff eff
[request-label op] (.-request eff)
k (partial q/apply-queue (.-cont eff))]
(if (= request-label label)
(condp instance? op
Tell (recur (mappend output (.-message ^Tell op)) (k nil))
Listen (mlet [^Pair result (run (.-body ^Listen op) (ctx/infer output))
:let [output* (.-fst result)]]
(resume* (mappend output output*) (k result)))
Pass (mlet [^Pair result (run (.-body ^Pass op) (ctx/infer output))
:let [output* (.-fst result)
^Pair vs (.-snd result)
f (.-fst vs)
v (.-snd vs)]]
(resume* (mappend output (f output*)) (k v))))
(fell.core/weave eff (pair output nil) resume)))))

(resume [label ^Pair suspension] (resume* label (.-fst suspension) (.-snd suspension)))

(run [eff label context]
(resume* label (mempty context) eff))]
{:tell tell #_"An Eff which outputs `message`."
:listen listen #_"An Eff that pairs the result value of `body` with the Writer output from `body`."
:pass pass #_"An Eff which maps the first field of the [[cats.data.Pair]] result value of `body` over
Writer messages from `body`."
:run run})) #_"Handle Writer effects in `body` using the Cats Monoid [[cats.protocols.Context]] `context`."

0 comments on commit 9a2c44b

Please sign in to comment.