Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
(ns hyperfiddle.via
[meander.epsilon :as m :refer [match]]
[meander.strategy.epsilon :as r]
[minitest :refer [tests]]))
; Goal here is to implement async/await sugar like this:
(via* (->Maybe)
(for [a ~(pure 1)
b ~(+ a ~(pure 42))
c 1]
(pure (+ a b c))))
=> #:Maybe{:just 45}
; This has applications in using event-streams for UI programming in an ergonomic way
; (no r/atoms, UI is an expression)
; This approach is term rewriting
(do> (~f ~a b ...)) => (fapply f a (pure b)) ; applicative await
(do> (for [a ~(f ...) ...])) => (mlet [a (f ...)] ...) ; monad await (flattened notation, later callbackified)
(do> (x ~(y ~z)) => ((comp x y) ~z) => (fmap (comp x y) z)) ; optimize based on laws (todo)
;(declare mlet pure fmap fapply bind) ; free symbols without ns or definition
(defn unquote-in-form? [form]
(m/find form
(m/scan (`unquote _)) ; (inc ~a b) but not (a (b ~c)) nor (inc a) nor ~a
(defn rewrite-binds [binds]
(->> (partition 2 binds)
(mapcat (fn [binding]
(m/match binding
(?k (`unquote ?form)) ; [a ~(just 1)]
[?k ?form] ; {a (just 1)}
(?k ?form) (m/subst [?k (pure ?form)]))))
vec #_(apply ordered-map)))
(defn rewrite-aps [xs]
(map (fn [x]
(m/rewrite x
(`unquote ?a) ?a
?a (pure ?a)))
(defn rewrite-await
"rewrite block to free Do-forms (mlet, pure, bind, fapply, fmap).
A later pass should rewrite the free forms into something concrete."
(m/match form
(`unquote ?v) ; ~a (clojure.core/unquote a)
`(unquote ~?v) ; pass through, likely a type error e.g. (for [a ~[1]] ~a)
(for [!binds ...] ?body)
`(~'mlet ~(rewrite-binds !binds) ~?body)
; hack
(mlet . _ ...) ; (bind {} (clojure.core/unquote a))
form ; leave alone
((m/pred symbol? ?f) (`unquote ?v)) ; (f ~v) but not (f b) nor (f ~a ~b)
`(~'fmap ~?f ~?v)
; If nested data literal (tree), lift the entire literal as a unit?
; What about s-expression?
;[!xs] ; hiccup support
;(m/cata (vector !xs)) ; todo
(m/pred unquote-in-form?) ; (inc ~a b c) [a ~b] but not ~a
`(~'fapply ~@(rewrite-aps form))
_ form)) ; inc (f a b c)
(def rewrite-do (r/until = (r/top-down (r/attempt rewrite-await))))
(defmacro do> [body]
(rewrite-do body))
(rewrite-await '(a ~b)) => '(fmap a b)
(rewrite-await '(a ~b ~c)) => '(fapply (pure a) b c)
(rewrite-await '[a ~b]) => '(fapply (pure a) b c)
(rewrite-await '[a ~b ~c]) => '(fapply (pure a) b c)
(macroexpand-1 '(do> (+ a 1)))
=> '(+ a 1)
(macroexpand-1 '(do> (inc ~a)))
=> '(fmap inc a)
(macroexpand-1 '(do> (inc ~a ~b c)))
=> '(fapply (pure inc) a b (pure c))
(macroexpand-1 '(do> (just 1)))
=> '(just 1)
(macroexpand-1 '(do> (+ a ~(just 42))))
=> '(fapply (pure +) (pure a) (just 42))
(macroexpand-1 '(do> (for [a 1] ...)))
=> '(mlet [a (pure 1)] ...)
(macroexpand-1 '(do> (for [a ~(just 1)] ...)))
=> '(mlet [a (just 1)] ...)
'(do> (for [a ~(just 1)
b ~(+ a ~(just 42))
c 1]
=> '(mlet [a (just 1),
b (fapply (pure +) (pure a) (just 42)),
c (pure 1)]
(macroexpand-1 '(do> ~a))
=> '(clojure.core/unquote a)
(macroexpand-1 '(do> (for [] ~a))) ; likely type error
=> '(mlet [] (clojure.core/unquote a)) ; leave it
(macroexpand-1 '(do> (for [a ~(just 1)] ~a)))
=> '(mlet [a (just 1)] (clojure.core/unquote a))
;(macroexpand-1 '(do> (bind {} (clojure.core/unquote a))))
;=> '(mlet [] (clojure.core/unquote a))
'(do> (for [a ~(just 1)
b ~(+ a ~(just 42))
c 1]
=> '(mlet [a (just 1) b (fapply (pure +) (pure a) (just 42)) c (pure 1)] ...)
(defn mlet [binds body] ; todo applicative-do
(->> (reverse (partition 2 binds))
(reduce (fn [acc [l r]]
`(~'bind ~r (fn [~l] ~acc))) ; free bind
;(defmacro fmap [& args] `(! :Do.fmap ~@args))
;(defmacro fapply [& args] `(! :Do.fapply ~@args))
;(defmacro pure [& args] `(! :Do.pure ~@args))
;(defmacro bind [& args] `(! :Do.bind ~@args))
(defn rewrite-free-sexp [form]
(m/match form
(fmap . !args ...) `(! :Do.fmap ~@!args)
(fapply . !args ...) `(! :Do.fapply ~@!args)
(bind . !args ...) `(! :Do.bind ~@!args)
(pure . !args ...) `(! :Do.pure ~@!args)
(mlet [!binds ...] ?body) (mlet !binds ?body)
_ form))
(def rewrite-free (r/until = (r/top-down (r/attempt rewrite-free-sexp))))
(rewrite-free '(mlet [a mv] ...))
=> '(hyperfiddle.via/! :Do.bind mv (clojure.core/fn [a] ...))
(rewrite-free '(mlet [f (just +)] ...))
=> '(hyperfiddle.via/! :Do.bind (just +) (clojure.core/fn [f] ...))
(rewrite-free '(mlet [a (just 1) b (fapply (pure +) (pure a) (just 42)) c (pure 1)] ...))
;=> '(bind (just 1) (clojure.core/fn [a]
; (bind (fapply (pure +) (pure a) (just 42)) (clojure.core/fn [b]
; (bind (pure 1) (clojure.core/fn [c]
; (do ...)))))))
=> '(hyperfiddle.via/!
(just 1)
(hyperfiddle.via/! :Do.fapply (hyperfiddle.via/! :Do.pure +) (hyperfiddle.via/! :Do.pure a) (just 42))
(clojure.core/fn [b] (hyperfiddle.via/! :Do.bind (hyperfiddle.via/! :Do.pure 1) (clojure.core/fn [c] ...))))))
; ---
(defprotocol Do-via
(inject [H]))
(def ^:dynamic *stack []) ; each via* layer has its own mutable state
(def ^:dynamic *resolve {}) ; methods available in this dynamic scope
(def ^:dynamic *this) ; points to the active state record in a ! frame
(defmacro via [R & body]
`(let [R# ~R ; R is the user defined state instance, e.g. a defrecord
fns# (resolver-for R#)] ; This is a protocol to allow for user defined state type
(assert (every? typed-tag? (keys fns#))) ; An action-type identifies a set of methods available on an object "of that action-type"
(let [n# (count *stack)
resolvers# ; methods for an action-type (no inheritance, )
(->> fns#
(group-by (comp tag-type key)) ; Override resolver methods as a single unit (no inheritance, via* must provide complete impl). GT said this is an optimization?
(reduce-kv (fn [m# action-type# methods#]
(assoc m# action-type# (into {::nth n#} methods#))) ; ?
(binding [*stack (conj *stack R#) ; save the state pointer
*resolve (merge *resolve resolvers#)] ; other action types are still available in dynamic scope
~@(map (comp rewrite-free rewrite-do) body)
(defn ! "call methods on object from stack variable"
[& [F & args :as action]]
;{:pre [(doto action println)]}
(assert (typed-action? action))
(let [R (get *resolve (action-type action))]
(binding [*this (nth *stack (::nth R))] ; state monad
(let [f (get R F) ; resolve handler
result (apply f args)] ; Re-entrant ! works
(set! *stack (assoc *stack (::nth R) *this)) ; Carry state forward
(defn get-state []
(or *this
(last *stack))) ; ?
;(macroexpand-1 '(mlet [a ma b mb] ...))
;=> (bind ma (fn [a] (bind mb (fn [b] ...))))
(macroexpand-1 '(via (reify) ; !
(for [f (pure +)
a (pure 1)
b ~(~f 10 ~a)]
(pure (inc b)))))
(catch Exception e e))
=> ::worked
(defn just [v] {:Maybe/just v}) ; none is nil
(deftype Maybe []
(inject [R]
{:Do.pure (fn [v] {:Maybe/just v})
:Do.fmap (fn [f & fvs]
(let [vs (map :Maybe/just fvs)]
(if (every? identity vs)
(just (apply f vs)))))
:Do.fapply (fn [& avs] (apply ! :Do.fmap #(apply % %&) avs))
:Do.bind (fn [{v :Maybe/just} cont] (if v (cont v)))})))
=> hyperfiddle.via.Maybe
(via (->Maybe)
(for [f (just +)
a (just 1)
b ~(~f 10 ~a)]
(pure (inc b))))
=> #:Maybe{:just 12}
(via (->Maybe)
(for [a ~(just 1)
b ~(+ a ~(just 42))
c (for [i (range (+ a 2))] i)] ; vanilla for
(pure (+ a b (reduce + c)))))
=> #:Maybe{:just 47}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.