From 0d5770729f240ba975ef1835d4f1c83a11901430 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 28 Mar 2026 16:15:58 +0000 Subject: [PATCH] sx-host step 3: HTTP server mode + define shorthand + SX highlighter MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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) --- hosts/ocaml/bin/sx_http.ml | 464 +++++++++++++++++++++++++++++++++++ hosts/ocaml/bin/sx_server.ml | 400 ++++++++++++++++++++++++++++++ hosts/ocaml/lib/sx_ref.ml | 9 +- lib/highlight.sx | 328 +++++++++++++++++++++++++ 4 files changed, 1200 insertions(+), 1 deletion(-) create mode 100644 hosts/ocaml/bin/sx_http.ml create mode 100644 lib/highlight.sx diff --git a/hosts/ocaml/bin/sx_http.ml b/hosts/ocaml/bin/sx_http.ml new file mode 100644 index 00000000..4cbf57fd --- /dev/null +++ b/hosts/ocaml/bin/sx_http.ml @@ -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 "

404 Not Found

" + else + http_response ~status:404 "

404 Not Found

" + 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 "

500 Internal Server Error

" + 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 diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 66ff6612..5b671e50 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -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 "

Not Found

" + else + http_response ~status:404 "

Not Found

" + end + with e -> + Printf.eprintf "[sx-http] Error: %s\n%!" (Printexc.to_string e); + http_response ~status:500 "

Internal Server Error

" + 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 diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index bec6d95b..e3007750 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -385,7 +385,14 @@ and step_eval state = (* step-eval-list *) and step_eval_list expr env kont = - (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (if sx_truthy ((prim_call "=" [name; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "define")])) then (step_sf_define (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) + (let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((let _or = (prim_call "=" [(type_of (head)); (String "symbol")]) in if sx_truthy _or then _or else (let _or = (prim_call "=" [(type_of (head)); (String "lambda")]) in if sx_truthy _or then _or else (prim_call "=" [(type_of (head)); (String "list")])))))))) then (if sx_truthy ((empty_p (expr))) then (make_cek_value ((List [])) (env) (kont)) else (make_cek_state ((first (expr))) (env) ((kont_push ((make_map_frame (Nil) ((rest (expr))) ((List [])) (env))) (kont))))) else (if sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])) then (let name = (symbol_name (head)) in (if sx_truthy ((prim_call "=" [name; (String "if")])) then (step_sf_if (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (step_sf_when (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (step_sf_cond (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (step_sf_case (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "and")])) then (step_sf_and (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "or")])) then (step_sf_or (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "let")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "let*")])) then (step_sf_let (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "lambda")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "fn")])) then (step_sf_lambda (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "define")])) then ( + (* Desugar (define (name args...) body...) → (define name (fn (args...) body...)) *) + match args with + | List (List (Symbol fname :: fparams) :: body) | ListRef { contents = List (Symbol fname :: fparams) :: body } -> + let fn_form = List [Symbol "fn"; List fparams; (match body with [b] -> b | _ -> List (Symbol "do" :: body))] in + step_sf_define (List [Symbol fname; fn_form]) (env) (kont) + | _ -> step_sf_define (args) (env) (kont) +) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (make_cek_value ((sf_defcomp (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (make_cek_value ((sf_defisland (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (make_cek_value ((sf_defmacro (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (step_sf_begin (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "quote")])) then (make_cek_value ((if sx_truthy ((empty_p (args))) then Nil else (first (args)))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "quasiquote")])) then (make_cek_value ((qq_expand ((first (args))) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (step_sf_thread_first (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (step_sf_set_b (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (step_sf_letrec (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reset")])) then (step_sf_reset (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "shift")])) then (step_sf_shift (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "deref")])) then (step_sf_deref (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "scope")])) then (step_sf_scope (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "provide")])) then (step_sf_provide (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "context")])) then (step_sf_context (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emit!")])) then (step_sf_emit (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "emitted")])) then (step_sf_emitted (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "dynamic-wind")])) then (make_cek_value ((sf_dynamic_wind (args) (env))) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map")])) then (step_ho_map (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "map-indexed")])) then (step_ho_map_indexed (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "filter")])) then (step_ho_filter (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "reduce")])) then (step_ho_reduce (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "some")])) then (step_ho_some (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "every?")])) then (step_ho_every (args) (env) (kont)) else (if sx_truthy ((prim_call "=" [name; (String "for-each")])) then (step_ho_for_each (args) (env) (kont)) else (if sx_truthy ((prim_call "has-key?" [custom_special_forms; name])) then (make_cek_value ((cek_call ((get (custom_special_forms) (name))) (List [args; env]))) (env) (kont)) else (if sx_truthy ((let _and = (env_has (env) (name)) in if not (sx_truthy _and) then _and else (is_macro ((env_get (env) (name)))))) then (let mac = (env_get (env) (name)) in (make_cek_state ((expand_macro (mac) (args) (env))) (env) (kont))) else (if sx_truthy ((let _and = render_check in if not (sx_truthy _and) then _and else (cek_call (render_check) (List [expr; env])))) then (make_cek_value ((cek_call (render_fn) (List [expr; env]))) (env) (kont)) else (step_eval_call (head) (args) (env) (kont))))))))))))))))))))))))))))))))))))))))))) else (step_eval_call (head) (args) (env) (kont))))) (* step-sf-if *) and step_sf_if args env kont = diff --git a/lib/highlight.sx b/lib/highlight.sx new file mode 100644 index 00000000..2c2de272 --- /dev/null +++ b/lib/highlight.sx @@ -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) + "\"))"))))