rewrite-await.cljc

(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}

  )