diff --git a/hosts/ocaml/browser/bundle.sh b/hosts/ocaml/browser/bundle.sh new file mode 100755 index 00000000..76b0677b --- /dev/null +++ b/hosts/ocaml/browser/bundle.sh @@ -0,0 +1,75 @@ +#!/bin/bash +# Bundle the WASM SX kernel + platform + .sx files for serving. +# +# Output goes to hosts/ocaml/browser/dist/ +# Serve dist/ at /wasm/ or similar path. + +set -e +cd "$(dirname "$0")" + +BUILD=../_build/default/browser +DIST=dist +ROOT=../../.. + +echo "=== Bundling SX WASM browser engine ===" + +rm -rf "$DIST" +mkdir -p "$DIST/sx" + +# 1. WASM kernel +cp "$BUILD/sx_browser.bc.wasm.js" "$DIST/" +cp -r "$BUILD/sx_browser.bc.wasm.assets" "$DIST/" + +# Also copy js_of_ocaml version as fallback +cp "$BUILD/sx_browser.bc.js" "$DIST/" + +# 2. Platform JS +cp sx-platform.js "$DIST/" + +# 3. Spec modules +cp "$ROOT/spec/render.sx" "$DIST/sx/" +cp "$ROOT/web/signals.sx" "$DIST/sx/" +cp "$ROOT/web/deps.sx" "$DIST/sx/" +cp "$ROOT/web/router.sx" "$DIST/sx/" +cp "$ROOT/web/page-helpers.sx" "$DIST/sx/" + +# 3b. Freeze scope (signal persistence) +cp "$ROOT/lib/freeze.sx" "$DIST/sx/" + +# 4. Bytecode compiler + VM +cp "$ROOT/lib/bytecode.sx" "$DIST/sx/" +cp "$ROOT/lib/compiler.sx" "$DIST/sx/" +cp "$ROOT/lib/vm.sx" "$DIST/sx/" + +# 5. Web libraries (8 FFI primitives) +cp "$ROOT/web/lib/dom.sx" "$DIST/sx/" +cp "$ROOT/web/lib/browser.sx" "$DIST/sx/" + +# 6. Web adapters +cp "$ROOT/web/adapter-html.sx" "$DIST/sx/" +cp "$ROOT/web/adapter-sx.sx" "$DIST/sx/" +cp "$ROOT/web/adapter-dom.sx" "$DIST/sx/" + +# 7. Boot helpers (platform functions in pure SX) +cp "$ROOT/web/lib/boot-helpers.sx" "$DIST/sx/" +cp "$ROOT/web/lib/hypersx.sx" "$DIST/sx/" + +# 8. Web framework +cp "$ROOT/web/engine.sx" "$DIST/sx/" +cp "$ROOT/web/orchestration.sx" "$DIST/sx/" +cp "$ROOT/web/boot.sx" "$DIST/sx/" + +# Summary +WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1) +JS_SIZE=$(du -sh "$DIST/sx_browser.bc.js" | cut -f1) +SX_SIZE=$(du -sh "$DIST/sx" | cut -f1) +echo " WASM kernel: $WASM_SIZE (assets)" +echo " JS fallback: $JS_SIZE" +echo " SX sources: $SX_SIZE ($(ls "$DIST/sx/" | wc -l) files)" +echo " Platform JS: $(du -sh "$DIST/sx-platform.js" | cut -f1)" +echo "" +echo " dist/ ready to serve" +echo "" +echo " HTML usage:" +echo ' ' +echo ' ' diff --git a/hosts/ocaml/browser/sx-platform.js b/hosts/ocaml/browser/sx-platform.js index c89df0c0..59a1d119 100644 --- a/hosts/ocaml/browser/sx-platform.js +++ b/hosts/ocaml/browser/sx-platform.js @@ -253,6 +253,7 @@ "sx/adapter-dom.sx", // Boot helpers (platform functions in pure SX) "sx/boot-helpers.sx", + "sx/hypersx.sx", // Web framework "sx/engine.sx", "sx/orchestration.sx", diff --git a/sx/sx/sx-tools-editor.sx b/sx/sx/sx-tools-editor.sx index 9866ec8e..6a056249 100644 --- a/sx/sx/sx-tools-editor.sx +++ b/sx/sx/sx-tools-editor.sx @@ -1 +1 @@ -(defisland ~sx-tools/tree-editor () (let ((source (signal "(defcomp ~card (&key title subtitle)\n (div :class \"card\"\n (h2 title)\n (when subtitle\n (p :class \"sub\" subtitle))))")) (view-mode (signal "tree")) (selected-path (signal nil)) (parsed (signal nil)) (bindings (signal (dict)))) (letrec ((fmt-path (fn (path) (str "[" (join "," (map str path)) "]"))) (node-disp (fn (node) (cond (nil? node) "nil" (= (type-of node) "symbol") (symbol-name node) (= (type-of node) "keyword") (str ":" (keyword-name node)) (string? node) (let ((s (if (> (len node) 35) (str (slice node 0 32) "...") node))) (str "\"" s "\"")) (number? node) (str node) (= (type-of node) "boolean") (if node "true" "false") (list? node) (if (empty? node) "()" (str "(" (node-disp (first node)) (if (> (len node) 1) " ..." "") ")")) :else (str node)))) (is-compact (fn (node) (and (list? node) (<= (len node) 4) (not (some (fn (c) (list? c)) (rest node)))))) (build-entries (fn (node path depth result) (if (list? node) (if (empty? node) (append! result {:expandable false :depth depth :text "()" :is-list false :path path}) (if (is-compact node) (append! result {:expandable false :depth depth :text (str "(" (join " " (map node-disp node)) ")") :is-list true :path path}) (do (append! result {:expandable true :depth depth :text (str "(" (node-disp (first node))) :is-list true :path path}) (for-each (fn (i) (build-entries (nth node i) (concat path (list i)) (+ depth 1) result)) (range 1 (len node)))))) (append! result {:expandable false :depth depth :text (node-disp node) :is-list false :path path})))) (nav (fn (tree path) (reduce (fn (current idx) (if (or (nil? current) (not (list? current)) (>= idx (len current))) nil (nth current idx))) tree path))) (build-context (fn (tree path) (let ((result (list))) (for-each (fn (depth) (let ((prefix (slice path 0 (+ depth 1))) (node (nav tree prefix))) (when (not (nil? node)) (let ((is-target (= (+ depth 1) (len path)))) (append! result {:depth depth :is-target is-target :text (if (list? node) (if (empty? node) "()" (let ((head (node-disp (first node)))) (if (> (len node) 3) (str "(" head " " (node-disp (nth node 1)) " ...)") (str "(" (join " " (map node-disp node)) ")")))) (node-disp node)) :path prefix}))))) (range 0 (len path))) result))) (do-validate (fn (tree) (let ((errors (list))) (letrec ((check (fn (node path) (when (list? node) (when (not (empty? node)) (let ((head (first node))) (when (and (= (type-of head) "symbol") (or (= (symbol-name head) "letrec")) (>= (len node) 2)) (let ((bindings (nth node 1))) (when (list? bindings) (for-each (fn (i) (let ((pair (nth bindings i))) (when (not (and (list? pair) (>= (len pair) 2) (= (type-of (first pair)) "symbol"))) (append! errors (str "Binding " i " at " (fmt-path (concat path (list 1 i))) " is not a (name value) pair"))))) (range 0 (len bindings)))))) (when (and (= (type-of head) "symbol") (or (= (symbol-name head) "defcomp") (= (symbol-name head) "defisland"))) (when (< (len node) 4) (append! errors (str (symbol-name head) " at " (fmt-path path) " missing body")))))) (for-each (fn (i) (check (nth node i) (concat path (list i)))) (range 0 (len node))))))) (for-each (fn (i) (check (nth tree i) (list i))) (range 0 (len tree)))) (if (empty? errors) "OK" (join "\n" errors))))) (extract-params (fn (expr) (let ((head (if (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol")) (symbol-name (first expr)) nil)) (params-list (if (and (list? expr) (> (len expr) 2)) (nth expr 2) nil))) (if (and (or (= head "defcomp") (= head "defisland")) (list? params-list)) (let ((result (list)) (in-key false)) (for-each (fn (p) (cond (and (= (type-of p) "symbol") (= (symbol-name p) "&key")) (set! in-key true) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) (set! in-key false) in-key (cond (and (list? p) (not (empty? p))) (append! result (if (= (type-of (first p)) "symbol") (symbol-name (first p)) (str (first p)))) (= (type-of p) "symbol") (append! result (symbol-name p)) :else nil))) params-list) result) (list)))))) (reset! parsed (sx-parse (deref source))) (div :class "space-y-4" (div :class "space-y-2" (label :class "text-sm font-medium text-stone-700" "SX Source") (textarea :class "w-full font-mono text-xs bg-stone-50 border border-stone-200 rounded p-3 leading-relaxed" :rows 6 :bind source)) (div :class "flex gap-2 items-center" (button :class "px-3 py-1 text-xs rounded bg-stone-700 text-white hover:bg-stone-800" :on-click (fn (e) (reset! parsed (sx-parse (deref source))) (reset! selected-path nil)) "Parse") (for-each (fn (mode) (button :class (str "px-3 py-1 text-xs rounded border transition-colors " (if (= (deref view-mode) mode) "bg-violet-600 text-white border-violet-600" "bg-white text-stone-600 border-stone-200 hover:border-violet-300")) :on-click (fn (e) (reset! view-mode mode)) mode)) (list "tree" "context" "validate" "render"))) (when (= (deref view-mode) "render") (let ((tree (deref parsed)) (all-params (let ((acc (list))) (when (and tree (not (empty? tree))) (for-each (fn (expr) (for-each (fn (p) (when (not (some (fn (x) (= x p)) acc)) (append! acc p))) (extract-params expr))) tree)) acc))) (when (not (empty? all-params)) (div :class "space-y-2 p-3 bg-violet-50 rounded border border-violet-200" (div :class "text-xs font-semibold text-violet-700 mb-1" "Parameters") (map (fn (pname) (div :class "flex items-center gap-2" (label :class "text-xs font-mono text-stone-600 w-24 text-right" pname) (input :type "text" :class "flex-1 px-2 py-1 text-xs font-mono border border-stone-300 rounded bg-white" :placeholder (str pname " value") :on-input (fn (e) (reset! bindings (assoc (deref bindings) pname (element-value (host-get e "target")))))))) all-params))))) (if (or (nil? (deref parsed)) (empty? (deref parsed))) (div :class "text-red-500 text-sm font-mono p-3 bg-red-50 rounded" "Parse error — check your s-expression syntax") (div :class "bg-stone-50 rounded border border-stone-200 p-3 font-mono text-xs leading-relaxed overflow-x-auto" (cond (= (deref view-mode) "tree") (let ((entries (list)) (tree (deref parsed))) (for-each (fn (i) (build-entries (nth tree i) (list i) 0 entries)) (range 0 (len tree))) (div :class "space-y-0" (map (fn (entry) (let ((path (get entry "path")) (sel (deref selected-path)) (is-selected (and (not (nil? sel)) (= (fmt-path sel) (fmt-path path))))) (div :class (str "py-0.5 cursor-pointer hover:bg-violet-50 rounded px-1 " (if is-selected "bg-violet-100" "")) :style (str "padding-left:" (* (get entry "depth") 16) "px") :on-click (fn (e) (reset! selected-path path)) (span :class "text-stone-400 mr-2 select-none" (fmt-path path)) (span :class (if (get entry "is-list") "text-sky-700" "text-stone-600") (get entry "text"))))) entries))) (= (deref view-mode) "context") (if (nil? (deref selected-path)) (p :class "text-stone-400 italic" "Click a node in tree view to see its context") (let ((ctx (build-context (deref parsed) (deref selected-path)))) (div :class "space-y-1" (map (fn (item) (div :style (str "padding-left:" (* (get item "depth") 16) "px") :class (if (get item "is-target") "text-violet-700 font-semibold" "text-stone-600") (span :class "text-stone-400 mr-2" (if (get item "is-target") "→ " " ") (fmt-path (get item "path"))) (span (get item "text")))) ctx)))) (= (deref view-mode) "validate") (let ((result (do-validate (deref parsed)))) (div :class (if (= result "OK") "text-emerald-600" "text-amber-600 whitespace-pre-wrap") result)) (= (deref view-mode) "render") (let ((tree (deref parsed))) (div :class "prose prose-sm max-w-none font-sans" (map (fn (expr) (if (not (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol"))) (div :class "font-mono text-xs text-stone-400 p-2 bg-stone-100 rounded" (sx-serialize expr)) (let ((head-name (symbol-name (first expr)))) (cond (is-html-tag? head-name) expr (or (= head-name "defcomp") (= head-name "defisland")) (let ((body (last expr)) (params (extract-params expr)) (b (deref bindings))) (div (div :class "text-xs text-stone-400 mb-2 font-mono" (str head-name " " (node-disp (nth expr 1)))) (letrec ((subst (fn (node) (cond (and (= (type-of node) "symbol") (some (fn (p) (= p (symbol-name node))) params)) (or (get b (symbol-name node)) "") (list? node) (map subst node) :else node)))) (subst body)))) (= head-name "let") (last expr) :else (div :class "font-mono text-xs text-stone-400 p-2 bg-stone-100 rounded" (sx-serialize expr)))))) tree))) :else (p "Select a view mode")))))))) +(defisland ~sx-tools/tree-editor () (let ((source (signal "(defcomp ~card (&key title subtitle)\n (div :class \"card\"\n (h2 title)\n (when subtitle\n (p :class \"sub\" subtitle))))")) (view-mode (signal "tree")) (selected-path (signal nil)) (parsed (signal nil)) (bindings (signal (dict)))) (letrec ((fmt-path (fn (path) (str "[" (join "," (map str path)) "]"))) (node-disp (fn (node) (cond (nil? node) "nil" (= (type-of node) "symbol") (symbol-name node) (= (type-of node) "keyword") (str ":" (keyword-name node)) (string? node) (let ((s (if (> (len node) 35) (str (slice node 0 32) "...") node))) (str "\"" s "\"")) (number? node) (str node) (= (type-of node) "boolean") (if node "true" "false") (list? node) (if (empty? node) "()" (str "(" (node-disp (first node)) (if (> (len node) 1) " ..." "") ")")) :else (str node)))) (is-compact (fn (node) (and (list? node) (<= (len node) 4) (not (some (fn (c) (list? c)) (rest node)))))) (build-entries (fn (node path depth result) (if (list? node) (if (empty? node) (append! result {:expandable false :depth depth :text "()" :is-list false :path path}) (if (is-compact node) (append! result {:expandable false :depth depth :text (str "(" (join " " (map node-disp node)) ")") :is-list true :path path}) (do (append! result {:expandable true :depth depth :text (str "(" (node-disp (first node))) :is-list true :path path}) (for-each (fn (i) (build-entries (nth node i) (concat path (list i)) (+ depth 1) result)) (range 1 (len node)))))) (append! result {:expandable false :depth depth :text (node-disp node) :is-list false :path path})))) (nav (fn (tree path) (reduce (fn (current idx) (if (or (nil? current) (not (list? current)) (>= idx (len current))) nil (nth current idx))) tree path))) (build-context (fn (tree path) (let ((result (list))) (for-each (fn (depth) (let ((prefix (slice path 0 (+ depth 1))) (node (nav tree prefix))) (when (not (nil? node)) (let ((is-target (= (+ depth 1) (len path)))) (append! result {:depth depth :is-target is-target :text (if (list? node) (if (empty? node) "()" (let ((head (node-disp (first node)))) (if (> (len node) 3) (str "(" head " " (node-disp (nth node 1)) " ...)") (str "(" (join " " (map node-disp node)) ")")))) (node-disp node)) :path prefix}))))) (range 0 (len path))) result))) (do-validate (fn (tree) (let ((errors (list))) (letrec ((check (fn (node path) (when (list? node) (when (not (empty? node)) (let ((head (first node))) (when (and (= (type-of head) "symbol") (or (= (symbol-name head) "letrec")) (>= (len node) 2)) (let ((bindings (nth node 1))) (when (list? bindings) (for-each (fn (i) (let ((pair (nth bindings i))) (when (not (and (list? pair) (>= (len pair) 2) (= (type-of (first pair)) "symbol"))) (append! errors (str "Binding " i " at " (fmt-path (concat path (list 1 i))) " is not a (name value) pair"))))) (range 0 (len bindings)))))) (when (and (= (type-of head) "symbol") (or (= (symbol-name head) "defcomp") (= (symbol-name head) "defisland"))) (when (< (len node) 4) (append! errors (str (symbol-name head) " at " (fmt-path path) " missing body")))))) (for-each (fn (i) (check (nth node i) (concat path (list i)))) (range 0 (len node))))))) (for-each (fn (i) (check (nth tree i) (list i))) (range 0 (len tree)))) (if (empty? errors) "OK" (join "\n" errors))))) (extract-params (fn (expr) (let ((head (if (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol")) (symbol-name (first expr)) nil)) (params-list (if (and (list? expr) (> (len expr) 2)) (nth expr 2) nil))) (if (and (or (= head "defcomp") (= head "defisland")) (list? params-list)) (let ((result (list)) (in-key false)) (for-each (fn (p) (cond (and (= (type-of p) "symbol") (= (symbol-name p) "&key")) (set! in-key true) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) (set! in-key false) in-key (cond (and (list? p) (not (empty? p))) (append! result (if (= (type-of (first p)) "symbol") (symbol-name (first p)) (str (first p)))) (= (type-of p) "symbol") (append! result (symbol-name p)) :else nil))) params-list) result) (list)))))) (reset! parsed (sx-parse (deref source))) (div :class "space-y-4" (div :class "space-y-2" (label :class "text-sm font-medium text-stone-700" "SX Source") (textarea :class "w-full font-mono text-xs bg-stone-50 border border-stone-200 rounded p-3 leading-relaxed" :rows 6 :bind source)) (div :class "flex gap-2 items-center" (button :class "px-3 py-1 text-xs rounded bg-stone-700 text-white hover:bg-stone-800" :on-click (fn (e) (reset! parsed (sx-parse (deref source))) (reset! selected-path nil)) "Parse") (for-each (fn (mode) (button :class (str "px-3 py-1 text-xs rounded border transition-colors " (if (= (deref view-mode) mode) "bg-violet-600 text-white border-violet-600" "bg-white text-stone-600 border-stone-200 hover:border-violet-300")) :on-click (fn (e) (reset! view-mode mode)) mode)) (list "tree" "context" "validate" "render" "hypersx"))) (when (= (deref view-mode) "render") (let ((tree (deref parsed)) (all-params (let ((acc (list))) (when (and tree (not (empty? tree))) (for-each (fn (expr) (for-each (fn (p) (when (not (some (fn (x) (= x p)) acc)) (append! acc p))) (extract-params expr))) tree)) acc))) (when (not (empty? all-params)) (div :class "space-y-2 p-3 bg-violet-50 rounded border border-violet-200" (div :class "text-xs font-semibold text-violet-700 mb-1" "Parameters") (map (fn (pname) (div :class "flex items-center gap-2" (label :class "text-xs font-mono text-stone-600 w-24 text-right" pname) (input :type "text" :class "flex-1 px-2 py-1 text-xs font-mono border border-stone-300 rounded bg-white" :placeholder (str pname " value") :on-input (fn (e) (reset! bindings (assoc (deref bindings) pname (element-value (host-get e "target")))))))) all-params))))) (if (or (nil? (deref parsed)) (empty? (deref parsed))) (div :class "text-red-500 text-sm font-mono p-3 bg-red-50 rounded" "Parse error — check your s-expression syntax") (div :class "bg-stone-50 rounded border border-stone-200 p-3 font-mono text-xs leading-relaxed overflow-x-auto" (cond (= (deref view-mode) "tree") (let ((entries (list)) (tree (deref parsed))) (for-each (fn (i) (build-entries (nth tree i) (list i) 0 entries)) (range 0 (len tree))) (div :class "space-y-0" (map (fn (entry) (let ((path (get entry "path")) (sel (deref selected-path)) (is-selected (and (not (nil? sel)) (= (fmt-path sel) (fmt-path path))))) (div :class (str "py-0.5 cursor-pointer hover:bg-violet-50 rounded px-1 " (if is-selected "bg-violet-100" "")) :style (str "padding-left:" (* (get entry "depth") 16) "px") :on-click (fn (e) (reset! selected-path path)) (span :class "text-stone-400 mr-2 select-none" (fmt-path path)) (span :class (if (get entry "is-list") "text-sky-700" "text-stone-600") (get entry "text"))))) entries))) (= (deref view-mode) "context") (if (nil? (deref selected-path)) (p :class "text-stone-400 italic" "Click a node in tree view to see its context") (let ((ctx (build-context (deref parsed) (deref selected-path)))) (div :class "space-y-1" (map (fn (item) (div :style (str "padding-left:" (* (get item "depth") 16) "px") :class (if (get item "is-target") "text-violet-700 font-semibold" "text-stone-600") (span :class "text-stone-400 mr-2" (if (get item "is-target") "→ " " ") (fmt-path (get item "path"))) (span (get item "text")))) ctx)))) (= (deref view-mode) "validate") (let ((result (do-validate (deref parsed)))) (div :class (if (= result "OK") "text-emerald-600" "text-amber-600 whitespace-pre-wrap") result)) (= (deref view-mode) "render") (let ((tree (deref parsed))) (div :class "prose prose-sm max-w-none font-sans" (map (fn (expr) (if (not (and (list? expr) (not (empty? expr)) (= (type-of (first expr)) "symbol"))) (div :class "font-mono text-xs text-stone-400 p-2 bg-stone-100 rounded" (sx-serialize expr)) (let ((head-name (symbol-name (first expr)))) (cond (is-html-tag? head-name) expr (or (= head-name "defcomp") (= head-name "defisland")) (let ((body (last expr)) (params (extract-params expr)) (b (deref bindings))) (div (div :class "text-xs text-stone-400 mb-2 font-mono" (str head-name " " (node-disp (nth expr 1)))) (letrec ((subst (fn (node) (cond (and (= (type-of node) "symbol") (some (fn (p) (= p (symbol-name node))) params)) (or (get b (symbol-name node)) "") (list? node) (map subst node) :else node)))) (subst body)))) (= head-name "let") (last expr) :else (div :class "font-mono text-xs text-stone-400 p-2 bg-stone-100 rounded" (sx-serialize expr)))))) tree))) (= (deref view-mode) "hypersx") (pre :class "font-mono text-xs text-stone-700 whitespace-pre-wrap overflow-x-auto" (sx->hypersx (deref parsed))) :else (p "Select a view mode")))))))) diff --git a/web/lib/hypersx.sx b/web/lib/hypersx.sx new file mode 100644 index 00000000..1082d8fe --- /dev/null +++ b/web/lib/hypersx.sx @@ -0,0 +1,25 @@ +(define hsx-indent (fn (depth) (let ((result "")) (for-each (fn (_) (set! result (str result " "))) (range 0 depth)) result))) + +(define hsx-sym-name (fn (node) (if (= (type-of node) "symbol") (symbol-name node) nil))) + +(define hsx-kw-name (fn (node) (if (= (type-of node) "keyword") (keyword-name node) nil))) + +(define hsx-is-element? (fn (name) (and name (not (starts-with? name "~")) (is-html-tag? name)))) + +(define hsx-is-component? (fn (name) (and name (starts-with? name "~")))) + +(define hsx-extract-css (fn (args) (let ((classes nil) (id nil) (rest-attrs (list)) (i 0) (n (len args))) (letrec ((walk (fn () (when (< i n) (let ((kn (hsx-kw-name (nth args i)))) (cond (= kn "class") (do (set! classes (nth args (+ i 1))) (set! i (+ i 2)) (walk)) (= kn "id") (do (set! id (nth args (+ i 1))) (set! i (+ i 2)) (walk)) kn (do (append! rest-attrs (nth args i)) (append! rest-attrs (nth args (+ i 1))) (set! i (+ i 2)) (walk)) :else nil)))))) (walk) (dict "classes" classes "id" id "attrs" rest-attrs "children" (if (< i n) (slice args i) (list))))))) + +(define hsx-tag-str (fn (name css) (let ((s name) (cls (get css "classes")) (eid (get css "id"))) (when (and cls (string? cls)) (for-each (fn (c) (set! s (str s "." c))) (split cls " "))) (when eid (set! s (str s "#" eid))) s))) + +(define hsx-atom (fn (node) (cond (nil? node) "nil" (string? node) (str "\"" node "\"") (number? node) (str node) (= (type-of node) "boolean") (if node "true" "false") (= (type-of node) "symbol") (str "{" (symbol-name node) "}") (= (type-of node) "keyword") (str ":" (keyword-name node)) :else (sx-serialize node)))) + +(define hsx-inline (fn (node) (cond (not (list? node)) (sx-serialize node) (empty? node) "()" :else (let ((hd (hsx-sym-name (first node)))) (cond (= hd "deref") (str "@" (sx-serialize (nth node 1))) (= hd "signal") (str "signal(" (if (> (len node) 1) (hsx-inline (nth node 1)) "") ")") (= hd "reset!") (str (sx-serialize (nth node 1)) " := " (hsx-inline (nth node 2))) (= hd "swap!") (str (sx-serialize (nth node 1)) " <- " (hsx-inline (nth node 2))) (= hd "str") (str "\"" (join "" (map (fn (a) (if (string? a) a (str "{" (hsx-inline a) "}"))) (rest node))) "\"") :else (str "(" (sx-serialize (first node)) (if (> (len node) 1) (str " " (join " " (map hsx-inline (rest node)))) "") ")")))))) + +(define hsx-attrs-str (fn (attrs) (if (empty? attrs) "" (let ((parts (list)) (i 0)) (letrec ((walk (fn () (when (< i (len attrs)) (append! parts (str ":" (keyword-name (nth attrs i)) " " (hsx-atom (nth attrs (+ i 1))))) (set! i (+ i 2)) (walk))))) (walk)) (str " " (join " " parts)))))) + +(define hsx-children (fn (line kids depth) (if (empty? kids) line (if (and (= (len kids) 1) (not (list? (first kids)))) (str line " " (hsx-atom (first kids))) (str line "\n" (join "\n" (map (fn (c) (sx->hypersx-node c (+ depth 1))) kids))))))) + +(define sx->hypersx-node (fn (node depth) (let ((pad (hsx-indent depth))) (cond (nil? node) (str pad "nil") (not (list? node)) (str pad (hsx-atom node)) (empty? node) (str pad "()") :else (let ((hd (hsx-sym-name (first node)))) (cond (= hd "str") (str pad (hsx-inline node)) (= hd "deref") (str pad (hsx-inline node)) (= hd "reset!") (str pad (hsx-inline node)) (= hd "swap!") (str pad (hsx-inline node)) (= hd "signal") (str pad (hsx-inline node)) (or (= hd "defcomp") (= hd "defisland")) (str pad hd " " (sx-serialize (nth node 1)) " " (sx-serialize (nth node 2)) "\n" (sx->hypersx-node (last node) (+ depth 1))) (= hd "when") (str pad "when " (hsx-inline (nth node 1)) "\n" (join "\n" (map (fn (c) (sx->hypersx-node c (+ depth 1))) (slice node 2)))) (= hd "if") (let ((test (nth node 1)) (then-b (nth node 2)) (else-b (if (> (len node) 3) (nth node 3) nil))) (if (and (not (list? then-b)) (or (nil? else-b) (not (list? else-b)))) (str pad "if " (hsx-inline test) " " (hsx-atom then-b) (if else-b (str " " (hsx-atom else-b)) "")) (str pad "if " (hsx-inline test) "\n" (sx->hypersx-node then-b (+ depth 1)) (if else-b (str "\n" pad "else\n" (sx->hypersx-node else-b (+ depth 1))) "")))) (or (= hd "let") (= hd "letrec") (= hd "let*")) (let ((binds (nth node 1)) (body (slice node 2))) (str pad hd " " (join ", " (map (fn (b) (if (and (list? b) (>= (len b) 2)) (str (sx-serialize (first b)) " = " (hsx-inline (nth b 1))) (sx-serialize b))) (if (and (list? binds) (not (empty? binds)) (list? (first binds))) binds (list binds)))) "\n" (join "\n" (map (fn (b) (sx->hypersx-node b (+ depth 1))) body)))) (and (= hd "map") (= (len node) 3) (list? (nth node 1)) (= (hsx-sym-name (first (nth node 1))) "fn")) (let ((fn-node (nth node 1)) (coll (nth node 2))) (str pad "map " (hsx-inline coll) " -> " (sx-serialize (nth fn-node 1)) "\n" (sx->hypersx-node (last fn-node) (+ depth 1)))) (and (= hd "for-each") (= (len node) 3) (list? (nth node 1)) (= (hsx-sym-name (first (nth node 1))) "fn")) (let ((fn-node (nth node 1)) (coll (nth node 2))) (str pad "for " (sx-serialize (nth fn-node 1)) " in " (hsx-inline coll) "\n" (sx->hypersx-node (last fn-node) (+ depth 1)))) (hsx-is-element? hd) (let ((css (hsx-extract-css (rest node)))) (hsx-children (str pad (hsx-tag-str hd css) (hsx-attrs-str (get css "attrs"))) (get css "children") depth)) (hsx-is-component? hd) (let ((css (hsx-extract-css (rest node)))) (hsx-children (str pad hd (hsx-attrs-str (get css "attrs"))) (get css "children") depth)) :else (str pad (sx-serialize node)))))))) + +(define sx->hypersx (fn (tree) (join "\n\n" (map (fn (expr) (sx->hypersx-node expr 0)) tree))))