giles
26e16f6aa4
These are domain definition forms (same pattern as defhandler, defpage, etc.), not core language constructs. Moving them to web-forms.sx keeps the core evaluator + types.sx cleaner for WASM compilation. web-forms.sx now loaded in both JS and Python build pipelines. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
316 lines
12 KiB
Plaintext
316 lines
12 KiB
Plaintext
;; ==========================================================================
|
|
;; 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))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Register web forms with adapters
|
|
;;
|
|
;; Appends form names to the extension lists that definition-form?,
|
|
;; render-html-form?, special-form? etc. check. No function wrapping —
|
|
;; survives spec reloads.
|
|
;; --------------------------------------------------------------------------
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; defstyle — bind name to evaluated style expression
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(register-special-form! "defstyle"
|
|
(fn (args env)
|
|
(let ((name-sym (first args))
|
|
(value (trampoline (eval-expr (nth args 1) env))))
|
|
(env-bind! env (symbol-name name-sym) value)
|
|
value)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; deftype — register a named type alias / union / record
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define normalize-type-body
|
|
(fn (body)
|
|
(cond
|
|
(nil? body) "nil"
|
|
(= (type-of body) "symbol")
|
|
(symbol-name body)
|
|
(= (type-of body) "string")
|
|
body
|
|
(= (type-of body) "keyword")
|
|
(keyword-name body)
|
|
(= (type-of body) "dict")
|
|
(map-dict (fn (k v) (normalize-type-body v)) body)
|
|
(= (type-of body) "list")
|
|
(if (empty? body) "any"
|
|
(let ((head-name (if (= (type-of (first body)) "symbol")
|
|
(symbol-name (first body)) (str (first body)))))
|
|
(if (= head-name "union")
|
|
(cons "or" (map normalize-type-body (rest body)))
|
|
(cons head-name (map normalize-type-body (rest body))))))
|
|
:else (str body))))
|
|
|
|
(register-special-form! "deftype"
|
|
(fn (args env)
|
|
(let ((name-or-form (first args))
|
|
(body-expr (nth args 1))
|
|
(type-name nil)
|
|
(type-params (list)))
|
|
(if (= (type-of name-or-form) "symbol")
|
|
(set! type-name (symbol-name name-or-form))
|
|
(when (= (type-of name-or-form) "list")
|
|
(set! type-name (symbol-name (first name-or-form)))
|
|
(set! type-params
|
|
(map (fn (p) (if (= (type-of p) "symbol")
|
|
(symbol-name p) (str p)))
|
|
(rest name-or-form)))))
|
|
(let ((body (normalize-type-body body-expr))
|
|
(registry (if (env-has? env "*type-registry*")
|
|
(env-get env "*type-registry*")
|
|
(dict))))
|
|
(dict-set! registry type-name
|
|
{:name type-name :params type-params :body body})
|
|
(env-bind! env "*type-registry*" registry)
|
|
nil))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; defeffect — register an effect name
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(register-special-form! "defeffect"
|
|
(fn (args env)
|
|
(let ((effect-name (if (= (type-of (first args)) "symbol")
|
|
(symbol-name (first args))
|
|
(str (first args))))
|
|
(registry (if (env-has? env "*effect-registry*")
|
|
(env-get env "*effect-registry*")
|
|
(list))))
|
|
(when (not (contains? registry effect-name))
|
|
(append! registry effect-name))
|
|
(env-bind! env "*effect-registry*" registry)
|
|
nil)))
|
|
|
|
|
|
(define WEB_FORM_NAMES
|
|
(list "defhandler" "defpage" "defquery" "defaction" "defrelation"
|
|
"defstyle" "deftype" "defeffect"))
|
|
|
|
;; Extend definition-form? via the stable extension point in render.sx
|
|
(for-each (fn (name)
|
|
(append! *definition-form-extensions* name))
|
|
WEB_FORM_NAMES)
|
|
|
|
;; Extend adapter form-name lists so dispatchers recognise web forms.
|
|
(for-each (fn (name)
|
|
(append! RENDER_HTML_FORMS name)
|
|
(append! SPECIAL_FORM_NAMES name))
|
|
WEB_FORM_NAMES)
|