From 63babc0d2d358966e88ee2e5da1415180746958b Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 25 Mar 2026 20:35:40 +0000 Subject: [PATCH] Add render tab to tree editor, switch MCP paths to SX format MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Tree editor island now has 4 tabs: tree, context, validate, render. The render tab evaluates SX source as live HTML — type a (div (h2 "Hello")) and see it rendered immediately. MCP server paths changed from JSON arrays [0,2,1] to SX strings "(0 2 1)". Fixes serialization issues and is more natural for an SX tool. The json_to_path function now parses SX via sx-parse. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bin/mcp_tree.ml | 15 ++- sx/sx/sx-tools-editor.sx | 193 +----------------------------------- 2 files changed, 14 insertions(+), 194 deletions(-) diff --git a/hosts/ocaml/bin/mcp_tree.ml b/hosts/ocaml/bin/mcp_tree.ml index e305d94c..30b971c6 100644 --- a/hosts/ocaml/bin/mcp_tree.ml +++ b/hosts/ocaml/bin/mcp_tree.ml @@ -174,9 +174,20 @@ let parse_file path = let exprs = Sx_parser.parse_all src in List exprs +let parse_path_str s = + (* Parse SX path string: "(0 3 2)" or "0 3 2" → SX list of numbers *) + let exprs = Sx_parser.parse_all s in + match exprs with + | [List items] -> + (* (0 3 2) → list of numbers *) + List (List.map (fun x -> match x with Number _ -> x | _ -> Number 0.0) items) + | _ -> + (* Bare numbers: "0 3 2" → parsed as separate exprs *) + List (List.map (fun x -> match x with Number _ -> x | _ -> Number 0.0) exprs) + let json_to_path j = let open Yojson.Safe.Util in - List (List.map (fun x -> Number (float_of_int (to_int x))) (to_list j)) + parse_path_str (to_string j) let value_to_string v = match v with @@ -311,7 +322,7 @@ let tool name desc props required = ("properties", `Assoc props)])] let file_prop = ("file", `Assoc [("type", `String "string"); ("description", `String "Path to .sx file")]) -let path_prop = ("path", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "integer")]); ("description", `String "Index path, e.g. [0,2,1]")]) +let path_prop = ("path", `Assoc [("type", `String "string"); ("description", `String "SX path, e.g. \"(0 2 1)\"")]) let tool_definitions = `List [ tool "sx_read_tree" "Read an .sx file as an annotated tree with path labels on every node. Use this to understand structure before editing." diff --git a/sx/sx/sx-tools-editor.sx b/sx/sx/sx-tools-editor.sx index fe07a717..ab8db4ff 100644 --- a/sx/sx/sx-tools-editor.sx +++ b/sx/sx/sx-tools-editor.sx @@ -1,192 +1 @@ -;; SX Tools — Interactive tree editor island -;; Demonstrates the tree comprehension tools on user-provided SX source. - -(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))) - - ;; --- Inline tree display functions (pure, no lib dependency) --- - - (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 a list of {path, text, depth, is-list, expandable} entries - (build-entries (fn (node path depth result) - (if (list? node) - (if (empty? node) - (append! result {"path" path "text" "()" "depth" depth "is-list" false "expandable" false}) - (if (is-compact node) - (append! result {"path" path "text" (str "(" (join " " (map node-disp node)) ")") "depth" depth "is-list" true "expandable" false}) - (do - (append! result {"path" path "text" (str "(" (node-disp (first node))) "depth" depth "is-list" true "expandable" true}) - (for-each (fn (i) - (build-entries (nth node i) (concat path (list i)) (+ depth 1) result)) - (range 1 (len node)))))) - (append! result {"path" path "text" (node-disp node) "depth" depth "is-list" false "expandable" false})))) - - ;; Navigate to a node by 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 chain for a 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 - {"path" prefix - "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)) - "is-target" is-target - "depth" depth}))))) - (range 0 (len path))) - result))) - - ;; Simple validate - (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)))))) - - ;; Initial parse - (reset! parsed (sx-parse (deref source))) - - ;; --- Render --- - (div :class "space-y-4" - ;; Input area - (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)) - - ;; Parse button + mode selector - (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"))) - - ;; Output area - (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" - - ;; TREE VIEW - (when (= (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)))) - - ;; CONTEXT VIEW - (when (= (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") "\u2192 " " ") - (fmt-path (get item "path"))) - (span (get item "text")))) - ctx))))) - - ;; VALIDATE VIEW - (when (= (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))))))))) +(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))) (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)))))) (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"))) (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" (when (= (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)))) (when (= (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))))) (when (= (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))) (when (= (deref view-mode) "render") (let ((tree (deref parsed))) (div :class "space-y-2" (for-each (fn (i) (let ((expr (nth tree i))) (div :class "border border-stone-200 rounded p-3" (if (and (list? expr) (not (empty? expr))) (let ((head (first expr))) (if (and (= (type-of head) "symbol") (is-html-tag? (symbol-name head))) expr (div :class "font-mono text-xs text-stone-500" (sx-serialize expr)))) (div :class "font-mono text-xs text-stone-500" (sx-serialize expr)))))) (range 0 (len tree))))))))))))