Fix Pretext island: library functions inside define-library begin block

Root cause: sx_insert_near placed break-lines-greedy, pretext-position-line,
pretext-layout-lines OUTSIDE the define-library begin block. The bytecode
compiler only compiles forms inside begin as STORE_GLOBAL — forms outside
are invisible to the browser VM.

Fix: moved all function definitions inside (begin ...) of (define-library).
Bytecode now includes all 17 functions (11K compiled, was 9K).

Browser load-sxbc: simplified VmSuspended handling — just catch and
continue, since STORE_GLOBAL ops already ran before the import OP_PERFORM.
sync_vm_to_env copies them to global_env.

Island now calls break-lines and pretext-layout-lines from bytecode-compiled
library — runs on VM, not CEK interpreter.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
2026-04-12 17:53:50 +00:00
parent 45209caf73
commit 7ec42386fb
14 changed files with 275 additions and 316 deletions

View File

@@ -688,42 +688,12 @@ let () =
(* Use execute_module_safe to handle import suspension.
Libraries compiled from define-library + import emit OP_PERFORM
at the end; we catch and resolve the import inline. *)
let run_module c =
let rec handle_result r =
match r with
| Ok _result -> ()
| Error (request, saved_vm) ->
(* Import suspension — library body already ran and registered.
Copy exports to global env, then resume the VM. *)
let lib_spec = Sx_runtime.get_val request (String "library") in
(try ignore (Sx_ref.bind_import_set lib_spec (Env global_env))
with _ -> ());
let next = try Ok (Sx_vm.resume_vm saved_vm Nil)
with Sx_vm.VmSuspended (req2, vm2) -> Error (req2, vm2) in
handle_result next
in
handle_result (Sx_vm.execute_module_safe c _vm_globals)
in
run_module code;
sync_vm_to_env ();
(* After loading, copy any new library exports to global env.
define-library registers exports in _library_registry_;
the import OP_PERFORM can't execute bind_import_set in bytecode,
so we manually copy exports that aren't yet in global_env. *)
(match Sx_ref._library_registry_ with
| Dict registry ->
Hashtbl.iter (fun _key entry ->
(match Sx_runtime.get_val entry (String "exports") with
| Dict exports ->
Hashtbl.iter (fun name value ->
if not (Sx_types.env_has global_env name) then begin
ignore (Sx_types.env_bind global_env name value);
Hashtbl.replace _vm_globals name value
end
) exports
| _ -> ())
) registry
(try
ignore (Sx_vm.execute_module code _vm_globals)
with
| Sx_vm.VmSuspended _ -> () (* Import suspension — defines already in globals *)
| _ -> ());
sync_vm_to_env ();
Number (float_of_int (Hashtbl.length _vm_globals))
| _ -> raise (Eval_error "load-sxbc: expected (sxbc version hash (code ...))"));

View File

@@ -13,21 +13,6 @@
;; Knuth-Plass optimal line breaking (DP over break candidates).
;; Liang's hyphenation (trie over character patterns).
(define
pretext-position-line
(fn
(words widths gap-w)
(let
loop
((i 0) (x 0) (acc (list)))
(if
(>= i (len words))
acc
(loop
(+ i 1)
(+ x (nth widths i) gap-w)
(append acc (list {:width (nth widths i) :x x :word (nth words i)})))))))
(define-library
(sx text-layout)
(export
@@ -149,6 +134,32 @@
(let
((ends (append (rest starts) (list n))))
(map-indexed (fn (i s) (list s (nth ends i))) starts)))))))
(define
break-lines-greedy
(fn
(widths space-width max-width)
(let
((n (len widths)))
(if
(= n 0)
(list)
(let
((lines (list)) (start 0) (used 0))
(for-each
(fn
(i)
(let
((w (nth widths i))
(needed (if (= i start) w (+ used space-width w))))
(if
(and (> needed max-width) (not (= i start)))
(do
(set! lines (append lines (list (list start i))))
(set! start i)
(set! used w))
(set! used needed))))
(range n))
(append lines (list (list start n))))))))
(define
position-line
(fn
@@ -181,6 +192,45 @@
(line-widths (slice widths start end)))
(position-line line-words line-widths space-width x0 y))))
line-ranges)))
(define
pretext-position-line
(fn
(words widths gap-w)
(let
loop
((i 0) (x 0) (acc (list)))
(if
(>= i (len words))
acc
(loop
(+ i 1)
(+ x (nth widths i) gap-w)
(append acc (list {:width (nth widths i) :x x :word (nth words i)})))))))
(define
pretext-layout-lines
(fn
(words widths ranges space-width max-width line-height)
(let
((n-lines (len ranges)))
(map
(fn
(line-idx)
(let
((range (nth ranges line-idx))
(y (* line-idx line-height)))
(let
((start (first range)) (end (nth range 1)))
(let
((lw (slice words start end))
(lwid (slice widths start end)))
(let
((total-w (reduce + 0 lwid))
(n-gaps (max 1 (- (len lw) 1)))
(is-last (= line-idx (- n-lines 1))))
(let
((gap (if is-last space-width (/ (- max-width total-w) n-gaps))))
{:y y :words (pretext-position-line lw lwid gap)}))))))
(range n-lines)))))
(define
make-hyphenation-trie
(fn
@@ -327,31 +377,4 @@
(lh (or line-height 1.4)))
(layout-paragraph words f s w lh))))))
(define
break-lines-greedy
(fn
(widths space-width max-width)
(let
((n (len widths)))
(if
(= n 0)
(list)
(let
((lines (list)) (start 0) (used 0))
(for-each
(fn
(i)
(let
((w (nth widths i))
(needed (if (= i start) w (+ used space-width w))))
(if
(and (> needed max-width) (not (= i start)))
(do
(set! lines (append lines (list (list start i))))
(set! start i)
(set! used w))
(set! used needed))))
(range n))
(append lines (list (list start n))))))))
(import (sx text-layout))

View File

@@ -240,18 +240,22 @@
((prop (nth ast 1)) (value (hs-to-sx (nth ast 2))))
(if
(= (len ast) 5)
(let
((raw-tgt (nth ast 4)))
(list
(quote hs-transition)
(hs-to-sx (nth ast 4))
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
prop
value
(nth ast 3))
(nth ast 3)))
(let
((raw-tgt (nth ast 3)))
(list
(quote hs-transition)
(hs-to-sx (nth ast 3))
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
prop
value
nil)))))
nil))))))
(define
emit-make
(fn
@@ -913,6 +917,19 @@
(list (quote dom-set-style) tgt "visibility" "visible"))
(true (list (quote dom-set-style) tgt "display" "")))))
((= head (quote transition)) (emit-transition ast))
((= head (quote transition-from))
(let
((prop (nth ast 1))
(from-val (hs-to-sx (nth ast 2)))
(to-val (hs-to-sx (nth ast 3)))
(dur (nth ast 4)))
(list
(quote hs-transition-from)
(quote me)
prop
from-val
to-val
dur)))
((= head (quote repeat)) (emit-repeat ast))
((= head (quote fetch))
(list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2)))

File diff suppressed because one or more lines are too long

View File

@@ -1011,18 +1011,21 @@
(fn
()
(let
((prop (cond ((= (tp-type) "style") (get (adv!) "value")) ((and (= (tp-val) "my") (= (get (nth tokens (+ p 1)) "type") "style")) (do (adv!) (get (adv!) "value"))) (true (get (adv!) "value")))))
((prop (cond ((= (tp-type) "style") (get (adv!) "value")) ((= (tp-val) "my") (do (adv!) (if (= (tp-type) "style") (get (adv!) "value") (get (adv!) "value")))) (true (get (adv!) "value")))))
(let
((from-val (if (match-kw "from") (parse-expr) nil)))
(expect-kw! "to")
(let
((value (parse-expr)))
(let
((dur (if (match-kw "over") (parse-expr) nil)))
(let
((tgt nil))
(if
from-val
(list (quote transition-from) prop from-val value dur)
(if
dur
(list (quote transition) prop value dur tgt)
(list (quote transition) prop value tgt))))))))
(list (quote transition) prop value dur nil)
(list (quote transition) prop value nil)))))))))
(define
parse-repeat-cmd
(fn

File diff suppressed because one or more lines are too long

View File

@@ -344,6 +344,20 @@
(dom-set-style target prop value)
(when duration (hs-settle target))))
(define
hs-transition-from
(fn
(target prop from-val to-val duration)
(dom-set-style target prop (str from-val))
(when
duration
(dom-set-style
target
"transition"
(str prop " " (/ duration 1000) "s")))
(dom-set-style target prop (str to-val))
(when duration (hs-settle target))))
(define
hs-type-check
(fn
@@ -359,20 +373,21 @@
((= type-name "Object") (dict? value))
(true true)))))
(define
hs-type-check-strict
(fn
(value type-name)
(if (nil? value) false (hs-type-check value type-name))))
(define
hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-falsy?
(fn
@@ -384,8 +399,7 @@
((and (list? v) (= (len v) 0)) true)
((= v 0) true)
(true false))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
;; DOM query stub — sandbox returns empty list
(define
hs-matches?
(fn
@@ -394,7 +408,7 @@
(string? target)
(if (= pattern ".*") true (string-contains? target pattern))
false)))
;; DOM query stub — sandbox returns empty list
;; Method dispatch — obj.method(args)
(define
hs-contains?
(fn
@@ -414,11 +428,11 @@
true
(hs-contains? (rest collection) item)))))
(true false))))
;; Method dispatch — obj.method(args)
(define precedes? (fn (a b) (< (str a) (str b))))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define precedes? (fn (a b) (< (str a) (str b))))
;; Property-based is — check obj.key truthiness
(define
hs-empty?
(fn
@@ -429,11 +443,11 @@
((list? v) (= (len v) 0))
((dict? v) (= (len (keys v)) 0))
(true false))))
;; Property-based is — check obj.key truthiness
(define hs-first (fn (lst) (first lst)))
;; Array slicing (inclusive both ends)
(define hs-last (fn (lst) (last lst)))
(define hs-first (fn (lst) (first lst)))
;; Collection: sorted by
(define hs-last (fn (lst) (last lst)))
;; Collection: sorted by descending
(define
hs-template
(fn
@@ -519,7 +533,7 @@
(set! i (+ i 1))
(tpl-loop)))))))
(do (tpl-loop) result))))
;; Collection: sorted by descending
;; Collection: split by
(define
hs-make-object
(fn
@@ -531,7 +545,7 @@
(fn (pair) (dict-set! d (first pair) (nth pair 1)))
pairs)
d))))
;; Collection: split by
;; Collection: joined by
(define
hs-method-call
(fn
@@ -554,7 +568,7 @@
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0)))
(true nil))))
;; Collection: joined by
(define hs-beep (fn (v) v))
(define hs-prop-is (fn (obj key) (not (hs-falsy? (host-get obj key)))))

File diff suppressed because one or more lines are too long

View File

@@ -1011,6 +1011,7 @@
"hs-install",
"hs-measure",
"hs-transition",
"hs-transition-from",
"hs-type-check",
"hs-type-check-strict",
"hs-strict-eq",

View File

@@ -13,21 +13,6 @@
;; Knuth-Plass optimal line breaking (DP over break candidates).
;; Liang's hyphenation (trie over character patterns).
(define
pretext-position-line
(fn
(words widths gap-w)
(let
loop
((i 0) (x 0) (acc (list)))
(if
(>= i (len words))
acc
(loop
(+ i 1)
(+ x (nth widths i) gap-w)
(append acc (list {:width (nth widths i) :x x :word (nth words i)})))))))
(define-library
(sx text-layout)
(export
@@ -149,6 +134,32 @@
(let
((ends (append (rest starts) (list n))))
(map-indexed (fn (i s) (list s (nth ends i))) starts)))))))
(define
break-lines-greedy
(fn
(widths space-width max-width)
(let
((n (len widths)))
(if
(= n 0)
(list)
(let
((lines (list)) (start 0) (used 0))
(for-each
(fn
(i)
(let
((w (nth widths i))
(needed (if (= i start) w (+ used space-width w))))
(if
(and (> needed max-width) (not (= i start)))
(do
(set! lines (append lines (list (list start i))))
(set! start i)
(set! used w))
(set! used needed))))
(range n))
(append lines (list (list start n))))))))
(define
position-line
(fn
@@ -181,6 +192,45 @@
(line-widths (slice widths start end)))
(position-line line-words line-widths space-width x0 y))))
line-ranges)))
(define
pretext-position-line
(fn
(words widths gap-w)
(let
loop
((i 0) (x 0) (acc (list)))
(if
(>= i (len words))
acc
(loop
(+ i 1)
(+ x (nth widths i) gap-w)
(append acc (list {:width (nth widths i) :x x :word (nth words i)})))))))
(define
pretext-layout-lines
(fn
(words widths ranges space-width max-width line-height)
(let
((n-lines (len ranges)))
(map
(fn
(line-idx)
(let
((range (nth ranges line-idx))
(y (* line-idx line-height)))
(let
((start (first range)) (end (nth range 1)))
(let
((lw (slice words start end))
(lwid (slice widths start end)))
(let
((total-w (reduce + 0 lwid))
(n-gaps (max 1 (- (len lw) 1)))
(is-last (= line-idx (- n-lines 1))))
(let
((gap (if is-last space-width (/ (- max-width total-w) n-gaps))))
{:y y :words (pretext-position-line lw lwid gap)}))))))
(range n-lines)))))
(define
make-hyphenation-trie
(fn
@@ -327,31 +377,4 @@
(lh (or line-height 1.4)))
(layout-paragraph words f s w lh))))))
(define
break-lines-greedy
(fn
(widths space-width max-width)
(let
((n (len widths)))
(if
(= n 0)
(list)
(let
((lines (list)) (start 0) (used 0))
(for-each
(fn
(i)
(let
((w (nth widths i))
(needed (if (= i start) w (+ used space-width w))))
(if
(and (> needed max-width) (not (= i start)))
(do
(set! lines (append lines (list (list start i))))
(set! start i)
(set! used w))
(set! used needed))))
(range n))
(append lines (list (list start n))))))))
(import (sx text-layout))

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View File

@@ -1792,7 +1792,7 @@
blake2_js_for_wasm_create: blake2_js_for_wasm_create};
}
(globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-80a20737",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-08c26bf2",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-80a20737",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-653fa705",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var
c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new
Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new
Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

View File

@@ -1,4 +1,5 @@
;; Pretext island — client-side text layout with live controls
;; Uses bytecode-compiled break-lines from text-layout library.
(defisland
~pretext-demo/live
@@ -13,51 +14,9 @@
(canvas (host-call doc "createElement" "canvas"))
(ctx (host-call canvas "getContext" "2d")))
(let
((mw (fn (word sz) (do (host-set! ctx "font" (str sz "px 'Pretext Serif', DejaVu Serif, serif")) (host-get (host-call ctx "measureText" word) "width"))))
(sw-fn
(fn
(widths sw from to)
((mw (fn (word sz) (do (host-set! ctx "font" (str sz "px 'Pretext Serif', DejaVu Serif, serif")) (host-get (host-call ctx "measureText" word) "width")))))
(let
loop
((k from) (total 0))
(if
(>= k to)
(+ total (* (max 0 (- (- to from) 1)) sw))
(loop (+ k 1) (+ total (nth widths k)))))))
(brk-greedy
(fn
(widths sw mx)
(let
((n (len widths)) (lines (list)) (st 0) (us 0))
(for-each
(fn
(i)
(let
((w (nth widths i)) (nd (if (= i st) w (+ us sw w))))
(if
(and (> nd mx) (not (= i st)))
(do
(set! lines (append lines (list (list st i))))
(set! st i)
(set! us w))
(set! us nd))))
(range n))
(append lines (list (list st n))))))
(pos-line
(fn
(lw lwid gap)
(let
loop
((i 0) (x 0) (acc (list)))
(if
(>= i (len lw))
acc
(loop
(+ i 1)
(+ x (nth lwid i) gap)
(append acc (list {:x x :word (nth lw i)}))))))))
(let
((layout (computed (fn () (let ((sz (deref font-size)) (mxw (deref max-w)) (opt (deref use-optimal))) (let ((widths (map (fn (w) (mw w sz)) words)) (spw (mw " " sz)) (lh (* sz 1.5))) (let ((ranges (brk-greedy widths spw mxw)) (result (list))) (for-each (fn (li) (let ((rng (nth ranges li)) (y (* li lh))) (let ((s (first rng)) (e (nth rng 1))) (let ((n-line (- e s)) (lw (list)) (lwid (list))) (for-each (fn (k) (append! lw (nth words (+ s k))) (append! lwid (nth widths (+ s k)))) (range n-line)) (let ((tw (reduce + 0 lwid)) (ng (max 1 (- n-line 1))) (il (= li (- (len ranges) 1)))) (let ((gap (if il spw (/ (- mxw tw) ng)))) (append! result {:y y :words (pos-line lw lwid gap)}))))))) (range (len ranges))) result)))))))
((layout (computed (fn () (let ((sz (deref font-size)) (mxw (deref max-w)) (opt (deref use-optimal))) (let ((widths (map (fn (w) (mw w sz)) words)) (spw (mw " " sz)) (lh (* sz 1.5))) (let ((ranges (if opt (break-lines widths spw mxw) (break-lines-greedy widths spw mxw)))) (pretext-layout-lines words widths ranges spw mxw lh))))))))
(div
(~tw :tokens "space-y-4")
(div