Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
(ns user.dustin.bind10
(:require
[contrib.do :refer [Do-via via* !]]
[meander.epsilon :as m :refer [rewrite]]
[meander.strategy.epsilon :as r]))
(declare do> mlet pure fmap fapply bind)
(comment
; Goal is to implement async/await sugar like this:
(via* (->Maybe)
(do> (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)
; 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)
)
(defn unquote-in-form? [form]
#_{:pre [(doto form println)]}
(m/find form
(m/scan (`unquote _)) ; (inc ~a b) but not (a (b ~c)) nor (inc a) nor ~a
true))
(defn rewrite-binds [binds]
(->> (partition 2 binds)
(mapcat (fn [binding]
#_{:post [(doto % println)]}
(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]
#_{:pre [(doto xs println)] :post [(doto % println)]}
(map (fn [x]
(m/rewrite x
(`unquote ?a) ?a
?a (pure ?a)))
xs))
(defn rewrite-await [form]
#_{:pre [(doto form println)] #_#_:post [(doto % println)]}
(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)
(m/pred unquote-in-form? ?form) ; (inc ~a b c) [a ~b] but not ~a
`(~'fapply ~@(rewrite-aps form))
_ form)) ; inc (f a b c)
(def rewrite-awaits (r/until = (r/top-down (r/attempt rewrite-await)))) ; top-down lets us deep inspect (let [x ~a])
(defmacro do> [body]
#_`(via* ~(rewrite-awaits body))
(rewrite-awaits body))
(comment
(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)] ...)
(macroexpand-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> (bind {} (clojure.core/unquote a))))
=> '(mlet [] (clojure.core/unquote a))
(macroexpand-1 '(do> (for [a ~(just 1)] ~a)))
=> '(mlet [a (just 1)] (clojure.core/unquote a))
)
(defmacro mlet [binds body] ; todo applicative-do
;{:pre [(doto binds println)]}
(->> (reverse (partition 2 binds))
(reduce (fn [acc [l r]]
`(~'bind ~r (fn [~l] ~acc)))
`(do ~body))))
(comment
(macroexpand-1 '(mlet [a mv] ...))
=> (bind mv (fn [a] ...))
(macroexpand-1 '(mlet [a ma b mb] ...))
=> (bind ma (fn [a] (bind mb (fn [b] ...))))
(macroexpand-1
'(do> (for [a ~(just 1)
b ~(+ a ~(just 42))
c 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 ...)))))))
)
(defmacro fmap [& args]
`(! :Functor.fmap ~@args))
(defmacro fapply [& args]
`(! :Applicative.fapply ~@args))
(defmacro pure [& args]
`(! :Applicative.pure ~@args))
(defmacro bind [& args]
`(! :Monad.bind ~@args))
(comment
(macroexpand
'(do> (for [a ~(just 1)
b ~(+ a ~(just 42))
c 1]
...)))
=>
(contrib.do/! :Monad.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 ...)))))))
)
(deftype Maybe []
Do-via
(resolver-for [R]
{:Functor.fmap
(fn [[_ f {v :Maybe/just}]]
(if v {:Maybe/just (f v)} {}))
:Applicative.pure
(fn [[_ v]] {:Maybe/just v})
:Applicative.fapply
(fn [[_ & avs]]
(let [vs (map :Maybe/just avs)]
(if (every? identity vs)
(let [[f & args] vs]
{:Maybe/just (apply f args)})
{})))
:Monad.bind
(fn [[_ {v :Maybe/just} mf]]
(if v
(mf v)
{}))}))
(defn just [v] {:Maybe/just v})
(comment
(via* (->Maybe) (! :Functor.fmap identity {:Maybe/just 1}))
=> #:Maybe{:just 1}
(via* (->Maybe) (! :Functor.fmap identity {}))
=> {}
(via* (->Maybe)
(mlet [a (just 1)
b (fapply (pure +) (pure a) (just 42))
c (pure 1)]
(pure (+ a b c))))
=> #:Maybe{:just 45}
(via* (->Maybe)
(do> (for [a ~(just 1)
b ~(+ a ~(just 42))
c 1]
(pure (+ a b c)))))
=> #:Maybe{:just 45}
)
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.