giles
5ed984e7e3
Nav refactoring: - Split nav-data.sx (32 forms) into 6 files: nav-geography, nav-language, nav-applications, nav-etc, nav-tools, nav-tree - Add Tools top-level nav category with SX Tools and Services pages - New services-tools.sx page documenting the rose-ash-services MCP server JS build fixes (fixes 5 Playwright failures): - Wire web/web-signals.sx into JS build (stores, events, resources) - Add cek-try primitive to JS platform (island hydration error handling) - Merge PRIMITIVES into getRenderEnv (island env was missing primitives) - Rename web/signals.sx → web/web-signals.sx to avoid spec/ collision New MCP tools: - sx_trace: step-through CEK evaluation showing lookups, calls, returns - sx_deps: dependency analysis — free symbols + cross-file resolution - sx_build_manifest: show build contents for JS and OCaml targets - sx_harness_eval extended: multi-file loading + setup expressions Deep path bug fix: - Native OCaml list-replace and navigate bypass CEK callback chain - Fixes sx_replace_node and sx_read_subtree corruption on paths 6+ deep Tests: 1478/1478 JS full suite, 91/91 Playwright Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1318 lines
37 KiB
Plaintext
1318 lines
37 KiB
Plaintext
(define
|
|
path-str
|
|
:effects ()
|
|
(fn ((path :as list)) (str "[" (join "," (map str path)) "]")))
|
|
|
|
(define
|
|
annotate-tree
|
|
:effects ()
|
|
(fn
|
|
(exprs)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))))
|
|
(let
|
|
((result (list)))
|
|
(for-each
|
|
(fn (i) (annotate-node (nth nodes i) (list i) 0 result))
|
|
(range 0 (len nodes)))
|
|
(join "\n" result)))))
|
|
|
|
(define
|
|
annotate-node
|
|
:effects ()
|
|
(fn
|
|
(node path depth result)
|
|
(let
|
|
((indent (join "" (map (fn (_) " ") (range 0 depth))))
|
|
(label (path-str path)))
|
|
(if
|
|
(list? node)
|
|
(if
|
|
(empty? node)
|
|
(append! result (str indent label " ()"))
|
|
(let
|
|
((head (first node)) (head-str (node-display head)))
|
|
(if
|
|
(and
|
|
(<= (len node) 4)
|
|
(not (some (fn (c) (list? c)) (rest node))))
|
|
(append!
|
|
result
|
|
(str
|
|
indent
|
|
label
|
|
" ("
|
|
(join " " (map node-display node))
|
|
")"))
|
|
(do
|
|
(append! result (str indent label " (" head-str))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(annotate-node
|
|
(nth node i)
|
|
(concat path (list i))
|
|
(+ depth 1)
|
|
result))
|
|
(range 1 (len node)))
|
|
(append! result (str indent " )"))))))
|
|
(append! result (str indent label " " (node-display node)))))))
|
|
|
|
(define
|
|
node-display
|
|
:effects ()
|
|
(fn
|
|
(node)
|
|
(cond
|
|
(nil? node)
|
|
"nil"
|
|
(= (type-of node) "symbol")
|
|
(symbol-name node)
|
|
(= (type-of node) "keyword")
|
|
(str ":" (keyword-name node))
|
|
(= (type-of node) "string")
|
|
(let
|
|
((s (if (> (len node) 40) (str (slice node 0 37) "...") node)))
|
|
(str "\"" s "\""))
|
|
(= (type-of node) "number")
|
|
(str node)
|
|
(= (type-of node) "boolean")
|
|
(if node "true" "false")
|
|
(list? node)
|
|
(if
|
|
(empty? node)
|
|
"()"
|
|
(str
|
|
"("
|
|
(node-display (first node))
|
|
(if (> (len node) 1) " ..." "")
|
|
")"))
|
|
(= (type-of node) "dict")
|
|
"{...}"
|
|
:else (str node))))
|
|
|
|
(define
|
|
summarise
|
|
:effects ()
|
|
(fn
|
|
(exprs max-depth)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))) (result (list)))
|
|
(for-each
|
|
(fn (i) (summarise-node (nth nodes i) (list i) 0 max-depth result))
|
|
(range 0 (len nodes)))
|
|
(join "\n" result))))
|
|
|
|
(define
|
|
summarise-node
|
|
:effects ()
|
|
(fn
|
|
(node path depth max-depth result)
|
|
(let
|
|
((indent (join "" (map (fn (_) " ") (range 0 depth))))
|
|
(label (path-str path)))
|
|
(if
|
|
(list? node)
|
|
(if
|
|
(empty? node)
|
|
(append! result (str indent label " ()"))
|
|
(let
|
|
((head (first node)) (head-str (node-display head)))
|
|
(if
|
|
(>= depth max-depth)
|
|
(append!
|
|
result
|
|
(str
|
|
indent
|
|
label
|
|
" ("
|
|
head-str
|
|
(if
|
|
(> (len node) 1)
|
|
(str " ... " (- (len node) 1) " children")
|
|
"")
|
|
")"))
|
|
(do
|
|
(append! result (str indent label " (" head-str))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(summarise-node
|
|
(nth node i)
|
|
(concat path (list i))
|
|
(+ depth 1)
|
|
max-depth
|
|
result))
|
|
(range 1 (len node)))
|
|
(append! result (str indent " )"))))))
|
|
(append! result (str indent label " " (node-display node)))))))
|
|
|
|
(define
|
|
read-subtree
|
|
:effects ()
|
|
(fn
|
|
(exprs path)
|
|
(let
|
|
((node (navigate exprs path)))
|
|
(if
|
|
(nil? node)
|
|
(str "Error: path " (path-str path) " not found")
|
|
(annotate-tree (list node))))))
|
|
|
|
(define
|
|
get-context
|
|
:effects ()
|
|
(fn
|
|
(exprs path)
|
|
(let
|
|
((result (list)) (nodes (if (list? exprs) exprs (list exprs))))
|
|
(for-each
|
|
(fn
|
|
(depth)
|
|
(let
|
|
((prefix (slice path 0 (+ depth 1)))
|
|
(node (navigate nodes prefix)))
|
|
(when
|
|
(not (nil? node))
|
|
(let
|
|
((label (path-str prefix))
|
|
(indent (join "" (map (fn (_) " ") (range 0 depth))))
|
|
(marker (if (= (+ depth 1) (len path)) "→ " " ")))
|
|
(if
|
|
(list? node)
|
|
(append!
|
|
result
|
|
(str indent marker label " " (node-summary node)))
|
|
(append!
|
|
result
|
|
(str indent marker label " " (node-display node))))))))
|
|
(range 0 (len path)))
|
|
(join "\n" result))))
|
|
|
|
(define
|
|
node-summary
|
|
:effects ()
|
|
(fn
|
|
(node)
|
|
(if
|
|
(or (not (list? node)) (empty? node))
|
|
(node-display node)
|
|
(let
|
|
((head (node-display (first node)))
|
|
(child-count (- (len node) 1)))
|
|
(if
|
|
(<= child-count 3)
|
|
(str "(" (join " " (map node-display node)) ")")
|
|
(str
|
|
"("
|
|
head
|
|
" "
|
|
(node-display (nth node 1))
|
|
(when (> child-count 1) (str " ... +" (- child-count 1)))
|
|
")"))))))
|
|
|
|
(define
|
|
find-all
|
|
:effects ()
|
|
(fn
|
|
(exprs pattern)
|
|
(let
|
|
((results (list)) (nodes (if (list? exprs) exprs (list exprs))))
|
|
(for-each
|
|
(fn (i) (find-in-node (nth nodes i) (list i) pattern results))
|
|
(range 0 (len nodes)))
|
|
results)))
|
|
|
|
(define
|
|
find-in-node
|
|
:effects ()
|
|
(fn
|
|
(node path pattern results)
|
|
(when
|
|
(node-matches? node pattern)
|
|
(append! results (list path (node-summary-short node))))
|
|
(when
|
|
(list? node)
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(find-in-node (nth node i) (concat path (list i)) pattern results))
|
|
(range 0 (len node))))))
|
|
|
|
(define
|
|
node-matches?
|
|
:effects ()
|
|
(fn
|
|
(node pattern)
|
|
(cond
|
|
(= (type-of node) "symbol")
|
|
(contains? (symbol-name node) pattern)
|
|
(string? node)
|
|
(contains? node pattern)
|
|
(and
|
|
(list? node)
|
|
(not (empty? node))
|
|
(= (type-of (first node)) "symbol"))
|
|
(contains? (symbol-name (first node)) pattern)
|
|
:else false)))
|
|
|
|
(define
|
|
node-summary-short
|
|
:effects ()
|
|
(fn
|
|
(node)
|
|
(if
|
|
(list? node)
|
|
(if
|
|
(empty? node)
|
|
"()"
|
|
(let
|
|
((head (node-display (first node))))
|
|
(if
|
|
(> (len node) 3)
|
|
(str "(" head " " (node-display (nth node 1)) " ...)")
|
|
(str "(" (join " " (map node-display node)) ")"))))
|
|
(node-display node))))
|
|
|
|
(define
|
|
get-siblings
|
|
:effects ()
|
|
(fn
|
|
(exprs path)
|
|
(if
|
|
(empty? path)
|
|
"Error: root has no siblings"
|
|
(let
|
|
((parent-path (slice path 0 (- (len path) 1)))
|
|
(target-idx (last path))
|
|
(parent (navigate exprs parent-path)))
|
|
(if
|
|
(or (nil? parent) (not (list? parent)))
|
|
(str
|
|
"Error: parent at "
|
|
(path-str parent-path)
|
|
" not found or not a list")
|
|
(let
|
|
((result (list)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((child (nth parent i))
|
|
(child-path (concat parent-path (list i)))
|
|
(marker (if (= i target-idx) "→ " " ")))
|
|
(append!
|
|
result
|
|
(str
|
|
marker
|
|
(path-str child-path)
|
|
" "
|
|
(if
|
|
(list? child)
|
|
(node-summary child)
|
|
(node-display child))))))
|
|
(range 0 (len parent)))
|
|
(join "\n" result)))))))
|
|
|
|
(define
|
|
validate
|
|
:effects ()
|
|
(fn
|
|
(exprs)
|
|
(let
|
|
((errors (list)) (nodes (if (list? exprs) exprs (list exprs))))
|
|
(for-each
|
|
(fn (i) (validate-node (nth nodes i) (list i) errors))
|
|
(range 0 (len nodes)))
|
|
(if (empty? errors) "OK" (join "\n" errors)))))
|
|
|
|
(define
|
|
validate-node
|
|
:effects ()
|
|
(fn
|
|
(node path errors)
|
|
(when
|
|
(list? node)
|
|
(when
|
|
(not (empty? node))
|
|
(let
|
|
((head (first node)))
|
|
(when
|
|
(and
|
|
(= (type-of head) "symbol")
|
|
(= (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
|
|
"WARNING "
|
|
(path-str (concat path (list 1 i)))
|
|
": letrec binding "
|
|
i
|
|
" is not a (name value) pair: "
|
|
(node-display pair))))))
|
|
(range 0 (len bindings))))))
|
|
(when
|
|
(and
|
|
(= (type-of head) "symbol")
|
|
(or
|
|
(= (symbol-name head) "defisland")
|
|
(= (symbol-name head) "defcomp")))
|
|
(when
|
|
(< (len node) 4)
|
|
(append!
|
|
errors
|
|
(str
|
|
"ERROR "
|
|
(path-str path)
|
|
": "
|
|
(symbol-name head)
|
|
" has fewer than 3 args (name params body)"))))))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(validate-node (nth node i) (concat path (list i)) errors))
|
|
(range 0 (len node))))))
|
|
|
|
(define
|
|
navigate
|
|
:effects ()
|
|
(fn
|
|
(exprs path)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))))
|
|
(reduce
|
|
(fn
|
|
(current idx)
|
|
(if
|
|
(or
|
|
(nil? current)
|
|
(not (list? current))
|
|
(>= idx (len current)))
|
|
nil
|
|
(nth current idx)))
|
|
nodes
|
|
path))))
|
|
|
|
(define
|
|
resolve-named-path
|
|
:effects ()
|
|
(fn
|
|
(exprs named-path)
|
|
(let
|
|
((segments (if (string? named-path) (split-path-string named-path) named-path))
|
|
(nodes (if (list? exprs) exprs (list exprs))))
|
|
(let
|
|
((result (reduce (fn (state segment) (if (nil? (get state "node")) state (let ((node (get state "node")) (path (get state "path"))) (if (not (list? node)) {:node nil :path path} (let ((idx (find-child-by-name node segment))) (if (nil? idx) {:node nil :path path} {:node (nth node idx) :path (concat path (list idx))})))))) {:node nodes :path (list)} segments)))
|
|
(get result "path")))))
|
|
|
|
(define
|
|
split-path-string
|
|
:effects ()
|
|
(fn
|
|
((s :as string))
|
|
(filter (fn (x) (not (= (trim x) ""))) (split s ">"))))
|
|
|
|
(define
|
|
find-child-by-name
|
|
:effects ()
|
|
(fn
|
|
(node name)
|
|
(let
|
|
((trimmed (trim name)) (result nil))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(when
|
|
(nil? result)
|
|
(let
|
|
((child (nth node i)))
|
|
(when
|
|
(or
|
|
(and
|
|
(= (type-of child) "symbol")
|
|
(= (symbol-name child) trimmed))
|
|
(and
|
|
(list? child)
|
|
(not (empty? child))
|
|
(= (type-of (first child)) "symbol")
|
|
(= (symbol-name (first child)) trimmed)))
|
|
(set! result i)))))
|
|
(range 0 (len node)))
|
|
result)))
|
|
|
|
(define
|
|
replace-node
|
|
:effects ()
|
|
(fn
|
|
(exprs path new-source)
|
|
(let
|
|
((fragment (sx-parse new-source)))
|
|
(if
|
|
(empty? fragment)
|
|
{:error (str "Fragment parse error: empty result from: " new-source)}
|
|
(let
|
|
((new-node (if (= (len fragment) 1) (first fragment) (cons (make-symbol "begin") fragment)))
|
|
(result (tree-set exprs path new-node)))
|
|
(if (nil? result) {:error (str "Path not found: " (path-str path))} {:ok result}))))))
|
|
|
|
(define
|
|
insert-child
|
|
:effects ()
|
|
(fn
|
|
(exprs path index new-source)
|
|
(let
|
|
((fragment (sx-parse new-source)))
|
|
(if
|
|
(empty? fragment)
|
|
{:error (str "Failed to parse new source: " new-source)}
|
|
(let
|
|
((parent (navigate exprs path)))
|
|
(if
|
|
(or (nil? parent) (not (list? parent)))
|
|
{:error (str "Parent at " (path-str path) " not found or not a list")}
|
|
(if
|
|
(or (< index 0) (> index (len parent)))
|
|
{:error (str "Index " index " out of range for parent with " (len parent) " children")}
|
|
(let
|
|
((new-parent (concat (slice parent 0 index) fragment (slice parent index)))
|
|
(result (tree-set exprs path new-parent)))
|
|
(if (nil? result) {:error (str "Failed to set node at path " (path-str path))} {:ok result})))))))))
|
|
|
|
(define
|
|
delete-node
|
|
:effects ()
|
|
(fn
|
|
(exprs path)
|
|
(if
|
|
(empty? path)
|
|
{:error "Cannot delete root"}
|
|
(let
|
|
((parent-path (slice path 0 (- (len path) 1)))
|
|
(child-idx (last path))
|
|
(parent (navigate exprs parent-path)))
|
|
(if
|
|
(or (nil? parent) (not (list? parent)))
|
|
{:error (str "Parent not found or not a list: " (path-str parent-path))}
|
|
(if
|
|
(or (< child-idx 0) (>= child-idx (len parent)))
|
|
{:error (str "Index " child-idx " out of range")}
|
|
(let
|
|
((new-parent (list-remove parent child-idx))
|
|
(result (tree-set exprs parent-path new-parent)))
|
|
(if (nil? result) {:error "Failed to update tree"} {:ok result}))))))))
|
|
|
|
(define
|
|
wrap-node
|
|
:effects ()
|
|
(fn
|
|
(exprs path wrapper-source)
|
|
(let
|
|
((fragment (sx-parse wrapper-source)))
|
|
(if
|
|
(empty? fragment)
|
|
{:error (str "Wrapper parse error: empty result from: " wrapper-source)}
|
|
(let
|
|
((wrapper (first fragment)) (target (navigate exprs path)))
|
|
(if
|
|
(nil? target)
|
|
{:error (str "Path not found: " (path-str path))}
|
|
(let
|
|
((filled (replace-placeholder wrapper target)))
|
|
(if
|
|
(nil? filled)
|
|
{:error "Wrapper must contain _ as placeholder for the wrapped node"}
|
|
(let
|
|
((result (tree-set exprs path filled)))
|
|
(if (nil? result) {:error "Failed to update tree"} {:ok result}))))))))))
|
|
|
|
(define
|
|
replace-placeholder
|
|
:effects ()
|
|
(fn
|
|
(node replacement)
|
|
(cond
|
|
(and (= (type-of node) "symbol") (= (symbol-name node) "_"))
|
|
replacement
|
|
(list? node)
|
|
(let
|
|
((found false)
|
|
(result
|
|
(map
|
|
(fn
|
|
(child)
|
|
(if
|
|
found
|
|
child
|
|
(if
|
|
(and
|
|
(= (type-of child) "symbol")
|
|
(= (symbol-name child) "_"))
|
|
(do (set! found true) replacement)
|
|
(if
|
|
(list? child)
|
|
(let
|
|
((sub (replace-placeholder child replacement)))
|
|
(if (nil? sub) child (do (set! found true) sub)))
|
|
child))))
|
|
node)))
|
|
(if found result nil))
|
|
:else nil)))
|
|
|
|
(define
|
|
tree-set
|
|
:effects ()
|
|
(fn
|
|
(exprs path new-node)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))))
|
|
(if
|
|
(empty? path)
|
|
(if (list? new-node) new-node (list new-node))
|
|
(tree-set-inner nodes path 0 new-node)))))
|
|
|
|
(define
|
|
tree-set-inner
|
|
:effects ()
|
|
(fn
|
|
(node path depth new-node)
|
|
(if
|
|
(not (list? node))
|
|
nil
|
|
(let
|
|
((idx (nth path depth)))
|
|
(if
|
|
(or (< idx 0) (>= idx (len node)))
|
|
nil
|
|
(if
|
|
(= depth (- (len path) 1))
|
|
(list-replace node idx new-node)
|
|
(let
|
|
((child (nth node idx))
|
|
(new-child (tree-set-inner child path (+ depth 1) new-node)))
|
|
(if (nil? new-child) nil (list-replace node idx new-child)))))))))
|
|
|
|
(define
|
|
list-replace
|
|
:effects ()
|
|
(fn
|
|
(lst idx val)
|
|
(map-indexed (fn (i item) (if (= i idx) val item)) lst)))
|
|
|
|
(define
|
|
list-insert
|
|
:effects ()
|
|
(fn (lst idx val) (concat (slice lst 0 idx) (list val) (slice lst idx))))
|
|
|
|
(define
|
|
list-remove
|
|
:effects ()
|
|
(fn (lst idx) (concat (slice lst 0 idx) (slice lst (+ idx 1)))))
|
|
|
|
(define
|
|
tree-diff
|
|
:effects ()
|
|
(fn
|
|
(exprs-a exprs-b)
|
|
(let
|
|
((nodes-a (if (list? exprs-a) exprs-a (list exprs-a)))
|
|
(nodes-b (if (list? exprs-b) exprs-b (list exprs-b)))
|
|
(results (list)))
|
|
(diff-children nodes-a nodes-b (list) results)
|
|
(if (empty? results) "No differences" (join "\n" results)))))
|
|
|
|
(define
|
|
diff-children
|
|
:effects ()
|
|
(fn
|
|
(list-a list-b path results)
|
|
(let
|
|
((len-a (len list-a))
|
|
(len-b (len list-b))
|
|
(min-len (if (< len-a len-b) len-a len-b)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(diff-node
|
|
(nth list-a i)
|
|
(nth list-b i)
|
|
(concat path (list i))
|
|
results))
|
|
(range 0 min-len))
|
|
(when
|
|
(> len-b min-len)
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(append!
|
|
results
|
|
(str
|
|
"ADDED "
|
|
(path-str (concat path (list i)))
|
|
" "
|
|
(node-summary-short (nth list-b i)))))
|
|
(range min-len len-b)))
|
|
(when
|
|
(> len-a min-len)
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(append!
|
|
results
|
|
(str
|
|
"REMOVED "
|
|
(path-str (concat path (list i)))
|
|
" "
|
|
(node-summary-short (nth list-a i)))))
|
|
(range min-len len-a))))))
|
|
|
|
(define
|
|
diff-node
|
|
:effects ()
|
|
(fn
|
|
(a b path results)
|
|
(cond
|
|
(and (list? a) (list? b))
|
|
(diff-children a b path results)
|
|
(and (not (list? a)) (not (list? b)))
|
|
(when
|
|
(not (= (node-display a) (node-display b)))
|
|
(append!
|
|
results
|
|
(str
|
|
"CHANGED "
|
|
(path-str path)
|
|
" "
|
|
(node-display a)
|
|
" → "
|
|
(node-display b))))
|
|
:else (append!
|
|
results
|
|
(str
|
|
"CHANGED "
|
|
(path-str path)
|
|
" "
|
|
(node-summary-short a)
|
|
" → "
|
|
(node-summary-short b))))))
|
|
|
|
(define
|
|
path-prefix?
|
|
:effects ()
|
|
(fn
|
|
(prefix path)
|
|
(if
|
|
(> (len prefix) (len path))
|
|
false
|
|
(let
|
|
((result true))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(when
|
|
(not (= (nth prefix i) (nth path i)))
|
|
(set! result false)))
|
|
(range 0 (len prefix)))
|
|
result))))
|
|
|
|
(define
|
|
path-on-match-route?
|
|
:effects ()
|
|
(fn
|
|
(path match-paths)
|
|
(let
|
|
((found false))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(when
|
|
(not found)
|
|
(let
|
|
((mp (first (nth match-paths i))))
|
|
(when
|
|
(or (path-prefix? path mp) (path-prefix? mp path))
|
|
(set! found true)))))
|
|
(range 0 (len match-paths)))
|
|
found)))
|
|
|
|
(define
|
|
annotate-focused
|
|
:effects ()
|
|
(fn
|
|
(exprs pattern)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs)))
|
|
(match-paths (find-all nodes pattern))
|
|
(result (list)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(annotate-node-focused (nth nodes i) (list i) 0 match-paths result))
|
|
(range 0 (len nodes)))
|
|
(join "\n" result))))
|
|
|
|
(define
|
|
annotate-node-focused
|
|
:effects ()
|
|
(fn
|
|
(node path depth match-paths result)
|
|
(let
|
|
((indent (join "" (map (fn (_) " ") (range 0 depth))))
|
|
(label (path-str path)))
|
|
(if
|
|
(list? node)
|
|
(if
|
|
(empty? node)
|
|
(append! result (str indent label " ()"))
|
|
(let
|
|
((head (first node))
|
|
(head-str (node-display head))
|
|
(on-route (path-on-match-route? path match-paths)))
|
|
(if
|
|
on-route
|
|
(do
|
|
(append! result (str indent label " (" head-str))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(annotate-node-focused
|
|
(nth node i)
|
|
(concat path (list i))
|
|
(+ depth 1)
|
|
match-paths
|
|
result))
|
|
(range 1 (len node)))
|
|
(append! result (str indent " )")))
|
|
(append!
|
|
result
|
|
(str
|
|
indent
|
|
label
|
|
" ("
|
|
head-str
|
|
(if
|
|
(> (len node) 1)
|
|
(str " ... " (- (len node) 1) " children")
|
|
"")
|
|
")")))))
|
|
(append! result (str indent label " " (node-display node)))))))
|
|
|
|
(define
|
|
annotate-paginated
|
|
:effects ()
|
|
(fn
|
|
(exprs offset limit)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))) (all-lines (list)))
|
|
(for-each
|
|
(fn (i) (annotate-node (nth nodes i) (list i) 0 all-lines))
|
|
(range 0 (len nodes)))
|
|
(let
|
|
((total (len all-lines))
|
|
(end (if (> (+ offset limit) total) total (+ offset limit)))
|
|
(sliced (slice all-lines offset end))
|
|
(header
|
|
(str
|
|
";; Lines "
|
|
offset
|
|
"-"
|
|
end
|
|
" of "
|
|
total
|
|
(if (< end total) " (more available)" " (complete)"))))
|
|
(str header "\n" (join "\n" sliced))))))
|
|
|
|
(define
|
|
rename-symbol
|
|
:effects ()
|
|
(fn
|
|
(exprs old-name new-name)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))))
|
|
(map (fn (node) (rename-in-node node old-name new-name)) nodes))))
|
|
|
|
(define
|
|
rename-in-node
|
|
:effects ()
|
|
(fn
|
|
(node old-name new-name)
|
|
(cond
|
|
(and (= (type-of node) "symbol") (= (symbol-name node) old-name))
|
|
(make-symbol new-name)
|
|
(list? node)
|
|
(map (fn (child) (rename-in-node child old-name new-name)) node)
|
|
:else node)))
|
|
|
|
(define
|
|
count-renames
|
|
:effects ()
|
|
(fn
|
|
(exprs old-name)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))) (hits (list)))
|
|
(count-in-node nodes old-name hits)
|
|
(len hits))))
|
|
|
|
(define
|
|
count-in-node
|
|
:effects ()
|
|
(fn
|
|
(node old-name hits)
|
|
(cond
|
|
(and (= (type-of node) "symbol") (= (symbol-name node) old-name))
|
|
(append! hits true)
|
|
(list? node)
|
|
(for-each (fn (child) (count-in-node child old-name hits)) node)
|
|
:else nil)))
|
|
|
|
(define
|
|
replace-by-pattern
|
|
:effects ()
|
|
(fn
|
|
(exprs pattern new-source)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs)))
|
|
(matches (find-all nodes pattern)))
|
|
(if
|
|
(empty? matches)
|
|
{:error (str "No nodes matching pattern: " pattern)}
|
|
(let
|
|
((target-path (first (first matches)))
|
|
(fragment (sx-parse new-source)))
|
|
(if
|
|
(empty? fragment)
|
|
{:error (str "Failed to parse new source: " new-source)}
|
|
(let
|
|
((new-node (first fragment))
|
|
(result (tree-set nodes target-path new-node)))
|
|
(if (nil? result) {:error (str "Failed to set node at path " (path-str target-path))} {:ok result :path target-path}))))))))
|
|
|
|
(define
|
|
replace-all-by-pattern
|
|
:effects ()
|
|
(fn
|
|
(exprs pattern new-source)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs)))
|
|
(matches (find-all nodes pattern))
|
|
(fragment (sx-parse new-source)))
|
|
(if
|
|
(empty? matches)
|
|
{:error (str "No nodes matching pattern: " pattern)}
|
|
(if
|
|
(empty? fragment)
|
|
{:error (str "Failed to parse new source: " new-source)}
|
|
(let
|
|
((new-node (first fragment)) (current nodes) (count 0))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((idx (- (- (len matches) 1) i))
|
|
(match (nth matches idx))
|
|
(target-path (first match))
|
|
(result (tree-set current target-path new-node)))
|
|
(when
|
|
(not (nil? result))
|
|
(set! current result)
|
|
(set! count (+ count 1)))))
|
|
(range 0 (len matches)))
|
|
{:count count :ok current}))))))
|
|
|
|
(define
|
|
insert-near-pattern
|
|
:effects ()
|
|
(fn
|
|
(exprs pattern position new-source)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs)))
|
|
(matches (find-all nodes pattern)))
|
|
(if
|
|
(empty? matches)
|
|
{:error (str "No nodes matching pattern: " pattern)}
|
|
(let
|
|
((match-path (first (first matches)))
|
|
(fragment (sx-parse new-source)))
|
|
(if
|
|
(empty? fragment)
|
|
{:error (str "Failed to parse new source: " new-source)}
|
|
(if
|
|
(empty? match-path)
|
|
{:error "Cannot insert near root node"}
|
|
(let
|
|
((top-idx (first match-path))
|
|
(insert-idx
|
|
(if (= position "after") (+ top-idx 1) top-idx))
|
|
(new-node (first fragment))
|
|
(new-tree (list-insert nodes insert-idx new-node)))
|
|
{:ok new-tree :path (list insert-idx)}))))))))
|
|
|
|
(define
|
|
lint-file
|
|
:effects ()
|
|
(fn
|
|
(exprs)
|
|
(let
|
|
((nodes (if (list? exprs) exprs (list exprs))) (warnings (list)))
|
|
(for-each
|
|
(fn (i) (lint-node (nth nodes i) (list i) warnings))
|
|
(range 0 (len nodes)))
|
|
warnings)))
|
|
|
|
(define
|
|
lint-node
|
|
:effects ()
|
|
(fn
|
|
(node path warnings)
|
|
(when
|
|
(list? node)
|
|
(when
|
|
(not (empty? node))
|
|
(let
|
|
((head (first node))
|
|
(head-name
|
|
(if (= (type-of head) "symbol") (symbol-name head) "")))
|
|
(when
|
|
(or (= head-name "let") (= head-name "letrec"))
|
|
(when
|
|
(>= (len node) 2)
|
|
(let
|
|
((bindings (nth node 1)))
|
|
(when
|
|
(and (list? bindings) (empty? bindings))
|
|
(append!
|
|
warnings
|
|
(str
|
|
"WARN "
|
|
(path-str path)
|
|
": "
|
|
head-name
|
|
" with empty bindings"))))))
|
|
(when
|
|
(or (= head-name "defcomp") (= head-name "defisland"))
|
|
(when
|
|
(< (len node) 4)
|
|
(append!
|
|
warnings
|
|
(str
|
|
"ERROR "
|
|
(path-str path)
|
|
": "
|
|
head-name
|
|
" needs (name params body), has "
|
|
(- (len node) 1)
|
|
" args"))))
|
|
(when
|
|
(= head-name "define")
|
|
(let
|
|
((effective-len (len (filter (fn (x) (not (= (type-of x) "keyword"))) (rest node)))))
|
|
(when
|
|
(< effective-len 2)
|
|
(append!
|
|
warnings
|
|
(str "WARN " (path-str path) ": define with no body")))))
|
|
(when
|
|
(or (= head-name "defcomp") (= head-name "defisland"))
|
|
(when
|
|
(>= (len node) 3)
|
|
(let
|
|
((params (nth node 2)))
|
|
(when
|
|
(list? params)
|
|
(let
|
|
((seen (list)))
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(when
|
|
(= (type-of p) "symbol")
|
|
(let
|
|
((pname (symbol-name p)))
|
|
(when
|
|
(and
|
|
(not (= pname "&key"))
|
|
(not (= pname "&rest"))
|
|
(not (starts-with? pname "&")))
|
|
(when
|
|
(contains? seen pname)
|
|
(append!
|
|
warnings
|
|
(str
|
|
"ERROR "
|
|
(path-str path)
|
|
": duplicate param "
|
|
pname)))
|
|
(append! seen pname)))))
|
|
params))))))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(lint-node (nth node i) (concat path (list i)) warnings))
|
|
(range 0 (len node))))))))
|
|
|
|
(define
|
|
collect-free-symbols
|
|
:effects ()
|
|
(fn
|
|
(node)
|
|
(let
|
|
((result (list))
|
|
(seen (dict))
|
|
(special-forms
|
|
(dict
|
|
"if"
|
|
true
|
|
"when"
|
|
true
|
|
"cond"
|
|
true
|
|
"case"
|
|
true
|
|
"and"
|
|
true
|
|
"or"
|
|
true
|
|
"let"
|
|
true
|
|
"let*"
|
|
true
|
|
"letrec"
|
|
true
|
|
"lambda"
|
|
true
|
|
"fn"
|
|
true
|
|
"define"
|
|
true
|
|
"defcomp"
|
|
true
|
|
"defisland"
|
|
true
|
|
"defmacro"
|
|
true
|
|
"deftest"
|
|
true
|
|
"begin"
|
|
true
|
|
"do"
|
|
true
|
|
"quote"
|
|
true
|
|
"quasiquote"
|
|
true
|
|
"set!"
|
|
true
|
|
"->"
|
|
true
|
|
"reset"
|
|
true
|
|
"shift"
|
|
true
|
|
"deref"
|
|
true
|
|
"scope"
|
|
true
|
|
"provide"
|
|
true
|
|
"context"
|
|
true
|
|
"emit!"
|
|
true
|
|
"emitted"
|
|
true
|
|
"dynamic-wind"
|
|
true
|
|
"map"
|
|
true
|
|
"filter"
|
|
true
|
|
"reduce"
|
|
true
|
|
"for-each"
|
|
true
|
|
"some"
|
|
true
|
|
"every?"
|
|
true
|
|
"map-indexed"
|
|
true
|
|
"list"
|
|
true
|
|
"dict"
|
|
true
|
|
"str"
|
|
true
|
|
"cons"
|
|
true
|
|
"concat"
|
|
true)))
|
|
(define
|
|
add-sym
|
|
(fn
|
|
(name)
|
|
(when
|
|
(and
|
|
(not (has-key? seen name))
|
|
(not (has-key? special-forms name))
|
|
(not (starts-with? name ":")))
|
|
(dict-set! seen name true)
|
|
(append! result name))))
|
|
(define
|
|
extract-binding-names
|
|
(fn
|
|
(bindings)
|
|
(let
|
|
((names (dict)))
|
|
(for-each
|
|
(fn
|
|
(b)
|
|
(when
|
|
(list? b)
|
|
(let
|
|
((name (first b)))
|
|
(when
|
|
(= (type-of name) "symbol")
|
|
(dict-set! names (symbol-name name) true)))))
|
|
bindings)
|
|
names)))
|
|
(define
|
|
walk
|
|
(fn
|
|
(node bound)
|
|
(cond
|
|
(nil? node)
|
|
nil
|
|
(= (type-of node) "symbol")
|
|
(let
|
|
((name (symbol-name node)))
|
|
(when (not (has-key? bound name)) (add-sym name)))
|
|
(= (type-of node) "keyword")
|
|
nil
|
|
(not (list? node))
|
|
nil
|
|
(empty? node)
|
|
nil
|
|
:else (let
|
|
((head (first node)) (args (rest node)))
|
|
(if
|
|
(not (= (type-of head) "symbol"))
|
|
(for-each (fn (child) (walk child bound)) node)
|
|
(let
|
|
((hname (symbol-name head)))
|
|
(cond
|
|
(or (= hname "define") (= hname "defmacro"))
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((body-start (if (= (type-of (nth args 1)) "keyword") 3 1)))
|
|
(for-each
|
|
(fn (child) (walk child bound))
|
|
(slice args body-start))))
|
|
(or
|
|
(= hname "defcomp")
|
|
(= hname "defisland")
|
|
(= hname "deftest"))
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((params (nth args 1)) (param-names (dict)))
|
|
(when
|
|
(list? params)
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(when
|
|
(= (type-of p) "symbol")
|
|
(dict-set! param-names (symbol-name p) true)))
|
|
params))
|
|
(let
|
|
((new-bound (merge bound param-names)))
|
|
(for-each
|
|
(fn (child) (walk child new-bound))
|
|
(slice args 2)))))
|
|
(or (= hname "fn") (= hname "lambda"))
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((params (first args)) (param-names (dict)))
|
|
(when
|
|
(list? params)
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(cond
|
|
(= (type-of p) "symbol")
|
|
(dict-set! param-names (symbol-name p) true)
|
|
(list? p)
|
|
(when
|
|
(= (type-of (first p)) "symbol")
|
|
(dict-set!
|
|
param-names
|
|
(symbol-name (first p))
|
|
true))))
|
|
params))
|
|
(let
|
|
((new-bound (merge bound param-names)))
|
|
(for-each
|
|
(fn (child) (walk child new-bound))
|
|
(rest args)))))
|
|
(or (= hname "let") (= hname "let*") (= hname "letrec"))
|
|
(when
|
|
(>= (len args) 2)
|
|
(let
|
|
((bindings (first args))
|
|
(bind-names
|
|
(if
|
|
(list? (first args))
|
|
(extract-binding-names (first args))
|
|
(dict))))
|
|
(let
|
|
((new-bound (merge bound bind-names)))
|
|
(when
|
|
(list? bindings)
|
|
(for-each
|
|
(fn
|
|
(b)
|
|
(when
|
|
(and (list? b) (>= (len b) 2))
|
|
(walk
|
|
(nth b 1)
|
|
(if (= hname "letrec") new-bound bound))))
|
|
bindings))
|
|
(for-each
|
|
(fn (child) (walk child new-bound))
|
|
(rest args)))))
|
|
(= hname "quote")
|
|
nil
|
|
(= hname "set!")
|
|
(when
|
|
(>= (len args) 2)
|
|
(when
|
|
(= (type-of (first args)) "symbol")
|
|
(let
|
|
((name (symbol-name (first args))))
|
|
(when (not (has-key? bound name)) (add-sym name))))
|
|
(walk (nth args 1) bound))
|
|
:else (do
|
|
(when
|
|
(not (has-key? special-forms hname))
|
|
(when (not (has-key? bound hname)) (add-sym hname)))
|
|
(for-each (fn (child) (walk child bound)) args)))))))))
|
|
(walk node (dict))
|
|
result)))
|