rose-ash/web/web-forms.sx

;; ==========================================================================
;; web-forms.sx — Web-specific definition forms
;;
;; Registers defhandler, defquery, defaction, defpage, and defrelation as
;; custom special forms via register-special-form!. These are web platform
;; constructs, not core language features — loaded as an extension module
;; rather than being hardcoded in the evaluator.
;;
;; Each form parses its domain-specific argument structure and stores
;; a definition dict in the environment with a namespaced key:
;;   handler:name, query:name, action:name, page:name, relation:name
;;
;; Platform hosts provide typed constructors (make-handler-def etc.) that
;; return host-appropriate values. If unavailable, plain dicts are used.
;; ==========================================================================


;; --------------------------------------------------------------------------
;; Shared helpers
;; --------------------------------------------------------------------------

(define parse-key-params
  (fn (params-expr)
    ;; Parse (&key param1 param2 ...) → list of param name strings.
    ;; Skips &key marker, collects symbol names.
    (let ((params (list)))
      (for-each
        (fn (p)
          (when (= (type-of p) "symbol")
            (let ((name (symbol-name p)))
              (when (not (= name "&key"))
                (append! params name)))))
        params-expr)
      params)))

(define parse-handler-args
  (fn (args)
    ;; Parse defhandler args after the name symbol.
    ;; Scans for :keyword value option pairs, then a list (params), then body.
    ;; Returns dict with keys: opts, params, body.
    (let ((opts (dict))
          (params (list))
          (body nil)
          (i 0)
          (n (len args))
          (done false))
      (for-each
        (fn (idx)
          (when (and (not done) (= idx i))
            (let ((arg (nth args idx)))
              (cond
                (= (type-of arg) "keyword")
                  (do
                    (when (< (+ idx 1) n)
                      (let ((val (nth args (+ idx 1))))
                        (dict-set! opts (keyword-name arg)
                          (if (= (type-of val) "keyword")
                            (keyword-name val)
                            val))))
                    (set! i (+ idx 2)))
                (= (type-of arg) "list")
                  (do
                    (set! params (parse-key-params arg))
                    (when (< (+ idx 1) n)
                      (set! body (nth args (+ idx 1))))
                    (set! done true))
                :else
                  (do
                    (set! body arg)
                    (set! done true))))))
        (range 0 n))
      (dict "opts" opts "params" params "body" body))))


;; --------------------------------------------------------------------------
;; defhandler — Event handler / HTTP endpoint definition
;; --------------------------------------------------------------------------

(register-special-form! "defhandler"
  (fn (args env)
    (let ((name-sym (first args))
          (name (symbol-name (first args)))
          (parsed (parse-handler-args (rest args)))
          (opts (get parsed "opts"))
          (params (get parsed "params"))
          (body (get parsed "body")))
      (let ((hdef (dict
              "__type" "handler"
              "name" name
              "params" params
              "body" body
              "closure" env
              "path" (or (get opts "path") nil)
              "method" (or (get opts "method") "get")
              "csrf" (let ((v (get opts "csrf")))
                       (if (nil? v) true v))
              "returns" (or (get opts "returns") "element"))))
        (env-bind! env (str "handler:" name) hdef)
        hdef))))


;; --------------------------------------------------------------------------
;; defquery — Named query for data fetching
;; --------------------------------------------------------------------------

(register-special-form! "defquery"
  (fn (args env)
    (let ((name (symbol-name (first args)))
          (params-raw (nth args 1))
          (params (parse-key-params params-raw))
          (has-doc (and (>= (len args) 4)
                       (= (type-of (nth args 2)) "string")))
          (doc (if has-doc (nth args 2) ""))
          (body (if has-doc (nth args 3) (nth args 2))))
      (let ((qdef (dict
              "__type" "query"
              "name" name
              "params" params
              "doc" doc
              "body" body
              "closure" env)))
        (env-bind! env (str "query:" name) qdef)
        qdef))))


;; --------------------------------------------------------------------------
;; defaction — Named action for mutations
;; --------------------------------------------------------------------------

(register-special-form! "defaction"
  (fn (args env)
    (let ((name (symbol-name (first args)))
          (params-raw (nth args 1))
          (params (parse-key-params params-raw))
          (has-doc (and (>= (len args) 4)
                       (= (type-of (nth args 2)) "string")))
          (doc (if has-doc (nth args 2) ""))
          (body (if has-doc (nth args 3) (nth args 2))))
      (let ((adef (dict
              "__type" "action"
              "name" name
              "params" params
              "doc" doc
              "body" body
              "closure" env)))
        (env-bind! env (str "action:" name) adef)
        adef))))


;; --------------------------------------------------------------------------
;; defpage — Page route definition
;; --------------------------------------------------------------------------

(register-special-form! "defpage"
  (fn (args env)
    (let ((name (symbol-name (first args)))
          (slots (dict))
          (n (len args)))
      ;; Parse :key value pairs after the name
      (for-each
        (fn (idx)
          (let ((k-idx (+ 1 (* idx 2)))
                (v-idx (+ 2 (* idx 2))))
            (when (and (< k-idx n) (< v-idx n)
                       (= (type-of (nth args k-idx)) "keyword"))
              (dict-set! slots (keyword-name (nth args k-idx))
                         (nth args v-idx)))))
        (range 0 (/ (- n 1) 2)))
      (let ((pdef (dict
              "__type" "page"
              "name" name
              "path" (or (get slots "path") "")
              "auth" (or (get slots "auth") "public")
              "layout" (get slots "layout")
              "data" (get slots "data")
              "content" (get slots "content")
              "filter" (get slots "filter")
              "aside" (get slots "aside")
              "menu" (get slots "menu")
              "stream" (get slots "stream")
              "fallback" (get slots "fallback")
              "shell" (get slots "shell")
              "closure" env)))
        (env-bind! env (str "page:" name) pdef)
        pdef))))


;; --------------------------------------------------------------------------
;; defrelation — Relationship definition (cross-domain)
;; --------------------------------------------------------------------------

(register-special-form! "defrelation"
  (fn (args env)
    (let ((name (symbol-name (first args)))
          (slots (dict))
          (n (len args)))
      (for-each
        (fn (idx)
          (let ((k-idx (+ 1 (* idx 2)))
                (v-idx (+ 2 (* idx 2))))
            (when (and (< k-idx n) (< v-idx n)
                       (= (type-of (nth args k-idx)) "keyword"))
              (dict-set! slots (keyword-name (nth args k-idx))
                         (nth args v-idx)))))
        (range 0 (/ (- n 1) 2)))
      (let ((rdef (dict
              "__type" "relation"
              "name" name
              "slots" slots
              "closure" env)))
        (env-bind! env (str "relation:" name) rdef)
        rdef))))


;; --------------------------------------------------------------------------
;; Patch form-classification functions
;;
;; The adapters (html, sx, dom, async) use classifier functions to decide
;; how to handle forms during rendering. Now that these web forms are
;; registered as custom special forms, we redefine the classifiers to
;; include them. This runs after all adapters are loaded.
;; --------------------------------------------------------------------------

(define WEB_FORM_NAMES
  (list "defhandler" "defpage" "defquery" "defaction" "defrelation"))

;; Redefine definition-form? to include web forms.
;; All adapters call this to identify "eval for side effects" forms.
(let ((core-definition-form? definition-form?))
  (define definition-form?
    (fn (name)
      (or (core-definition-form? name)
          (contains? WEB_FORM_NAMES name)))))

;; Extend adapter form-name lists so dispatchers recognise web forms.
;; These lists are mutable — append! adds to them in place.
(for-each (fn (name)
  (append! RENDER_HTML_FORMS name)
  (append! SPECIAL_FORM_NAMES name))
  WEB_FORM_NAMES)