diff --git a/hosts/ocaml/bin/dune b/hosts/ocaml/bin/dune index e5d14411..b12821ec 100644 --- a/hosts/ocaml/bin/dune +++ b/hosts/ocaml/bin/dune @@ -1,6 +1,6 @@ (executables (names run_tests debug_set sx_server integration_tests) - (libraries sx unix threads.posix)) + (libraries sx unix threads.posix otfm)) (executable (name mcp_tree) diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index 7c59e719..d744812d 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1422,6 +1422,7 @@ let run_spec_tests env test_files = let templates_dir = Filename.concat project_dir "shared/sx/templates" in load_module "tw.sx" templates_dir; load_module "tw-layout.sx" templates_dir; + load_module "font.sx" templates_dir; load_module "tw-type.sx" templates_dir; (* SX docs site: components, handlers, demos *) let sx_comp_dir = Filename.concat project_dir "sx/sxc" in diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index f71cc99c..a3b048f3 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -18,6 +18,123 @@ open Sx_types +(* ====================================================================== *) +(* Font measurement via otfm — reads OpenType/TrueType font tables *) +(* ====================================================================== *) + +(* Font cache: font-family → (units_per_em, glyph_id_map, advance_width_map) *) +let _font_cache : (string, (int * (int, int) Hashtbl.t * (int, int) Hashtbl.t)) Hashtbl.t = Hashtbl.create 4 + +(* Map font-family names to file paths *) +let _font_base = ref "shared/static/fonts" + +let font_path_for family = + let base = !_font_base in + let try_paths paths = + List.find_opt Sys.file_exists paths in + match String.lowercase_ascii family with + | "serif" | "times" | "times new roman" -> + try_paths [base ^ "/DejaVuSerif.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSerif.ttf"] + | "sans-serif" | "sans" | "arial" | "helvetica" -> + try_paths [base ^ "/DejaVuSans.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf"] + | "monospace" | "mono" | "courier" -> + try_paths [base ^ "/DejaVuSansMono-Bold.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSansMono-Bold.ttf"] + | path when Sys.file_exists path -> Some path + | _ -> try_paths [base ^ "/DejaVuSerif.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSerif.ttf"] + +(* Load a font file and extract cmap + hmtx tables *) +let load_font family = + match Hashtbl.find_opt _font_cache family with + | Some cached -> Some cached + | None -> + match font_path_for family with + | None -> None + | Some path -> + try + let ic = open_in_bin path in + let n = in_channel_length ic in + let buf = Bytes.create n in + really_input ic buf 0 n; + close_in ic; + let s = Bytes.to_string buf in + let d = Otfm.decoder (`String s) in + (* Get units_per_em from head table *) + let upm = match Otfm.head d with + | Error _ -> 2048 + | Ok h -> h.Otfm.head_units_per_em in + (* Build char→glyph_id map from cmap. + cmap folds: (acc -> map_kind -> (u0,u1) -> glyph_id -> acc) *) + let cmap_tbl = Hashtbl.create 256 in + let _ = Otfm.cmap d (fun acc kind (u0, u1) gid -> + (match kind with + | `Glyph -> + (* Single mapping: u0 -> gid (u0 = u1) *) + Hashtbl.replace cmap_tbl u0 gid + | `Glyph_range -> + (* Range: u0..u1 -> gid..(gid + u1 - u0) *) + for i = 0 to u1 - u0 do + Hashtbl.replace cmap_tbl (u0 + i) (gid + i) + done); + acc) () in + (* Build glyph_id→advance_width map from hmtx. + hmtx folds: (acc -> glyph_id -> adv_width -> lsb -> acc) *) + let hmtx_tbl = Hashtbl.create 256 in + let _ = Otfm.hmtx d (fun acc gid adv _lsb -> + Hashtbl.replace hmtx_tbl gid adv; acc) () in + let result = (upm, cmap_tbl, hmtx_tbl) in + Printf.eprintf "[font] loaded %s: %d glyphs, %d metrics, upm=%d\n%!" + (Filename.basename path) (Hashtbl.length cmap_tbl) (Hashtbl.length hmtx_tbl) upm; + Hashtbl.replace _font_cache family result; + Some result + with e -> + Printf.eprintf "[font] error loading %s: %s\n%!" path (Printexc.to_string e); + None + +(* Measure text width using font tables *) +let measure_text_otfm family size text = + match load_font family with + | None -> + (* Fallback to monospace approximation *) + let w = size *. 0.6 *. (float_of_int (String.length text)) in + (w, size, size *. 0.8, size *. 0.2) + | Some (upm, cmap_tbl, hmtx_tbl) -> + let scale = size /. (float_of_int upm) in + let width = ref 0.0 in + (* Iterate over UTF-8 codepoints *) + let i = ref 0 in + let len = String.length text in + while !i < len do + let byte = Char.code text.[!i] in + let cp, advance = + if byte < 0x80 then (byte, 1) + else if byte < 0xC0 then (byte, 1) (* continuation — skip *) + else if byte < 0xE0 then + ((byte land 0x1F) lsl 6 lor (Char.code text.[min (!i+1) (len-1)] land 0x3F), 2) + else if byte < 0xF0 then + ((byte land 0x0F) lsl 12 + lor (Char.code text.[min (!i+1) (len-1)] land 0x3F) lsl 6 + lor (Char.code text.[min (!i+2) (len-1)] land 0x3F), 3) + else + ((byte land 0x07) lsl 18 + lor (Char.code text.[min (!i+1) (len-1)] land 0x3F) lsl 12 + lor (Char.code text.[min (!i+2) (len-1)] land 0x3F) lsl 6 + lor (Char.code text.[min (!i+3) (len-1)] land 0x3F), 4) + in + let gid = match Hashtbl.find_opt cmap_tbl cp with + | Some g -> g | None -> 0 in + let adv = match Hashtbl.find_opt hmtx_tbl gid with + | Some a -> a | None -> upm / 2 in + width := !width +. (float_of_int adv) *. scale; + i := !i + advance + done; + let ascent = size *. 0.8 in (* approximate — could read OS/2 table *) + let descent = size *. 0.2 in + (!width, size, ascent, descent) + (* ====================================================================== *) (* Output helpers *) @@ -361,9 +478,9 @@ and cek_run_with_io state = Nil end | "text-measure" -> - (* Resolve locally — monospace approximation *) let args = let a = Sx_runtime.get_val request (String "args") in (match a with List l -> l | _ -> [a]) in + let font = match args with String f :: _ -> f | _ -> "serif" in let size = match args with | [_font; Number sz; _text] -> sz | [_font; Number sz] -> sz @@ -371,13 +488,12 @@ and cek_run_with_io state = let text = match args with | [_font; _sz; String t] -> t | _ -> "" in - let char_width = size *. 0.6 in - let width = char_width *. (float_of_int (String.length text)) in + let (w, h, asc, desc) = measure_text_otfm font size text in let d = Hashtbl.create 4 in - Hashtbl.replace d "width" (Number width); - Hashtbl.replace d "height" (Number size); - Hashtbl.replace d "ascent" (Number (size *. 0.8)); - Hashtbl.replace d "descent" (Number (size *. 0.2)); + Hashtbl.replace d "width" (Number w); + Hashtbl.replace d "height" (Number h); + Hashtbl.replace d "ascent" (Number asc); + Hashtbl.replace d "descent" (Number desc); Dict d | _ -> let args = let a = Sx_runtime.get_val request (String "args") in @@ -967,7 +1083,16 @@ let register_jit_hook env = (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with | Sx_vm.VmSuspended (request, saved_vm) -> - Some (make_vm_suspend_marker request saved_vm) + (* Try inline IO resolution; fall back to suspend marker *) + (match !Sx_types._cek_io_resolver with + | Some resolver -> + let rec resolve_loop req vm = + let result = resolver req (Nil) in + (try Some (Sx_vm.resume_vm vm result) + with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2) + in + resolve_loop request saved_vm + | None -> Some (make_vm_suspend_marker request saved_vm)) | e -> let fn_name = match l.l_name with Some n -> n | None -> "?" in if not (Hashtbl.mem _jit_warned fn_name) then begin @@ -992,7 +1117,15 @@ let register_jit_hook env = (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with | Sx_vm.VmSuspended (request, saved_vm) -> - Some (make_vm_suspend_marker request saved_vm) + (match !Sx_types._cek_io_resolver with + | Some resolver -> + let rec resolve_loop req vm = + let result = resolver req (Nil) in + (try Some (Sx_vm.resume_vm vm result) + with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2) + in + resolve_loop request saved_vm + | None -> Some (make_vm_suspend_marker request saved_vm)) | e -> Printf.eprintf "[jit] %s first-call fallback to CEK: %s\n%!" fn_name (Printexc.to_string e); Hashtbl.replace _jit_warned fn_name true; @@ -1852,6 +1985,8 @@ let eval_with_io_render expr env = | _ -> Nil in let result = match op with | "text-measure" -> + let font = match args with + | List (String f :: _) -> f | _ -> "serif" in let size = match args with | List [_font; Number sz; _text] -> sz | List [_font; Number sz] -> sz @@ -1859,13 +1994,12 @@ let eval_with_io_render expr env = let text = match args with | List [_font; _sz; String t] -> t | _ -> "" in - let char_width = size *. 0.6 in - let width = char_width *. (float_of_int (String.length text)) in + let (w, h, asc, desc) = measure_text_otfm font size text in let d = Hashtbl.create 4 in - Hashtbl.replace d "width" (Number width); - Hashtbl.replace d "height" (Number size); - Hashtbl.replace d "ascent" (Number (size *. 0.8)); - Hashtbl.replace d "descent" (Number (size *. 0.2)); + Hashtbl.replace d "width" (Number w); + Hashtbl.replace d "height" (Number h); + Hashtbl.replace d "ascent" (Number asc); + Hashtbl.replace d "descent" (Number desc); Dict d | "io-sleep" | "sleep" -> let ms = match args with @@ -2057,8 +2191,8 @@ let eval_with_io expr env = Nil with _ -> Nil) | "text-measure" -> - (* Pretext: server-side text measurement (monospace approximation). - Real otfm font-table parsing can replace this later. *) + let font = match args with + | List (String f :: _) -> f | _ -> "serif" in let size = match args with | List [_font; Number sz; _text] -> sz | List [_font; Number sz] -> sz @@ -2066,15 +2200,12 @@ let eval_with_io expr env = let text = match args with | List [_font; _sz; String t] -> t | _ -> "" in - let char_width = size *. 0.6 in - let width = char_width *. (float_of_int (String.length text)) in - let ascent = size *. 0.8 in - let descent = size *. 0.2 in + let (w, h, asc, desc) = measure_text_otfm font size text in let d = Hashtbl.create 4 in - Hashtbl.replace d "width" (Number width); - Hashtbl.replace d "height" (Number size); - Hashtbl.replace d "ascent" (Number ascent); - Hashtbl.replace d "descent" (Number descent); + Hashtbl.replace d "width" (Number w); + Hashtbl.replace d "height" (Number h); + Hashtbl.replace d "ascent" (Number asc); + Hashtbl.replace d "descent" (Number desc); Dict d | _ -> Printf.eprintf "[io] unhandled IO op: %s\n%!" op; @@ -3148,6 +3279,7 @@ let http_mode port = let dev_path = project_dir ^ "/shared/static" in if Sys.file_exists docker_path then docker_path else dev_path in Printf.eprintf "[sx-http] static_dir=%s\n%!" static_dir; + _font_base := static_dir ^ "/fonts"; (* HTTP mode always expands components — bind once, shared across domains *) ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true))); (* Inject shell statics with real file hashes, CSS, and pages registry *) @@ -3156,6 +3288,41 @@ let http_mode port = The env_bind hook keeps it in sync with any future bindings. *) (* Enable lazy JIT — compile lambdas to bytecode on first call *) register_jit_hook env; + (* Install global IO resolver so perform works inside aser/eval_expr. + This lets components call measure-text during server-side rendering. *) + Sx_types._cek_io_resolver := Some (fun request _state -> + (* Extract op and args from either Dict {op, args} or raw List/ListRef (op-symbol args...) *) + let op, args = match request with + | Dict d -> + let o = match Hashtbl.find_opt d "op" with Some (String s) -> s | Some (Symbol s) -> s | _ -> "" in + let a = match Hashtbl.find_opt d "args" with Some v -> v | None -> Nil in + (o, a) + | List (Symbol op_sym :: rest) | ListRef { contents = Symbol op_sym :: rest } -> (op_sym, List rest) + | List (String op_str :: rest) | ListRef { contents = String op_str :: rest } -> (op_str, List rest) + | _ -> ("", Nil) + in + match op with + | "text-measure" -> + let font = match args with + | List (String f :: _) -> f + | _ -> "serif" in + let size = match args with + | List [_font; Number sz; _text] -> sz + | List [_font; Number sz] -> sz + | _ -> 16.0 in + let text = match args with + | List [_font; _sz; String t] -> t + | _ -> "" in + let (width, height, ascent, descent) = measure_text_otfm font size text in + let d = Hashtbl.create 4 in + Hashtbl.replace d "width" (Number width); + Hashtbl.replace d "height" (Number height); + Hashtbl.replace d "ascent" (Number ascent); + Hashtbl.replace d "descent" (Number descent); + Dict d + | "io-sleep" | "sleep" -> Nil + | "import" -> Nil + | _ -> Nil); (* Response cache — path → full HTTP response string. Populated during pre-warm, serves cached responses in <0.1ms. Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for @@ -3721,6 +3888,7 @@ let site_mode () = ignore (env_bind env "_spec-dir" (String spec_base)); ignore (env_bind env "_lib-dir" (String lib_base)); ignore (env_bind env "_web-dir" (String web_base)); + _font_base := static_dir ^ "/fonts"; _import_env := Some env; let core_files = [ spec_base ^ "/parser.sx"; spec_base ^ "/render.sx"; spec_base ^ "/signals.sx"; diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 05fe4489..a699b921 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -585,7 +585,18 @@ and cek_step_loop state = (* cek-run *) and cek_run state = - (let final = (cek_step_loop (state)) in (if sx_truthy ((cek_suspended_p (final))) then (raise (Eval_error (value_to_str (String "IO suspension in non-IO context")))) else (cek_value (final)))) + let rec run s = + let final = cek_step_loop s in + if sx_truthy (cek_suspended_p final) then + match !Sx_types._cek_io_resolver with + | Some resolver -> + let request = cek_io_request final in + let result = resolver request final in + run (cek_resume final result) + | None -> + raise (Eval_error (value_to_str (String "IO suspension in non-IO context"))) + else cek_value final + in run state (* cek-resume *) and cek_resume suspended_state result' = diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index 6416f059..3cf17f52 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -246,6 +246,12 @@ exception Parse_error of string to avoid a dependency cycle between sx_runtime and sx_vm. *) exception CekPerformRequest of value +(** Hook: resolve IO suspension inline in cek_run. + When set, cek_run calls this instead of raising "IO suspension in non-IO context". + The function receives the suspended state and returns the resolved value. + Used by the HTTP server to handle perform (text-measure) during aser. *) +let _cek_io_resolver : (value -> value -> value) option ref = ref None + (** Hook: convert VM suspension exceptions to CekPerformRequest. Set by sx_vm after it defines VmSuspended. Called by sx_runtime.sx_apply_cek. *) let _convert_vm_suspension : (exn -> unit) ref = ref (fun _ -> ()) diff --git a/shared/static/fonts/DejaVuSans.ttf b/shared/static/fonts/DejaVuSans.ttf new file mode 100644 index 00000000..fb0bd945 Binary files /dev/null and b/shared/static/fonts/DejaVuSans.ttf differ diff --git a/shared/static/fonts/DejaVuSerif.ttf b/shared/static/fonts/DejaVuSerif.ttf new file mode 100644 index 00000000..daf01650 Binary files /dev/null and b/shared/static/fonts/DejaVuSerif.ttf differ diff --git a/shared/sx/templates/font.sx b/shared/sx/templates/font.sx new file mode 100644 index 00000000..5c343c90 --- /dev/null +++ b/shared/sx/templates/font.sx @@ -0,0 +1,41 @@ +;; ~font — web font component +;; +;; Works like ~tw: emits @font-face CSS into the cssx scope, +;; sets font-family on the parent element via spread. +;; +;; Usage: +;; (div (~font :family "Pretext Serif" :src "/static/fonts/DejaVuSerif.ttf") +;; "This text uses DejaVu Serif") +;; +;; (p (~font :family "Pretext Serif") ;; reuse already-declared font +;; "No :src needed after first declaration") + +;; Track which font families have already emitted @font-face rules +(define *font-declared* (dict)) + +(defcomp + ~font + (&key family src weight style format) + (let + ((fam (or family "serif")) + (wt (or weight "normal")) + (st (or style "normal")) + (fmt (or format "truetype"))) + (when + (and src (not (has-key? *font-declared* fam))) + (dict-set! *font-declared* fam true) + (collect! + "cssx" + (str + "@font-face{font-family:'" + fam + "';src:url('" + src + "') format('" + fmt + "');font-weight:" + wt + ";font-style:" + st + ";}"))) + (make-spread {:style (str "font-family:'" fam "',serif;")}))) \ No newline at end of file diff --git a/sx/sx/pretext-demo.sx b/sx/sx/pretext-demo.sx index 7873ca36..4a0ea9d9 100644 --- a/sx/sx/pretext-demo.sx +++ b/sx/sx/pretext-demo.sx @@ -1,7 +1,7 @@ ;; Pretext demo — DOM-free text layout ;; ;; Visual-first: shows typeset text, then explains how. -;; Uses measure-text (perform) for real glyph measurement. +;; Uses measure-text (perform) for glyph measurement. ;; Compute positioned word data for one line. (define @@ -45,15 +45,6 @@ {:y y :words (pretext-position-line lw lwid gap)})))))) (range n-lines))))) -;; Measure all words and return widths list -(define - pretext-measure-words - (fn - (words font size) - (map - (fn (w) (let ((m (measure-text font size w))) (get m :width))) - words))) - ;; Render pre-computed positioned lines (defcomp ~pretext-demo/render-paragraph @@ -109,13 +100,23 @@ (font "serif") (size 15)) (let - ((sw (pretext-measure-words sample-words font size)) - (space-m (measure-text font size " ")) - (n-words (len sample-words))) + ((sw (list)) (n-words (len sample-words))) + (for-each + (fn + (w) + (let + ((m (measure-text font size w))) + (append! sw (get m :width)))) + sample-words) (let - ((space-w (get space-m :width))) + ((space-m (measure-text font size " ")) + (space-w (get (measure-text font size " ") :width))) (div - (~tw :tokens "space-y-10") + (begin + (~tw :tokens "space-y-10") + (~font + :family "Pretext Serif" + :src "/static/fonts/DejaVuSerif.ttf")) (div (~tw :tokens "space-y-4") (div @@ -166,11 +167,6 @@ (div (~tw :tokens "grid grid-cols-1 md:grid-cols-2 gap-4") (~pretext-demo/render-paragraph - :words sample-words - :widths sw - :space-width space-w - :max-width nm - :line-height 22 :lines (pretext-layout-lines sample-words sw @@ -178,14 +174,11 @@ space-w nm 22) + :max-width nm + :line-height 22 :n-words n-words :label "Greedy (browser default)") (~pretext-demo/render-paragraph - :words sample-words - :widths sw - :space-width space-w - :max-width nm - :line-height 22 :lines (pretext-layout-lines sample-words sw @@ -193,6 +186,8 @@ space-w nm 22) + :max-width nm + :line-height 22 :n-words n-words :label "Knuth-Plass optimal")))) (div