ClojureScript OOP - defclass

macros.cljc

(ns cljs-engine.macros
  (:refer-clojure :exclude [get assoc assoc-in])
  (:require
    [applied-science.js-interop :as j]
    [cljs.core.async :as async]
    [clojure.string :as str]))

(defmacro call [o ks & args]
  `(j/call-in ~o ~(if (vector? ks)
                    ks
                    (mapv keyword (str/split (name ks) #"\.")))
              ~@args))

(defmacro cond-doto [expr & clauses]
  (assert (even? (count clauses)))
  (let [g (gensym)
        steps (map (fn [[test step]] `(if ~test (do (-> ~g ~step) ~g) ~g))
                   (partition 2 clauses))]
    `(let [~g ~expr
           ~@(interleave (repeat g) (butlast steps))]
       ~(if (empty? steps)
          g
          (last steps)))))

(defmacro cond-all [& clauses]
  (assert (even? (count clauses)))
  (let [pairs (partition 2 clauses)
        when-forms (map (fn [[condition action]]
                          `(when ~condition ~action))
                        pairs)]
    `(do ~@when-forms)))

(defmacro alet [bindings & body]
  (let [last-expr (last body)
        [body catch]
        (if (and (seq? last-expr) (= 'catch (first last-expr)))
          [(butlast body) last-expr]
          [body nil])

        ;; Parse bindings into pairs like let does
        binding-pairs (partition 2 bindings)]

    (letfn [;; Check if expression is (await ...)
            (await-form? [expr]
              (and (seq? expr) (= 'await (first expr))))

            ;; Extract inner expression from (await expr)
            (await-expr [expr]
              (second expr))

            ;; Convert promise-chan to JS Promise
            (promise-chan->js-promise [val-sym]
              `(js/Promise.
                 (fn [resolve# reject#]
                   (async/take! ~val-sym
                                (fn [result#]
                                  (if (instance? js/Error result#)
                                    (reject# result#)
                                    (resolve# result#)))))))

            ;; Ensure a JavaScript Promise from various awaitable values
            (ensure-promise [val-sym]
              `(if (and ~val-sym (satisfies? cljs.core.async.impl.protocols/ReadPort ~val-sym))
                 ~(promise-chan->js-promise val-sym)
                 (js/Promise.resolve ~val-sym)))

            ;; Await a value (JS Promise or promise-chan)
            (await-value [val-sym continue-fn]
              `(-> ~(ensure-promise val-sym) (.then ~continue-fn)))

            ;; Process body expressions sequentially
            (process-body [exprs]
              (if (empty? exprs)
                nil
                (let [expr (first exprs)
                      rest-exprs (rest exprs)]
                  (if (await-form? expr)
                    ;; It's an (await ...) form - await it
                    (let [inner-expr (await-expr expr)
                          result-sym (gensym "result")]
                      `(let [~result-sym ~inner-expr]
                         ~(await-value result-sym
                                       (if (empty? rest-exprs)
                                         `(fn [val#] val#)  ; Last expression, return value
                                         `(fn [~'_] ~(process-body rest-exprs)))))) ; Continue with rest
                    ;; Regular expression - execute and continue
                    (if (empty? rest-exprs)
                      expr                                  ; Last expression, return its value
                      `(do ~expr ~(process-body rest-exprs))))))) ; Execute and continue

            ;; Build nested promise chain for bindings
            (build-chain [pairs]
              (if (empty? pairs)
                ;; No more pairs, process the body
                (if (empty? body)
                  nil
                  (process-body body))
                ;; Process next binding
                (let [[name thenable] (first pairs)
                      next-chain (build-chain (rest pairs))]
                  (if (await-form? thenable)
                    ;; It's an (await ...) form - await it
                    (let [inner-expr (await-expr thenable)
                          val-sym (gensym "val")]
                      `(let [~val-sym ~inner-expr]
                         ~(await-value val-sym `(fn [~name] ~next-chain))))
                    ;; Regular expression - bind directly
                    `(let [~name ~thenable]
                       ~next-chain)))))]

      (let [chain (build-chain binding-pairs)]
        ;; Apply catch clause to the entire chain if present
        (if catch
          (let [[_ catch-name & catch-body] catch]
            `(-> (js/Promise.resolve ~chain)
                 (.catch (fn [~catch-name] ~@catch-body))))
          chain)))))

;;
;; Simple OOP-style class macro for CLJS
;;
;; Usage:
;; (defclass Player [{:keys [name]}]
;;  [health 100
;;   addresses nil
;;   ground? false
;;   ses-kek #js {:a 1}
;;   ded #js {:a #js {:b 0}}
;;   name name]
;;  (init []
;;        (println "init"))
;;  (swap []
;;        (println "swapping")
;;        (set health 1005))
;;  (show
;;    ([a]
;;     (println "Hey: " (.setHealth this 101)))
;;    ([a b]
;;     (println "Kek")))
;;  (setHealth [new-health]
;;             (println "DUDE!!")
;;             (set health new-health)
;;             (loc aa 123)
;;             (loc bb 444)
;;             (println "AA: " aa " - " bb)
;;             (loc cc 55)
;;             (await (utils/timeout 3000))
;;             (println "C: " cc "AA: " aa)
;;             (loc cc 23)
;;             (println "C: " cc)
;;             new-health)
;;  (jump []
;;        (when (not ground?)
;;              ;; do jump
;;              ))
;;  (update [dt]
;;          ;; update logic using dt
;;          ))
;;
;; Notes:
;; - Inside methods, you can refer to fields by name (e.g. ground?) and use
;;   (set field value) to mutate them. Reads are rewritten to lookups from an
;;   internal atom-backed state map.
;; - The generated constructor is a function named Name. that accepts an
;;   optional map of overrides to merge into defaults.
(defn- collect-bound-symbols
  "Collect symbols introduced by bindings or arg vectors across nested vectors/maps."
  [binding-form]
  (set (filter symbol?
               (tree-seq coll?
                         #(if (map? %)
                            (seq (mapcat identity %))
                            (seq %))
                         binding-form))))

;; Helper used by transformations to detect presence of (await ...)
(defn- contains-await?
  [forms]
  (boolean (some #(and (seq? %) (= 'await (first %)))
                 (tree-seq coll? seq forms))))

(defn- transform-method-body
  "Rewrite method body so that:
   - Bare field symbols become lookups from @state#
   - (set field value) becomes (swap! state# assoc :field value)
   - (get field) stays as a normal get from @state# when written as (field)
  Bound locals (args, let bindings, fn params) are respected."
  [body-forms field-syms method-syms state-sym obj-sym]
  (let [field-set (set field-syms)
        method-set (set method-syms)
        rewrite
        (fn rewrite [form bound]
          (cond
            (symbol? form)
            (cond
              (and (= form 'this) (not (contains? bound form))) obj-sym
              (and (field-set form) (not (contains? bound form)))
              `(cljs.core/aget ~state-sym ~(name form))
              :else form)

            (seq? form)
            (let [op (first form)
                  args (rest form)]
              (cond
                ;; Compound assignment for locals/fields: (+= x rhs), (-= x rhs), (*= x rhs)
                ;; Note: '/=' is not a readable Clojure symbol, so use 'div=' for division assignment.
                (#{'+= '-= '*= 'div=} op)
                (let [[lhs rhs] args
                      op-sym (cond
                               (= op '+=) 'cljs.core/+
                               (= op '-=) 'cljs.core/-
                               (= op '*=) 'cljs.core/*
                               (= op 'div=) 'cljs.core/divide)
                      rhs' (rewrite rhs bound)]
                  (if (and (symbol? lhs) (contains? bound lhs))
                    ;; local variable mutation via loc
                    (rewrite `(~'loc ~lhs (~op-sym ~lhs ~rhs')) bound)
                    ;; field update via set
                    (rewrite `(~'set ~lhs (~op-sym ~lhs ~rhs')) bound)))

                ;; Increment / Decrement: (++ x) (-- x)
                (#{'++ '--} op)
                (let [lhs (first args)
                      op-sym (if (= op '++) 'cljs.core/+ 'cljs.core/-)
                      one 1]
                  (if (and (symbol? lhs) (contains? bound lhs))
                    (rewrite `(~'loc ~lhs (~op-sym ~lhs ~one)) bound)
                    (rewrite `(~'set ~lhs (~op-sym ~lhs ~one)) bound)))

                ;; Rewrite (.method target &args) and nested chains (.a.b.c target ...)
                (and (symbol? op)
                     (let [s# (name op)] (and (>= (count s#) 2) (= "." (subs s# 0 1)))))
                (let [mname# (subs (name op) 1)
                      target# (first args)
                      call-args# (rest args)
                      target-expr# (if (and (symbol? target#)
                                            (= target# 'this)
                                            (not (contains? bound target#)))
                                     obj-sym
                                     (rewrite target# bound))
                      call-args-exprs# (map #(rewrite % bound) call-args#)]
                  `(cljs-engine.macros/call ~target-expr# ~(keyword mname#) ~@call-args-exprs#))

                (= op 'loc)
                (let [[_ sym rhs] form]
                  `(let [~sym ~(rewrite rhs bound)] nil))

                (= op 'set)
                (let [[fld val-expr] args
                      fld-sym (if (keyword? fld) (symbol (name fld)) fld)
                      fld-name (name fld-sym)
                      parts (str/split fld-name #"\.")
                      val-form (rewrite val-expr bound)]
                  (if (> (count parts) 1)
                    (let [root-sym (symbol (first parts))
                          obj-expr `(cljs.core/aget ~state-sym ~(name root-sym))
                          prop-path (map name (rest parts))]
                      `(cljs.core/aset ~obj-expr ~@prop-path ~val-form))
                    `(cljs.core/aset ~state-sym ~fld-name ~val-form)))

                (= op 'let)
                (let [[binds & let-body] args
                      ;; rewrite binding init exprs left-to-right while growing bound with symbols from binding forms
                      [rewritten-binds new-bound]
                      (loop [bs binds
                             acc []
                             bnd bound]
                        (if (empty? bs)
                          [acc bnd]
                          (let [bf (first bs)
                                rhs (second bs)
                                rhs' (rewrite rhs bnd)
                                bnd' (into bnd (collect-bound-symbols bf))]
                            (recur (nnext bs) (conj acc bf rhs') bnd'))))]
                  `(let [~@rewritten-binds] ~@(map #(rewrite % new-bound) let-body)))

                (= op 'fn)
                (let [[a1 & rest-args] args]
                  (cond
                    (vector? a1)
                    (let [params a1
                          fn-body rest-args
                          new-bound (into bound (collect-bound-symbols params))]
                      `(fn ~params ~@(map #(rewrite % new-bound) fn-body)))

                    (and (symbol? a1) (vector? (first rest-args)))
                    (let [nm a1
                          params (first rest-args)
                          fn-body (rest rest-args)
                          new-bound (into bound (collect-bound-symbols params))]
                      `(fn ~nm ~params ~@(map #(rewrite % new-bound) fn-body)))

                    :else
                    ;; Fallback: don't transform unknown fn shapes
                    form))

                ;; Call to another method in the same class: rewrite to obj method call
                (and (symbol? op) (method-set op) (not (contains? bound op)))
                (let [prop-name (name op)
                      callee `(cljs.core/aget ~obj-sym ~prop-name)]
                  `(.call ~callee ~obj-sym ~@(map #(rewrite % bound) args)))

                :else
                ;; Do not rewrite the operator position to avoid turning it into a value
                (apply list op (map #(rewrite % bound) args))))

            (vector? form)
            (vec (map #(rewrite % bound) form))

            (map? form)
            (into {} (for [[k v] form]
                       [(rewrite k bound) (rewrite v bound)]))

            :else form))]
    (let [forms-vec (vec body-forms)
          loc-form? (fn [f] (and (seq? f) (= 'loc (first f))))
          _ (doseq [f forms-vec
                    :when (loc-form? f)
                    :let [[_ sym# _] f]]
              (when (contains? field-set sym#)
                (throw (ex-info "loc cannot shadow a field name" {:field sym#}))))
          has-loc? (some loc-form? forms-vec)]
      (if (not has-loc?)
        (map #(rewrite % #{}) body-forms)
        (let [n (count forms-vec)
              last-form (when (pos? n) (nth forms-vec (dec n)))
              head-forms (if (> n 1) (subvec forms-vec 0 (dec n)) [])
              ;; track symbols introduced by loc in head
              loc-syms (into #{} (keep (fn [f]
                                         (when (and (seq? f) (= 'loc (first f)))
                                           (second f)))) head-forms)
              comp-ops #{'+= '-= '*= 'div= '++ '--}
              bindings (into []
                             (mapcat (fn [f]
                                       (cond
                                         (loc-form? f)
                                         (let [[_ sym rhs] f] [sym rhs])

                                         (and (seq? f) (comp-ops (first f)))
                                         (let [op (first f)
                                               args (rest f)
                                               lhs (first args)
                                               rhs (if (or (= op '++) (= op '--)) 1 (second args))
                                               core-op (cond
                                                         (= op '+=) 'cljs.core/+
                                                         (= op '-=) 'cljs.core/-
                                                         (= op '*=) 'cljs.core/*
                                                         (= op 'div=) 'cljs.core/divide
                                                         (= op '++) 'cljs.core/+
                                                         (= op '--) 'cljs.core/-)]
                                           (if (and (symbol? lhs) (contains? loc-syms lhs))
                                             [lhs `(~core-op ~lhs ~rhs)]
                                             ['_ f]))

                                         :else ['_ f])))
                             head-forms)
              use-alet? (contains-await? forms-vec)
              wrapper (if use-alet? 'cljs-engine.macros/alet 'let)
              new-expr (if last-form
                         `(~wrapper [~@bindings] ~last-form)
                         `(~wrapper [~@bindings] nil))]
          (list (rewrite new-expr #{})))))))

(defmacro defclass [class-name ctor-params & raw-forms]
  (let [parsed (let [ff (first (filter #(and (seq? %) (= 'fields (first %))) raw-forms))
                     first-form (first raw-forms)]
                 (cond
                   ff {:defaults (second ff)
                       :methods-in-fields (drop 2 ff)
                       :rest (remove #(and (seq? %) (= 'fields (first %))) raw-forms)}
                   (vector? first-form) {:defaults first-form
                                         :methods-in-fields []
                                         :rest (rest raw-forms)}
                   :else {:defaults []
                          :methods-in-fields []
                          :rest raw-forms}))
        default-pairs (:defaults parsed)
        _ (when (odd? (count default-pairs))
            (throw (ex-info "(fields [...]) requires an even number of forms" {:pairs default-pairs})))
        field-syms (map first (partition 2 default-pairs))
        defaults-map (into {}
                           (for [[k v] (partition 2 default-pairs)]
                             [(keyword (name k)) v]))
        top-level-methods (concat (:methods-in-fields parsed) (:rest parsed))
        {init-body :init methods :methods}
        (reduce (fn [acc f]
                  (if (and (seq? f) (symbol? (first f)))
                    (let [mname (first f)
                          rest-parts (rest f)]
                      (if (= mname 'init)
                        (cond
                          (and (vector? (first rest-parts)) (empty? (first rest-parts)))
                          (update acc :init into (rest rest-parts))

                          (vector? (first rest-parts))
                          (throw (ex-info "init must be zero-arity: (init [])" {:form f}))

                          :else
                          (throw (ex-info "init cannot be multi-arity" {:form f})))
                        (let [arities (if (vector? (first rest-parts))
                                        [[(first rest-parts) (rest rest-parts)]]
                                        (mapv (fn [af]
                                                (when-not (and (seq? af) (vector? (first af)))
                                                  (throw (ex-info "Invalid method arity form" {:form af :method mname})))
                                                [(first af) (rest af)])
                                              rest-parts))]
                          (update acc :methods conj [mname arities]))))
                    acc))
                {:init [] :methods []}
                top-level-methods)
        state-sym (gensym "state")
        obj-sym (gensym "obj")
        id-sym (gensym "id")
        ;; Use a simple unqualified symbol for the instance in debug mode
        inst-sym (gensym "inst")
        method-names (map first methods)
        ctor-binding (cond
                       (and (vector? ctor-params) (= 1 (count ctor-params))) (first ctor-params)
                       (and (vector? ctor-params) (empty? ctor-params)) nil
                       (= ctor-params '_) nil
                       :else ctor-params)
        param-sym (gensym "opts__auto__")
        mk-method-aset
        (fn [[mname arities]]
          (let [prop-name (clojure.core/name mname)
                target-prop (if (= prop-name "dispose") "__disposeUser" prop-name)
                underscore-prop (clojure.string/replace target-prop "-" "_")
                arms (map (fn [[params body]]
                            (let [tbody (transform-method-body body field-syms method-names state-sym obj-sym)]
                              `(~params ~@tbody)))
                          arities)]
            `(let [f# (fn ~@arms)]
               (cljs.core/aset ~obj-sym ~target-prop f#)
               (cljs.core/aset ~obj-sym ~underscore-prop f#))))
        transformed-init (when (seq init-body)
                           (transform-method-body init-body field-syms method-names state-sym obj-sym))]
    `(do
       (when js/goog.DEBUG
         (let [registry# (or (aget js/window "__defclass_instances__") (cljs.core/js-obj))
               keys# (js/Object.keys registry#)
               cname# (name '~class-name)]
           (loop [i# 0]
             (when (< i# (.-length keys#))
               (let [k# (aget keys# i#)
                     ~inst-sym (aget registry# k#)]
                 (when (= (cljs.core/aget ~inst-sym "class") cname#)
                   ~@(map (fn [[mname arities]]
                            (let [p# (name mname)
                                  target-prop (if (= p# "dispose") "__disposeUser" p#)
                                  underscore-prop (clojure.string/replace target-prop "-" "_")
                                  arms (map (fn [[params body]]
                                              (let [st# (gensym "state__auto__")
                                                    tb# (transform-method-body body field-syms method-names st# inst-sym)]
                                                `(~params (let [~st# (cljs.core/aget ~inst-sym "fields")] ~@tb#))))
                                            arities)]
                              `(let [f# (fn ~@arms)]
                                 (cljs.core/aset ~inst-sym ~target-prop f#)
                                 (cljs.core/aset ~inst-sym ~underscore-prop f#))))
                          methods)
                   (when-let [swap-fn# (cljs.core/aget ~inst-sym "swap")]
                     (.call swap-fn# ~inst-sym))))
               (recur (inc i#))))))
       (defn ~class-name
         ([~param-sym]
          (let [~@(concat (when ctor-binding [ctor-binding param-sym])
                          [state-sym `(cljs.core/js-obj ~@(mapcat (fn [[k v]]
                                                                    [(name k) v])
                                                                  defaults-map))
                           obj-sym '(cljs.core/js-obj)])]
            ;; assign unique id
            (let [~id-sym (let [c# (or (aget js/window "__defclass_uid__") 0)]
                            (aset js/window "__defclass_uid__" (cljs.core/inc c#))
                            c#)]
              (cljs.core/aset ~obj-sym "id" ~id-sym))
            ~@(map mk-method-aset methods)
            (when ~param-sym
              (js/Object.assign ~state-sym (cljs.core/clj->js ~param-sym)))
            (cljs.core/aset ~obj-sym "fields" ~state-sym)
            (cljs.core/aset ~obj-sym "class" (name '~class-name))
            (cljs.core/aset ~obj-sym "defclass" true)
            (when js/goog.DEBUG
              (let [registry# (or (aget js/window "__defclass_instances__") (cljs.core/js-obj))
                    idval# (cljs.core/aget ~obj-sym "id")]
                (aset registry# idval# ~obj-sym)
                (aset js/window "__defclass_instances__" registry#)))
            ~@(when (seq transformed-init)
                [`(do ~@transformed-init)])
            ;; attach a standard dispose method which calls user-defined one first if present
            (cljs.core/aset ~obj-sym "dispose"
                            (fn []
                              (when-let [user# (cljs.core/aget ~obj-sym "__disposeUser")]
                                (.call user# ~obj-sym))
                              (when js/goog.DEBUG
                                (let [registry# (or (aget js/window "__defclass_instances__") (cljs.core/js-obj))
                                      idval# (cljs.core/aget ~obj-sym "id")
                                      idstr# (cljs.core/str idval#)]
                                  (~'js-delete registry# idval#)
                                  (~'js-delete registry# idstr#)
                                  ;; identity fallback: rare case if stored under unknown key
                                  (let [keys# (js/Object.keys registry#)]
                                    (loop [i# 0]
                                      (when (< i# (.-length keys#))
                                        (let [k# (aget keys# i#)]
                                          (when (identical? (aget registry# k#) ~obj-sym)
                                            (~'js-delete registry# k#))
                                          (recur (inc i#))))))
                                  (aset js/window "__defclass_instances__" registry#)))
                              (cljs.core/aset ~obj-sym "fields" nil)
                              (cljs.core/aset ~obj-sym "disposed" true)))
            ~obj-sym))
         ([] (~class-name nil))))))

(comment
  (defclass Scene []
    (echo []
          (println "Scene is here!")))

  (defclass Player [{:keys [name]}]
    [health 100
     addresses nil
     ground? false
     ses-kek #js {:a 1}
     ded #js {:a #js {:b 0}}
     name name
     scene (Scene)]
    (init []
          (.echo scene)
          (println "init"))
    ;; It runs when re-compiled in REPL (dev mode)
    #_(swap []
            (println "swapping")
            (set health 1005))
    (show
      ([a]
       (println "Hey: " (.setHealth this 101)))
      ([a b]
       (println "Kek")))
    (setHealth [new-health]
               (println "DUDE!!")
               (set health new-health)
               (loc aa 123)
               (loc bb 444)
               (println "AA: " aa " - " bb)
               (loc cc 55)
               (await (async/timeout 3000))
               (println "C: " cc "AA: " aa)
               (loc cc 23)
               (println "C: " cc)
               new-health)
    (jump []
          (when (not ground?)
            ;; do jump
            ))
    (update [dt]))

  (def pp1 (Player {:name "Ertu"}))
  pp1
  (.show pp1 1)
  (.setHealth pp1 99)
  (.-fields pp1)
  )