do-via.cljc

(ns contrib.do
  #?(:cljs (:require-macros [contrib.do])))

(defn tag-type [tag]
  (some->> (re-matches #"^([A-Z][-a-z]*)(.*)$" (name tag)) second keyword))

(defn typed-tag? [tag]
  (not (nil? (tag-type tag))))

(defn typed-action? [val]
  (and (vector? val)
       (typed-tag? (first val))))

(defn action-tag [val]
  (assert (vector? val))
  (first val))

(defn action-type [val]
  (assert typed-action? val)
  (tag-type (action-tag val)))

; ----------------------------

(defprotocol Do-via
  (resolver-for [H]))

(def ^:dynamic *stack [])
(def ^:dynamic *resolve {})
(def ^:dynamic *state)

(defmacro via* [R & body]
  `(let [R# ~R
         fns# (resolver-for R#)]

     (assert (every? typed-tag? (keys fns#)))

     (let [n# (count *stack)
           resolvers#
           (->> fns#
                (group-by (comp tag-type key))
                (reduce-kv (fn [m# k# v#]
                             (assoc m# k# (into {::nth n#} v#))) {}))]

       (binding [*stack (conj *stack R#)
                 *resolve (merge *resolve resolvers#)]

         ~@body
         ))))

(defn ! [& action]
  (let [action (vec action)]

    (assert (typed-action? action))

    (let [R (get *resolve (action-type action))]
      (binding [*state (nth *stack (::nth R))]

        (as-> ((get R (action-tag action)) action) result
          (do (set! *stack (assoc *stack (::nth R) *state))
              result))
        ))))

(defn get-state []
  (or *state
      (last *stack)))

(defrecord Eval [scope]
  Do-via
  (resolver-for [_]
    ; Free effects
    {:Eval.get-var  (fn [[_ name]] (get (:scope do/*state) name))
     :Eval.set-var! (fn [[_ name val]]
                      (set! do/*state (update do/*state assoc-in [:scope name] val)))}))

(via* (->Eval {'x 42}) ; configure your interpreter
  ; execute effects
  (! :Eval.set-var 'x (inc (! :Eval.get-var 'x))))

It's a free monad. But where did the types go?