sx-host step 3: HTTP server mode + define shorthand + SX highlighter
HTTP server (--http PORT): OCaml serves sx-docs directly, no Python. Loads components at startup, routes /sx/ URLs, renders full pages with shell. Geography page: 124ms TTFB (vs 144ms Quart). Single process. define shorthand: (define (name args) body) desugars to (define name (fn (args) body)) in the CEK step function. SX highlighter (lib/highlight.sx): pure SX syntax highlighting with Tailwind spans. Tokenizes SX/Lisp code — comments, strings, keywords, components, specials, numbers, booleans. Replaces Python highlight.py. Platform constructors: make-lambda, make-component, make-island, make-macro, make-thunk, make-env + accessor functions bound for evaluator.sx compatibility in HTTP mode. Tests: 1116/1117 OCaml, 7/7 Playwright (main tree). Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
464
hosts/ocaml/bin/sx_http.ml
Normal file
464
hosts/ocaml/bin/sx_http.ml
Normal file
@@ -0,0 +1,464 @@
|
||||
(** SX HTTP server — serves sx-docs directly from OCaml, no Python bridge.
|
||||
|
||||
Replaces: Quart + Hypercorn + ocaml_bridge.py + sx_router.py
|
||||
Keeps: Caddy (TLS termination, static files, reverse proxy)
|
||||
|
||||
Usage:
|
||||
sx_http.exe [--port 8013] [--static /path/to/shared/static]
|
||||
|
||||
Architecture:
|
||||
1. At startup: load all .sx components, pre-compute shell statics
|
||||
2. Per request: parse HTTP GET → route → eval page → render HTML
|
||||
3. No Python, no bridge, no serialization boundaries *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Reuse sx_server infrastructure *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* Import make_server_env and rendering from sx_server.
|
||||
We can't directly share because OCaml doesn't support cross-executable
|
||||
linking. Instead, we duplicate the minimal setup and reuse library fns. *)
|
||||
|
||||
let escape_sx_string s =
|
||||
let buf = Buffer.create (String.length s + 16) in
|
||||
String.iter (function
|
||||
| '"' -> Buffer.add_string buf "\\\""
|
||||
| '\\' -> Buffer.add_string buf "\\\\"
|
||||
| '\n' -> Buffer.add_string buf "\\n"
|
||||
| '\r' -> Buffer.add_string buf "\\r"
|
||||
| '\t' -> Buffer.add_string buf "\\t"
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.contents buf
|
||||
|
||||
let rec serialize_value = function
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(" ^ String.concat " " (List.map serialize_value items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (serialize_value v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| RawHTML s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| SxExpr s -> s
|
||||
| _ -> "nil"
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Environment setup — mirrors make_server_env from sx_server.ml *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* IO bridge stubs — sx-docs has no IO callbacks, but the evaluator
|
||||
expects these symbols to exist. We stub them to raise clear errors. *)
|
||||
let setup_io_stubs env =
|
||||
let stub name =
|
||||
ignore (env_bind env name (NativeFn (name, fun _args ->
|
||||
raise (Eval_error (Printf.sprintf "IO primitive '%s' not available in sx_http" name)))))
|
||||
in
|
||||
stub "io-request";
|
||||
stub "helper";
|
||||
(* query/action/service: not needed for sx-docs *)
|
||||
stub "query";
|
||||
stub "action";
|
||||
stub "service"
|
||||
|
||||
let make_http_env () =
|
||||
let env = make_env () in
|
||||
Sx_render.setup_render_env env;
|
||||
Sx_scope.setup_scope_env env;
|
||||
(* Setup all the standard primitives *)
|
||||
(* Evaluator bridge — needed for aser, macro expansion *)
|
||||
ignore (env_bind env "eval-expr" (NativeFn ("eval-expr", fun args ->
|
||||
match args with
|
||||
| [expr; Env e] -> Sx_ref.eval_expr expr (Env e)
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env env)
|
||||
| _ -> Nil)));
|
||||
ignore (env_bind env "apply" (NativeFn ("apply", fun args ->
|
||||
match args with
|
||||
| [f; List a] -> Sx_ref.cek_call f (List a)
|
||||
| _ -> Nil)));
|
||||
ignore (env_bind env "macroexpand-1" (NativeFn ("macroexpand-1", fun args ->
|
||||
match args with
|
||||
| [expr; Env e] ->
|
||||
(try Sx_ref.eval_expr (List [Symbol "macroexpand-1-impl"; List [Symbol "quote"; expr]]) (Env e)
|
||||
with _ -> expr)
|
||||
| _ -> Nil)));
|
||||
(* Trampoline for HO primitives *)
|
||||
Sx_primitives._sx_trampoline_fn := (fun v ->
|
||||
match v with
|
||||
| Thunk (body, closure_env) -> Sx_ref.eval_expr body (Env closure_env)
|
||||
| other -> other);
|
||||
(* client? = false on server *)
|
||||
ignore (env_bind env "client?" (NativeFn ("client?", fun _ -> Bool false)));
|
||||
(* IO stubs *)
|
||||
setup_io_stubs env;
|
||||
(* Component introspection *)
|
||||
ignore (env_bind env "component-name" (NativeFn ("component-name", fun args ->
|
||||
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> Nil)));
|
||||
ignore (env_bind env "component-params" (NativeFn ("component-params", fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> Symbol s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> Symbol s) i.i_params)
|
||||
| _ -> Nil)));
|
||||
ignore (env_bind env "component-body" (NativeFn ("component-body", fun args ->
|
||||
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil)));
|
||||
ignore (env_bind env "component-has-children?" (NativeFn ("component-has-children?", fun args ->
|
||||
match args with [Component c] -> Bool c.c_has_children | [Island i] -> Bool i.i_has_children | _ -> Bool false)));
|
||||
ignore (env_bind env "component-affinity" (NativeFn ("component-affinity", fun args ->
|
||||
match args with [Component c] -> String c.c_affinity | [Island _] -> String "client" | _ -> String "auto")));
|
||||
(* Spread attrs *)
|
||||
ignore (env_bind env "spread-attrs" (NativeFn ("spread-attrs", fun args ->
|
||||
match args with [Spread pairs] ->
|
||||
let d = Hashtbl.create 8 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
|
||||
| _ -> Nil)));
|
||||
env
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* File loading *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let load_file env path =
|
||||
try
|
||||
let src = In_channel.with_open_text path In_channel.input_all in
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
List.iter (fun expr ->
|
||||
try ignore (Sx_ref.eval_expr expr (Env env))
|
||||
with e -> Printf.eprintf "[load] %s: %s\n%!" path (Printexc.to_string e)
|
||||
) exprs;
|
||||
Printf.eprintf "[load] %s (%d forms)\n%!" path (List.length exprs)
|
||||
with e ->
|
||||
Printf.eprintf "[load] failed %s: %s\n%!" path (Printexc.to_string e)
|
||||
|
||||
let load_dir env dir pattern =
|
||||
if Sys.file_exists dir && Sys.is_directory dir then
|
||||
Array.iter (fun f ->
|
||||
if Filename.check_suffix f pattern then
|
||||
load_file env (dir ^ "/" ^ f)
|
||||
) (Sys.readdir dir)
|
||||
|
||||
let load_all_components env project_dir =
|
||||
let spec = project_dir ^ "/spec" in
|
||||
let lib = project_dir ^ "/lib" in
|
||||
let web = project_dir ^ "/web" in
|
||||
let shared_sx = project_dir ^ "/shared/sx/templates" in
|
||||
let sx_sx = project_dir ^ "/sx/sx" in
|
||||
(* Core spec *)
|
||||
List.iter (fun f -> load_file env (spec ^ "/" ^ f)) [
|
||||
"parser.sx"; "primitives.sx"; "render.sx"; "evaluator.sx";
|
||||
];
|
||||
(* Libraries *)
|
||||
load_dir env lib ".sx";
|
||||
(* Web adapters *)
|
||||
load_dir env web ".sx";
|
||||
(* Shared templates *)
|
||||
load_dir env shared_sx ".sx";
|
||||
(* SX docs components *)
|
||||
load_dir env sx_sx ".sx"
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Shell statics — computed once at startup *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
type shell_static = {
|
||||
component_defs: string;
|
||||
component_hash: string;
|
||||
pages_sx: string;
|
||||
sx_css: string;
|
||||
asset_url: string;
|
||||
}
|
||||
|
||||
let compute_shell_statics env _project_dir =
|
||||
(* Serialize all components for client *)
|
||||
let buf = Buffer.create 65536 in
|
||||
Hashtbl.iter (fun _sym v ->
|
||||
match v with
|
||||
| Component c ->
|
||||
let ps = String.concat " " (
|
||||
"&key" :: c.c_params @
|
||||
(if c.c_has_children then ["&rest"; "children"] else []))
|
||||
in
|
||||
Buffer.add_string buf (Printf.sprintf "(defcomp ~%s (%s) %s)\n"
|
||||
c.c_name ps (serialize_value c.c_body))
|
||||
| Island i ->
|
||||
let ps = String.concat " " (
|
||||
"&key" :: i.i_params @
|
||||
(if i.i_has_children then ["&rest"; "children"] else []))
|
||||
in
|
||||
Buffer.add_string buf (Printf.sprintf "(defisland ~%s (%s) %s)\n"
|
||||
i.i_name ps (serialize_value i.i_body))
|
||||
| _ -> ()
|
||||
) env.bindings;
|
||||
let component_defs = Buffer.contents buf in
|
||||
let component_hash = Digest.string component_defs |> Digest.to_hex in
|
||||
(* Pages SX — collect defpage paths for client router *)
|
||||
(* For now, empty — client routing uses the pages script tag *)
|
||||
let pages_sx = "" in
|
||||
(* CSS — for now pass through empty, Caddy serves tw.css *)
|
||||
let sx_css = "" in
|
||||
{
|
||||
component_defs;
|
||||
component_hash;
|
||||
pages_sx;
|
||||
sx_css;
|
||||
asset_url = "/static";
|
||||
}
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML rendering — same as sx_server.ml *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let sx_render_to_html expr env =
|
||||
if env_has env "render-to-html" then
|
||||
let fn = env_get env "render-to-html" in
|
||||
let result = Sx_ref.cek_call fn (List [expr; Env env]) in
|
||||
match result with String s -> s | _ -> Sx_runtime.value_to_str result
|
||||
else
|
||||
Sx_render.render_to_html expr env
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Page rendering — aser + SSR + shell in one pass *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let render_page env statics path =
|
||||
let t0 = Unix.gettimeofday () in
|
||||
(* Build the page AST: evaluate the URL path as an SX expression *)
|
||||
let path_expr = if path = "/" || path = "" then "home"
|
||||
else begin
|
||||
(* /sx/(geography.(reactive)) → (geography (reactive)) *)
|
||||
let p = if String.length path > 4 && String.sub path 0 4 = "/sx/" then
|
||||
String.sub path 4 (String.length path - 4)
|
||||
else if String.length path > 1 && path.[0] = '/' then
|
||||
String.sub path 1 (String.length path - 1)
|
||||
else path
|
||||
in
|
||||
(* Convert dots to spaces for SX URL convention *)
|
||||
String.map (fun c -> if c = '.' then ' ' else c) p
|
||||
end
|
||||
in
|
||||
(* Evaluate page function to get component call *)
|
||||
let page_ast =
|
||||
try
|
||||
let exprs = Sx_parser.parse_all path_expr in
|
||||
let expr = match exprs with [e] -> e | _ -> List (List.map Fun.id exprs) in
|
||||
Sx_ref.eval_expr expr (Env env)
|
||||
with e ->
|
||||
Printf.eprintf "[route] eval failed for '%s': %s\n%!" path_expr (Printexc.to_string e);
|
||||
Nil
|
||||
in
|
||||
if page_ast = Nil then None
|
||||
else begin
|
||||
(* Wrap in layout: (~layouts/doc :path "/sx/..." page_ast) *)
|
||||
let nav_path = if String.sub path 0 4 = "/sx/" then path
|
||||
else "/sx" ^ path in
|
||||
let wrapped = List [
|
||||
Symbol "~layouts/doc"; Keyword "path"; String nav_path;
|
||||
page_ast
|
||||
] in
|
||||
(* Wrap in app-body *)
|
||||
let full_ast = List [
|
||||
Symbol "~shared:layout/app-body";
|
||||
Keyword "content"; wrapped
|
||||
] in
|
||||
let page_source = serialize_value full_ast in
|
||||
let t1 = Unix.gettimeofday () in
|
||||
(* Phase 1: aser — expand all components *)
|
||||
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
|
||||
ignore (env_bind env "expand-components?" expand_fn);
|
||||
let body_result =
|
||||
let call = List [Symbol "aser";
|
||||
List [Symbol "quote"; full_ast];
|
||||
Env env] in
|
||||
Sx_ref.eval_expr call (Env env)
|
||||
in
|
||||
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
||||
let body_str = match body_result with
|
||||
| String s | SxExpr s -> s
|
||||
| _ -> serialize_value body_result
|
||||
in
|
||||
let t2 = Unix.gettimeofday () in
|
||||
(* Phase 2: SSR — render expanded SX to HTML *)
|
||||
let body_html =
|
||||
try
|
||||
let body_exprs = Sx_parser.parse_all body_str in
|
||||
let body_expr = match body_exprs with
|
||||
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: body_exprs) in
|
||||
sx_render_to_html body_expr env
|
||||
with e ->
|
||||
Printf.eprintf "[ssr] render-to-html failed: %s\n%!" (Printexc.to_string e);
|
||||
""
|
||||
in
|
||||
let t3 = Unix.gettimeofday () in
|
||||
(* Phase 3: Shell — wrap in full HTML page *)
|
||||
let shell_args = [
|
||||
Keyword "title"; String "SX";
|
||||
Keyword "csrf"; String "";
|
||||
Keyword "page-sx"; String page_source;
|
||||
Keyword "body-html"; String body_html;
|
||||
Keyword "component-defs"; String statics.component_defs;
|
||||
Keyword "component-hash"; String statics.component_hash;
|
||||
Keyword "pages-sx"; String statics.pages_sx;
|
||||
Keyword "sx-css"; String statics.sx_css;
|
||||
Keyword "sx-css-classes"; String "";
|
||||
Keyword "asset-url"; String statics.asset_url;
|
||||
Keyword "sx-js-hash"; String "";
|
||||
Keyword "body-js-hash"; String "";
|
||||
Keyword "wasm-hash"; String "";
|
||||
Keyword "head-scripts"; Nil;
|
||||
Keyword "body-scripts"; Nil;
|
||||
Keyword "inline-css"; Nil;
|
||||
Keyword "inline-head-js"; Nil;
|
||||
Keyword "init-sx"; Nil;
|
||||
Keyword "use-wasm"; Bool (try Sys.getenv "SX_USE_WASM" = "1" with Not_found -> false);
|
||||
Keyword "meta-html"; String "";
|
||||
] in
|
||||
let shell_call = List (Symbol "~shared:shell/sx-page-shell" :: shell_args) in
|
||||
let html = sx_render_to_html shell_call env in
|
||||
let t4 = Unix.gettimeofday () in
|
||||
Printf.eprintf "[sx-http] %s route=%.3fs aser=%.3fs ssr=%.3fs shell=%.3fs total=%.3fs html=%d\n%!"
|
||||
path (t1 -. t0) (t2 -. t1) (t3 -. t2) (t4 -. t3) (t4 -. t0) (String.length html);
|
||||
Some html
|
||||
end
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTTP server *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let http_response ?(status=200) ?(content_type="text/html; charset=utf-8") body =
|
||||
let status_text = match status with
|
||||
| 200 -> "OK" | 404 -> "Not Found" | 500 -> "Internal Server Error"
|
||||
| _ -> "Unknown"
|
||||
in
|
||||
Printf.sprintf "HTTP/1.1 %d %s\r\nContent-Type: %s\r\nContent-Length: %d\r\nConnection: keep-alive\r\n\r\n%s"
|
||||
status status_text content_type (String.length body) body
|
||||
|
||||
let parse_request data =
|
||||
(* Extract method and path from "GET /path HTTP/1.1\r\n..." *)
|
||||
match String.split_on_char ' ' (String.trim (
|
||||
match String.index_opt data '\r' with
|
||||
| Some i -> String.sub data 0 i
|
||||
| None -> match String.index_opt data '\n' with
|
||||
| Some i -> String.sub data 0 i
|
||||
| None -> data
|
||||
)) with
|
||||
| method_ :: path :: _ -> Some (method_, path)
|
||||
| _ -> None
|
||||
|
||||
let handle_request env statics data =
|
||||
match parse_request data with
|
||||
| None -> http_response ~status:400 "Bad Request"
|
||||
| Some (method_, path) ->
|
||||
if method_ <> "GET" then
|
||||
http_response ~status:405 "Method Not Allowed"
|
||||
else begin
|
||||
let decoded = try
|
||||
let b = Buffer.create (String.length path) in
|
||||
let i = ref 0 in
|
||||
while !i < String.length path do
|
||||
if path.[!i] = '%' && !i + 2 < String.length path then begin
|
||||
let hex = String.sub path (!i + 1) 2 in
|
||||
Buffer.add_char b (Char.chr (int_of_string ("0x" ^ hex)));
|
||||
i := !i + 3
|
||||
end else begin
|
||||
Buffer.add_char b path.[!i];
|
||||
i := !i + 1
|
||||
end
|
||||
done;
|
||||
Buffer.contents b
|
||||
with _ -> path
|
||||
in
|
||||
(* Route: /sx/... or / → page render *)
|
||||
let is_sx_path = String.length decoded >= 4 && String.sub decoded 0 4 = "/sx/" in
|
||||
let is_home = decoded = "/" || decoded = "/sx/" in
|
||||
if is_home || is_sx_path then
|
||||
match render_page env statics decoded with
|
||||
| Some html -> http_response html
|
||||
| None -> http_response ~status:404 "<h1>404 Not Found</h1>"
|
||||
else
|
||||
http_response ~status:404 "<h1>404 Not Found</h1>"
|
||||
end
|
||||
|
||||
let serve env statics port =
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
||||
Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_any, port));
|
||||
Unix.listen sock 128;
|
||||
Printf.eprintf "[sx-http] Listening on port %d\n%!" port;
|
||||
while true do
|
||||
let (client, _addr) = Unix.accept sock in
|
||||
(* Read request — simple: read up to 8KB, enough for any GET *)
|
||||
let buf = Bytes.create 8192 in
|
||||
let n = try Unix.read client buf 0 8192 with _ -> 0 in
|
||||
if n > 0 then begin
|
||||
let data = Bytes.sub_string buf 0 n in
|
||||
let response =
|
||||
try handle_request env statics data
|
||||
with e ->
|
||||
Printf.eprintf "[sx-http] Error: %s\n%!" (Printexc.to_string e);
|
||||
http_response ~status:500 "<h1>500 Internal Server Error</h1>"
|
||||
in
|
||||
let resp_bytes = Bytes.of_string response in
|
||||
let total = Bytes.length resp_bytes in
|
||||
let written = ref 0 in
|
||||
while !written < total do
|
||||
let n = Unix.write client resp_bytes !written (total - !written) in
|
||||
written := !written + n
|
||||
done
|
||||
end;
|
||||
Unix.close client
|
||||
done
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Main *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () =
|
||||
let port = ref 8014 in
|
||||
let project_dir = ref (try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
||||
try Sys.getenv "SX_ROOT" with Not_found ->
|
||||
if Sys.file_exists "/app/spec" then "/app"
|
||||
else Sys.getcwd ()) in
|
||||
(* Parse args *)
|
||||
let args = Array.to_list Sys.argv in
|
||||
let rec parse = function
|
||||
| "--port" :: p :: rest -> port := int_of_string p; parse rest
|
||||
| "--project" :: d :: rest -> project_dir := d; parse rest
|
||||
| _ :: rest -> parse rest
|
||||
| [] -> ()
|
||||
in
|
||||
parse (List.tl args);
|
||||
|
||||
Printf.eprintf "[sx-http] project_dir=%s\n%!" !project_dir;
|
||||
|
||||
(* Build environment *)
|
||||
let env = make_http_env () in
|
||||
|
||||
(* Load all components *)
|
||||
let t0 = Unix.gettimeofday () in
|
||||
load_all_components env !project_dir;
|
||||
let t1 = Unix.gettimeofday () in
|
||||
Printf.eprintf "[sx-http] Components loaded in %.3fs\n%!" (t1 -. t0);
|
||||
|
||||
(* Compute shell statics *)
|
||||
let statics = compute_shell_statics env !project_dir in
|
||||
let t2 = Unix.gettimeofday () in
|
||||
Printf.eprintf "[sx-http] Shell statics computed in %.3fs (defs=%d hash=%s)\n%!"
|
||||
(t2 -. t1) (String.length statics.component_defs) statics.component_hash;
|
||||
|
||||
(* Start HTTP server *)
|
||||
serve env statics !port
|
||||
@@ -1391,6 +1391,396 @@ let test_mode () =
|
||||
end
|
||||
end
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTTP server mode (--http PORT) *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let http_response ?(status=200) ?(content_type="text/html; charset=utf-8") body =
|
||||
let status_text = match status with
|
||||
| 200 -> "OK" | 301 -> "Moved Permanently" | 304 -> "Not Modified"
|
||||
| 404 -> "Not Found" | 405 -> "Method Not Allowed"
|
||||
| 500 -> "Internal Server Error" | _ -> "Unknown"
|
||||
in
|
||||
Printf.sprintf "HTTP/1.1 %d %s\r\nContent-Type: %s\r\nContent-Length: %d\r\nConnection: keep-alive\r\n\r\n%s"
|
||||
status status_text content_type (String.length body) body
|
||||
|
||||
let _http_redirect url =
|
||||
Printf.sprintf "HTTP/1.1 301 Moved Permanently\r\nLocation: %s\r\nContent-Length: 0\r\nConnection: keep-alive\r\n\r\n" url
|
||||
|
||||
let parse_http_request data =
|
||||
match String.index_opt data '\r' with
|
||||
| None -> (match String.index_opt data '\n' with
|
||||
| None -> None
|
||||
| Some i -> let line = String.sub data 0 i in
|
||||
(match String.split_on_char ' ' line with
|
||||
| m :: p :: _ -> Some (m, p) | _ -> None))
|
||||
| Some i -> let line = String.sub data 0 i in
|
||||
(match String.split_on_char ' ' line with
|
||||
| m :: p :: _ -> Some (m, p) | _ -> None)
|
||||
|
||||
let url_decode s =
|
||||
let buf = Buffer.create (String.length s) in
|
||||
let i = ref 0 in
|
||||
while !i < String.length s do
|
||||
if s.[!i] = '%' && !i + 2 < String.length s then begin
|
||||
(try
|
||||
let hex = String.sub s (!i + 1) 2 in
|
||||
Buffer.add_char buf (Char.chr (int_of_string ("0x" ^ hex)))
|
||||
with _ -> Buffer.add_char buf s.[!i]);
|
||||
i := !i + 3
|
||||
end else begin
|
||||
Buffer.add_char buf s.[!i];
|
||||
i := !i + 1
|
||||
end
|
||||
done;
|
||||
Buffer.contents buf
|
||||
|
||||
(** Render a page from an SX URL path. Returns HTML or None. *)
|
||||
let http_render_page env path =
|
||||
let t0 = Unix.gettimeofday () in
|
||||
(* Parse the URL path to an SX expression *)
|
||||
let path_expr =
|
||||
if path = "/" || path = "/sx/" || path = "/sx" then "home"
|
||||
else begin
|
||||
let p = if String.length path > 4 && String.sub path 0 4 = "/sx/" then
|
||||
String.sub path 4 (String.length path - 4)
|
||||
else if String.length path > 1 && path.[0] = '/' then
|
||||
String.sub path 1 (String.length path - 1)
|
||||
else path
|
||||
in
|
||||
(* URL convention: dots → spaces *)
|
||||
String.map (fun c -> if c = '.' then ' ' else c) p
|
||||
end
|
||||
in
|
||||
(* Evaluate page function to get component call *)
|
||||
let page_ast =
|
||||
try
|
||||
let exprs = Sx_parser.parse_all path_expr in
|
||||
let expr = match exprs with [e] -> e | _ -> List exprs in
|
||||
Sx_ref.eval_expr expr (Env env)
|
||||
with e ->
|
||||
Printf.eprintf "[http-route] eval failed for '%s': %s\n%!" path_expr (Printexc.to_string e);
|
||||
Nil
|
||||
in
|
||||
if page_ast = Nil then None
|
||||
else begin
|
||||
(* Wrap: (~layouts/doc :path "/sx/..." content) → (~shared:layout/app-body :content wrapped) *)
|
||||
let nav_path = if String.length path >= 4 && String.sub path 0 4 = "/sx/" then path
|
||||
else "/sx" ^ path in
|
||||
let wrapped = List [
|
||||
Symbol "~layouts/doc"; Keyword "path"; String nav_path; page_ast
|
||||
] in
|
||||
let full_ast = List [
|
||||
Symbol "~shared:layout/app-body"; Keyword "content"; wrapped
|
||||
] in
|
||||
let page_source = serialize_value full_ast in
|
||||
let t1 = Unix.gettimeofday () in
|
||||
(* Phase 1: aser — expand all components server-side *)
|
||||
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
|
||||
ignore (env_bind env "expand-components?" expand_fn);
|
||||
let body_result =
|
||||
try
|
||||
let call = List [Symbol "aser"; List [Symbol "quote"; full_ast]; Env env] in
|
||||
Sx_ref.eval_expr call (Env env)
|
||||
with e ->
|
||||
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
||||
raise e
|
||||
in
|
||||
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
||||
let body_str = match body_result with
|
||||
| String s | SxExpr s -> s
|
||||
| _ -> serialize_value body_result
|
||||
in
|
||||
let t2 = Unix.gettimeofday () in
|
||||
(* Phase 2: SSR — render to HTML *)
|
||||
let body_html =
|
||||
try
|
||||
let body_exprs = Sx_parser.parse_all body_str in
|
||||
let body_expr = match body_exprs with
|
||||
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: body_exprs) in
|
||||
sx_render_to_html body_expr env
|
||||
with e ->
|
||||
Printf.eprintf "[http-ssr] failed: %s\n%!" (Printexc.to_string e); ""
|
||||
in
|
||||
let t3 = Unix.gettimeofday () in
|
||||
(* Phase 3: Shell — wrap in full HTML page.
|
||||
Shell kwargs reference pre-injected __shell-* vars from env. *)
|
||||
let get_shell_var name = try env_get env ("__shell-" ^ name) with _ -> Nil in
|
||||
let shell_args = [
|
||||
Keyword "title"; String "SX";
|
||||
Keyword "csrf"; String "";
|
||||
Keyword "page-sx"; String page_source;
|
||||
Keyword "body-html"; String body_html;
|
||||
Keyword "component-defs"; get_shell_var "component-defs";
|
||||
Keyword "component-hash"; get_shell_var "component-hash";
|
||||
Keyword "pages-sx"; get_shell_var "pages-sx";
|
||||
Keyword "sx-css"; get_shell_var "sx-css";
|
||||
Keyword "sx-css-classes"; get_shell_var "sx-css-classes";
|
||||
Keyword "asset-url"; get_shell_var "asset-url";
|
||||
Keyword "sx-js-hash"; get_shell_var "sx-js-hash";
|
||||
Keyword "body-js-hash"; get_shell_var "body-js-hash";
|
||||
Keyword "wasm-hash"; get_shell_var "wasm-hash";
|
||||
Keyword "head-scripts"; get_shell_var "head-scripts";
|
||||
Keyword "body-scripts"; get_shell_var "body-scripts";
|
||||
Keyword "inline-css"; get_shell_var "inline-css";
|
||||
Keyword "inline-head-js"; get_shell_var "inline-head-js";
|
||||
Keyword "init-sx"; get_shell_var "init-sx";
|
||||
Keyword "use-wasm"; Bool (try Sys.getenv "SX_USE_WASM" = "1" with Not_found -> false);
|
||||
Keyword "meta-html"; String "";
|
||||
] in
|
||||
let shell_call = List (Symbol "~shared:shell/sx-page-shell" :: shell_args) in
|
||||
let html = sx_render_to_html shell_call env in
|
||||
let t4 = Unix.gettimeofday () in
|
||||
Printf.eprintf "[sx-http] %s route=%.3fs aser=%.3fs ssr=%.3fs shell=%.3fs total=%.3fs html=%d\n%!"
|
||||
path (t1 -. t0) (t2 -. t1) (t3 -. t2) (t4 -. t3) (t4 -. t0) (String.length html);
|
||||
Some html
|
||||
end
|
||||
|
||||
(** Pre-compute shell statics and inject into env as __shell-* vars. *)
|
||||
let http_inject_shell_statics env =
|
||||
(* Component definitions for client *)
|
||||
let buf = Buffer.create 65536 in
|
||||
Hashtbl.iter (fun _sym v ->
|
||||
match v with
|
||||
| Component c ->
|
||||
let ps = String.concat " " (
|
||||
"&key" :: c.c_params @
|
||||
(if c.c_has_children then ["&rest"; "children"] else [])) in
|
||||
Buffer.add_string buf (Printf.sprintf "(defcomp ~%s (%s) %s)\n"
|
||||
c.c_name ps (serialize_value c.c_body))
|
||||
| Island i ->
|
||||
let ps = String.concat " " (
|
||||
"&key" :: i.i_params @
|
||||
(if i.i_has_children then ["&rest"; "children"] else [])) in
|
||||
Buffer.add_string buf (Printf.sprintf "(defisland ~%s (%s) %s)\n"
|
||||
i.i_name ps (serialize_value i.i_body))
|
||||
| _ -> ()
|
||||
) env.bindings;
|
||||
let component_defs = Buffer.contents buf in
|
||||
let component_hash = Digest.string component_defs |> Digest.to_hex in
|
||||
ignore (env_bind env "__shell-component-defs" (String component_defs));
|
||||
ignore (env_bind env "__shell-component-hash" (String component_hash));
|
||||
ignore (env_bind env "__shell-pages-sx" (String ""));
|
||||
ignore (env_bind env "__shell-sx-css" (String ""));
|
||||
ignore (env_bind env "__shell-sx-css-classes" (String ""));
|
||||
ignore (env_bind env "__shell-asset-url" (String "/static"));
|
||||
ignore (env_bind env "__shell-sx-js-hash" (String ""));
|
||||
ignore (env_bind env "__shell-body-js-hash" (String ""));
|
||||
ignore (env_bind env "__shell-wasm-hash" (String ""));
|
||||
ignore (env_bind env "__shell-head-scripts" Nil);
|
||||
ignore (env_bind env "__shell-body-scripts" Nil);
|
||||
ignore (env_bind env "__shell-inline-css" Nil);
|
||||
ignore (env_bind env "__shell-inline-head-js" Nil);
|
||||
ignore (env_bind env "__shell-init-sx" Nil);
|
||||
Printf.eprintf "[sx-http] Shell statics injected (defs=%d hash=%s)\n%!"
|
||||
(String.length component_defs) component_hash
|
||||
|
||||
let http_setup_declarative_stubs env =
|
||||
(* Stub declarative forms that are metadata-only — no-ops at render time. *)
|
||||
let noop name =
|
||||
ignore (env_bind env name (NativeFn (name, fun _args -> Nil))) in
|
||||
noop "define-module";
|
||||
noop "define-primitive";
|
||||
noop "deftype";
|
||||
noop "defeffect";
|
||||
noop "define-page-helper"
|
||||
|
||||
let http_setup_platform_constructors env =
|
||||
(* Platform constructor functions expected by evaluator.sx.
|
||||
The OCaml CEK evaluator handles lambda/component/etc as special forms
|
||||
natively, but when evaluator.sx's SX-level code processes these forms
|
||||
it calls make-lambda etc. by name. Bind them to the OCaml constructors. *)
|
||||
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
||||
bind "make-lambda" (fun args ->
|
||||
match args with
|
||||
| [params; body; env_val] -> Sx_types.make_lambda params body env_val
|
||||
| _ -> raise (Eval_error "make-lambda: expected (params body env)"));
|
||||
bind "make-component" (fun args ->
|
||||
match args with
|
||||
| [name; params; has_children; body; env_val; affinity] ->
|
||||
Sx_types.make_component name params has_children body env_val affinity
|
||||
| [name; params; has_children; body; env_val] ->
|
||||
Sx_types.make_component name params has_children body env_val (String "auto")
|
||||
| _ -> raise (Eval_error "make-component: expected (name params has-children body env [affinity])"));
|
||||
bind "make-island" (fun args ->
|
||||
match args with
|
||||
| [name; params; has_children; body; env_val] ->
|
||||
Sx_types.make_island name params has_children body env_val
|
||||
| _ -> raise (Eval_error "make-island: expected (name params has-children body env)"));
|
||||
bind "make-macro" (fun args ->
|
||||
match args with
|
||||
| [params; rest_param; body; closure; name] ->
|
||||
Sx_types.make_macro params rest_param body closure name
|
||||
| [params; body; Env _e] ->
|
||||
(* Simplified: no rest_param, no closure needed *)
|
||||
Sx_types.make_macro params Nil body Nil (String "anonymous")
|
||||
| _ -> raise (Eval_error "make-macro: expected (params rest-param body closure name)"));
|
||||
bind "make-thunk" (fun args ->
|
||||
match args with
|
||||
| [body; Env e] -> Thunk (body, e)
|
||||
| _ -> raise (Eval_error "make-thunk: expected (body env)"));
|
||||
bind "make-env" (fun args ->
|
||||
match args with
|
||||
| [] -> Env (make_env ())
|
||||
| [Env parent] -> Env { bindings = Hashtbl.create 8; parent = Some parent }
|
||||
| _ -> raise (Eval_error "make-env: expected () or (parent-env)"));
|
||||
(* Platform accessor functions — evaluator.sx expects these *)
|
||||
bind "lambda-name" (fun args -> match args with [v] -> Sx_types.lambda_name v | _ -> Nil);
|
||||
bind "lambda-params" (fun args -> match args with [v] -> Sx_types.lambda_params v | _ -> Nil);
|
||||
bind "lambda-body" (fun args -> match args with [v] -> Sx_types.lambda_body v | _ -> Nil);
|
||||
bind "lambda-closure" (fun args -> match args with [v] -> Sx_types.lambda_closure v | _ -> Nil);
|
||||
bind "set-lambda-name!" (fun args -> match args with [l; n] -> ignore (Sx_runtime.set_lambda_name l n); l | _ -> Nil);
|
||||
bind "env-has?" (fun args ->
|
||||
match args with [Env e; String k] | [Env e; Symbol k] -> Bool (env_has e k) | _ -> Bool false);
|
||||
bind "env-get" (fun args ->
|
||||
match args with [Env e; String k] | [Env e; Symbol k] -> (try env_get e k with _ -> Nil) | _ -> Nil);
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] | [Env e; Symbol k; v] -> ignore (env_bind e k v); Nil
|
||||
| _ -> Nil);
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] | [Env e; Symbol k; v] -> ignore (env_bind e k v); Nil
|
||||
| _ -> Nil);
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env parent] -> Env { bindings = Hashtbl.create 8; parent = Some parent }
|
||||
| _ -> Env (make_env ()));
|
||||
bind "env-keys" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> List (Hashtbl.fold (fun k _v acc -> String (Sx_types.unintern k) :: acc) e.bindings [])
|
||||
| _ -> List [])
|
||||
|
||||
let http_load_files env files =
|
||||
(* Like cli_load_files but tolerant — logs errors, doesn't crash *)
|
||||
List.iter (fun path ->
|
||||
if Sys.file_exists path then begin
|
||||
try
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
List.iter (fun expr ->
|
||||
try ignore (Sx_ref.eval_expr expr (Env env))
|
||||
with e -> Printf.eprintf "[http-load] %s: %s\n%!" (Filename.basename path) (Printexc.to_string e)
|
||||
) exprs
|
||||
with e -> Printf.eprintf "[http-load] parse error %s: %s\n%!" path (Printexc.to_string e)
|
||||
end
|
||||
) files;
|
||||
rebind_host_extensions env
|
||||
|
||||
let http_setup_page_helpers env =
|
||||
(* Page helpers that Python normally provides. Minimal stubs for HTTP mode. *)
|
||||
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
||||
(* highlight — passthrough without syntax coloring *)
|
||||
bind "highlight" (fun args ->
|
||||
match args with
|
||||
| String code :: _ ->
|
||||
let escaped = escape_sx_string code in
|
||||
SxExpr (Printf.sprintf "(pre :class \"text-sm overflow-x-auto\" (code \"%s\"))" escaped)
|
||||
| _ -> Nil);
|
||||
(* component-source — stub *)
|
||||
bind "component-source" (fun _args -> String "")
|
||||
|
||||
let http_mode port =
|
||||
let env = make_server_env () in
|
||||
(* Stub declarative metadata forms — no-ops at render time *)
|
||||
http_setup_declarative_stubs env;
|
||||
(* Platform constructors expected by evaluator.sx *)
|
||||
http_setup_platform_constructors env;
|
||||
(* Page helpers *)
|
||||
http_setup_page_helpers env;
|
||||
(* Load all .sx files *)
|
||||
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
||||
try Sys.getenv "SX_ROOT" with Not_found ->
|
||||
if Sys.file_exists "/app/spec" then "/app" else Sys.getcwd () in
|
||||
let spec_base = try Sys.getenv "SX_SPEC_DIR" with Not_found ->
|
||||
project_dir ^ "/spec" in
|
||||
let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found ->
|
||||
project_dir ^ "/lib" in
|
||||
let web_base = try Sys.getenv "SX_WEB_DIR" with Not_found ->
|
||||
project_dir ^ "/web" in
|
||||
let shared_sx = project_dir ^ "/shared/sx/templates" in
|
||||
let sx_sx = project_dir ^ "/sx/sx" in
|
||||
let t0 = Unix.gettimeofday () in
|
||||
(* Core spec + adapters.
|
||||
Skip primitives.sx (declarative metadata — all prims are native in OCaml)
|
||||
and types.sx (gradual type system — not needed for rendering). *)
|
||||
let core_files = [
|
||||
spec_base ^ "/parser.sx";
|
||||
spec_base ^ "/render.sx"; spec_base ^ "/evaluator.sx";
|
||||
web_base ^ "/adapter-html.sx"; web_base ^ "/adapter-sx.sx";
|
||||
web_base ^ "/web-forms.sx";
|
||||
] in
|
||||
http_load_files env core_files;
|
||||
(* Libraries *)
|
||||
(* Files to skip — declarative metadata, not needed for rendering *)
|
||||
let skip_files = ["primitives.sx"; "types.sx"; "boundary.sx";
|
||||
"harness.sx"; "eval-rules.sx"] in
|
||||
let load_dir dir =
|
||||
if Sys.file_exists dir && Sys.is_directory dir then begin
|
||||
let files = Sys.readdir dir in
|
||||
Array.sort String.compare files;
|
||||
Array.iter (fun f ->
|
||||
if Filename.check_suffix f ".sx"
|
||||
&& not (List.mem f skip_files)
|
||||
&& not (Filename.check_suffix f ".test.sx") then
|
||||
http_load_files env [dir ^ "/" ^ f]
|
||||
) files
|
||||
end
|
||||
in
|
||||
load_dir lib_base;
|
||||
load_dir shared_sx;
|
||||
load_dir sx_sx;
|
||||
let t1 = Unix.gettimeofday () in
|
||||
Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0);
|
||||
(* Inject shell statics *)
|
||||
http_inject_shell_statics env;
|
||||
(* Start TCP server *)
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
||||
Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_any, port));
|
||||
Unix.listen sock 128;
|
||||
Printf.eprintf "[sx-http] Listening on port %d (project=%s)\n%!" port project_dir;
|
||||
while true do
|
||||
let (client, _addr) = Unix.accept sock in
|
||||
let buf = Bytes.create 8192 in
|
||||
let n = try Unix.read client buf 0 8192 with _ -> 0 in
|
||||
if n > 0 then begin
|
||||
let data = Bytes.sub_string buf 0 n in
|
||||
let response =
|
||||
try
|
||||
match parse_http_request data with
|
||||
| None -> http_response ~status:400 "Bad Request"
|
||||
| Some (method_, raw_path) ->
|
||||
if method_ <> "GET" && method_ <> "HEAD" then
|
||||
http_response ~status:405 "Method Not Allowed"
|
||||
else begin
|
||||
let path = url_decode raw_path in
|
||||
let is_sx = path = "/" || path = "/sx/" || path = "/sx"
|
||||
|| (String.length path > 4 && String.sub path 0 4 = "/sx/") in
|
||||
if is_sx then
|
||||
match http_render_page env path with
|
||||
| Some html -> http_response html
|
||||
| None -> http_response ~status:404 "<h1>Not Found</h1>"
|
||||
else
|
||||
http_response ~status:404 "<h1>Not Found</h1>"
|
||||
end
|
||||
with e ->
|
||||
Printf.eprintf "[sx-http] Error: %s\n%!" (Printexc.to_string e);
|
||||
http_response ~status:500 "<h1>Internal Server Error</h1>"
|
||||
in
|
||||
let resp_bytes = Bytes.of_string response in
|
||||
let total = Bytes.length resp_bytes in
|
||||
let written = ref 0 in
|
||||
(try
|
||||
while !written < total do
|
||||
let n = Unix.write client resp_bytes !written (total - !written) in
|
||||
written := !written + n
|
||||
done
|
||||
with Unix.Unix_error _ -> ());
|
||||
end;
|
||||
(try Unix.close client with _ -> ())
|
||||
done
|
||||
|
||||
|
||||
let () =
|
||||
(* Check for CLI mode flags *)
|
||||
let args = Array.to_list Sys.argv in
|
||||
@@ -1398,6 +1788,16 @@ let () =
|
||||
else if List.mem "--render" args then cli_mode "render"
|
||||
else if List.mem "--aser-slot" args then cli_mode "aser-slot"
|
||||
else if List.mem "--aser" args then cli_mode "aser"
|
||||
else if List.mem "--http" args then begin
|
||||
(* Extract port: --http PORT *)
|
||||
let port = ref 8014 in
|
||||
let rec find = function
|
||||
| "--http" :: p :: _ -> (try port := int_of_string p with _ -> ())
|
||||
| _ :: rest -> find rest
|
||||
| [] -> ()
|
||||
in find args;
|
||||
http_mode !port
|
||||
end
|
||||
else begin
|
||||
(* Normal persistent server mode *)
|
||||
let env = make_server_env () in
|
||||
|
||||
File diff suppressed because one or more lines are too long
328
lib/highlight.sx
Normal file
328
lib/highlight.sx
Normal file
@@ -0,0 +1,328 @@
|
||||
(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)
|
||||
(let
|
||||
((result "") (i 0) (len (string-length s)))
|
||||
(let
|
||||
loop
|
||||
()
|
||||
(when
|
||||
(< i len)
|
||||
(let
|
||||
((c (substring s i (+ i 1))))
|
||||
(set!
|
||||
result
|
||||
(str
|
||||
result
|
||||
(if
|
||||
(= c "\\")
|
||||
"\\\\"
|
||||
(if
|
||||
(= c "\"")
|
||||
"\\\""
|
||||
(if
|
||||
(= c "\n")
|
||||
"\\n"
|
||||
(if (= c "\t") "\\t" (if (= c "\r") "\\r" c)))))))
|
||||
(set! i (+ i 1))
|
||||
(loop))))
|
||||
result)))
|
||||
|
||||
(define
|
||||
hl-span
|
||||
(fn
|
||||
(class text)
|
||||
(if
|
||||
(= class "")
|
||||
(str "(span \"" (hl-escape text) "\")")
|
||||
(str "(span :class \"" class "\" \"" (hl-escape text) "\")"))))
|
||||
|
||||
(define
|
||||
tokenize-sx
|
||||
(fn
|
||||
(code)
|
||||
(let
|
||||
((tokens (list)) (i 0) (len (string-length code)))
|
||||
(let
|
||||
loop
|
||||
()
|
||||
(when
|
||||
(< i len)
|
||||
(let
|
||||
((c (substring code i (+ i 1))))
|
||||
(if
|
||||
(= c ";")
|
||||
(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))))))
|
||||
(if
|
||||
(= 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 "keyword" (substring code start i))))))
|
||||
(if
|
||||
(= c "~")
|
||||
(let
|
||||
((start i))
|
||||
(set! i (+ i 1))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(let
|
||||
((x (substring code i (+ i 1))))
|
||||
(or (hl-sym-char? x) (= x "/"))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(list (list "component" (substring code start i))))))
|
||||
(if
|
||||
(or
|
||||
(= c "(")
|
||||
(= c ")")
|
||||
(= c "[")
|
||||
(= c "]")
|
||||
(= c "{")
|
||||
(= c "}"))
|
||||
(do
|
||||
(set!
|
||||
tokens
|
||||
(append tokens (list (list "paren" c))))
|
||||
(set! i (+ i 1)))
|
||||
(if
|
||||
(hl-digit? c)
|
||||
(let
|
||||
((start i))
|
||||
(let
|
||||
scan
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< i len)
|
||||
(let
|
||||
((x (substring code i (+ i 1))))
|
||||
(or (hl-digit? x) (= x "."))))
|
||||
(set! i (+ i 1))
|
||||
(scan)))
|
||||
(set!
|
||||
tokens
|
||||
(append
|
||||
tokens
|
||||
(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
|
||||
(tokens)
|
||||
(let
|
||||
((parts (map (fn (tok) (let ((kind (first tok)) (text (first (rest tok)))) (hl-span (get sx-token-classes kind "") text))) tokens)))
|
||||
(str "(<> " (join " " parts) ")"))))
|
||||
|
||||
(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)
|
||||
(str
|
||||
"(pre :class \"text-sm overflow-x-auto\" (code \""
|
||||
(hl-escape code)
|
||||
"\"))"))))
|
||||
Reference in New Issue
Block a user