Adopt Step 7 language features across SX codebase
112 conversions across 19 .sx files using match, let-match, and pipe operators: match (17): type/value dispatch replacing cond/if chains - lib/vm.sx: HO form dispatch (for-each/map/filter/reduce/some/every?) - lib/tree-tools.sx: node-display, node-matches?, rename, count, replace, free-symbols - lib/types.sx: narrow-type, substitute-in-type, infer-type, resolve-type - web/engine.sx: default-trigger, resolve-target, classify-trigger - web/deps.sx: scan-refs-walk, scan-io-refs-walk let-match (89): dict destructuring replacing (get d "key") patterns - shared/page-functions.sx (20), blog/admin.sx (17), pub-api.sx (13) - events/ layouts/page/tickets/entries/forms (27 total) - specs-explorer.sx (7), federation/social.sx (3), lib/ small files (3) -> pipes (6): replacing triple-chained gets in lib/vm.sx - frame-closure → closure-code → code-bytecode chains Also: lib/vm.sx accessor upgrades (get vm "sp" → vm-sp vm throughout) 2650/2650 tests pass, zero regressions. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
169
lib/freeze.sx
169
lib/freeze.sx
@@ -21,7 +21,8 @@
|
||||
|
||||
;; Registry of freeze scopes: name → list of {name signal} entries
|
||||
|
||||
(define-library (sx freeze)
|
||||
(define-library
|
||||
(sx freeze)
|
||||
(export
|
||||
freeze-registry
|
||||
freeze-signal
|
||||
@@ -33,82 +34,96 @@
|
||||
freeze-to-sx
|
||||
thaw-from-sx)
|
||||
(begin
|
||||
|
||||
(define freeze-registry (dict))
|
||||
|
||||
;; Register a signal in the current freeze scope
|
||||
(define freeze-signal :effects [mutation]
|
||||
(fn (name sig)
|
||||
(let ((scope-name (context "sx-freeze-scope" nil)))
|
||||
(when scope-name
|
||||
(let ((entries (or (get freeze-registry scope-name) (list))))
|
||||
(append! entries (dict "name" name "signal" sig))
|
||||
(dict-set! freeze-registry scope-name entries))))))
|
||||
|
||||
;; Freeze scope delimiter — collects signals registered within body
|
||||
(define freeze-scope :effects [mutation]
|
||||
(fn (name body-fn)
|
||||
(scope-push! "sx-freeze-scope" name)
|
||||
;; Initialize empty entry list for this scope
|
||||
(dict-set! freeze-registry name (list))
|
||||
(cek-call body-fn nil)
|
||||
(scope-pop! "sx-freeze-scope")
|
||||
nil))
|
||||
|
||||
;; Freeze a named scope → SX dict of signal values
|
||||
(define cek-freeze-scope :effects []
|
||||
(fn (name)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(signals-dict (dict)))
|
||||
(for-each (fn (entry)
|
||||
(dict-set! signals-dict
|
||||
(get entry "name")
|
||||
(signal-value (get entry "signal"))))
|
||||
entries)
|
||||
(dict "name" name "signals" signals-dict))))
|
||||
|
||||
;; Freeze all scopes
|
||||
(define cek-freeze-all :effects []
|
||||
(fn ()
|
||||
(map (fn (name) (cek-freeze-scope name))
|
||||
(keys freeze-registry))))
|
||||
|
||||
;; Thaw a named scope — restore signal values from frozen data
|
||||
(define cek-thaw-scope :effects [mutation]
|
||||
(fn (name frozen)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(values (get frozen "signals")))
|
||||
(when values
|
||||
(for-each (fn (entry)
|
||||
(let ((sig-name (get entry "name"))
|
||||
(sig (get entry "signal"))
|
||||
(val (get values sig-name)))
|
||||
(when (not (nil? val))
|
||||
(reset! sig val))))
|
||||
entries)))))
|
||||
|
||||
;; Thaw all scopes from a list of frozen scope dicts
|
||||
(define cek-thaw-all :effects [mutation]
|
||||
(fn (frozen-list)
|
||||
(for-each (fn (frozen)
|
||||
(cek-thaw-scope (get frozen "name") frozen))
|
||||
frozen-list)))
|
||||
|
||||
;; Serialize a frozen scope to SX text
|
||||
(define freeze-to-sx :effects []
|
||||
(fn (name)
|
||||
(sx-serialize (cek-freeze-scope name))))
|
||||
|
||||
;; Restore from SX text
|
||||
(define thaw-from-sx :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((parsed (sx-parse sx-text)))
|
||||
(when (not (empty? parsed))
|
||||
(let ((frozen (first parsed)))
|
||||
(cek-thaw-scope (get frozen "name") frozen))))))
|
||||
|
||||
|
||||
)) ;; end define-library
|
||||
(define freeze-registry (dict))
|
||||
(define
|
||||
freeze-signal
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(name sig)
|
||||
(let
|
||||
((scope-name (context "sx-freeze-scope" nil)))
|
||||
(when
|
||||
scope-name
|
||||
(let
|
||||
((entries (or (get freeze-registry scope-name) (list))))
|
||||
(append! entries (dict "name" name "signal" sig))
|
||||
(dict-set! freeze-registry scope-name entries))))))
|
||||
(define
|
||||
freeze-scope
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(name body-fn)
|
||||
(scope-push! "sx-freeze-scope" name)
|
||||
(dict-set! freeze-registry name (list))
|
||||
(cek-call body-fn nil)
|
||||
(scope-pop! "sx-freeze-scope")
|
||||
nil))
|
||||
(define
|
||||
cek-freeze-scope
|
||||
:effects ()
|
||||
(fn
|
||||
(name)
|
||||
(let
|
||||
((entries (or (get freeze-registry name) (list)))
|
||||
(signals-dict (dict)))
|
||||
(for-each
|
||||
(fn
|
||||
(entry)
|
||||
(dict-set!
|
||||
signals-dict
|
||||
(get entry "name")
|
||||
(signal-value (get entry "signal"))))
|
||||
entries)
|
||||
(dict "name" name "signals" signals-dict))))
|
||||
(define
|
||||
cek-freeze-all
|
||||
:effects ()
|
||||
(fn
|
||||
()
|
||||
(map (fn (name) (cek-freeze-scope name)) (keys freeze-registry))))
|
||||
(define
|
||||
cek-thaw-scope
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(name frozen)
|
||||
(let
|
||||
((entries (or (get freeze-registry name) (list)))
|
||||
(values (get frozen "signals")))
|
||||
(when
|
||||
values
|
||||
(for-each
|
||||
(fn
|
||||
(entry)
|
||||
(let
|
||||
((sig-name (get entry "name"))
|
||||
(sig (get entry "signal"))
|
||||
(val (get values sig-name)))
|
||||
(when (not (nil? val)) (reset! sig val))))
|
||||
entries)))))
|
||||
(define
|
||||
cek-thaw-all
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(frozen-list)
|
||||
(for-each
|
||||
(fn (frozen) (cek-thaw-scope (get frozen "name") frozen))
|
||||
frozen-list)))
|
||||
(define
|
||||
freeze-to-sx
|
||||
:effects ()
|
||||
(fn (name) (sx-serialize (cek-freeze-scope name))))
|
||||
(define
|
||||
thaw-from-sx
|
||||
:effects (mutation)
|
||||
(fn
|
||||
(sx-text)
|
||||
(let
|
||||
((parsed (sx-parse sx-text)))
|
||||
(when
|
||||
(not (empty? parsed))
|
||||
(let
|
||||
((frozen (first parsed)))
|
||||
(cek-thaw-scope (get frozen "name") frozen)))))))) ;; end define-library
|
||||
|
||||
;; Re-export to global namespace for backward compatibility
|
||||
(import (sx freeze))
|
||||
|
||||
509
lib/highlight.sx
509
lib/highlight.sx
@@ -1,6 +1,7 @@
|
||||
|
||||
|
||||
(define-library (sx highlight)
|
||||
(define-library
|
||||
(sx highlight)
|
||||
(export
|
||||
sx-specials
|
||||
sx-special?
|
||||
@@ -16,204 +17,184 @@
|
||||
highlight-sx
|
||||
highlight)
|
||||
(begin
|
||||
|
||||
(define
|
||||
sx-specials
|
||||
(list
|
||||
"defcomp"
|
||||
"defrelation"
|
||||
"defisland"
|
||||
"defpage"
|
||||
"defhelper"
|
||||
"define"
|
||||
"defmacro"
|
||||
"defconfig"
|
||||
"deftest"
|
||||
"if"
|
||||
"when"
|
||||
"cond"
|
||||
"case"
|
||||
"and"
|
||||
"or"
|
||||
"not"
|
||||
"let"
|
||||
"let*"
|
||||
"lambda"
|
||||
"fn"
|
||||
"do"
|
||||
"begin"
|
||||
"quote"
|
||||
"quasiquote"
|
||||
"->"
|
||||
"map"
|
||||
"filter"
|
||||
"reduce"
|
||||
"some"
|
||||
"every?"
|
||||
"map-indexed"
|
||||
"for-each"
|
||||
"&key"
|
||||
"&rest"
|
||||
"set!"))
|
||||
|
||||
(define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials)))
|
||||
|
||||
(define hl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
||||
|
||||
(define
|
||||
hl-alpha?
|
||||
(fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
|
||||
|
||||
(define
|
||||
hl-sym-char?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(hl-alpha? c)
|
||||
(hl-digit? c)
|
||||
(= c "_")
|
||||
(= c "-")
|
||||
(= c "?")
|
||||
(= c "!")
|
||||
(= c "+")
|
||||
(= c "*")
|
||||
(= c "/")
|
||||
(= c "<")
|
||||
(= c ">")
|
||||
(= c "=")
|
||||
(= c "&")
|
||||
(= c "."))))
|
||||
|
||||
(define hl-ws? (fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r"))))
|
||||
|
||||
(define hl-escape (fn (s) s))
|
||||
|
||||
(define
|
||||
hl-span
|
||||
(fn
|
||||
(class text)
|
||||
(if
|
||||
(= class "")
|
||||
(list (quote span) text)
|
||||
(list (quote span) (make-keyword "class") class text))))
|
||||
|
||||
(define
|
||||
tokenize-sx
|
||||
(fn
|
||||
(code)
|
||||
(let
|
||||
((tokens (list)) (i 0) (len (string-length code)))
|
||||
(let
|
||||
loop
|
||||
()
|
||||
(when
|
||||
(< i len)
|
||||
(define
|
||||
sx-specials
|
||||
(list
|
||||
"defcomp"
|
||||
"defrelation"
|
||||
"defisland"
|
||||
"defpage"
|
||||
"defhelper"
|
||||
"define"
|
||||
"defmacro"
|
||||
"defconfig"
|
||||
"deftest"
|
||||
"if"
|
||||
"when"
|
||||
"cond"
|
||||
"case"
|
||||
"and"
|
||||
"or"
|
||||
"not"
|
||||
"let"
|
||||
"let*"
|
||||
"lambda"
|
||||
"fn"
|
||||
"do"
|
||||
"begin"
|
||||
"quote"
|
||||
"quasiquote"
|
||||
"->"
|
||||
"map"
|
||||
"filter"
|
||||
"reduce"
|
||||
"some"
|
||||
"every?"
|
||||
"map-indexed"
|
||||
"for-each"
|
||||
"&key"
|
||||
"&rest"
|
||||
"set!"
|
||||
"satisfies?"
|
||||
"match"
|
||||
"let-match"
|
||||
"define-protocol"
|
||||
"implement"
|
||||
"->>"
|
||||
"|>"
|
||||
"as->"
|
||||
"define-library"
|
||||
"import"
|
||||
"perform"
|
||||
"guard"
|
||||
"call/cc"
|
||||
"raise"
|
||||
"define-syntax"
|
||||
"syntax-rules"
|
||||
"make-parameter"
|
||||
"parameterize"))
|
||||
(define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials)))
|
||||
(define hl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
||||
(define
|
||||
hl-alpha?
|
||||
(fn
|
||||
(c)
|
||||
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
|
||||
(define
|
||||
hl-sym-char?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(hl-alpha? c)
|
||||
(hl-digit? c)
|
||||
(= c "_")
|
||||
(= c "-")
|
||||
(= c "?")
|
||||
(= c "!")
|
||||
(= c "+")
|
||||
(= c "*")
|
||||
(= c "/")
|
||||
(= c "<")
|
||||
(= c ">")
|
||||
(= c "=")
|
||||
(= c "&")
|
||||
(= c "."))))
|
||||
(define
|
||||
hl-ws?
|
||||
(fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r"))))
|
||||
(define hl-escape (fn (s) s))
|
||||
(define
|
||||
hl-span
|
||||
(fn
|
||||
(class text)
|
||||
(if
|
||||
(= class "")
|
||||
(list (quote span) text)
|
||||
(list (quote span) (make-keyword "class") class text))))
|
||||
(define
|
||||
tokenize-sx
|
||||
(fn
|
||||
(code)
|
||||
(let
|
||||
((tokens (list)) (i 0) (len (string-length code)))
|
||||
(let
|
||||
((c (substring code i (+ i 1))))
|
||||
(if
|
||||
(= c ";")
|
||||
loop
|
||||
()
|
||||
(when
|
||||
(< i len)
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(not (= (substring code i (+ i 1)) "\n")))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "comment" (substring code start i))))))
|
||||
(if
|
||||
(= c "\"")
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(let
|
||||
sloop
|
||||
()
|
||||
(when
|
||||
(< i len)
|
||||
(let
|
||||
((sc (substring code i (+ i 1))))
|
||||
(if
|
||||
(= sc "\\")
|
||||
(do (set! i (+ i 2)) (sloop))
|
||||
(if
|
||||
(= sc "\"")
|
||||
(set! i (+ i 1))
|
||||
(do (set! i (+ i 1)) (sloop)))))))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "string" (substring code start i))))))
|
||||
((c (substring code i (+ i 1))))
|
||||
(if
|
||||
(= c ":")
|
||||
(= c ";")
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-alpha? (substring code i (+ i 1))))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-sym-char? (substring code i (+ i 1))))
|
||||
(set! i (+ i 1))
|
||||
(scan))))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(not (= (substring code i (+ i 1)) "\n")))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "keyword" (substring code start i))))))
|
||||
(list (list "comment" (substring code start i))))))
|
||||
(if
|
||||
(= c "~")
|
||||
(= c "\"")
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(let
|
||||
scan
|
||||
sloop
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(let
|
||||
((x (substring code i (+ i 1))))
|
||||
(or (hl-sym-char? x) (= x "/"))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(< i len)
|
||||
(let
|
||||
((sc (substring code i (+ i 1))))
|
||||
(if
|
||||
(= sc "\\")
|
||||
(do (set! i (+ i 2)) (sloop))
|
||||
(if
|
||||
(= sc "\"")
|
||||
(set! i (+ i 1))
|
||||
(do (set! i (+ i 1)) (sloop)))))))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "component" (substring code start i))))))
|
||||
(list (list "string" (substring code start i))))))
|
||||
(if
|
||||
(or
|
||||
(= c "(")
|
||||
(= c ")")
|
||||
(= c "[")
|
||||
(= c "]")
|
||||
(= c "{")
|
||||
(= c "}"))
|
||||
(do
|
||||
(= c ":")
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-alpha? (substring code i (+ i 1))))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-sym-char? (substring code i (+ i 1))))
|
||||
(set! i (+ i 1))
|
||||
(scan))))
|
||||
(set!
|
||||
tokens
|
||||
(append tokens (list (list "paren" c))))
|
||||
(set! i (+ i 1)))
|
||||
(append
|
||||
tokens
|
||||
(list (list "keyword" (substring code start i))))))
|
||||
(if
|
||||
(hl-digit? c)
|
||||
(= c "~")
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
@@ -222,53 +203,30 @@
|
||||
(< i len)
|
||||
(let
|
||||
((x (substring code i (+ i 1))))
|
||||
(or (hl-digit? x) (= x "."))))
|
||||
(or (hl-sym-char? x) (= x "/"))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "number" (substring code start i))))))
|
||||
(list
|
||||
(list "component" (substring code start i))))))
|
||||
(if
|
||||
(hl-sym-char? c)
|
||||
(let
|
||||
((start i))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-sym-char? (substring code i (+ i 1))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(let
|
||||
((text (substring code start i)))
|
||||
(if
|
||||
(or
|
||||
(= text "true")
|
||||
(= text "false")
|
||||
(= text "nil"))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "boolean" text))))
|
||||
(if
|
||||
(sx-special? text)
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "special" text))))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "symbol" text))))))))
|
||||
(or
|
||||
(= c "(")
|
||||
(= c ")")
|
||||
(= c "[")
|
||||
(= c "]")
|
||||
(= c "{")
|
||||
(= c "}"))
|
||||
(do
|
||||
(set!
|
||||
tokens
|
||||
(append tokens (list (list "paren" c))))
|
||||
(set! i (+ i 1)))
|
||||
(if
|
||||
(hl-ws? c)
|
||||
(hl-digit? c)
|
||||
(let
|
||||
((start i))
|
||||
(let
|
||||
@@ -277,49 +235,106 @@
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-ws? (substring code i (+ i 1))))
|
||||
(let
|
||||
((x (substring code i (+ i 1))))
|
||||
(or (hl-digit? x) (= x "."))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "ws" (substring code start i))))))
|
||||
(do
|
||||
(set!
|
||||
tokens
|
||||
(append tokens (list (list "other" c))))
|
||||
(set! i (+ i 1))))))))))))
|
||||
(loop)))
|
||||
tokens)))
|
||||
|
||||
(define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"})
|
||||
|
||||
(define
|
||||
render-sx-tokens
|
||||
(fn
|
||||
(tokens)
|
||||
(map
|
||||
(list
|
||||
(list "number" (substring code start i))))))
|
||||
(if
|
||||
(hl-sym-char? c)
|
||||
(let
|
||||
((start i))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-sym-char?
|
||||
(substring code i (+ i 1))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(let
|
||||
((text (substring code start i)))
|
||||
(if
|
||||
(or
|
||||
(= text "true")
|
||||
(= text "false")
|
||||
(= text "nil"))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "boolean" text))))
|
||||
(if
|
||||
(sx-special? text)
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "special" text))))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "symbol" text))))))))
|
||||
(if
|
||||
(hl-ws? c)
|
||||
(let
|
||||
((start i))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(hl-ws? (substring code i (+ i 1))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list
|
||||
(list "ws" (substring code start i))))))
|
||||
(do
|
||||
(set!
|
||||
tokens
|
||||
(append tokens (list (list "other" c))))
|
||||
(set! i (+ i 1))))))))))))
|
||||
(loop)))
|
||||
tokens)))
|
||||
(define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"})
|
||||
(define
|
||||
render-sx-tokens
|
||||
(fn
|
||||
(tok)
|
||||
(let
|
||||
((cls (or (dict-get sx-token-classes (first tok)) "")))
|
||||
(hl-span cls (nth tok 1))))
|
||||
tokens)))
|
||||
|
||||
(define highlight-sx (fn (code) (render-sx-tokens (tokenize-sx code))))
|
||||
|
||||
(define
|
||||
highlight
|
||||
(fn
|
||||
(code lang)
|
||||
(if
|
||||
(or (= lang "lisp") (= lang "sx") (= lang "sexp") (= lang "scheme"))
|
||||
(highlight-sx code)
|
||||
(list (quote code) code))))
|
||||
|
||||
|
||||
)) ;; end define-library
|
||||
(tokens)
|
||||
(map
|
||||
(fn
|
||||
(tok)
|
||||
(let
|
||||
((cls (or (dict-get sx-token-classes (first tok)) "")))
|
||||
(hl-span cls (nth tok 1))))
|
||||
tokens)))
|
||||
(define highlight-sx (fn (code) (-> code tokenize-sx render-sx-tokens)))
|
||||
(define
|
||||
highlight
|
||||
(fn
|
||||
(code lang)
|
||||
(if
|
||||
(or
|
||||
(= lang "lisp")
|
||||
(= lang "sx")
|
||||
(= lang "sexp")
|
||||
(= lang "scheme"))
|
||||
(highlight-sx code)
|
||||
(list (quote code) code)))))) ;; end define-library
|
||||
|
||||
;; Re-export to global namespace for backward compatibility
|
||||
(import (sx highlight))
|
||||
|
||||
554
lib/sx-swap.sx
554
lib/sx-swap.sx
@@ -1,6 +1,7 @@
|
||||
|
||||
|
||||
(define-library (sx swap)
|
||||
(define-library
|
||||
(sx swap)
|
||||
(export
|
||||
_skip-string
|
||||
_find-close
|
||||
@@ -16,310 +17,311 @@
|
||||
strip-oob
|
||||
apply-response)
|
||||
(begin
|
||||
|
||||
(define
|
||||
_skip-string
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(cond
|
||||
(= ch "\\")
|
||||
(_skip-string src (+ i 2))
|
||||
(= ch "\"")
|
||||
(+ i 1)
|
||||
:else (_skip-string src (+ i 1)))))))
|
||||
|
||||
(define
|
||||
_find-close
|
||||
(fn
|
||||
(src i depth in-str)
|
||||
(if
|
||||
(>= i (len src))
|
||||
-1
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(cond
|
||||
in-str
|
||||
(cond
|
||||
(= ch "\\")
|
||||
(_find-close src (+ i 2) depth true)
|
||||
(= ch "\"")
|
||||
(_find-close src (+ i 1) depth false)
|
||||
:else (_find-close src (+ i 1) depth true))
|
||||
(= ch "\"")
|
||||
(_find-close src (+ i 1) depth true)
|
||||
(= ch "(")
|
||||
(_find-close src (+ i 1) (+ depth 1) false)
|
||||
(= ch ")")
|
||||
(if (= depth 1) i (_find-close src (+ i 1) (- depth 1) false))
|
||||
:else (_find-close src (+ i 1) depth false))))))
|
||||
|
||||
(define
|
||||
_skip-ws
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(define
|
||||
_skip-string
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(or (= ch " ") (= ch "\n") (= ch "\t") (= ch "\r"))
|
||||
(_skip-ws src (+ i 1))
|
||||
i)))))
|
||||
|
||||
(define
|
||||
_skip-token
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(if
|
||||
(or
|
||||
(= ch " ")
|
||||
(= ch "\n")
|
||||
(= ch "\t")
|
||||
(= ch "\r")
|
||||
(= ch "(")
|
||||
(= ch ")")
|
||||
(= ch "\""))
|
||||
(>= i (len src))
|
||||
i
|
||||
(_skip-token src (+ i 1)))))))
|
||||
|
||||
(define
|
||||
_skip-value
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(cond
|
||||
(= ch "\"")
|
||||
(_skip-string src (+ i 1))
|
||||
(= ch "(")
|
||||
(let
|
||||
((close (_find-close src (+ i 1) 1 false)))
|
||||
(if (= close -1) (len src) (+ close 1)))
|
||||
:else (_skip-token src i))))))
|
||||
|
||||
(define
|
||||
_find-children-start
|
||||
(fn
|
||||
(src elem-start elem-end)
|
||||
(let
|
||||
((after-open (+ elem-start 1)))
|
||||
(let
|
||||
((after-tag (_skip-token src (_skip-ws src after-open))))
|
||||
(define
|
||||
_skip-attrs
|
||||
(fn
|
||||
(j)
|
||||
(let
|
||||
((pos (_skip-ws src j)))
|
||||
(if
|
||||
(>= pos elem-end)
|
||||
pos
|
||||
(if
|
||||
(= (nth src pos) ":")
|
||||
(let
|
||||
((after-kw (_skip-token src pos)))
|
||||
(_skip-attrs (_skip-value src (_skip-ws src after-kw))))
|
||||
pos)))))
|
||||
(_skip-attrs after-tag)))))
|
||||
|
||||
(define
|
||||
_scan-back
|
||||
(fn
|
||||
(src i)
|
||||
(if (< i 0) -1 (if (= (nth src i) "(") i (_scan-back src (- i 1))))))
|
||||
|
||||
(define
|
||||
find-element-by-id
|
||||
(fn
|
||||
(src target-id)
|
||||
(let
|
||||
((pattern (str ":id \"" target-id "\"")))
|
||||
(let
|
||||
((pos (index-of src pattern)))
|
||||
((ch (nth src i)))
|
||||
(cond
|
||||
(= ch "\\")
|
||||
(_skip-string src (+ i 2))
|
||||
(= ch "\"")
|
||||
(+ i 1)
|
||||
:else (_skip-string src (+ i 1)))))))
|
||||
(define
|
||||
_find-close
|
||||
(fn
|
||||
(src i depth in-str)
|
||||
(if
|
||||
(= pos -1)
|
||||
nil
|
||||
(>= i (len src))
|
||||
-1
|
||||
(let
|
||||
((elem-start (_scan-back src (- pos 1))))
|
||||
((ch (nth src i)))
|
||||
(cond
|
||||
in-str
|
||||
(cond
|
||||
(= ch "\\")
|
||||
(_find-close src (+ i 2) depth true)
|
||||
(= ch "\"")
|
||||
(_find-close src (+ i 1) depth false)
|
||||
:else (_find-close src (+ i 1) depth true))
|
||||
(= ch "\"")
|
||||
(_find-close src (+ i 1) depth true)
|
||||
(= ch "(")
|
||||
(_find-close src (+ i 1) (+ depth 1) false)
|
||||
(= ch ")")
|
||||
(if
|
||||
(= depth 1)
|
||||
i
|
||||
(_find-close src (+ i 1) (- depth 1) false))
|
||||
:else (_find-close src (+ i 1) depth false))))))
|
||||
(define
|
||||
_skip-ws
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(if
|
||||
(= elem-start -1)
|
||||
(or (= ch " ") (= ch "\n") (= ch "\t") (= ch "\r"))
|
||||
(_skip-ws src (+ i 1))
|
||||
i)))))
|
||||
(define
|
||||
_skip-token
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(if
|
||||
(or
|
||||
(= ch " ")
|
||||
(= ch "\n")
|
||||
(= ch "\t")
|
||||
(= ch "\r")
|
||||
(= ch "(")
|
||||
(= ch ")")
|
||||
(= ch "\""))
|
||||
i
|
||||
(_skip-token src (+ i 1)))))))
|
||||
(define
|
||||
_skip-value
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(>= i (len src))
|
||||
i
|
||||
(let
|
||||
((ch (nth src i)))
|
||||
(cond
|
||||
(= ch "\"")
|
||||
(_skip-string src (+ i 1))
|
||||
(= ch "(")
|
||||
(let
|
||||
((close (_find-close src (+ i 1) 1 false)))
|
||||
(if (= close -1) (len src) (+ close 1)))
|
||||
:else (_skip-token src i))))))
|
||||
(define
|
||||
_find-children-start
|
||||
(fn
|
||||
(src elem-start elem-end)
|
||||
(let
|
||||
((after-open (+ elem-start 1)))
|
||||
(let
|
||||
((after-tag (_skip-token src (_skip-ws src after-open))))
|
||||
(define
|
||||
_skip-attrs
|
||||
(fn
|
||||
(j)
|
||||
(let
|
||||
((pos (_skip-ws src j)))
|
||||
(if
|
||||
(>= pos elem-end)
|
||||
pos
|
||||
(if
|
||||
(= (nth src pos) ":")
|
||||
(let
|
||||
((after-kw (_skip-token src pos)))
|
||||
(_skip-attrs
|
||||
(_skip-value src (_skip-ws src after-kw))))
|
||||
pos)))))
|
||||
(_skip-attrs after-tag)))))
|
||||
(define
|
||||
_scan-back
|
||||
(fn
|
||||
(src i)
|
||||
(if
|
||||
(< i 0)
|
||||
-1
|
||||
(if (= (nth src i) "(") i (_scan-back src (- i 1))))))
|
||||
(define
|
||||
find-element-by-id
|
||||
(fn
|
||||
(src target-id)
|
||||
(let
|
||||
((pattern (str ":id \"" target-id "\"")))
|
||||
(let
|
||||
((pos (index-of src pattern)))
|
||||
(if
|
||||
(= pos -1)
|
||||
nil
|
||||
(let
|
||||
((elem-end (_find-close src (+ elem-start 1) 1 false)))
|
||||
((elem-start (_scan-back src (- pos 1))))
|
||||
(if
|
||||
(= elem-end -1)
|
||||
(= elem-start -1)
|
||||
nil
|
||||
(let
|
||||
((cs (_find-children-start src elem-start elem-end)))
|
||||
{:end elem-end :start elem-start :children-start cs}))))))))))
|
||||
|
||||
(define
|
||||
sx-swap
|
||||
(fn
|
||||
(src mode target-id new-content)
|
||||
(let
|
||||
((info (find-element-by-id src target-id)))
|
||||
(if
|
||||
(nil? info)
|
||||
src
|
||||
(let
|
||||
((s (get info "start"))
|
||||
(e (get info "end"))
|
||||
(cs (get info "children-start")))
|
||||
(case
|
||||
mode
|
||||
"innerHTML"
|
||||
(str (slice src 0 cs) new-content (slice src e (len src)))
|
||||
"outerHTML"
|
||||
(str (slice src 0 s) new-content (slice src (+ e 1) (len src)))
|
||||
"beforeend"
|
||||
(str (slice src 0 e) " " new-content (slice src e (len src)))
|
||||
"afterbegin"
|
||||
(str (slice src 0 cs) new-content " " (slice src cs (len src)))
|
||||
"beforebegin"
|
||||
(str (slice src 0 s) new-content (slice src s (len src)))
|
||||
"afterend"
|
||||
(str
|
||||
(slice src 0 (+ e 1))
|
||||
new-content
|
||||
(slice src (+ e 1) (len src)))
|
||||
"delete"
|
||||
(str (slice src 0 s) (slice src (+ e 1) (len src)))
|
||||
"none"
|
||||
src
|
||||
:else src))))))
|
||||
|
||||
(define
|
||||
_extract-attr-value
|
||||
(fn
|
||||
(src keyword-end)
|
||||
(let
|
||||
((val-start (_skip-ws src keyword-end)))
|
||||
(if
|
||||
(= (nth src val-start) "\"")
|
||||
(let
|
||||
((str-end (_skip-string src (+ val-start 1))))
|
||||
(slice src (+ val-start 1) (- str-end 1)))
|
||||
(let
|
||||
((tok-end (_skip-token src val-start)))
|
||||
(slice src val-start tok-end))))))
|
||||
|
||||
(define
|
||||
find-oob-elements
|
||||
(fn
|
||||
(src)
|
||||
((elem-end (_find-close src (+ elem-start 1) 1 false)))
|
||||
(if
|
||||
(= elem-end -1)
|
||||
nil
|
||||
(let
|
||||
((cs (_find-children-start src elem-start elem-end)))
|
||||
{:end elem-end :start elem-start :children-start cs}))))))))))
|
||||
(define
|
||||
_scan
|
||||
sx-swap
|
||||
(fn
|
||||
(from results)
|
||||
(src mode target-id new-content)
|
||||
(let
|
||||
((rel-pos (index-of (slice src from (len src)) ":sx-swap-oob")))
|
||||
((info (find-element-by-id src target-id)))
|
||||
(if
|
||||
(= rel-pos -1)
|
||||
results
|
||||
(nil? info)
|
||||
src
|
||||
(let-match
|
||||
{:end e :start s :children-start cs}
|
||||
info
|
||||
(case
|
||||
mode
|
||||
"innerHTML"
|
||||
(str (slice src 0 cs) new-content (slice src e (len src)))
|
||||
"outerHTML"
|
||||
(str
|
||||
(slice src 0 s)
|
||||
new-content
|
||||
(slice src (+ e 1) (len src)))
|
||||
"beforeend"
|
||||
(str
|
||||
(slice src 0 e)
|
||||
" "
|
||||
new-content
|
||||
(slice src e (len src)))
|
||||
"afterbegin"
|
||||
(str
|
||||
(slice src 0 cs)
|
||||
new-content
|
||||
" "
|
||||
(slice src cs (len src)))
|
||||
"beforebegin"
|
||||
(str (slice src 0 s) new-content (slice src s (len src)))
|
||||
"afterend"
|
||||
(str
|
||||
(slice src 0 (+ e 1))
|
||||
new-content
|
||||
(slice src (+ e 1) (len src)))
|
||||
"delete"
|
||||
(str (slice src 0 s) (slice src (+ e 1) (len src)))
|
||||
"none"
|
||||
src
|
||||
:else src))))))
|
||||
(define
|
||||
_extract-attr-value
|
||||
(fn
|
||||
(src keyword-end)
|
||||
(let
|
||||
((val-start (_skip-ws src keyword-end)))
|
||||
(if
|
||||
(= (nth src val-start) "\"")
|
||||
(let
|
||||
((abs-pos (+ from rel-pos)))
|
||||
(let
|
||||
((mode (_extract-attr-value src (+ abs-pos 12))))
|
||||
((str-end (_skip-string src (+ val-start 1))))
|
||||
(slice src (+ val-start 1) (- str-end 1)))
|
||||
(let
|
||||
((tok-end (_skip-token src val-start)))
|
||||
(slice src val-start tok-end))))))
|
||||
(define
|
||||
find-oob-elements
|
||||
(fn
|
||||
(src)
|
||||
(define
|
||||
_scan
|
||||
(fn
|
||||
(from results)
|
||||
(let
|
||||
((rel-pos (index-of (slice src from (len src)) ":sx-swap-oob")))
|
||||
(if
|
||||
(= rel-pos -1)
|
||||
results
|
||||
(let
|
||||
((elem-start (_scan-back src (- abs-pos 1))))
|
||||
(if
|
||||
(= elem-start -1)
|
||||
results
|
||||
((abs-pos (+ from rel-pos)))
|
||||
(let
|
||||
((mode (_extract-attr-value src (+ abs-pos 12))))
|
||||
(let
|
||||
((elem-end (_find-close src (+ elem-start 1) 1 false)))
|
||||
((elem-start (_scan-back src (- abs-pos 1))))
|
||||
(if
|
||||
(= elem-end -1)
|
||||
(= elem-start -1)
|
||||
results
|
||||
(let
|
||||
((id-pattern ":id \""))
|
||||
(let
|
||||
((id-pos (index-of (slice src elem-start (+ elem-end 1)) id-pattern)))
|
||||
(if
|
||||
(= id-pos -1)
|
||||
(_scan (+ elem-end 1) results)
|
||||
((elem-end (_find-close src (+ elem-start 1) 1 false)))
|
||||
(if
|
||||
(= elem-end -1)
|
||||
results
|
||||
(let
|
||||
((id-pattern ":id \""))
|
||||
(let
|
||||
((id-abs (+ elem-start id-pos)))
|
||||
(let
|
||||
((id-val (_extract-attr-value src (+ id-abs 3))))
|
||||
((id-pos (index-of (slice src elem-start (+ elem-end 1)) id-pattern)))
|
||||
(if
|
||||
(= id-pos -1)
|
||||
(_scan (+ elem-end 1) results)
|
||||
(let
|
||||
((cs (_find-children-start src elem-start elem-end)))
|
||||
((id-abs (+ elem-start id-pos)))
|
||||
(let
|
||||
((children-str (slice src cs elem-end)))
|
||||
(_scan
|
||||
(+ elem-end 1)
|
||||
(append results (list {:end elem-end :mode mode :content children-str :start elem-start :id id-val}))))))))))))))))))))
|
||||
(_scan 0 (list))))
|
||||
|
||||
(define
|
||||
strip-oob
|
||||
(fn
|
||||
(src oob-list)
|
||||
(if
|
||||
(empty? oob-list)
|
||||
src
|
||||
(let
|
||||
((sorted (reverse oob-list)))
|
||||
(define
|
||||
_strip
|
||||
(fn
|
||||
(s items)
|
||||
(if
|
||||
(empty? items)
|
||||
s
|
||||
(let
|
||||
((item (first items)))
|
||||
(let
|
||||
((before (slice s 0 (get item "start")))
|
||||
(after (slice s (+ (get item "end") 1) (len s))))
|
||||
(_strip (str before after) (rest items)))))))
|
||||
(_strip src sorted)))))
|
||||
|
||||
(define
|
||||
apply-response
|
||||
(fn
|
||||
(page response primary-mode primary-target)
|
||||
(let
|
||||
((oobs (find-oob-elements response)))
|
||||
(let
|
||||
((main-content (strip-oob response oobs)))
|
||||
(let
|
||||
((result (sx-swap page primary-mode primary-target main-content)))
|
||||
(do
|
||||
((id-val (_extract-attr-value src (+ id-abs 3))))
|
||||
(let
|
||||
((cs (_find-children-start src elem-start elem-end)))
|
||||
(let
|
||||
((children-str (slice src cs elem-end)))
|
||||
(_scan
|
||||
(+ elem-end 1)
|
||||
(append results (list {:end elem-end :mode mode :content children-str :start elem-start :id id-val}))))))))))))))))))))
|
||||
(_scan 0 (list))))
|
||||
(define
|
||||
strip-oob
|
||||
(fn
|
||||
(src oob-list)
|
||||
(if
|
||||
(empty? oob-list)
|
||||
src
|
||||
(let
|
||||
((sorted (reverse oob-list)))
|
||||
(define
|
||||
_apply-oobs
|
||||
_strip
|
||||
(fn
|
||||
(page-acc items)
|
||||
(s items)
|
||||
(if
|
||||
(empty? items)
|
||||
page-acc
|
||||
s
|
||||
(let
|
||||
((oob (first items)))
|
||||
(_apply-oobs
|
||||
(sx-swap
|
||||
page-acc
|
||||
(get oob "mode")
|
||||
(get oob "id")
|
||||
(get oob "content"))
|
||||
(rest items))))))
|
||||
(_apply-oobs result oobs)))))))
|
||||
|
||||
|
||||
)) ;; end define-library
|
||||
((item (first items)))
|
||||
(let
|
||||
((before (slice s 0 (get item "start")))
|
||||
(after (slice s (+ (get item "end") 1) (len s))))
|
||||
(_strip (str before after) (rest items)))))))
|
||||
(_strip src sorted)))))
|
||||
(define
|
||||
apply-response
|
||||
(fn
|
||||
(page response primary-mode primary-target)
|
||||
(let
|
||||
((oobs (find-oob-elements response)))
|
||||
(let
|
||||
((main-content (strip-oob response oobs)))
|
||||
(let
|
||||
((result (sx-swap page primary-mode primary-target main-content)))
|
||||
(do
|
||||
(define
|
||||
_apply-oobs
|
||||
(fn
|
||||
(page-acc items)
|
||||
(if
|
||||
(empty? items)
|
||||
page-acc
|
||||
(let
|
||||
((oob (first items)))
|
||||
(_apply-oobs
|
||||
(sx-swap
|
||||
page-acc
|
||||
(get oob "mode")
|
||||
(get oob "id")
|
||||
(get oob "content"))
|
||||
(rest items))))))
|
||||
(_apply-oobs result oobs))))))))) ;; end define-library
|
||||
|
||||
;; Re-export to global namespace for backward compatibility
|
||||
(import (sx swap))
|
||||
|
||||
@@ -63,33 +63,28 @@
|
||||
: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))))
|
||||
(match
|
||||
(type-of node)
|
||||
("nil" "nil")
|
||||
("symbol" (symbol-name node))
|
||||
("keyword" (str ":" (keyword-name node)))
|
||||
("string"
|
||||
(let
|
||||
((s (if (> (len node) 40) (str (slice node 0 37) "...") node)))
|
||||
(str "\"" s "\"")))
|
||||
("number" (str node))
|
||||
("boolean" (if node "true" "false"))
|
||||
("list"
|
||||
(if
|
||||
(empty? node)
|
||||
"()"
|
||||
(str
|
||||
"("
|
||||
(node-display (first node))
|
||||
(if (> (len node) 1) " ..." "")
|
||||
")")))
|
||||
("dict" "{...}")
|
||||
(_ (str node)))))
|
||||
|
||||
(define
|
||||
summarise
|
||||
@@ -244,17 +239,16 @@
|
||||
: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)))
|
||||
(match
|
||||
(type-of node)
|
||||
("symbol" (contains? (symbol-name node) pattern))
|
||||
("string" (contains? node pattern))
|
||||
("list"
|
||||
(if
|
||||
(empty? node)
|
||||
false
|
||||
(some (fn (child) (node-matches? child pattern)) node)))
|
||||
(_ false))))
|
||||
|
||||
(define
|
||||
node-summary-short
|
||||
@@ -546,33 +540,33 @@
|
||||
: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
|
||||
(match
|
||||
(type-of node)
|
||||
("symbol" (if (= (symbol-name node) "_") replacement nil))
|
||||
("list"
|
||||
(let
|
||||
((found false)
|
||||
(result
|
||||
(map
|
||||
(fn
|
||||
(child)
|
||||
(if
|
||||
(and
|
||||
(= (type-of child) "symbol")
|
||||
(= (symbol-name child) "_"))
|
||||
(do (set! found true) replacement)
|
||||
found
|
||||
child
|
||||
(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)))
|
||||
(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)))
|
||||
(_ nil))))
|
||||
|
||||
(define
|
||||
tree-set
|
||||
@@ -851,12 +845,13 @@
|
||||
: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)))
|
||||
(match
|
||||
(type-of node)
|
||||
("symbol"
|
||||
(if (= (symbol-name node) old-name) (make-symbol new-name) node))
|
||||
("list"
|
||||
(map (fn (child) (rename-in-node child old-name new-name)) node))
|
||||
(_ node))))
|
||||
|
||||
(define
|
||||
count-renames
|
||||
@@ -873,12 +868,12 @@
|
||||
: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)))
|
||||
(match
|
||||
(type-of node)
|
||||
("symbol" (when (= (symbol-name node) old-name) (append! hits true)))
|
||||
("list"
|
||||
(for-each (fn (child) (count-in-node child old-name hits)) node))
|
||||
(_ nil))))
|
||||
|
||||
(define
|
||||
replace-by-pattern
|
||||
@@ -1341,17 +1336,30 @@
|
||||
(walk node (dict))
|
||||
result)))
|
||||
|
||||
(define find-use-declarations :effects ()
|
||||
(fn (nodes)
|
||||
(let ((uses (list)))
|
||||
(for-each (fn (node)
|
||||
(when (and (list? node) (>= (len node) 2)
|
||||
(= (type-of (first node)) "symbol")
|
||||
(= (symbol-name (first node)) "use"))
|
||||
(for-each (fn (arg)
|
||||
(cond
|
||||
(= (type-of arg) "symbol") (append! uses (symbol-name arg))
|
||||
(= (type-of arg) "string") (append! uses arg)))
|
||||
(rest node))))
|
||||
(define
|
||||
find-use-declarations
|
||||
:effects ()
|
||||
(fn
|
||||
(nodes)
|
||||
(let
|
||||
((uses (list)))
|
||||
(for-each
|
||||
(fn
|
||||
(node)
|
||||
(when
|
||||
(and
|
||||
(list? node)
|
||||
(>= (len node) 2)
|
||||
(= (type-of (first node)) "symbol")
|
||||
(= (symbol-name (first node)) "use"))
|
||||
(for-each
|
||||
(fn
|
||||
(arg)
|
||||
(cond
|
||||
(= (type-of arg) "symbol")
|
||||
(append! uses (symbol-name arg))
|
||||
(= (type-of arg) "string")
|
||||
(append! uses arg)))
|
||||
(rest node))))
|
||||
(if (list? nodes) nodes (list nodes)))
|
||||
uses)))
|
||||
|
||||
1583
lib/types.sx
1583
lib/types.sx
File diff suppressed because it is too large
Load Diff
133
lib/vm.sx
133
lib/vm.sx
@@ -79,35 +79,35 @@
|
||||
(fn
|
||||
(vm value)
|
||||
(let
|
||||
((sp (get vm "sp")) (stack (get vm "stack")))
|
||||
((sp (vm-sp vm)) (stack (vm-stack vm)))
|
||||
(when
|
||||
(>= sp (vm-stack-length stack))
|
||||
(let
|
||||
((new-stack (make-vm-stack (* sp 2))))
|
||||
((new-stack (vm-stack-grow stack sp)))
|
||||
(vm-stack-copy! stack new-stack sp)
|
||||
(dict-set! vm "stack" new-stack)
|
||||
(vm-set-stack! vm new-stack)
|
||||
(set! stack new-stack)))
|
||||
(vm-stack-set! stack sp value)
|
||||
(dict-set! vm "sp" (+ sp 1)))))
|
||||
(vm-set-sp! vm (+ sp 1)))))
|
||||
(define
|
||||
vm-pop
|
||||
(fn
|
||||
(vm)
|
||||
(let
|
||||
((sp (- (get vm "sp") 1)))
|
||||
(dict-set! vm "sp" sp)
|
||||
(vm-stack-get (get vm "stack") sp))))
|
||||
((sp (- (vm-sp vm) 1)))
|
||||
(vm-set-sp! vm sp)
|
||||
(vm-stack-get (vm-stack vm) sp))))
|
||||
(define
|
||||
vm-peek
|
||||
(fn (vm) (vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
|
||||
(fn (vm) (vm-stack-get (vm-stack vm) (- (vm-sp vm) 1))))
|
||||
(define
|
||||
frame-read-u8
|
||||
(fn
|
||||
(frame)
|
||||
(let
|
||||
((ip (get frame "ip"))
|
||||
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
|
||||
(let ((v (nth bc ip))) (dict-set! frame "ip" (+ ip 1)) v))))
|
||||
((ip (frame-ip frame))
|
||||
(bc (-> frame frame-closure closure-code code-bytecode)))
|
||||
(let ((v (nth bc ip))) (frame-set-ip! frame (+ ip 1)) v))))
|
||||
(define
|
||||
frame-read-u16
|
||||
(fn
|
||||
@@ -206,31 +206,28 @@
|
||||
(if
|
||||
(has-key? cells key)
|
||||
(uv-get (get cells key))
|
||||
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
|
||||
(vm-stack-get (vm-stack vm) (+ (frame-base frame) slot))))))
|
||||
(define
|
||||
frame-local-set
|
||||
(fn
|
||||
(vm frame slot value)
|
||||
"Write a local variable — to shared cell if captured, else to stack."
|
||||
"Write a local variable — to shared cell or stack."
|
||||
(let
|
||||
((cells (get frame "local-cells")) (key (str slot)))
|
||||
(if
|
||||
(has-key? cells key)
|
||||
(uv-set! (get cells key) value)
|
||||
(vm-stack-set!
|
||||
(get vm "stack")
|
||||
(+ (get frame "base") slot)
|
||||
value)))))
|
||||
(vm-stack-set! (vm-stack vm) (+ (frame-base frame) slot) value)))))
|
||||
(define
|
||||
frame-upvalue-get
|
||||
(fn
|
||||
(frame idx)
|
||||
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
|
||||
(uv-get (nth (-> frame frame-closure closure-upvalues) idx))))
|
||||
(define
|
||||
frame-upvalue-set
|
||||
(fn
|
||||
(frame idx value)
|
||||
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
|
||||
(uv-set! (nth (-> frame frame-closure closure-upvalues) idx) value)))
|
||||
(define frame-ip (fn (frame) (get frame "ip")))
|
||||
(define frame-set-ip! (fn (frame val) (dict-set! frame "ip" val)))
|
||||
(define frame-base (fn (frame) (get frame "base")))
|
||||
@@ -302,12 +299,12 @@
|
||||
(vm frame name)
|
||||
"Look up a global: globals table → closure env → primitives → HO wrappers"
|
||||
(let
|
||||
((globals (get vm "globals")))
|
||||
((globals (vm-globals-ref vm)))
|
||||
(if
|
||||
(has-key? globals name)
|
||||
(get globals name)
|
||||
(let
|
||||
((closure-env (get (get frame "closure") "closure-env")))
|
||||
((closure-env (-> frame frame-closure closure-env)))
|
||||
(if
|
||||
(nil? closure-env)
|
||||
(cek-try
|
||||
@@ -325,41 +322,42 @@
|
||||
vm-resolve-ho-form
|
||||
(fn
|
||||
(vm name)
|
||||
(cond
|
||||
(= name "for-each")
|
||||
(fn
|
||||
(f coll)
|
||||
(for-each (fn (x) (vm-call-external vm f (list x))) coll))
|
||||
(= name "map")
|
||||
(fn
|
||||
(f coll)
|
||||
(map (fn (x) (vm-call-external vm f (list x))) coll))
|
||||
(= name "map-indexed")
|
||||
(fn
|
||||
(f coll)
|
||||
(map-indexed
|
||||
(fn (i x) (vm-call-external vm f (list i x)))
|
||||
coll))
|
||||
(= name "filter")
|
||||
(fn
|
||||
(f coll)
|
||||
(filter (fn (x) (vm-call-external vm f (list x))) coll))
|
||||
(= name "reduce")
|
||||
(fn
|
||||
(f init coll)
|
||||
(reduce
|
||||
(fn (acc x) (vm-call-external vm f (list acc x)))
|
||||
init
|
||||
coll))
|
||||
(= name "some")
|
||||
(fn
|
||||
(f coll)
|
||||
(some (fn (x) (vm-call-external vm f (list x))) coll))
|
||||
(= name "every?")
|
||||
(fn
|
||||
(f coll)
|
||||
(every? (fn (x) (vm-call-external vm f (list x))) coll))
|
||||
:else (error (str "VM undefined: " name)))))
|
||||
(match
|
||||
name
|
||||
("for-each"
|
||||
(fn
|
||||
(f coll)
|
||||
(for-each (fn (x) (vm-call-external vm f (list x))) coll)))
|
||||
("map"
|
||||
(fn
|
||||
(f coll)
|
||||
(map (fn (x) (vm-call-external vm f (list x))) coll)))
|
||||
("map-indexed"
|
||||
(fn
|
||||
(f coll)
|
||||
(map-indexed
|
||||
(fn (i x) (vm-call-external vm f (list i x)))
|
||||
coll)))
|
||||
("filter"
|
||||
(fn
|
||||
(f coll)
|
||||
(filter (fn (x) (vm-call-external vm f (list x))) coll)))
|
||||
("reduce"
|
||||
(fn
|
||||
(f init coll)
|
||||
(reduce
|
||||
(fn (acc x) (vm-call-external vm f (list acc x)))
|
||||
init
|
||||
coll)))
|
||||
("some"
|
||||
(fn
|
||||
(f coll)
|
||||
(some (fn (x) (vm-call-external vm f (list x))) coll)))
|
||||
("every?"
|
||||
(fn
|
||||
(f coll)
|
||||
(every? (fn (x) (vm-call-external vm f (list x))) coll)))
|
||||
(_ (error (str "VM undefined: " name))))))
|
||||
(define
|
||||
vm-call-external
|
||||
(fn
|
||||
@@ -372,14 +370,14 @@
|
||||
vm-global-set
|
||||
(fn
|
||||
(vm frame name value)
|
||||
"Set a global: write to closure env if name exists there, else globals."
|
||||
"Set a global: write to closure env if found, else globals table."
|
||||
(let
|
||||
((closure-env (get (get frame "closure") "vm-closure-env"))
|
||||
((closure-env (get (frame-closure frame) "vm-closure-env"))
|
||||
(written false))
|
||||
(when
|
||||
(not (nil? closure-env))
|
||||
(set! written (env-walk-set! closure-env name value)))
|
||||
(when (not written) (dict-set! (get vm "globals") name value)))))
|
||||
(when (not written) (dict-set! (vm-globals-ref vm) name value)))))
|
||||
(define
|
||||
env-walk
|
||||
(fn
|
||||
@@ -414,20 +412,15 @@
|
||||
(let
|
||||
((code (code-from-value code-val))
|
||||
(uv-count
|
||||
(if
|
||||
(dict? code-val)
|
||||
(let
|
||||
((n (get code-val "upvalue-count")))
|
||||
(if (nil? n) 0 n))
|
||||
0)))
|
||||
(if (dict? code-val) (or (get code-val "upvalue-count") 0) 0)))
|
||||
(let
|
||||
((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (get vm "stack") (+ (get frame "base") index))))) (dict-set! cells key c) c))) (nth (get (get frame "closure") "vm-upvalues") index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result)))
|
||||
(make-vm-closure code upvalues nil (get vm "globals") nil)))))
|
||||
((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (vm-stack vm) (+ (frame-base frame) index))))) (dict-set! cells key c) c))) (nth (-> frame frame-closure closure-upvalues) index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result)))
|
||||
(make-vm-closure code upvalues nil (vm-globals-ref vm) nil)))))
|
||||
(define
|
||||
vm-run
|
||||
(fn
|
||||
(vm)
|
||||
"Execute bytecode until all frames are consumed."
|
||||
"Execute bytecode until all frames are done or IO suspension."
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
@@ -438,9 +431,9 @@
|
||||
((frame (first (vm-frames vm)))
|
||||
(rest-frames (rest (vm-frames vm))))
|
||||
(let
|
||||
((bc (code-bytecode (closure-code (frame-closure frame))))
|
||||
((bc (-> frame frame-closure closure-code code-bytecode))
|
||||
(consts
|
||||
(code-constants (closure-code (frame-closure frame)))))
|
||||
(-> frame frame-closure closure-code code-constants)))
|
||||
(if
|
||||
(>= (frame-ip frame) (len bc))
|
||||
(vm-set-frames! vm (list))
|
||||
|
||||
Reference in New Issue
Block a user