Compare commits
562 Commits
9b4f735a0e
...
architectu
| Author | SHA1 | Date | |
|---|---|---|---|
| 75130876c7 | |||
| d3ff4f7ef3 | |||
| 577d09f443 | |||
| 3a9d113537 | |||
| 022c4f7f26 | |||
| cf088a33b4 | |||
| 770c7fd821 | |||
| f5da2bcfd5 | |||
| 9a57bd5beb | |||
| c5d2fa8c96 | |||
| f1ba7177e7 | |||
| 4cd0e77331 | |||
| 3336c4e957 | |||
| 9552750c4f | |||
| 5d88b363e4 | |||
| 516f9c7186 | |||
| 67ae88b87f | |||
| 1d68f20a37 | |||
| 7f772e0f23 | |||
| b61b437ccd | |||
| 000f285ae8 | |||
| 4082561438 | |||
| fb30351be2 | |||
| a74c983615 | |||
| 2cf4c73ab3 | |||
| c4dd125210 | |||
| fb7338c022 | |||
| 0e311f0c7d | |||
| fb262aa49b | |||
| 44b520a9e9 | |||
| a965731a33 | |||
| 98fd315f14 | |||
| b3e9ebee1d | |||
| b8f389ac9b | |||
| 244c669334 | |||
| 107c1b8b97 | |||
| 499f728a36 | |||
| 143a2ebefe | |||
| 5df21fca36 | |||
| 6e216038ba | |||
| 191981a22b | |||
| e84f5cc1f5 | |||
| 6fe3476e18 | |||
| 5ac1ca9756 | |||
| b0a4be0f22 | |||
| 2f3e727a6f | |||
| f4f8715d06 | |||
| 9b060ef8c5 | |||
| c0665ba58e | |||
| aee4770a6a | |||
| 4baed1853c | |||
| 2727577702 | |||
| efd0d9168f | |||
| 653be79c8d | |||
| 9607f3c44a | |||
| cd414b96a7 | |||
| f814193c94 | |||
| e46cdf3d4d | |||
| 54ee673050 | |||
| cd61c049e3 | |||
| df89d8249b | |||
| fc2b5e502f | |||
| 7b4c918773 | |||
| ac772ac357 | |||
| 6008a1be30 | |||
| 2d7dd7d582 | |||
| 397d0f39c0 | |||
| 5f72801901 | |||
| b6f304e91a | |||
| 9257b6a2d8 | |||
| cfc697821f | |||
| 19e7a6ee2d | |||
| 1dd4c87d64 | |||
| 9b8a8dd272 | |||
| af63d49451 | |||
| 5390df7b0b | |||
| 36acb56a3a | |||
| 38556af423 | |||
| 033b2cb304 | |||
| 2e329f273a | |||
| 5f5e9379d4 | |||
| 8e5cf2a5d5 | |||
| a79caed27b | |||
| 41e76b886f | |||
| bd8d62cd9a | |||
| be47a5c1a5 | |||
| e33fbd29e7 | |||
| db1f7f1bfb | |||
| 1498cc2bdb | |||
| 21ad052272 | |||
| 508a0017a7 | |||
| 3c419501e1 | |||
| d4244b47bf | |||
| 67c4a6a14d | |||
| ede05c26f5 | |||
| 17b6c872f2 | |||
| 9dd90eba7f | |||
| 869f49bc01 | |||
| 6d5c410d68 | |||
| 14d5158b06 | |||
| d9803cafee | |||
| a64b693a09 | |||
| 670295bf01 | |||
| 1098dd3794 | |||
| c578dedbcc | |||
| b6e144a6fd | |||
| bea8779aea | |||
| 547d271571 | |||
| b13962e8dd | |||
| 9a64f13dc6 | |||
| 1dd7c22201 | |||
| 58a122a73a | |||
| 14388913c9 | |||
| 4ef05f1a4e | |||
| 7a002bf2ab | |||
| 6ed89c6a78 | |||
| d40a9c6796 | |||
| 9ed1100ef6 | |||
| 8ab7e367d8 | |||
| dea1879e27 | |||
| 92a59eba9d | |||
| c430ef8110 | |||
| 3aa6695c69 | |||
| e44a689783 | |||
| 7651260fc7 | |||
| 90a2eaaf7a | |||
| 9594362427 | |||
| 45c2f2bfb0 | |||
| d627746147 | |||
| 6e885f49b6 | |||
| b3718c06d0 | |||
| 683e334546 | |||
| 235d73d837 | |||
| 13eb701518 | |||
| 33350ced6d | |||
| 0019f8e56a | |||
| f66195ce18 | |||
| d2f4ab71d1 | |||
| f857b3eddb | |||
| 909ec6e145 | |||
| cbd5ad0a52 | |||
| fb9fe45f71 | |||
| e468ca4ef7 | |||
| 5ab45c969c | |||
| 714538f1b4 | |||
| 204e527f31 | |||
| 601ee7d8ab | |||
| b9d30749f7 | |||
| aa508bad77 | |||
| f5f58ea47e | |||
| d1b49db057 | |||
| 84938a1f94 | |||
| a5c6d947fd | |||
| c1c073f26f | |||
| bdb54d5919 | |||
| 3d8e3363ce | |||
| 824f06d3b7 | |||
| 52c8af66b9 | |||
| 92688215de | |||
| 32001d03eb | |||
| 678d96e1ea | |||
| 5c2fc9b9c0 | |||
| 87a48ac2aa | |||
| a0f4ff02a1 | |||
| 21c3e951ec | |||
| 775ab301f6 | |||
| 86c67e5955 | |||
| 46f77c3b1e | |||
| cd9ebc0cd8 | |||
| ffead559a4 | |||
| 584445a843 | |||
| 9f097026f8 | |||
| 4ea43e3659 | |||
| 8027f51ef3 | |||
| 174260df93 | |||
| 461fae269b | |||
| fe6115f2fc | |||
| f8bc1fd12a | |||
| 9bd03bc26b | |||
| 464c767a19 | |||
| c0ded3facb | |||
| b19f5436f6 | |||
| ba6c5de6e7 | |||
| 833415b170 | |||
| b62dfb25e5 | |||
| 609be68c9c | |||
| 75827b4828 | |||
| 83b4afcd7a | |||
| fde376a7dd | |||
| 3d6f43260b | |||
| e7fe6598c5 | |||
| fcb7e2ccaf | |||
| 3598a34e3d | |||
| a2348e5281 | |||
| 9dd27a328b | |||
| 28273eb740 | |||
| 9742d0236e | |||
| 6550e9b2e4 | |||
| 4eeb7777aa | |||
| 200e5d5e47 | |||
| a7efcaf679 | |||
| 4cb4551753 | |||
| 42aa6b1e67 | |||
| c6e7ce9596 | |||
| 8fd01c2ab0 | |||
| 521782d579 | |||
| e1770499df | |||
| e2b29fb9f3 | |||
| 128dbe1b25 | |||
| b423ebcea9 | |||
| c55f6f9c4b | |||
| d9aa19cfe9 | |||
| 1b13872369 | |||
| d26029fee2 | |||
| 141a351acc | |||
| 9cf67e7354 | |||
| f828fb023b | |||
| 465ce1abcb | |||
| 9ce8659f74 | |||
| 5abc947ac7 | |||
| d81a518732 | |||
| 5b55b75a9a | |||
| 80931e4972 | |||
| 408eca1cb0 | |||
| b274e428eb | |||
| 03c2115f0d | |||
| e14947cedc | |||
| fffb5ab0b5 | |||
| 951b3a6586 | |||
| a24efc1a00 | |||
| 1985c648eb | |||
| 7a4a6c8a85 | |||
| 671d19c978 | |||
| 847d04d4ba | |||
| 6845ced98f | |||
| e8d6aa1198 | |||
| 5c30dcd82c | |||
| 9af38a8fbe | |||
| 501934f9c6 | |||
| 0d9e37f33c | |||
| 702074eaa9 | |||
| 07f5d03ac1 | |||
| a38b5a9b44 | |||
| 4e89b9a66b | |||
| 3e1727004c | |||
| 85f72af74b | |||
| b4107fa52b | |||
| 97e711a80d | |||
| e41f918765 | |||
| 74bab85139 | |||
| edf3354050 | |||
| 1ad90ed23d | |||
| f978792e62 | |||
| 62d8602de4 | |||
| 7ea4c3a652 | |||
| 4ab8e17d9b | |||
| 4dde8ba684 | |||
| 6a4b2d9a33 | |||
| 98f74149b2 | |||
| 9057f5a42e | |||
| 6134bd2ea5 | |||
| ef34122a25 | |||
| 84a48f0de3 | |||
| 20b3dfb8a0 | |||
| aa4c911178 | |||
| ea52f567de | |||
| 8bba02fbc9 | |||
| 394c86b474 | |||
| 5c8b05a66f | |||
| a9a0a23437 | |||
| d0c03a7648 | |||
| e1ef883339 | |||
| 015781313c | |||
| 1c9622d940 | |||
| f3a437ee87 | |||
| b708b210eb | |||
| 58d6a6de07 | |||
| 1bbecad861 | |||
| 30785c92c0 | |||
| 4294ee3d94 | |||
| f3e516feec | |||
| 6a22699587 | |||
| aea9231e0a | |||
| dc5da2f5ed | |||
| 31ae9b5110 | |||
| 900de713c3 | |||
| 39eb217c15 | |||
| 303fc5c319 | |||
| f1d08bbbe9 | |||
| 10037a0b04 | |||
| e756ff847f | |||
| f905ff287c | |||
| c794e33dda | |||
| 2ae42d3898 | |||
| c8301c5947 | |||
| 7108b01e37 | |||
| abca040a5d | |||
| 1412648f6e | |||
| 3620a433c1 | |||
| 8e1870246d | |||
| 8105064e82 | |||
| 1d064a1914 | |||
| 9fc13efa1a | |||
| 0d5770729f | |||
| 90918fb2b1 | |||
| 153f02c672 | |||
| 27fd470ac8 | |||
| 95df738bdc | |||
| 9ac2e38c24 | |||
| 0cae1fbb6b | |||
| 919ce927b1 | |||
| 07fabeb4ed | |||
| f0d8db9b68 | |||
| 07d1603b2c | |||
| 77a80e0640 | |||
| 91185ff520 | |||
| 17b2df108e | |||
| 70d03eca18 | |||
| 83c2e23fd1 | |||
| e6d7a08f8c | |||
| e0070041d6 | |||
| 8d3ab040ef | |||
| 553bbf123e | |||
| 2ee4d4324a | |||
| 31af9a5ca3 | |||
| dab81fc571 | |||
| 0699de0144 | |||
| 3e6898197d | |||
| c923a34fa8 | |||
| 00de248ee9 | |||
| cb7bbc9557 | |||
| 2802dd99e2 | |||
| f33eaf8f3a | |||
| 226c01bbf6 | |||
| c72a5af04d | |||
| 10576f86d1 | |||
| 589507392c | |||
| 6e698ae9f8 | |||
| 96d0d29f10 | |||
| 5a5521f21f | |||
| 36ba3eb298 | |||
| 3b4156c722 | |||
| c0c6787189 | |||
| 6f1810dc4e | |||
| 91d5de0554 | |||
| c04f3ab7ce | |||
| 3ac8cb48f3 | |||
| 4bb4d47d63 | |||
| 5ed984e7e3 | |||
| 4e88b8a9dd | |||
| 6e2696ca20 | |||
| dc72aac5b1 | |||
| b98e5b83de | |||
| 11f0098006 | |||
| 2bfae33659 | |||
| 9e079c9c19 | |||
| 9ce40bdc4f | |||
| 2a1d3a34e7 | |||
| 296ba4cd57 | |||
| 4853513599 | |||
| b53a0fabea | |||
| 7a8a166326 | |||
| 5754a9ff9f | |||
| fea44f9fcc | |||
| 4fa0850c01 | |||
| b104663481 | |||
| b1690a92c4 | |||
| 4b733e71b0 | |||
| f7cf5dbd47 | |||
| d8161050a8 | |||
| 250bee69c7 | |||
| 6806343d0e | |||
| 7047a5d7f3 | |||
| 76ce0c3ecb | |||
| 68c05dcd28 | |||
| 85702e92c9 | |||
| 8c99ec4fac | |||
| 3559ce44f2 | |||
| 63babc0d2d | |||
| 6d0e512f19 | |||
| 934604c2bd | |||
| 6f96452f70 | |||
| 739d04672b | |||
| c18f46278f | |||
| 1777f631a5 | |||
| 9f0c541872 | |||
| c62e7319cf | |||
| effa767b09 | |||
| 43cf590541 | |||
| 57e7ce9fe4 | |||
| 2775ce935b | |||
| 3e80f371da | |||
| 296729049e | |||
| 31ed8b20f4 | |||
| 27059c0581 | |||
| 5ca6952217 | |||
| 8aecbcc094 | |||
| ebbdec8f4c | |||
| f0f16d24bc | |||
| fb8dbeba9f | |||
| 0c8c0b6426 | |||
| 1a3ee40e0d | |||
| 759309c5c4 | |||
| 998536f52d | |||
| 1e42eb62a2 | |||
| eacde62806 | |||
| 07bbcaf1bb | |||
| 68fcdd6cc0 | |||
| d12f38a9d5 | |||
| aa1d4d7a67 | |||
| 5aea9d2678 | |||
| cf130c4174 | |||
| 99e2009c2b | |||
| 7b3d763291 | |||
| 1ae5906ff6 | |||
| 4dfaf09e04 | |||
| b174a57c9c | |||
| 0fce6934cb | |||
| 7d7de86034 | |||
| 858275dff9 | |||
| f3f70cc00b | |||
| 50871780a3 | |||
| 57cffb8bcc | |||
| eb4233ff36 | |||
| 5b2ef0a2af | |||
| 32df71abd4 | |||
| 91cf39153b | |||
| 953f0ec744 | |||
| 13ba5ee423 | |||
| a6e0e84521 | |||
| 3ae49b69f5 | |||
| 2d8741779e | |||
| 945b4c1dd7 | |||
| 33af6b9266 | |||
| c8280e156f | |||
| 732d733eac | |||
| 3df8c41ca1 | |||
| 6ef9688bd2 | |||
| f9f810ffd7 | |||
| e887c0d978 | |||
| 7434de53a6 | |||
| d735e28b39 | |||
| 482bc0ca5e | |||
| aa88c06c00 | |||
| ee868f686b | |||
| 96f2862385 | |||
| 26e16f6aa4 | |||
| 9caf8b6e94 | |||
| 8e6e7dce43 | |||
| bc7da977a0 | |||
| efb2d92b99 | |||
| 89543e0152 | |||
| 0c7567925e | |||
| 2a9a4b41bd | |||
| 8a08de26cd | |||
| 8ccf5f7c1e | |||
| bf305deae1 | |||
| e021184935 | |||
| 55061d6451 | |||
| ce9c5d3a08 | |||
| 49fd4a51d6 | |||
| 7d793ec76c | |||
| e4cabcbb59 | |||
| 284572c7a9 | |||
| 70a58bddd8 | |||
| 23c8b97cb1 | |||
| 5270d2e956 | |||
| dd057247a5 | |||
| 8958714c85 | |||
| 30cfbf777a | |||
| ffe849df8e | |||
| 49b03b246d | |||
| 33a02c8fe1 | |||
| a823e59376 | |||
| 96f50b9dfa | |||
| 890c472893 | |||
| 5cfeed81c1 | |||
| 2727a2ed8c | |||
| 6e804bbb5c | |||
| c4224925f9 | |||
| fe84b57bed | |||
| 5b370b69e3 | |||
| 639a6a2a53 | |||
| 3cce3df5b0 | |||
| 9ff913c312 | |||
| b1de591e9e | |||
| 364fbac9e1 | |||
| 8f2a51af9d | |||
| fa700e0202 | |||
| f4610e1799 | |||
| f3c0cbd8e2 | |||
| 6e1d28d1d7 | |||
| 2c8afd230d | |||
| 92bfef6406 | |||
| 894321db18 | |||
| 9bd4863ce1 | |||
| 2a5ef0ea09 | |||
| 1cc3e761a2 | |||
| e12b2eab6b | |||
| 09feb51762 | |||
| 4734d38f3b | |||
| a716e3f745 | |||
| 318c818728 | |||
| 7628659854 | |||
| bb34b4948b | |||
| df461beec2 | |||
| 6d73edf297 | |||
| 373a4f0134 | |||
| ae0e87fbf8 | |||
| 8dd3eaa1d9 | |||
| e6663a74ba | |||
| 231bfbecb5 | |||
| df256b5607 | |||
| 0ce23521b7 | |||
| c79aa880af | |||
| f12bbae6c9 | |||
| c8c4b322a9 | |||
| e7da397f8e | |||
| 1bb40415a8 | |||
| a62b7c8a5e | |||
| ceb2adfe50 | |||
| 5ca2ee92bc | |||
| e14fc9b0e1 | |||
| a8d1163aa6 | |||
| c8533181ab | |||
| 40d0f1a438 | |||
| d9e80d8544 | |||
| c16142d14c | |||
| 8707f21ca2 | |||
| 96e7bbbac1 | |||
| d3b3b4b720 | |||
| f819fda587 | |||
| d06de87bca | |||
| 109ca7c70b | |||
| 171c18d3be | |||
| 1c91680e63 | |||
| e61dc4974b | |||
| 8373c6cf16 | |||
| fac97883f9 | |||
| 71c2003a60 | |||
| 5b6e883e6d | |||
| 2203f56849 | |||
| ecbe670a6a | |||
| f9e65e1d17 | |||
| 4c54843542 | |||
| f7e4e3d762 | |||
| 4308591982 | |||
| 4ce4762237 | |||
| 06666ac8c4 | |||
| 5ab3ecb7e0 | |||
| 313f7d6be1 | |||
| 16fa813d6d | |||
| 818e5d53f0 | |||
| 3a268e7277 | |||
| bdbf594bc8 | |||
| a1fa1edf8a | |||
| 2ef3f03db3 | |||
| 9f32c8cf0d | |||
| 719da7914e | |||
| c6a662c980 | |||
| e475222099 | |||
| b4df216fae |
27
.claude/agents/explore.md
Normal file
27
.claude/agents/explore.md
Normal file
@@ -0,0 +1,27 @@
|
||||
---
|
||||
name: explore
|
||||
description: Explore codebase using sx-tree MCP tools for .sx files
|
||||
tools: Read, Grep, Glob, Bash, mcp__sx-tree__sx_summarise, mcp__sx-tree__sx_read_tree, mcp__sx-tree__sx_read_subtree, mcp__sx-tree__sx_find_all, mcp__sx-tree__sx_get_context, mcp__sx-tree__sx_get_siblings, mcp__sx-tree__sx_validate
|
||||
hooks:
|
||||
PreToolUse:
|
||||
- matcher: "Read"
|
||||
hooks:
|
||||
- type: command
|
||||
command: "bash .claude/hooks/block-sx-edit.sh"
|
||||
---
|
||||
|
||||
Fast codebase exploration agent. Use for finding files, searching code, and answering questions about the codebase.
|
||||
|
||||
## Critical rule for .sx and .sxc files
|
||||
|
||||
NEVER use Read on .sx or .sxc files. The hook will block it. Instead use the sx-tree MCP tools:
|
||||
|
||||
- `mcp__sx-tree__sx_summarise` — structural overview at configurable depth
|
||||
- `mcp__sx-tree__sx_read_tree` — full annotated tree with path labels
|
||||
- `mcp__sx-tree__sx_read_subtree` — expand a specific subtree by path
|
||||
- `mcp__sx-tree__sx_find_all` — search for nodes matching a pattern
|
||||
- `mcp__sx-tree__sx_get_context` — enclosing chain from root to target
|
||||
- `mcp__sx-tree__sx_get_siblings` — siblings of a node with target marked
|
||||
- `mcp__sx-tree__sx_validate` — structural integrity checks
|
||||
|
||||
For all other file types, use Read, Grep, Glob, and Bash as normal.
|
||||
7
.claude/hooks/block-sx-edit.sh
Executable file
7
.claude/hooks/block-sx-edit.sh
Executable file
@@ -0,0 +1,7 @@
|
||||
#!/bin/bash
|
||||
# Block Edit/Read/Write on .sx/.sxc files — force use of sx-tree MCP tools
|
||||
FILE=$(jq -r '.tool_input.file_path // .tool_input.file // empty' 2>/dev/null)
|
||||
if [ -n "$FILE" ] && echo "$FILE" | grep -qE '\.(sx|sxc)$'; then
|
||||
printf '{"decision":"block","reason":"Use sx-tree MCP tools instead of Edit/Read/Write on .sx/.sxc files. For new files use sx_write_file, for reading use sx_read_tree/sx_summarise, for editing use sx_replace_node/sx_rename_symbol/etc. See CLAUDE.md for the protocol."}'
|
||||
exit 2
|
||||
fi
|
||||
@@ -0,0 +1,17 @@
|
||||
---
|
||||
name: SX navigation single-source-of-truth
|
||||
description: Navigation must be defined once in nav-data.sx — no fragment URLs, no duplicated case statements, use make-page-fn for convention-based routing
|
||||
type: feedback
|
||||
---
|
||||
|
||||
Never use fragment URLs (#anchors) in the SX docs nav system. Every navigable item must have its own Lisp URL.
|
||||
|
||||
**Why:** Fragment URLs don't work with the SX URL routing system — fragments are client-side only and never reach the server, so nav resolution can't identify the current page.
|
||||
|
||||
**How to apply:**
|
||||
- `nav-data.sx` is the single source of truth for all navigation labels, hrefs, summaries, and hierarchy
|
||||
- `page-functions.sx` uses `make-page-fn` (convention-based) or `slug->component` to derive component names from slugs — no hand-written case statements for simple pages
|
||||
- Overview/index pages should generate link lists from nav-data variables (e.g. `reactive-examples-nav-items`) rather than hardcoding URLs
|
||||
- To add a new simple page: add nav item to nav-data.sx, create the component file. That's it — the naming convention handles routing.
|
||||
- Pages that need server-side data fetching (reference, spec, test, bootstrapper, isomorphism) still use custom functions with explicit case clauses
|
||||
- Legacy Python nav lists in `content/pages.py` have been removed — nav-data.sx is canonical
|
||||
@@ -1,5 +1,5 @@
|
||||
.git
|
||||
.gitea
|
||||
.gitea/workflows
|
||||
.env
|
||||
_snapshot
|
||||
docs
|
||||
|
||||
85
.gitea/Dockerfile.test
Normal file
85
.gitea/Dockerfile.test
Normal file
@@ -0,0 +1,85 @@
|
||||
# syntax=docker/dockerfile:1
|
||||
#
|
||||
# CI test image — Python 3 + Node.js + OCaml 5.2 + dune.
|
||||
#
|
||||
# Build chain:
|
||||
# 1. Compile OCaml from checked-in sx_ref.ml — produces sx_server.exe
|
||||
# 2. Bootstrap JS (sx-browser.js) — OcamlSync transpiler → JS
|
||||
# 3. Re-bootstrap OCaml (sx_ref.ml) — OcamlSync transpiler → OCaml
|
||||
# 4. Recompile OCaml with fresh sx_ref.ml — final native binary
|
||||
#
|
||||
# Test suites (run at CMD):
|
||||
# - JS standard + full tests — Node
|
||||
# - OCaml spec tests — native binary
|
||||
# - OCaml bridge integration tests — Python + OCaml subprocess
|
||||
#
|
||||
# Usage:
|
||||
# docker build -f .gitea/Dockerfile.test -t sx-test .
|
||||
# docker run --rm sx-test
|
||||
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2
|
||||
|
||||
USER root
|
||||
RUN apt-get update && apt-get install -y --no-install-recommends \
|
||||
python3 ca-certificates curl xz-utils \
|
||||
&& rm -rf /var/lib/apt/lists/*
|
||||
# Node.js — direct binary (avoids the massive Debian nodejs dep tree)
|
||||
RUN NODE_VERSION=22.22.1 \
|
||||
&& ARCH=$(dpkg --print-architecture | sed 's/amd64/x64/;s/arm64/arm64/;s/armhf/armv7l/') \
|
||||
&& curl -fsSL "https://nodejs.org/dist/v${NODE_VERSION}/node-v${NODE_VERSION}-linux-${ARCH}.tar.xz" \
|
||||
| tar -xJ --strip-components=1 -C /usr/local
|
||||
USER opam
|
||||
|
||||
# Install dune into the opam switch
|
||||
RUN opam install dune -y
|
||||
|
||||
# Bake the opam switch PATH into the image so dune/ocamlfind work in RUN
|
||||
ENV PATH="/home/opam/.opam/5.2/bin:${PATH}"
|
||||
|
||||
WORKDIR /home/opam/project
|
||||
|
||||
# Copy OCaml sources first (changes less often → better caching)
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./hosts/ocaml/
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./hosts/ocaml/lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/ ./hosts/ocaml/bin/
|
||||
|
||||
# Copy spec, lib, web, shared (needed by bootstrappers + tests)
|
||||
COPY --chown=opam:opam spec/ ./spec/
|
||||
COPY --chown=opam:opam lib/ ./lib/
|
||||
COPY --chown=opam:opam web/ ./web/
|
||||
COPY --chown=opam:opam shared/sx/ ./shared/sx/
|
||||
COPY --chown=opam:opam shared/__init__.py ./shared/__init__.py
|
||||
|
||||
# Copy JS host (bootstrapper + test runner)
|
||||
COPY --chown=opam:opam hosts/javascript/ ./hosts/javascript/
|
||||
|
||||
# Copy OCaml host (bootstrapper + transpiler)
|
||||
COPY --chown=opam:opam hosts/ocaml/bootstrap.py ./hosts/ocaml/bootstrap.py
|
||||
COPY --chown=opam:opam hosts/ocaml/transpiler.sx ./hosts/ocaml/transpiler.sx
|
||||
|
||||
# Create output directory for JS builds
|
||||
RUN mkdir -p shared/static/scripts
|
||||
|
||||
# Step 1: Compile OCaml from checked-in sx_ref.ml
|
||||
# → produces sx_server.exe (needed by both JS and OCaml bootstrappers)
|
||||
RUN cd hosts/ocaml && dune build
|
||||
|
||||
# Step 2: Bootstrap JS (uses sx_server.exe via OcamlSync)
|
||||
RUN python3 hosts/javascript/cli.py \
|
||||
--output shared/static/scripts/sx-browser.js \
|
||||
&& python3 hosts/javascript/cli.py \
|
||||
--extensions continuations --spec-modules types \
|
||||
--output shared/static/scripts/sx-full-test.js
|
||||
|
||||
# Step 3: Re-bootstrap OCaml (transpile current spec → fresh sx_ref.ml)
|
||||
RUN python3 hosts/ocaml/bootstrap.py \
|
||||
--output hosts/ocaml/lib/sx_ref.ml
|
||||
|
||||
# Step 4: Recompile OCaml with freshly bootstrapped sx_ref.ml
|
||||
RUN cd hosts/ocaml && dune build
|
||||
|
||||
# Default: run all tests
|
||||
COPY --chown=opam:opam .gitea/run-ci-tests.sh ./run-ci-tests.sh
|
||||
RUN chmod +x run-ci-tests.sh
|
||||
|
||||
CMD ["./run-ci-tests.sh"]
|
||||
115
.gitea/run-ci-tests.sh
Executable file
115
.gitea/run-ci-tests.sh
Executable file
@@ -0,0 +1,115 @@
|
||||
#!/usr/bin/env bash
|
||||
# ===========================================================================
|
||||
# run-ci-tests.sh — CI test runner for SX language suite.
|
||||
#
|
||||
# Runs JS + OCaml tests. No Python evaluator (eliminated).
|
||||
# Exit non-zero if any suite fails.
|
||||
# ===========================================================================
|
||||
set -euo pipefail
|
||||
|
||||
FAILURES=()
|
||||
PASSES=()
|
||||
|
||||
run_suite() {
|
||||
local name="$1"
|
||||
shift
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " $name"
|
||||
echo "============================================================"
|
||||
if "$@"; then
|
||||
PASSES+=("$name")
|
||||
else
|
||||
FAILURES+=("$name")
|
||||
fi
|
||||
}
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 1. JS standard tests
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "JS standard (spec tests)" \
|
||||
node hosts/javascript/run_tests.js
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 2. JS full tests (continuations + types + VM)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "JS full (spec + continuations + types + VM)" \
|
||||
node hosts/javascript/run_tests.js --full
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 3. OCaml spec tests
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "OCaml (spec tests)" \
|
||||
hosts/ocaml/_build/default/bin/run_tests.exe
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 4. OCaml bridge integration (custom special forms, web-forms.sx)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "OCaml bridge — custom special forms + web-forms" \
|
||||
python3 -c "
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
bridge = OcamlSync()
|
||||
for f in ['spec/parser.sx', 'spec/render.sx', 'web/adapter-html.sx', 'web/adapter-sx.sx', 'web/web-forms.sx', 'lib/freeze.sx']:
|
||||
bridge.load(f)
|
||||
ok = 0; fail = 0
|
||||
def check(name, expr, expected=None):
|
||||
global ok, fail
|
||||
try:
|
||||
r = bridge.eval(expr)
|
||||
if expected is not None and r != expected:
|
||||
print(f' FAIL: {name}: expected {expected!r}, got {r!r}'); fail += 1
|
||||
else:
|
||||
print(f' PASS: {name}'); ok += 1
|
||||
except Exception as e:
|
||||
print(f' FAIL: {name}: {e}'); fail += 1
|
||||
|
||||
for form in ['defhandler', 'defquery', 'defaction', 'defpage', 'defrelation', 'defstyle', 'deftype', 'defeffect']:
|
||||
check(f'{form} registered', f'(has-key? *custom-special-forms* \"{form}\")', 'true')
|
||||
|
||||
check('deftype via eval', '(deftype test-t number)', 'nil')
|
||||
check('defeffect via eval', '(defeffect test-e)', 'nil')
|
||||
check('defstyle via eval', '(defstyle my-s \"bold\")', 'bold')
|
||||
check('defhandler via eval', '(has-key? (defhandler test-h (&key x) x) \"__type\")', 'true')
|
||||
|
||||
check('definition-form-extensions populated', '(> (len *definition-form-extensions*) 0)', 'true')
|
||||
check('RENDER_HTML_FORMS has defstyle', '(contains? RENDER_HTML_FORMS \"defstyle\")', 'true')
|
||||
|
||||
bridge2 = OcamlSync()
|
||||
bridge2.eval('(register-special-form! \"shadow-test\" (fn (args env) 42))')
|
||||
bridge2.load('spec/evaluator.sx')
|
||||
check('custom form survives evaluator.sx load',
|
||||
bridge2.eval('(has-key? *custom-special-forms* \"shadow-test\")'), 'true')
|
||||
bridge2.eval('(register-special-form! \"post-load\" (fn (args env) 99))')
|
||||
check('custom form callable after evaluator.sx load',
|
||||
bridge2.eval('(post-load 1)'), '99')
|
||||
|
||||
print(f'\nResults: {ok} passed, {fail} failed')
|
||||
import sys; sys.exit(1 if fail > 0 else 0)
|
||||
"
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# Summary
|
||||
# -------------------------------------------------------------------
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " CI TEST SUMMARY"
|
||||
echo "============================================================"
|
||||
for p in "${PASSES[@]}"; do
|
||||
echo " PASS: $p"
|
||||
done
|
||||
for f in "${FAILURES[@]}"; do
|
||||
echo " FAIL: $f"
|
||||
done
|
||||
echo "============================================================"
|
||||
|
||||
if [ ${#FAILURES[@]} -gt 0 ]; then
|
||||
echo ""
|
||||
echo " ${#FAILURES[@]} suite(s) FAILED"
|
||||
echo ""
|
||||
exit 1
|
||||
else
|
||||
echo ""
|
||||
echo " All ${#PASSES[@]} suites passed."
|
||||
echo ""
|
||||
exit 0
|
||||
fi
|
||||
@@ -1,4 +1,4 @@
|
||||
name: Build and Deploy
|
||||
name: Test, Build, and Deploy
|
||||
|
||||
on:
|
||||
push:
|
||||
@@ -10,7 +10,7 @@ env:
|
||||
BUILD_DIR: /root/rose-ash-ci
|
||||
|
||||
jobs:
|
||||
build-and-deploy:
|
||||
test-build-deploy:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
@@ -29,12 +29,11 @@ jobs:
|
||||
chmod 600 ~/.ssh/id_rsa
|
||||
ssh-keyscan -H "$DEPLOY_HOST" >> ~/.ssh/known_hosts 2>/dev/null || true
|
||||
|
||||
- name: Build and deploy changed apps
|
||||
- name: Sync CI build directory
|
||||
env:
|
||||
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||
run: |
|
||||
ssh "root@$DEPLOY_HOST" "
|
||||
# --- Build in isolated CI directory (never touch dev working tree) ---
|
||||
BUILD=${{ env.BUILD_DIR }}
|
||||
ORIGIN=\$(git -C ${{ env.APP_DIR }} remote get-url origin)
|
||||
if [ ! -d \"\$BUILD/.git\" ]; then
|
||||
@@ -43,6 +42,31 @@ jobs:
|
||||
cd \"\$BUILD\"
|
||||
git fetch origin
|
||||
git reset --hard origin/${{ github.ref_name }}
|
||||
"
|
||||
|
||||
- name: Test SX language suite
|
||||
env:
|
||||
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||
run: |
|
||||
ssh "root@$DEPLOY_HOST" "
|
||||
cd ${{ env.BUILD_DIR }}
|
||||
|
||||
echo '=== Building SX test image ==='
|
||||
docker build \
|
||||
-f .gitea/Dockerfile.test \
|
||||
-t sx-test:${{ github.sha }} \
|
||||
.
|
||||
|
||||
echo '=== Running SX tests ==='
|
||||
docker run --rm sx-test:${{ github.sha }}
|
||||
"
|
||||
|
||||
- name: Build and deploy changed apps
|
||||
env:
|
||||
DEPLOY_HOST: ${{ secrets.DEPLOY_HOST }}
|
||||
run: |
|
||||
ssh "root@$DEPLOY_HOST" "
|
||||
cd ${{ env.BUILD_DIR }}
|
||||
|
||||
# Detect changes using push event SHAs (not local checkout state)
|
||||
BEFORE='${{ github.event.before }}'
|
||||
|
||||
14
.gitignore
vendored
14
.gitignore
vendored
@@ -14,3 +14,17 @@ _debug/
|
||||
sx-haskell/
|
||||
sx-rust/
|
||||
shared/static/scripts/sx-full-test.js
|
||||
hosts/ocaml/_build/
|
||||
hosts/ocaml/browser/sx_browser.bc.wasm.assets/
|
||||
hosts/ocaml/browser/sx_browser.bc.wasm.assets.bak/
|
||||
hosts/ocaml/bin/mcp_tree_built.exe
|
||||
hosts/ocaml/hosts/
|
||||
hosts/ocaml/test-results/
|
||||
shared/static/wasm/sx_browser.bc.wasm.assets/
|
||||
.claude/worktrees/
|
||||
tests/playwright/test-results/
|
||||
test-case-define.sx
|
||||
test-case-define.txt
|
||||
test_all.js
|
||||
test_final.js
|
||||
test_interactive.js
|
||||
|
||||
13
.mcp.json
Normal file
13
.mcp.json
Normal file
@@ -0,0 +1,13 @@
|
||||
{
|
||||
"mcpServers": {
|
||||
"sx-tree": {
|
||||
"type": "stdio",
|
||||
"command": "./hosts/ocaml/_build/default/bin/mcp_tree.exe"
|
||||
},
|
||||
"rose-ash-services": {
|
||||
"type": "stdio",
|
||||
"command": "python3",
|
||||
"args": ["tools/mcp_services.py"]
|
||||
}
|
||||
}
|
||||
}
|
||||
228
CLAUDE.md
228
CLAUDE.md
@@ -2,6 +2,124 @@
|
||||
|
||||
Cooperative web platform: federated content, commerce, events, and media processing. Each domain runs as an independent Quart microservice with its own database, communicating via HMAC-signed internal HTTP and ActivityPub events.
|
||||
|
||||
## S-expression files — reading and editing protocol
|
||||
|
||||
**Never use `Edit`, `Read`, or `Write` on `.sx` or `.sxc` files.** A hook blocks these tools on `.sx`/`.sxc` files. Use the `sx-tree` MCP server tools instead — they operate on the parsed tree, not raw text. Bracket errors are impossible by construction.
|
||||
|
||||
### Before doing anything in an `.sx` file
|
||||
|
||||
1. Call `sx_summarise` to get a structural overview of the whole file
|
||||
2. Call `sx_read_subtree` on the region you intend to work in
|
||||
3. Call `sx_get_context` on specific nodes to understand their position
|
||||
4. Call `sx_find_all` to locate definitions or patterns by name
|
||||
5. For project-wide searches, use `sx_find_across`, `sx_comp_list`, or `sx_comp_usage`
|
||||
|
||||
**Never proceed to an edit without first establishing where you are in the tree using the comprehension tools.**
|
||||
|
||||
### For every s-expression edit
|
||||
|
||||
**Path-based** (when you know the exact path):
|
||||
1. Call `sx_read_subtree` on the target region to confirm the correct path
|
||||
2. Call `sx_replace_node` / `sx_insert_child` / `sx_delete_node` / `sx_wrap_node`
|
||||
3. Call `sx_validate` to confirm structural integrity
|
||||
4. Call `sx_read_subtree` again on the edited region to verify the result
|
||||
|
||||
**Pattern-based** (when you can describe what to find):
|
||||
- `sx_rename_symbol` — rename all occurrences of a symbol in a file
|
||||
- `sx_replace_by_pattern` — find + replace first/all nodes matching a pattern
|
||||
- `sx_insert_near` — insert before/after a pattern match (top-level)
|
||||
- `sx_rename_across` — rename a symbol across all `.sx` files (use `dry_run=true` first)
|
||||
|
||||
### Creating new `.sx` files
|
||||
|
||||
Use `sx_write_file` — it validates the source by parsing before writing. Malformed SX is rejected.
|
||||
|
||||
### On failure
|
||||
|
||||
Read the error carefully. Fragment errors give the parse failure in the new source. Path errors tell you which segment was not found. Fix the specific problem and retry the tree edit. **Never fall back to raw file writes.**
|
||||
|
||||
### Available MCP tools (sx-tree server)
|
||||
|
||||
**Comprehension:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_read_tree` | Annotated tree — auto-summarises large files. Params: `focus` (expand matching subtrees), `max_depth`, `max_lines`/`offset` |
|
||||
| `sx_summarise` | Folded overview at configurable depth |
|
||||
| `sx_read_subtree` | Expand a specific subtree by path |
|
||||
| `sx_get_context` | Enclosing chain from root to target |
|
||||
| `sx_find_all` | Search by pattern in one file, returns paths |
|
||||
| `sx_get_siblings` | Siblings of a node with target marked |
|
||||
| `sx_validate` | Structural integrity checks |
|
||||
|
||||
**Path-based editing:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_replace_node` | Replace node at path with new source |
|
||||
| `sx_insert_child` | Insert child at index in a list |
|
||||
| `sx_delete_node` | Remove node, siblings shift |
|
||||
| `sx_wrap_node` | Wrap in template with `_` placeholder |
|
||||
|
||||
**Smart editing (pattern-based):**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_rename_symbol` | Rename all occurrences of a symbol in a file |
|
||||
| `sx_replace_by_pattern` | Find + replace first/all nodes matching a pattern. `all=true` for all matches |
|
||||
| `sx_insert_near` | Insert before/after a pattern match (top-level). `position="before"` or `"after"` |
|
||||
| `sx_rename_across` | Rename symbol across all `.sx` files in a directory. `dry_run=true` to preview |
|
||||
|
||||
**Project-wide:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_find_across` | Search pattern across all `.sx` files in a directory |
|
||||
| `sx_comp_list` | List all definitions (defcomp/defisland/defmacro/defpage/define) across files |
|
||||
| `sx_comp_usage` | Find all uses of a component/symbol across files |
|
||||
|
||||
**Development:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_pretty_print` | Reformat an `.sx` file with indentation. Also used automatically by all edit tools |
|
||||
| `sx_write_file` | Create/overwrite `.sx` file with parse validation |
|
||||
| `sx_build` | Build JS bundle (`target="js"`) or OCaml binary (`target="ocaml"`) |
|
||||
| `sx_test` | Run test suite (`host="js"` or `"ocaml"`, `full=true` for extensions) |
|
||||
| `sx_format_check` | Lint: empty bindings, missing bodies, duplicate params |
|
||||
| `sx_macroexpand` | Evaluate expression with a file's macro definitions loaded |
|
||||
| `sx_eval` | REPL — evaluate SX expressions in the MCP server env |
|
||||
|
||||
**Git integration:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_changed` | List `.sx` files changed since a ref with structural summaries |
|
||||
| `sx_diff_branch` | Structural diff of all `.sx` changes on branch vs base ref |
|
||||
| `sx_blame` | Git blame for `.sx` file, optionally focused on a tree path |
|
||||
|
||||
**Test harness:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_harness_eval` | Evaluate SX in a sandboxed harness with mock IO. Returns result + IO trace. Params: `expr`, optional `mock`, `file`, `files` (array), `setup` (SX expr run before eval) |
|
||||
|
||||
**Analysis:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_diff` | Structural diff between two `.sx` files (ADDED/REMOVED/CHANGED) |
|
||||
| `sx_doc_gen` | Generate component docs from signatures across a directory |
|
||||
| `sx_playwright` | Run Playwright browser tests for the SX docs site |
|
||||
|
||||
**Debugging & analysis:**
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `sx_trace` | Step-through CEK evaluation showing symbol lookups, function calls, returns. Params: `expr`, optional `file`, `max_steps` |
|
||||
| `sx_deps` | Dependency analysis — shows all free symbols in a component and where they're defined. Params: `file`, optional `name`, `dir` |
|
||||
| `sx_build_manifest` | Show build contents: adapters, spec modules, primitives. Params: optional `target` ("js" or "ocaml") |
|
||||
|
||||
## Deployment
|
||||
|
||||
- **Do NOT push** until explicitly told to. Pushes reload code to dev automatically.
|
||||
@@ -64,6 +182,8 @@ The SX language is defined by a self-hosting specification in `shared/sx/ref/`.
|
||||
- **`shared/sx/ref/primitives.sx`** — All ~80 built-in pure functions: arithmetic, comparison, predicates, string ops, collection ops, dict ops, format helpers, CSSX style primitives.
|
||||
- **`shared/sx/ref/render.sx`** — Three rendering modes: `render-to-html` (server HTML), `render-to-sx`/`aser` (SX wire format for client), `render-to-dom` (browser). HTML tag registry, void elements, boolean attrs.
|
||||
- **`shared/sx/ref/bootstrap_js.py`** — Transpiler: reads the `.sx` spec files and emits `sx-ref.js`.
|
||||
- **`spec/harness.sx`** — Test harness: mock IO platform for testing components. Sessions, IO interception, log queries, assertions (`assert-io-called`, `assert-io-count`, `assert-io-args`, `assert-no-io`, `assert-state`). Extensible — new platforms add entries to the platform dict. Loaded automatically by test runners.
|
||||
- **`spec/tests/test-harness.sx`** — Tests for the harness itself (15 tests).
|
||||
|
||||
### Type system
|
||||
|
||||
@@ -108,6 +228,26 @@ lambda, component, macro, thunk (TCO deferred eval)
|
||||
|
||||
The `aser` (async-serialize) mode evaluates control flow and function calls but serializes HTML tags and component calls as SX source — the client renders them. This is the wire format for HTMX-like responses.
|
||||
|
||||
### Test harness (from harness.sx)
|
||||
|
||||
The harness provides sandboxed testing of IO behavior. It's a spec-level facility — works on every host.
|
||||
|
||||
**Core concepts:**
|
||||
- **Session** — `(make-harness &key platform)` creates a session with mock IO operations
|
||||
- **Interceptor** — `(make-interceptor session op-name mock-fn)` wraps a mock to record calls
|
||||
- **IO log** — append-only trace of every IO call. Query with `io-calls`, `io-call-count`, `io-call-args`
|
||||
- **Assertions** — `assert-io-called`, `assert-no-io`, `assert-io-count`, `assert-io-args`, `assert-state`
|
||||
|
||||
**Default platform** provides 30+ mock IO operations (fetch, query, action, cookies, DOM, storage, etc.) that return sensible empty values. Override per-test with `:platform` on `make-harness`.
|
||||
|
||||
**Extensibility:** New platforms add entries to the platform dict. The harness intercepts any registered operation — no harness code changes needed for new IO types.
|
||||
|
||||
**Platform-specific test extensions** live in the platform spec, not the core harness:
|
||||
- `web/harness-web.sx` — DOM assertions, `simulate-click`, CSS class checks
|
||||
- `web/harness-reactive.sx` — signal assertions: `assert-signal-value`, `assert-signal-subscribers`
|
||||
|
||||
**Components ship with tests** via `deftest` forms. Tests reference components by name or CID (`:for` param). Tests are independent content-addressed objects — anyone can publish tests for any component.
|
||||
|
||||
### Platform interface
|
||||
|
||||
Each target (JS, Python) must provide: type inspection (`type-of`), constructors (`make-lambda`, `make-component`, `make-macro`, `make-thunk`), accessors, environment operations (`env-has?`, `env-get`, `env-set!`, `env-extend`, `env-merge`), and DOM/HTML rendering primitives.
|
||||
@@ -209,6 +349,9 @@ Shared components live in `shared/sx/templates/` and are loaded by `load_shared_
|
||||
| relations | (internal only) | 8008 |
|
||||
| likes | (internal only) | 8009 |
|
||||
| orders | orders.rose-ash.com | 8010 |
|
||||
| sx_docs | sx.rose-ash.com | 8013 |
|
||||
|
||||
**Dev serves live domains.** Docker dev containers bind-mount host files and Caddy routes public domains (e.g. `sx.rose-ash.com`) to the dev container ports (e.g. `localhost:8013`). There is no separate "local" vs "production" — editing files on the host and restarting the container updates the live site immediately. Playwright tests at `localhost:8013` test the same server visitors see at `sx.rose-ash.com`.
|
||||
|
||||
## Dev Container Mounts
|
||||
|
||||
@@ -226,3 +369,88 @@ Dev bind mounts in `docker-compose.dev.yml` must mirror the Docker image's COPY
|
||||
|
||||
- Use Context7 MCP for up-to-date library documentation
|
||||
- Playwright MCP is available for browser automation/testing
|
||||
|
||||
### Service introspection MCP (rose-ash-services)
|
||||
|
||||
Python-based MCP server for understanding the microservice topology. Static analysis — works without running services.
|
||||
|
||||
| Tool | Purpose |
|
||||
|------|---------|
|
||||
| `svc_status` | Docker container status for all rose-ash services |
|
||||
| `svc_routes` | List all HTTP routes for a service by scanning blueprints |
|
||||
| `svc_calls` | Map inter-service calls (fetch_data/call_action/send_internal_activity/fetch_fragment) |
|
||||
| `svc_config` | Environment variables and config for a service |
|
||||
| `svc_models` | SQLAlchemy models, columns, relationships for a service |
|
||||
| `svc_schema` | Live defquery/defaction manifest from a running service |
|
||||
| `alembic_status` | Migration count and latest migration per service |
|
||||
| `svc_logs` | Recent Docker logs for a service |
|
||||
| `svc_start` | Start services via dev.sh |
|
||||
| `svc_stop` | Stop all services |
|
||||
| `svc_queries` | List all defquery definitions from queries.sx files |
|
||||
| `svc_actions` | List all defaction definitions from actions.sx files |
|
||||
### VM / Bytecode Debugging Tools
|
||||
|
||||
These are OCaml server commands sent via the epoch protocol (`printf '(epoch N)\n(command args)\n' | sx_server.exe`). They're available in any context where the OCaml kernel is running (dev server, CLI, tests).
|
||||
|
||||
```bash
|
||||
# Full build pipeline — OCaml + JS browser + JS test + run tests
|
||||
./scripts/sx-build-all.sh
|
||||
|
||||
# WASM boot test — verify sx_browser.bc.js loads in Node.js without a browser
|
||||
bash hosts/ocaml/browser/test_boot.sh
|
||||
```
|
||||
|
||||
#### `(vm-trace "<sx-source>")`
|
||||
Step through bytecode execution. Returns a list of trace entries, each with:
|
||||
- `:opcode` — instruction name (CONST, CALL, JUMP_IF_FALSE, etc.)
|
||||
- `:stack` — top 5 values on the stack at that point
|
||||
- `:depth` — frame nesting depth
|
||||
|
||||
Requires the compiler to be loaded (`lib/compiler.sx`). Use this to debug unexpected VM behavior — it shows exactly what the bytecode does step by step.
|
||||
|
||||
```bash
|
||||
printf '(epoch 1)\n(load "lib/compiler.sx")\n(epoch 2)\n(vm-trace "(+ 1 2)")\n' | sx_server.exe
|
||||
```
|
||||
|
||||
#### `(bytecode-inspect "<function-name>")`
|
||||
Disassemble a compiled function's bytecode. Returns a dict with:
|
||||
- `:arity` — number of parameters
|
||||
- `:num_locals` — stack frame size
|
||||
- `:constants` — constant pool (strings, numbers, symbols)
|
||||
- `:bytecode` — list of instructions, each with `:offset`, `:opcode`, `:operands`
|
||||
|
||||
Only works on functions that have been JIT-compiled (have a `vm_closure`). Use this to verify the compiler emits correct bytecode.
|
||||
|
||||
```bash
|
||||
printf '(epoch 1)\n(bytecode-inspect "my-function")\n' | sx_server.exe
|
||||
```
|
||||
|
||||
#### `(deps-check "<sx-source>")`
|
||||
Strict symbol resolution checker. Parses the source, walks the AST, and checks every symbol reference against:
|
||||
- Environment bindings (defines, let bindings)
|
||||
- Primitive functions table
|
||||
- Special form names (if, when, cond, let, define, etc.)
|
||||
|
||||
Returns `{:resolved (...) :unresolved (...)}`. Run this on `.sx` files before compilation to catch typos and missing imports (e.g., `extract-verb-info` vs `get-verb-info`).
|
||||
|
||||
```bash
|
||||
printf '(epoch 1)\n(deps-check "(defcomp ~my-comp () (div (frobnicate x)))")\n' | sx_server.exe
|
||||
# => {:resolved ("defcomp" "div") :unresolved ("frobnicate" "x")}
|
||||
```
|
||||
|
||||
#### `(prim-check "<function-name>")`
|
||||
Scan compiled bytecode for `CALL_PRIM` instructions and verify each primitive name exists in the runtime. Returns `{:valid (...) :invalid (...)}`. Catches mismatches like `length` vs `len` that would crash at runtime.
|
||||
|
||||
```bash
|
||||
printf '(epoch 1)\n(prim-check "my-compiled-fn")\n' | sx_server.exe
|
||||
# => {:valid ("+" "len" "first") :invalid ("length")}
|
||||
```
|
||||
|
||||
### SX Island Authoring Rules
|
||||
|
||||
Key patterns discovered from the reactive runtime demos (see `sx/sx/reactive-runtime.sx`):
|
||||
|
||||
1. **Multi-expression bodies need `(do ...)`** — `fn`, `let`, and `when` bodies evaluate only the last expression. Wrap multiples in `(do expr1 expr2 expr3)`.
|
||||
2. **`let` is parallel, not sequential** — bindings in the same `let` can't reference each other. Use nested `let` blocks when functions need to reference signals defined earlier.
|
||||
3. **Reactive text needs `(deref (computed ...))`** — bare `(len (deref items))` is NOT reactive. Wrap in `(deref (computed (fn () (len (deref items)))))`.
|
||||
4. **Effects go in inner `let`** — signals in outer `let`, functions and effects in inner `let`. The OCaml SSR evaluator can't resolve outer `let` bindings from same-`let` lambdas.
|
||||
|
||||
1
_config/app-config.sx
Normal file
1
_config/app-config.sx
Normal file
@@ -0,0 +1 @@
|
||||
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :section-titles ("ingredients" "allergy information" "allergens" "nutritional information" "nutrition" "storage" "directions" "preparation" "serving suggestions" "origin" "country of origin" "recycling" "general information" "additional information" "a note about prices") :blacklist {:category ("branded-goods/alcoholic-drinks" "branded-goods/beers" "branded-goods/ciders" "branded-goods/wines") :product ("list-price-suma-current-suma-price-list-each-bk012-2-html") :product-details ("General Information" "A Note About Prices")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})
|
||||
155
applications/sxtp/spec.sx
Normal file
155
applications/sxtp/spec.sx
Normal file
@@ -0,0 +1,155 @@
|
||||
(define
|
||||
request-fields
|
||||
(quote
|
||||
((:verb "Symbol — the action to perform (required)")
|
||||
(:path "String — resource path (required)")
|
||||
(:headers "Dict — structured request metadata (optional)")
|
||||
(:cookies "Dict — client state, values can be any SX type (optional)")
|
||||
(:params "Dict — query parameters as typed values (optional)")
|
||||
(:capabilities "List — capabilities this request requires (optional)")
|
||||
(:body "Any SX value — request payload (optional)"))))
|
||||
|
||||
(define
|
||||
response-fields
|
||||
(quote
|
||||
((:status "Symbol or condition — result status (required)")
|
||||
(:headers "Dict — structured response metadata (optional)")
|
||||
(:set-cookie
|
||||
"Dict — cookies to set, values are dicts with :value :max-age :path (optional)")
|
||||
(:body "Any SX value — response payload (optional)")
|
||||
(:stream "Boolean — if true, body is a sequence of chunks (optional)"))))
|
||||
|
||||
(define
|
||||
core-verbs
|
||||
(quote
|
||||
((navigate "Retrieve a page for display — analogous to GET for documents")
|
||||
(fetch "Retrieve data — analogous to GET for APIs")
|
||||
(query "Structured query — body contains a query expression")
|
||||
(mutate "Change state — analogous to POST/PUT/PATCH")
|
||||
(create "Create a new resource — analogous to POST")
|
||||
(delete "Remove a resource — analogous to DELETE")
|
||||
(subscribe "Open a streaming channel for real-time updates")
|
||||
(inspect "Retrieve metadata about a resource (capabilities, schema)")
|
||||
(ping "Liveness check — server responds with (response :status ok)"))))
|
||||
|
||||
(define
|
||||
standard-headers
|
||||
(quote
|
||||
((:accept "List of acceptable response types")
|
||||
(:language "String or list — preferred languages")
|
||||
(:if-match "String — content hash for conditional requests")
|
||||
(:capabilities "List — capabilities the client holds")
|
||||
(:origin "String — requesting origin for CORS-like checks")
|
||||
(:content-type "String — always text/sx in pure SXTP")
|
||||
(:content-hash "String — SHA3-256 of the body expression")
|
||||
(:cache "Symbol — :immutable, :revalidate, :none")
|
||||
(:vary "List of header keys that affect caching")
|
||||
(:link "Dict — related resources"))))
|
||||
|
||||
(define
|
||||
cookie-options
|
||||
(quote
|
||||
((:value "Any SX value — the cookie payload (required)")
|
||||
(:max-age "Number — seconds until expiry (optional)")
|
||||
(:path "String — path scope (optional, default /)")
|
||||
(:domain "String — domain scope (optional)")
|
||||
(:secure "Boolean — require secure transport (optional)")
|
||||
(:same-site "Symbol — :strict, :lax, or :none (optional)")
|
||||
(:delete "Boolean — if true, remove this cookie (optional)"))))
|
||||
|
||||
(define
|
||||
status-symbols
|
||||
(quote
|
||||
((ok "Success — body contains the result")
|
||||
(created "Resource created — body contains the new resource")
|
||||
(accepted "Request accepted for async processing")
|
||||
(no-content "Success with no body")
|
||||
(redirect "See :headers :location for target")
|
||||
(not-modified "Cached version is current based on :if-match")
|
||||
(error "General error — see :body for condition")
|
||||
(not-found "Resource does not exist")
|
||||
(forbidden "Insufficient capabilities")
|
||||
(invalid "Malformed request or invalid params")
|
||||
(conflict "State conflict — concurrent edit")
|
||||
(unavailable "Service temporarily unavailable"))))
|
||||
|
||||
(define
|
||||
condition-fields
|
||||
(quote
|
||||
((:type "Symbol — condition type (required)")
|
||||
(:message "String — human-readable description (optional)")
|
||||
(:path "String — resource that caused the error (optional)")
|
||||
(:retry "Boolean — whether retrying may succeed (optional)")
|
||||
(:detail "Any SX value — domain-specific detail (optional)"))))
|
||||
|
||||
(define
|
||||
chunk-fields
|
||||
(quote
|
||||
((:seq "Number — sequence index for ordered chunks")
|
||||
(:body "Any SX value — the chunk content")
|
||||
(:done "Boolean — signals end of stream"))))
|
||||
|
||||
(define
|
||||
event-fields
|
||||
(quote
|
||||
((:type "Symbol — event type (required)")
|
||||
(:id "String — event or resource identifier (optional)")
|
||||
(:body "Any SX value — event payload (optional)")
|
||||
(:time "Number — unix timestamp (optional)"))))
|
||||
|
||||
(define
|
||||
example-navigate
|
||||
(quote
|
||||
((request :verb navigate :path "/geography/capabilities" :headers {:host "sx.rose-ash.com" :accept "text/sx"})
|
||||
(response
|
||||
:status ok
|
||||
:headers {:content-type "text/sx" :content-hash "sha3-9f2a"}
|
||||
:body (page
|
||||
:title "Capabilities"
|
||||
(h1 "Geography Capabilities")
|
||||
(~capability-list :domain "geography"))))))
|
||||
|
||||
(define
|
||||
example-query
|
||||
(quote
|
||||
((request :verb query :path "/events" :capabilities (fetch db:read) :params {:after "2026-03-01" :limit 10} :body (filter (events) (fn (e) (> (:attendees e) 50))))
|
||||
(response
|
||||
:status ok
|
||||
:headers {:cache :revalidate}
|
||||
:body ((event :id "evt-42" :title "Jazz Night" :attendees 87)
|
||||
(event :id "evt-55" :title "Art Walk" :attendees 120))))))
|
||||
|
||||
(define
|
||||
example-mutate
|
||||
(quote
|
||||
((request :verb create :path "/blog/posts" :capabilities (mutate blog:publish) :cookies {:session "tok_abc123"} :body {:tags ("protocol" "sx" "web") :body (article (h1 "SXTP") (p "Everything is SX.")) :title "SXTP Protocol"})
|
||||
(response :status created :headers {:location "/blog/posts/sxtp-protocol" :content-hash "sha3-ff01"} :body {:created-at 1711612800 :id "post-789" :path "/blog/posts/sxtp-protocol"}))))
|
||||
|
||||
(define
|
||||
example-subscribe
|
||||
(quote
|
||||
((request :verb subscribe :path "/events/live" :capabilities (fetch) :headers {:host "events.rose-ash.com"})
|
||||
(response :status ok :stream true)
|
||||
(event
|
||||
:type new-event
|
||||
:id "evt-99"
|
||||
:body (div :class "event-card" (h3 "Poetry Slam")))
|
||||
(event :type heartbeat :time 1711612860))))
|
||||
|
||||
(define
|
||||
example-error
|
||||
(quote
|
||||
((request :verb fetch :path "/blog/nonexistent")
|
||||
(response
|
||||
:status not-found
|
||||
:body (condition
|
||||
:type resource-not-found
|
||||
:path "/blog/nonexistent"
|
||||
:message "No such post"
|
||||
:retry false)))))
|
||||
|
||||
(define
|
||||
example-inspect
|
||||
(quote
|
||||
((request :verb inspect :path "/cart/checkout")
|
||||
(response :status ok :body {:available-verbs (inspect mutate) :params-schema {:payment-method "symbol" :shipping-address "dict"} :required-capabilities (mutate cart:checkout)}))))
|
||||
Binary file not shown.
1
blog/config/app-config.sx
Normal file
1
blog/config/app-config.sx
Normal file
@@ -0,0 +1 @@
|
||||
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :section-titles ("ingredients" "allergy information" "allergens" "nutritional information" "nutrition" "storage" "directions" "preparation" "serving suggestions" "origin" "country of origin" "recycling" "general information" "additional information" "a note about prices") :blacklist {:category ("branded-goods/alcoholic-drinks" "branded-goods/beers" "branded-goods/ciders" "branded-goods/wines") :product ("list-price-suma-current-suma-price-list-each-bk012-2-html") :product-details ("General Information" "A Note About Prices")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})
|
||||
703
blog/sx/admin.sx
703
blog/sx/admin.sx
@@ -144,78 +144,140 @@
|
||||
edit-form delete-form))
|
||||
|
||||
;; Data-driven snippets list (replaces Python _snippets_sx loop)
|
||||
(defcomp ~admin/snippets-from-data (&key snippets user-id is-admin csrf badge-colours)
|
||||
(defcomp
|
||||
~admin/snippets-from-data
|
||||
(&key snippets user-id is-admin csrf badge-colours)
|
||||
(~admin/snippets-list
|
||||
:rows (<> (map (lambda (s)
|
||||
(let* ((s-id (get s "id"))
|
||||
(s-name (get s "name"))
|
||||
(s-uid (get s "user_id"))
|
||||
(s-vis (get s "visibility"))
|
||||
(owner (if (= s-uid user-id) "You" (str "User #" s-uid)))
|
||||
(badge-cls (or (get badge-colours s-vis) "bg-stone-200 text-stone-700"))
|
||||
(extra (<>
|
||||
(when is-admin
|
||||
(~admin/snippet-visibility-select
|
||||
:patch-url (get s "patch_url")
|
||||
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
|
||||
:options (<>
|
||||
(~admin/snippet-option :value "private" :selected (= s-vis "private") :label "private")
|
||||
(~admin/snippet-option :value "shared" :selected (= s-vis "shared") :label "shared")
|
||||
(~admin/snippet-option :value "admin" :selected (= s-vis "admin") :label "admin"))
|
||||
:cls "text-sm border border-stone-300 rounded px-2 py-1"))
|
||||
(when (or (= s-uid user-id) is-admin)
|
||||
(~shared:misc/delete-btn :url (get s "delete_url") :trigger-target "#snippets-list"
|
||||
:title "Delete snippet?"
|
||||
:text (str "Delete \u201c" s-name "\u201d?")
|
||||
:sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
|
||||
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 rounded text-red-800 flex-shrink-0")))))
|
||||
(~admin/snippet-row :name s-name :owner owner :badge-cls badge-cls
|
||||
:visibility s-vis :extra extra)))
|
||||
(or snippets (list))))))
|
||||
:rows (<>
|
||||
(map
|
||||
(lambda
|
||||
(s)
|
||||
(let-match
|
||||
{:visibility s-vis :delete_url delete-url :patch_url patch-url :id s-id :user_id s-uid :name s-name}
|
||||
s
|
||||
(let*
|
||||
((owner (if (= s-uid user-id) "You" (str "User #" s-uid)))
|
||||
(badge-cls
|
||||
(or (get badge-colours s-vis) "bg-stone-200 text-stone-700"))
|
||||
(extra
|
||||
(<>
|
||||
(when
|
||||
is-admin
|
||||
(~admin/snippet-visibility-select
|
||||
:patch-url patch-url
|
||||
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
|
||||
:options (<>
|
||||
(~admin/snippet-option
|
||||
:value "private"
|
||||
:selected (= s-vis "private")
|
||||
:label "private")
|
||||
(~admin/snippet-option
|
||||
:value "shared"
|
||||
:selected (= s-vis "shared")
|
||||
:label "shared")
|
||||
(~admin/snippet-option
|
||||
:value "admin"
|
||||
:selected (= s-vis "admin")
|
||||
:label "admin"))
|
||||
:cls "text-sm border border-stone-300 rounded px-2 py-0.5"))
|
||||
(when
|
||||
(or (= s-uid user-id) is-admin)
|
||||
(~shared:misc/delete-btn
|
||||
:url delete-url
|
||||
:trigger-target "#snippets-list"
|
||||
:title "Delete snippet?"
|
||||
:text (str "Delete \"" s-name "\"?")
|
||||
:sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
|
||||
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 text-red-800 rounded-full")))))
|
||||
(~admin/snippet-row
|
||||
:name s-name
|
||||
:owner owner
|
||||
:badge-cls badge-cls
|
||||
:visibility s-vis
|
||||
:extra extra))))
|
||||
(or snippets (list))))))
|
||||
|
||||
;; Data-driven menu items list (replaces Python _menu_items_list_sx loop)
|
||||
(defcomp ~admin/menu-items-from-data (&key items csrf)
|
||||
(defcomp
|
||||
~admin/menu-items-from-data
|
||||
(&key items csrf)
|
||||
(~admin/menu-items-list
|
||||
:rows (<> (map (lambda (item)
|
||||
(let* ((img (~shared:misc/img-or-placeholder :src (get item "feature_image") :alt (get item "label")
|
||||
:size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")))
|
||||
(~admin/menu-item-row
|
||||
:img img :label (get item "label") :slug (get item "slug")
|
||||
:sort-order (get item "sort_order") :edit-url (get item "edit_url")
|
||||
:delete-url (get item "delete_url")
|
||||
:confirm-text (str "Remove " (get item "label") " from the menu?")
|
||||
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}"))))
|
||||
(or items (list))))))
|
||||
:rows (<>
|
||||
(map
|
||||
(lambda
|
||||
(item)
|
||||
(let-match
|
||||
{:delete_url delete-url :sort_order sort-order :edit_url edit-url :feature_image feature-image :label label :slug slug}
|
||||
item
|
||||
(let
|
||||
((img (~shared:misc/img-or-placeholder :src feature-image :alt label :size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")))
|
||||
(~admin/menu-item-row
|
||||
:img img
|
||||
:label label
|
||||
:slug slug
|
||||
:sort-order sort-order
|
||||
:edit-url edit-url
|
||||
:delete-url delete-url
|
||||
:confirm-text (str "Remove " label " from the menu?")
|
||||
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")))))
|
||||
(or items (list))))))
|
||||
|
||||
;; Data-driven tag groups main (replaces Python _tag_groups_main_panel_sx loops)
|
||||
(defcomp ~admin/tag-groups-from-data (&key groups unassigned-tags csrf create-url)
|
||||
(defcomp
|
||||
~admin/tag-groups-from-data
|
||||
(&key groups unassigned-tags csrf create-url)
|
||||
(~admin/tag-groups-main
|
||||
:form (~admin/tag-groups-create-form :create-url create-url :csrf csrf)
|
||||
:groups (if (empty? (or groups (list)))
|
||||
(~shared:misc/empty-state :message "No tag groups yet." :cls "text-stone-500 text-sm")
|
||||
:groups (if
|
||||
(empty? (or groups (list)))
|
||||
(~shared:misc/empty-state
|
||||
:message "No tag groups yet."
|
||||
:cls "text-stone-500 text-sm")
|
||||
(~admin/tag-groups-list
|
||||
:items (<> (map (lambda (g)
|
||||
(let* ((icon (if (get g "feature_image")
|
||||
(~admin/tag-group-icon-image :src (get g "feature_image") :name (get g "name"))
|
||||
(~admin/tag-group-icon-color :style (get g "style") :initial (get g "initial")))))
|
||||
(~admin/tag-group-li :icon icon :edit-href (get g "edit_href")
|
||||
:name (get g "name") :slug (get g "slug") :sort-order (get g "sort_order"))))
|
||||
groups))))
|
||||
:unassigned (when (not (empty? (or unassigned-tags (list))))
|
||||
:items (<>
|
||||
(map
|
||||
(lambda
|
||||
(g)
|
||||
(let-match
|
||||
{:sort_order sort-order :feature_image feature-image :slug slug :edit_href edit-href :initial initial :name name :style style}
|
||||
g
|
||||
(let
|
||||
((icon (if feature-image (~admin/tag-group-icon-image :src feature-image :name name) (~admin/tag-group-icon-color :style style :initial initial))))
|
||||
(~admin/tag-group-li
|
||||
:icon icon
|
||||
:edit-href edit-href
|
||||
:name name
|
||||
:slug slug
|
||||
:sort-order sort-order))))
|
||||
groups))))
|
||||
:unassigned (when
|
||||
(not (empty? (or unassigned-tags (list))))
|
||||
(~admin/unassigned-tags
|
||||
:heading (str "Unassigned Tags (" (len unassigned-tags) ")")
|
||||
:spans (<> (map (lambda (t)
|
||||
(~admin/unassigned-tag :name (get t "name")))
|
||||
unassigned-tags))))))
|
||||
:spans (<>
|
||||
(map
|
||||
(lambda (t) (~admin/unassigned-tag :name (get t "name")))
|
||||
unassigned-tags))))))
|
||||
|
||||
;; Data-driven tag group edit (replaces Python _tag_groups_edit_main_panel_sx loop)
|
||||
(defcomp ~admin/tag-checkboxes-from-data (&key tags)
|
||||
(<> (map (lambda (t)
|
||||
(~admin/tag-checkbox
|
||||
:tag-id (get t "tag_id") :checked (get t "checked")
|
||||
:img (when (get t "feature_image") (~admin/tag-checkbox-image :src (get t "feature_image")))
|
||||
:name (get t "name")))
|
||||
(or tags (list)))))
|
||||
(defcomp
|
||||
~admin/tag-checkboxes-from-data
|
||||
(&key tags)
|
||||
(<>
|
||||
(map
|
||||
(lambda
|
||||
(t)
|
||||
(let-match
|
||||
{:tag_id tag-id :checked checked :feature_image feature-image :name name}
|
||||
t
|
||||
(~admin/tag-checkbox
|
||||
:tag-id tag-id
|
||||
:checked checked
|
||||
:img (when
|
||||
feature-image
|
||||
(~admin/tag-checkbox-image :src feature-image))
|
||||
:name name)))
|
||||
(or tags (list)))))
|
||||
|
||||
;; Preview panel components
|
||||
|
||||
@@ -258,113 +320,175 @@
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; Snippets — receives serialized snippet dicts from service
|
||||
(defcomp ~admin/snippets-content (&key snippets is-admin csrf)
|
||||
(defcomp
|
||||
~admin/snippets-content
|
||||
(&key snippets is-admin csrf)
|
||||
(~admin/snippets-panel
|
||||
:list (if (empty? (or snippets (list)))
|
||||
(~shared:misc/empty-state :icon "fa fa-puzzle-piece"
|
||||
:list (if
|
||||
(empty? (or snippets (list)))
|
||||
(~shared:misc/empty-state
|
||||
:icon "fa fa-puzzle-piece"
|
||||
:message "No snippets yet. Create one from the blog editor.")
|
||||
(~admin/snippets-list
|
||||
:rows (map (lambda (s)
|
||||
(let* ((badge-colours (dict
|
||||
"private" "bg-stone-200 text-stone-700"
|
||||
"shared" "bg-blue-100 text-blue-700"
|
||||
"admin" "bg-amber-100 text-amber-700"))
|
||||
(vis (or (get s "visibility") "private"))
|
||||
(badge-cls (or (get badge-colours vis) "bg-stone-200 text-stone-700"))
|
||||
(name (get s "name"))
|
||||
(owner (get s "owner"))
|
||||
(can-delete (get s "can_delete")))
|
||||
(~admin/snippet-row
|
||||
:name name :owner owner :badge-cls badge-cls :visibility vis
|
||||
:extra (<>
|
||||
(when is-admin
|
||||
(~admin/snippet-visibility-select
|
||||
:patch-url (get s "patch_url")
|
||||
:hx-headers {:X-CSRFToken csrf}
|
||||
:options (<>
|
||||
(~admin/snippet-option :value "private" :selected (= vis "private") :label "private")
|
||||
(~admin/snippet-option :value "shared" :selected (= vis "shared") :label "shared")
|
||||
(~admin/snippet-option :value "admin" :selected (= vis "admin") :label "admin"))))
|
||||
(when can-delete
|
||||
(~shared:misc/delete-btn
|
||||
:url (get s "delete_url")
|
||||
:trigger-target "#snippets-list"
|
||||
:title "Delete snippet?"
|
||||
:text (str "Delete \u201c" name "\u201d?")
|
||||
:sx-headers {:X-CSRFToken csrf}
|
||||
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 rounded text-red-800 flex-shrink-0"))))))
|
||||
:rows (map
|
||||
(lambda
|
||||
(s)
|
||||
(let-match
|
||||
{:visibility vis* :delete_url delete-url :owner owner :can_delete can-delete :patch_url patch-url :name name}
|
||||
s
|
||||
(let*
|
||||
((vis (or vis* "private"))
|
||||
(badge-colours
|
||||
(dict
|
||||
"private"
|
||||
"bg-stone-200 text-stone-700"
|
||||
"shared"
|
||||
"bg-blue-100 text-blue-700"
|
||||
"admin"
|
||||
"bg-amber-100 text-amber-700"))
|
||||
(badge-cls
|
||||
(or (get badge-colours vis) "bg-stone-200 text-stone-700")))
|
||||
(~admin/snippet-row
|
||||
:name name
|
||||
:owner owner
|
||||
:badge-cls badge-cls
|
||||
:visibility vis
|
||||
:extra (<>
|
||||
(when
|
||||
is-admin
|
||||
(~admin/snippet-visibility-select
|
||||
:patch-url patch-url
|
||||
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
|
||||
:options (<>
|
||||
(~admin/snippet-option
|
||||
:value "private"
|
||||
:selected (= vis "private")
|
||||
:label "private")
|
||||
(~admin/snippet-option
|
||||
:value "shared"
|
||||
:selected (= vis "shared")
|
||||
:label "shared")
|
||||
(~admin/snippet-option
|
||||
:value "admin"
|
||||
:selected (= vis "admin")
|
||||
:label "admin"))))
|
||||
(when
|
||||
can-delete
|
||||
(~shared:misc/delete-btn
|
||||
:url delete-url
|
||||
:trigger-target "#snippets-list"
|
||||
:title "Delete snippet?"
|
||||
:text (str "Delete \"" name "\"?")
|
||||
:sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
|
||||
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 text-red-800 rounded-full")))))))
|
||||
(or snippets (list)))))))
|
||||
|
||||
;; Menu Items — receives serialized menu item dicts from service
|
||||
(defcomp ~admin/menu-items-content (&key menu-items new-url csrf)
|
||||
(defcomp
|
||||
~admin/menu-items-content
|
||||
(&key menu-items new-url csrf)
|
||||
(~admin/menu-items-panel
|
||||
:new-url new-url
|
||||
:list (if (empty? (or menu-items (list)))
|
||||
(~shared:misc/empty-state :icon "fa fa-inbox"
|
||||
:list (if
|
||||
(empty? (or menu-items (list)))
|
||||
(~shared:misc/empty-state
|
||||
:icon "fa fa-inbox"
|
||||
:message "No menu items yet. Add one to get started!")
|
||||
(~admin/menu-items-list
|
||||
:rows (map (lambda (mi)
|
||||
(~admin/menu-item-row
|
||||
:img (~shared:misc/img-or-placeholder
|
||||
:src (get mi "feature_image") :alt (get mi "label")
|
||||
:size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")
|
||||
:label (get mi "label")
|
||||
:slug (get mi "url")
|
||||
:sort-order (str (or (get mi "sort_order") 0))
|
||||
:edit-url (get mi "edit_url")
|
||||
:delete-url (get mi "delete_url")
|
||||
:confirm-text (str "Remove " (get mi "label") " from the menu?")
|
||||
:hx-headers {:X-CSRFToken csrf}))
|
||||
:rows (map
|
||||
(lambda
|
||||
(mi)
|
||||
(let-match
|
||||
{:delete_url delete-url :url url :sort_order sort-order :edit_url edit-url :feature_image feature-image :label label}
|
||||
mi
|
||||
(~admin/menu-item-row
|
||||
:img (~shared:misc/img-or-placeholder
|
||||
:src feature-image
|
||||
:alt label
|
||||
:size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")
|
||||
:label label
|
||||
:slug url
|
||||
:sort-order (str (or sort-order 0))
|
||||
:edit-url edit-url
|
||||
:delete-url delete-url
|
||||
:confirm-text (str "Remove " label " from the menu?")
|
||||
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}"))))
|
||||
(or menu-items (list)))))))
|
||||
|
||||
;; Tag Groups — receives serialized tag group data from service
|
||||
(defcomp ~admin/tag-groups-content (&key groups unassigned-tags create-url csrf)
|
||||
(defcomp
|
||||
~admin/tag-groups-content
|
||||
(&key groups unassigned-tags create-url csrf)
|
||||
(~admin/tag-groups-main
|
||||
:form (~admin/tag-groups-create-form :create-url create-url :csrf csrf)
|
||||
:groups (if (empty? (or groups (list)))
|
||||
(~shared:misc/empty-state :icon "fa fa-tags" :message "No tag groups yet.")
|
||||
:groups (if
|
||||
(empty? (or groups (list)))
|
||||
(~shared:misc/empty-state
|
||||
:icon "fa fa-tags"
|
||||
:message "No tag groups yet.")
|
||||
(~admin/tag-groups-list
|
||||
:items (map (lambda (g)
|
||||
(let* ((fi (get g "feature_image"))
|
||||
(colour (get g "colour"))
|
||||
(name (get g "name"))
|
||||
(initial (slice (or name "?") 0 1))
|
||||
(icon (if fi
|
||||
(~admin/tag-group-icon-image :src fi :name name)
|
||||
(~admin/tag-group-icon-color
|
||||
:style (if colour (str "background:" colour) "background:#e7e5e4")
|
||||
:initial initial))))
|
||||
(~admin/tag-group-li
|
||||
:icon icon
|
||||
:edit-href (get g "edit_href")
|
||||
:name name
|
||||
:slug (or (get g "slug") "")
|
||||
:sort-order (or (get g "sort_order") 0))))
|
||||
:items (map
|
||||
(lambda
|
||||
(g)
|
||||
(let-match
|
||||
{:colour colour :sort_order sort-order* :feature_image fi :edit_href edit-href :slug slug* :name name}
|
||||
g
|
||||
(let*
|
||||
((initial (slice (or name "?") 0 1))
|
||||
(icon
|
||||
(if
|
||||
fi
|
||||
(~admin/tag-group-icon-image :src fi :name name)
|
||||
(~admin/tag-group-icon-color
|
||||
:style (if
|
||||
colour
|
||||
(str "background:" colour)
|
||||
"background:#e7e5e4")
|
||||
:initial initial))))
|
||||
(~admin/tag-group-li
|
||||
:icon icon
|
||||
:edit-href edit-href
|
||||
:name name
|
||||
:slug (or slug* "")
|
||||
:sort-order (or sort-order* 0)))))
|
||||
(or groups (list)))))
|
||||
:unassigned (when (not (empty? (or unassigned-tags (list))))
|
||||
:unassigned (when
|
||||
(not (empty? (or unassigned-tags (list))))
|
||||
(~admin/unassigned-tags
|
||||
:heading (str (len (or unassigned-tags (list))) " Unassigned Tags")
|
||||
:spans (map (lambda (t)
|
||||
(~admin/unassigned-tag :name (get t "name")))
|
||||
:spans (map
|
||||
(lambda (t) (~admin/unassigned-tag :name (get t "name")))
|
||||
(or unassigned-tags (list)))))))
|
||||
|
||||
;; Tag Group Edit — receives serialized tag group + tags from service
|
||||
(defcomp ~admin/tag-group-edit-content (&key group all-tags save-url delete-url csrf)
|
||||
(defcomp
|
||||
~admin/tag-group-edit-content
|
||||
(&key group all-tags save-url delete-url csrf)
|
||||
(~admin/tag-group-edit-main
|
||||
:edit-form (~admin/tag-group-edit-form
|
||||
:save-url save-url :csrf csrf
|
||||
:name (get group "name")
|
||||
:colour (get group "colour")
|
||||
:sort-order (get group "sort_order")
|
||||
:feature-image (get group "feature_image")
|
||||
:tags (map (lambda (t)
|
||||
(~admin/tag-checkbox
|
||||
:tag-id (get t "id")
|
||||
:checked (get t "checked")
|
||||
:img (when (get t "feature_image")
|
||||
(~admin/tag-checkbox-image :src (get t "feature_image")))
|
||||
:name (get t "name")))
|
||||
(or all-tags (list))))
|
||||
:edit-form (let-match
|
||||
{:colour colour :sort_order sort-order :feature_image feature-image :name name}
|
||||
group
|
||||
(~admin/tag-group-edit-form
|
||||
:save-url save-url
|
||||
:csrf csrf
|
||||
:name name
|
||||
:colour colour
|
||||
:sort-order sort-order
|
||||
:feature-image feature-image
|
||||
:tags (map
|
||||
(lambda
|
||||
(t)
|
||||
(let-match
|
||||
{:checked checked :feature_image t-feature-image :id tag-id :name t-name}
|
||||
t
|
||||
(~admin/tag-checkbox
|
||||
:tag-id tag-id
|
||||
:checked checked
|
||||
:img (when
|
||||
t-feature-image
|
||||
(~admin/tag-checkbox-image :src t-feature-image))
|
||||
:name t-name)))
|
||||
(or all-tags (list)))))
|
||||
:delete-form (~admin/tag-group-delete-form :delete-url delete-url :csrf csrf)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
@@ -400,31 +524,54 @@
|
||||
(code value)
|
||||
value))))
|
||||
|
||||
(defcomp ~admin/data-scalar-table (&key columns)
|
||||
(div :class "w-full overflow-x-auto sm:overflow-visible"
|
||||
(table :class "w-full table-fixed text-sm border border-neutral-200 rounded-xl overflow-hidden"
|
||||
(thead :class "bg-neutral-50/70"
|
||||
(tr (th :class "px-3 py-2 text-left font-medium w-40 sm:w-56" "Field")
|
||||
(th :class "px-3 py-2 text-left font-medium" "Value")))
|
||||
(defcomp
|
||||
~admin/data-scalar-table
|
||||
(&key columns)
|
||||
(div
|
||||
:class "w-full overflow-x-auto sm:overflow-visible"
|
||||
(table
|
||||
:class "w-full table-fixed text-sm border border-neutral-200 rounded-xl overflow-hidden"
|
||||
(thead
|
||||
:class "bg-neutral-50/70"
|
||||
(tr
|
||||
(th :class "px-3 py-2 text-left font-medium w-40 sm:w-56" "Field")
|
||||
(th :class "px-3 py-2 text-left font-medium" "Value")))
|
||||
(tbody
|
||||
(map (lambda (col)
|
||||
(tr :class "border-t border-neutral-200 align-top"
|
||||
(td :class "px-3 py-2 whitespace-nowrap text-neutral-600 align-top" (get col "key"))
|
||||
(td :class "px-3 py-2 align-top"
|
||||
(~admin/data-value-cell :value (get col "value") :value-type (get col "type")))))
|
||||
(map
|
||||
(lambda
|
||||
(col)
|
||||
(let-match
|
||||
{:value value :key key :type type}
|
||||
col
|
||||
(tr
|
||||
:class "border-t border-neutral-200 align-top"
|
||||
(td :class "px-3 py-2 whitespace-nowrap text-neutral-600" key)
|
||||
(td
|
||||
:class "px-3 py-2 align-top"
|
||||
(~admin/data-value-cell :value value :value-type type)))))
|
||||
(or columns (list)))))))
|
||||
|
||||
(defcomp ~admin/data-relationship-item (&key index summary children)
|
||||
(tr :class "border-t border-neutral-200 align-top"
|
||||
(defcomp
|
||||
~admin/data-relationship-item
|
||||
(&key index summary children)
|
||||
(tr
|
||||
:class "border-t border-neutral-200 align-top"
|
||||
(td :class "px-2 py-1 whitespace-nowrap align-top" (str index))
|
||||
(td :class "px-2 py-1 align-top"
|
||||
(pre :class "whitespace-pre-wrap break-words break-all text-xs"
|
||||
(td
|
||||
:class "px-2 py-1 align-top"
|
||||
(pre
|
||||
:class "whitespace-pre-wrap break-words break-all text-xs"
|
||||
(code summary))
|
||||
(when children
|
||||
(div :class "mt-2 pl-3 border-l border-neutral-200"
|
||||
(~admin/data-model-content
|
||||
:columns (get children "columns")
|
||||
:relationships (get children "relationships")))))))
|
||||
(when
|
||||
children
|
||||
(div
|
||||
:class "mt-2 pl-3 border-l border-neutral-200"
|
||||
(let-match
|
||||
{:relationships relationships :columns columns}
|
||||
children
|
||||
(~admin/data-model-content
|
||||
:columns columns
|
||||
:relationships relationships)))))))
|
||||
|
||||
(defcomp ~admin/data-relationship (&key name cardinality class-name loaded value)
|
||||
(div :class "rounded-xl border border-neutral-200"
|
||||
@@ -463,29 +610,50 @@
|
||||
:columns (get (get value "children") "columns")
|
||||
:relationships (get (get value "children") "relationships"))))))))))
|
||||
|
||||
(defcomp ~admin/data-model-content (&key columns relationships)
|
||||
(div :class "space-y-4"
|
||||
(defcomp
|
||||
~admin/data-model-content
|
||||
(&key columns relationships)
|
||||
(div
|
||||
:class "space-y-4"
|
||||
(~admin/data-scalar-table :columns columns)
|
||||
(when (not (empty? (or relationships (list))))
|
||||
(div :class "space-y-3"
|
||||
(map (lambda (rel)
|
||||
(~admin/data-relationship
|
||||
:name (get rel "name")
|
||||
:cardinality (get rel "cardinality")
|
||||
:class-name (get rel "class_name")
|
||||
:loaded (get rel "loaded")
|
||||
:value (get rel "value")))
|
||||
(when
|
||||
(not (empty? (or relationships (list))))
|
||||
(div
|
||||
:class "space-y-3"
|
||||
(map
|
||||
(lambda
|
||||
(rel)
|
||||
(let-match
|
||||
{:cardinality cardinality :class_name class-name :loaded loaded :value value :name name}
|
||||
rel
|
||||
(~admin/data-relationship
|
||||
:name name
|
||||
:cardinality cardinality
|
||||
:class-name class-name
|
||||
:loaded loaded
|
||||
:value value)))
|
||||
relationships)))))
|
||||
|
||||
(defcomp ~admin/data-table-content (&key tablename model-data)
|
||||
(if (not model-data)
|
||||
(defcomp
|
||||
~admin/data-table-content
|
||||
(&key tablename model-data)
|
||||
(if
|
||||
(not model-data)
|
||||
(div :class "px-4 py-8 text-stone-400" "No post data available.")
|
||||
(div :class "px-4 py-8"
|
||||
(div :class "mb-6 text-sm text-neutral-500"
|
||||
"Model: " (code "Post") " \u2022 Table: " (code tablename))
|
||||
(~admin/data-model-content
|
||||
:columns (get model-data "columns")
|
||||
:relationships (get model-data "relationships")))))
|
||||
(div
|
||||
:class "px-4 py-8"
|
||||
(div
|
||||
:class "mb-6 text-sm text-neutral-500"
|
||||
"Model: "
|
||||
(code "Post")
|
||||
" • Table: "
|
||||
(code tablename))
|
||||
(let-match
|
||||
{:relationships relationships :columns columns}
|
||||
model-data
|
||||
(~admin/data-model-content
|
||||
:columns columns
|
||||
:relationships relationships)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Calendar month view for browsing/toggling entries (B1)
|
||||
@@ -518,59 +686,117 @@
|
||||
:sx-on:afterSwap "document.body.dispatchEvent(new CustomEvent('entryToggled'))"
|
||||
(span :class "truncate block" name)))
|
||||
|
||||
(defcomp ~admin/calendar-view (&key cal-id year month-name
|
||||
current-url prev-month-url prev-year-url
|
||||
next-month-url next-year-url
|
||||
weekday-names days csrf)
|
||||
(let* ((target (str "#calendar-view-" cal-id)))
|
||||
(div :id (str "calendar-view-" cal-id)
|
||||
:sx-get current-url :sx-trigger "entryToggled from:body" :sx-swap "outerHTML"
|
||||
(header :class "flex items-center justify-center mb-4"
|
||||
(nav :class "flex items-center gap-2 text-xl"
|
||||
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get prev-year-url :sx-target target :sx-swap "outerHTML"
|
||||
(defcomp
|
||||
~admin/calendar-view
|
||||
(&key
|
||||
cal-id
|
||||
year
|
||||
month-name
|
||||
current-url
|
||||
prev-month-url
|
||||
prev-year-url
|
||||
next-month-url
|
||||
next-year-url
|
||||
weekday-names
|
||||
days
|
||||
csrf)
|
||||
(let*
|
||||
((target (str "#calendar-view-" cal-id)))
|
||||
(div
|
||||
:id (str "calendar-view-" cal-id)
|
||||
:sx-get current-url
|
||||
:sx-trigger "entryToggled from:body"
|
||||
:sx-swap "outerHTML"
|
||||
(header
|
||||
:class "flex items-center justify-center mb-4"
|
||||
(nav
|
||||
:class "flex items-center gap-2 text-xl"
|
||||
(a
|
||||
:class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get prev-year-url
|
||||
:sx-target target
|
||||
:sx-swap "outerHTML"
|
||||
(raw! "«"))
|
||||
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get prev-month-url :sx-target target :sx-swap "outerHTML"
|
||||
(a
|
||||
:class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get prev-month-url
|
||||
:sx-target target
|
||||
:sx-swap "outerHTML"
|
||||
(raw! "‹"))
|
||||
(div :class "px-3 font-medium" (str month-name " " year))
|
||||
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get next-month-url :sx-target target :sx-swap "outerHTML"
|
||||
(a
|
||||
:class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get next-month-url
|
||||
:sx-target target
|
||||
:sx-swap "outerHTML"
|
||||
(raw! "›"))
|
||||
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get next-year-url :sx-target target :sx-swap "outerHTML"
|
||||
(a
|
||||
:class "px-2 py-1 hover:bg-stone-100 rounded"
|
||||
:sx-get next-year-url
|
||||
:sx-target target
|
||||
:sx-swap "outerHTML"
|
||||
(raw! "»"))))
|
||||
(div :class "rounded border bg-white"
|
||||
(div :class "hidden sm:grid grid-cols-7 text-center text-xs font-semibold text-stone-700 bg-stone-50 border-b"
|
||||
(map (lambda (wd) (div :class "py-2" wd)) (or weekday-names (list))))
|
||||
(div :class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200"
|
||||
(map (lambda (day)
|
||||
(let* ((extra-cls (if (get day "in_month") "" " bg-stone-50 text-stone-400"))
|
||||
(entries (or (get day "entries") (list))))
|
||||
(div :class (str "min-h-20 bg-white px-2 py-2 text-xs" extra-cls)
|
||||
(div :class "font-medium mb-1" (str (get day "day")))
|
||||
(when (not (empty? entries))
|
||||
(div :class "space-y-0.5"
|
||||
(map (lambda (e)
|
||||
(if (get e "is_associated")
|
||||
(~admin/cal-entry-associated
|
||||
:name (get e "name") :toggle-url (get e "toggle_url") :csrf csrf)
|
||||
(~admin/cal-entry-unassociated
|
||||
:name (get e "name") :toggle-url (get e "toggle_url") :csrf csrf)))
|
||||
entries))))))
|
||||
(div
|
||||
:class "rounded border bg-white"
|
||||
(div
|
||||
:class "hidden sm:grid grid-cols-7 text-center text-xs font-semibold text-stone-700 bg-stone-50 border-b"
|
||||
(map
|
||||
(lambda (wd) (div :class "py-2" wd))
|
||||
(or weekday-names (list))))
|
||||
(div
|
||||
:class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200"
|
||||
(map
|
||||
(lambda
|
||||
(day)
|
||||
(let-match
|
||||
{:entries entries* :in_month in-month :day day-num}
|
||||
day
|
||||
(let*
|
||||
((extra-cls (if in-month "" " bg-stone-50 text-stone-400"))
|
||||
(entries (or entries* (list))))
|
||||
(div
|
||||
:class (str "min-h-20 bg-white px-2 py-2 text-xs" extra-cls)
|
||||
(div :class "font-medium mb-1" (str day-num))
|
||||
(when
|
||||
(not (empty? entries))
|
||||
(div
|
||||
:class "space-y-0.5"
|
||||
(map
|
||||
(lambda
|
||||
(e)
|
||||
(let-match
|
||||
{:is_associated is-associated :toggle_url toggle-url :name name}
|
||||
e
|
||||
(if
|
||||
is-associated
|
||||
(~admin/cal-entry-associated
|
||||
:name name
|
||||
:toggle-url toggle-url
|
||||
:csrf csrf)
|
||||
(~admin/cal-entry-unassociated
|
||||
:name name
|
||||
:toggle-url toggle-url
|
||||
:csrf csrf))))
|
||||
entries)))))))
|
||||
(or days (list))))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Nav entries OOB — renders associated entry/calendar items in scroll wrapper (B2)
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(defcomp ~admin/nav-entries-oob (&key entries calendars)
|
||||
(let* ((entry-list (or entries (list)))
|
||||
(cal-list (or calendars (list)))
|
||||
(has-items (or (not (empty? entry-list)) (not (empty? cal-list))))
|
||||
(nav-cls "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black [.hover-capable_&]:hover:bg-yellow-300 aria-selected:bg-stone-500 aria-selected:text-white [.hover-capable_&[aria-selected=true]:hover]:bg-orange-500 p-2")
|
||||
(scroll-hs "on load or scroll if window.innerWidth >= 640 and my.scrollWidth > my.clientWidth remove .hidden from .entries-nav-arrow add .flex to .entries-nav-arrow else add .hidden to .entries-nav-arrow remove .flex from .entries-nav-arrow end"))
|
||||
(if (not has-items)
|
||||
(defcomp
|
||||
~admin/nav-entries-oob
|
||||
(&key entries calendars)
|
||||
(let*
|
||||
((entry-list (or entries (list)))
|
||||
(cal-list (or calendars (list)))
|
||||
(has-items (or (not (empty? entry-list)) (not (empty? cal-list))))
|
||||
(nav-cls
|
||||
"justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black [.hover-capable_&]:hover:bg-yellow-300 aria-selected:bg-stone-500 aria-selected:text-white [.hover-capable_&[aria-selected=true]:hover]:bg-orange-500 p-2")
|
||||
(scroll-hs
|
||||
"on load or scroll if window.innerWidth >= 640 and my.scrollWidth > my.clientWidth remove .hidden from .entries-nav-arrow add .flex to .entries-nav-arrow else add .hidden to .entries-nav-arrow remove .flex from .entries-nav-arrow end"))
|
||||
(if
|
||||
(not has-items)
|
||||
(~shared:nav/blog-nav-entries-empty)
|
||||
(~shared:misc/scroll-nav-wrapper
|
||||
:wrapper-id "entries-calendars-nav-wrapper"
|
||||
@@ -580,14 +806,27 @@
|
||||
:scroll-hs scroll-hs
|
||||
:right-hs "on click set #associated-items-container.scrollLeft to #associated-items-container.scrollLeft + 200"
|
||||
:items (<>
|
||||
(map (lambda (e)
|
||||
(~shared:navigation/calendar-entry-nav
|
||||
:href (get e "href") :nav-class nav-cls
|
||||
:name (get e "name") :date-str (get e "date_str")))
|
||||
(map
|
||||
(lambda
|
||||
(e)
|
||||
(let-match
|
||||
{:href href :date_str date-str :name name}
|
||||
e
|
||||
(~shared:navigation/calendar-entry-nav
|
||||
:href href
|
||||
:nav-class nav-cls
|
||||
:name name
|
||||
:date-str date-str)))
|
||||
entry-list)
|
||||
(map (lambda (c)
|
||||
(~shared:nav/blog-nav-calendar-item
|
||||
:href (get c "href") :nav-cls nav-cls
|
||||
:name (get c "name")))
|
||||
(map
|
||||
(lambda
|
||||
(c)
|
||||
(let-match
|
||||
{:href href :name name}
|
||||
c
|
||||
(~shared:nav/blog-nav-calendar-item
|
||||
:href href
|
||||
:nav-cls nav-cls
|
||||
:name name)))
|
||||
cal-list))
|
||||
:oob true))))
|
||||
|
||||
1
cart/config/app-config.sx
Normal file
1
cart/config/app-config.sx
Normal file
@@ -0,0 +1 @@
|
||||
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :section-titles ("ingredients" "allergy information" "allergens" "nutritional information" "nutrition" "storage" "directions" "preparation" "serving suggestions" "origin" "country of origin" "recycling" "general information" "additional information" "a note about prices") :blacklist {:category ("branded-goods/alcoholic-drinks" "branded-goods/beers" "branded-goods/ciders" "branded-goods/wines") :product ("list-price-suma-current-suma-price-list-each-bk012-2-html") :product-details ("General Information" "A Note About Prices")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})
|
||||
18
deploy.sh
18
deploy.sh
@@ -53,24 +53,22 @@ fi
|
||||
echo "Building: ${BUILD[*]}"
|
||||
echo ""
|
||||
|
||||
# --- Run unit tests before deploying ---
|
||||
echo "=== Running unit tests ==="
|
||||
docker build -f test/Dockerfile.unit -t rose-ash-test-unit:latest . -q
|
||||
if ! docker run --rm rose-ash-test-unit:latest; then
|
||||
echo ""
|
||||
echo "Unit tests FAILED — aborting deploy."
|
||||
# --- Run unit tests before deploying (skip Playwright — needs running server) ---
|
||||
if ! QUICK=true ./run-tests.sh; then
|
||||
exit 1
|
||||
fi
|
||||
echo "Unit tests passed."
|
||||
echo ""
|
||||
|
||||
for app in "${BUILD[@]}"; do
|
||||
dir=$(_app_dir "$app")
|
||||
echo "=== $app ==="
|
||||
docker build -f "$dir/Dockerfile" -t "$REGISTRY/$app:latest" .
|
||||
docker push "$REGISTRY/$app:latest"
|
||||
docker service update --force "coop_$app" 2>/dev/null \
|
||||
|| echo " (service coop_$app not running — will start on next stack deploy)"
|
||||
case "$app" in
|
||||
sx_docs) svc="sx-web_sx_docs" ;;
|
||||
*) svc="coop_$app" ;;
|
||||
esac
|
||||
docker service update --force "$svc" 2>/dev/null \
|
||||
|| echo " (service $svc not running — will start on next stack deploy)"
|
||||
echo ""
|
||||
done
|
||||
|
||||
|
||||
30
dev-pub.sh
Executable file
30
dev-pub.sh
Executable file
@@ -0,0 +1,30 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
|
||||
# Dev mode for sx-pub (SX-based ActivityPub)
|
||||
# Bind-mounted source + auto-reload on externalnet
|
||||
# Browse to pub.sx-web.org
|
||||
#
|
||||
# Usage:
|
||||
# ./dev-pub.sh # Start sx-pub dev
|
||||
# ./dev-pub.sh down # Stop
|
||||
# ./dev-pub.sh logs # Tail logs
|
||||
# ./dev-pub.sh --build # Rebuild image then start
|
||||
|
||||
COMPOSE="docker compose -p sx-pub -f docker-compose.dev-pub.yml"
|
||||
|
||||
case "${1:-up}" in
|
||||
down)
|
||||
$COMPOSE down
|
||||
;;
|
||||
logs)
|
||||
$COMPOSE logs -f sx_pub
|
||||
;;
|
||||
*)
|
||||
BUILD_FLAG=""
|
||||
if [[ "${1:-}" == "--build" ]]; then
|
||||
BUILD_FLAG="--build"
|
||||
fi
|
||||
$COMPOSE up $BUILD_FLAG
|
||||
;;
|
||||
esac
|
||||
37
dev-sx-native.sh
Executable file
37
dev-sx-native.sh
Executable file
@@ -0,0 +1,37 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
|
||||
# Dev mode for sx_docs using the native OCaml HTTP server.
|
||||
# No Docker, no Python, no Quart — just the OCaml binary.
|
||||
# Caddy still handles TLS and static files on externalnet.
|
||||
#
|
||||
# Usage:
|
||||
# ./dev-sx-native.sh # Start on port 8013
|
||||
# ./dev-sx-native.sh 8014 # Start on custom port
|
||||
# ./dev-sx-native.sh --build # Rebuild OCaml binary first
|
||||
|
||||
PORT="${1:-8013}"
|
||||
BUILD=false
|
||||
|
||||
if [[ "${1:-}" == "--build" ]]; then
|
||||
BUILD=true
|
||||
PORT="${2:-8013}"
|
||||
fi
|
||||
|
||||
# Build if requested or binary doesn't exist
|
||||
BIN="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [[ "$BUILD" == true ]] || [[ ! -f "$BIN" ]]; then
|
||||
echo "[dev-sx-native] Building OCaml binary..."
|
||||
cd hosts/ocaml && eval "$(opam env)" && dune build bin/sx_server.exe && cd ../..
|
||||
echo "[dev-sx-native] Build complete"
|
||||
fi
|
||||
|
||||
# Set project dir so the server finds spec/, lib/, web/, sx/sx/
|
||||
export SX_PROJECT_DIR="$(pwd)"
|
||||
|
||||
echo "[dev-sx-native] Starting OCaml HTTP server on port $PORT"
|
||||
echo "[dev-sx-native] project=$SX_PROJECT_DIR"
|
||||
echo "[dev-sx-native] binary=$BIN"
|
||||
echo ""
|
||||
|
||||
exec "$BIN" --http "$PORT"
|
||||
114
docker-compose.dev-pub.yml
Normal file
114
docker-compose.dev-pub.yml
Normal file
@@ -0,0 +1,114 @@
|
||||
# Dev mode for sx-pub (SX-based ActivityPub)
|
||||
# Starts as sx_docs clone — AP protocol built in SX from scratch
|
||||
# Accessible at pub.sx-web.org via Caddy on externalnet
|
||||
# Own DB + pgbouncer + IPFS node
|
||||
|
||||
services:
|
||||
sx_pub:
|
||||
image: registry.rose-ash.com:5000/sx_docs:latest
|
||||
environment:
|
||||
SX_STANDALONE: "true"
|
||||
SECRET_KEY: "${SECRET_KEY:-pub-dev-secret}"
|
||||
REDIS_URL: redis://redis:6379/0
|
||||
DATABASE_URL: postgresql+asyncpg://postgres:change-me@pgbouncer:5432/sx_pub
|
||||
ALEMBIC_DATABASE_URL: postgresql+psycopg://postgres:change-me@db:5432/sx_pub
|
||||
SX_PUB_DOMAIN: pub.sx-web.org
|
||||
WORKERS: "1"
|
||||
ENVIRONMENT: development
|
||||
RELOAD: "true"
|
||||
SX_USE_REF: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_DEV: "1"
|
||||
OCAMLRUNPARAM: "b"
|
||||
IPFS_API: http://ipfs:5001
|
||||
ports:
|
||||
- "8014:8000"
|
||||
volumes:
|
||||
- /root/sx-pub/_config/dev-sh-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./sx/app.py:/app/app.py
|
||||
- ./sx/sxc:/app/sxc
|
||||
- ./sx/bp:/app/bp
|
||||
- ./sx/services:/app/services
|
||||
- ./sx/content:/app/content
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
- ./sx/__init__.py:/app/__init__.py:ro
|
||||
# Spec + web SX files
|
||||
- ./spec:/app/spec:ro
|
||||
- ./web:/app/web:ro
|
||||
# OCaml SX kernel binary
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
# sibling models for cross-domain SQLAlchemy imports
|
||||
- ./blog/__init__.py:/app/blog/__init__.py:ro
|
||||
- ./blog/models:/app/blog/models:ro
|
||||
- ./market/__init__.py:/app/market/__init__.py:ro
|
||||
- ./market/models:/app/market/models:ro
|
||||
- ./cart/__init__.py:/app/cart/__init__.py:ro
|
||||
- ./cart/models:/app/cart/models:ro
|
||||
- ./events/__init__.py:/app/events/__init__.py:ro
|
||||
- ./events/models:/app/events/models:ro
|
||||
- ./federation/__init__.py:/app/federation/__init__.py:ro
|
||||
- ./federation/models:/app/federation/models:ro
|
||||
- ./account/__init__.py:/app/account/__init__.py:ro
|
||||
- ./account/models:/app/account/models:ro
|
||||
- ./relations/__init__.py:/app/relations/__init__.py:ro
|
||||
- ./relations/models:/app/relations/models:ro
|
||||
- ./likes/__init__.py:/app/likes/__init__.py:ro
|
||||
- ./likes/models:/app/likes/models:ro
|
||||
- ./orders/__init__.py:/app/orders/__init__.py:ro
|
||||
- ./orders/models:/app/orders/models:ro
|
||||
depends_on:
|
||||
- pgbouncer
|
||||
- redis
|
||||
- ipfs
|
||||
networks:
|
||||
- externalnet
|
||||
- default
|
||||
restart: unless-stopped
|
||||
|
||||
db:
|
||||
image: postgres:16
|
||||
environment:
|
||||
POSTGRES_USER: postgres
|
||||
POSTGRES_PASSWORD: change-me
|
||||
POSTGRES_DB: sx_pub
|
||||
volumes:
|
||||
- db_data:/var/lib/postgresql/data
|
||||
restart: unless-stopped
|
||||
|
||||
pgbouncer:
|
||||
image: edoburu/pgbouncer:latest
|
||||
environment:
|
||||
DB_HOST: db
|
||||
DB_PORT: "5432"
|
||||
DB_USER: postgres
|
||||
DB_PASSWORD: change-me
|
||||
POOL_MODE: transaction
|
||||
DEFAULT_POOL_SIZE: "10"
|
||||
MAX_CLIENT_CONN: "100"
|
||||
AUTH_TYPE: plain
|
||||
depends_on:
|
||||
- db
|
||||
restart: unless-stopped
|
||||
|
||||
ipfs:
|
||||
image: ipfs/kubo:latest
|
||||
volumes:
|
||||
- ipfs_data:/data/ipfs
|
||||
restart: unless-stopped
|
||||
|
||||
redis:
|
||||
image: redis:7-alpine
|
||||
restart: unless-stopped
|
||||
|
||||
volumes:
|
||||
db_data:
|
||||
ipfs_data:
|
||||
|
||||
networks:
|
||||
externalnet:
|
||||
external: true
|
||||
17
docker-compose.dev-sx-native.yml
Normal file
17
docker-compose.dev-sx-native.yml
Normal file
@@ -0,0 +1,17 @@
|
||||
# Native OCaml HTTP server for sx_docs — no Python, no Quart
|
||||
# Overrides dev-sx.yml entrypoint to use sx_server --http
|
||||
#
|
||||
# Usage:
|
||||
# docker compose -p sx-dev -f docker-compose.dev-sx.yml -f docker-compose.dev-sx-native.yml up
|
||||
|
||||
services:
|
||||
sx_docs:
|
||||
entrypoint: ["/app/bin/sx_server", "--http", "8000"]
|
||||
environment:
|
||||
SX_PROJECT_DIR: /app
|
||||
SX_SPEC_DIR: /app/spec
|
||||
SX_LIB_DIR: /app/lib
|
||||
SX_WEB_DIR: /app/web
|
||||
volumes:
|
||||
# Static files (CSS, JS, WASM) — served by Caddy on externalnet
|
||||
- ./shared/static:/app/static:ro
|
||||
@@ -1,60 +1,31 @@
|
||||
# Standalone dev mode for sx_docs only
|
||||
# Replaces ~/sx-web production stack with bind-mounted source + auto-reload
|
||||
# Native OCaml SX server — no Python, no Quart
|
||||
# Accessible at sx.rose-ash.com via Caddy on externalnet
|
||||
|
||||
services:
|
||||
sx_docs:
|
||||
image: registry.rose-ash.com:5000/sx_docs:latest
|
||||
entrypoint: ["/app/bin/sx_server", "--http", "8000"]
|
||||
working_dir: /app
|
||||
environment:
|
||||
SX_STANDALONE: "true"
|
||||
SECRET_KEY: "${SECRET_KEY:-sx-dev-secret}"
|
||||
REDIS_URL: redis://redis:6379/0
|
||||
WORKERS: "1"
|
||||
ENVIRONMENT: development
|
||||
RELOAD: "true"
|
||||
SX_USE_REF: "1"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_DEV: "1"
|
||||
SX_PROJECT_DIR: /app
|
||||
OCAMLRUNPARAM: "b"
|
||||
ports:
|
||||
- "8013:8000"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/dev-sh-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./sx/app.py:/app/app.py
|
||||
- ./sx/sxc:/app/sxc
|
||||
- ./sx/bp:/app/bp
|
||||
- ./sx/services:/app/services
|
||||
- ./sx/content:/app/content
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
- ./sx/__init__.py:/app/__init__.py:ro
|
||||
# sibling models for cross-domain SQLAlchemy imports
|
||||
- ./blog/__init__.py:/app/blog/__init__.py:ro
|
||||
- ./blog/models:/app/blog/models:ro
|
||||
- ./market/__init__.py:/app/market/__init__.py:ro
|
||||
- ./market/models:/app/market/models:ro
|
||||
- ./cart/__init__.py:/app/cart/__init__.py:ro
|
||||
- ./cart/models:/app/cart/models:ro
|
||||
- ./events/__init__.py:/app/events/__init__.py:ro
|
||||
- ./events/models:/app/events/models:ro
|
||||
- ./federation/__init__.py:/app/federation/__init__.py:ro
|
||||
- ./federation/models:/app/federation/models:ro
|
||||
- ./account/__init__.py:/app/account/__init__.py:ro
|
||||
- ./account/models:/app/account/models:ro
|
||||
- ./relations/__init__.py:/app/relations/__init__.py:ro
|
||||
- ./relations/models:/app/relations/models:ro
|
||||
- ./likes/__init__.py:/app/likes/__init__.py:ro
|
||||
- ./likes/models:/app/likes/models:ro
|
||||
- ./orders/__init__.py:/app/orders/__init__.py:ro
|
||||
- ./orders/models:/app/orders/models:ro
|
||||
# SX source files (hot-reload on restart)
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./sx/sx:/app/sx:ro
|
||||
- ./sx/sxc:/app/sxc:ro
|
||||
- ./shared:/app/shared:ro
|
||||
# OCaml binary (rebuild with: cd hosts/ocaml && eval $(opam env) && dune build)
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
networks:
|
||||
- externalnet
|
||||
- default
|
||||
restart: unless-stopped
|
||||
|
||||
redis:
|
||||
image: redis:7-alpine
|
||||
restart: unless-stopped
|
||||
|
||||
networks:
|
||||
externalnet:
|
||||
external: true
|
||||
|
||||
@@ -12,6 +12,8 @@ x-dev-env: &dev-env
|
||||
WORKERS: "1"
|
||||
SX_USE_REF: "1"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
x-sibling-models: &sibling-models
|
||||
# Every app needs all sibling __init__.py + models/ for cross-domain SQLAlchemy imports
|
||||
@@ -44,6 +46,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./blog/alembic.ini:/app/blog/alembic.ini:ro
|
||||
- ./blog/alembic:/app/blog/alembic:ro
|
||||
- ./blog/app.py:/app/app.py
|
||||
@@ -83,6 +89,10 @@ services:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- /root/rose-ash/_snapshot:/app/_snapshot
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./market/alembic.ini:/app/market/alembic.ini:ro
|
||||
- ./market/alembic:/app/market/alembic:ro
|
||||
- ./market/app.py:/app/app.py
|
||||
@@ -121,6 +131,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./cart/alembic.ini:/app/cart/alembic.ini:ro
|
||||
- ./cart/alembic:/app/cart/alembic:ro
|
||||
- ./cart/app.py:/app/app.py
|
||||
@@ -159,6 +173,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./events/alembic.ini:/app/events/alembic.ini:ro
|
||||
- ./events/alembic:/app/events/alembic:ro
|
||||
- ./events/app.py:/app/app.py
|
||||
@@ -197,6 +215,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./federation/alembic.ini:/app/federation/alembic.ini:ro
|
||||
- ./federation/alembic:/app/federation/alembic:ro
|
||||
- ./federation/app.py:/app/app.py
|
||||
@@ -235,6 +257,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./account/alembic.ini:/app/account/alembic.ini:ro
|
||||
- ./account/alembic:/app/account/alembic:ro
|
||||
- ./account/app.py:/app/app.py
|
||||
@@ -273,6 +299,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./relations/alembic.ini:/app/relations/alembic.ini:ro
|
||||
- ./relations/alembic:/app/relations/alembic:ro
|
||||
- ./relations/app.py:/app/app.py
|
||||
@@ -304,6 +334,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./likes/alembic.ini:/app/likes/alembic.ini:ro
|
||||
- ./likes/alembic:/app/likes/alembic:ro
|
||||
- ./likes/app.py:/app/app.py
|
||||
@@ -335,6 +369,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./orders/alembic.ini:/app/orders/alembic.ini:ro
|
||||
- ./orders/alembic:/app/orders/alembic:ro
|
||||
- ./orders/app.py:/app/app.py
|
||||
@@ -369,6 +407,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./test/app.py:/app/app.py
|
||||
- ./test/sx:/app/sx
|
||||
- ./test/bp:/app/bp
|
||||
@@ -393,9 +435,14 @@ services:
|
||||
- "8012:8000"
|
||||
environment:
|
||||
<<: *dev-env
|
||||
SX_STANDALONE: "true"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./sx/app.py:/app/app.py
|
||||
- ./sx/sxc:/app/sxc
|
||||
- ./sx/bp:/app/bp
|
||||
@@ -431,6 +478,10 @@ services:
|
||||
dockerfile: test/Dockerfile.unit
|
||||
volumes:
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./artdag/core:/app/artdag/core
|
||||
- ./artdag/l1/tests:/app/artdag/l1/tests
|
||||
- ./artdag/l1/sexp_effects:/app/artdag/l1/sexp_effects
|
||||
@@ -456,6 +507,10 @@ services:
|
||||
dockerfile: test/Dockerfile.integration
|
||||
volumes:
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./artdag:/app/artdag
|
||||
profiles:
|
||||
- test
|
||||
|
||||
@@ -58,6 +58,8 @@ x-app-env: &app-env
|
||||
EXTERNAL_INBOXES: "artdag|https://celery-artdag.rose-ash.com/inbox"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_REF: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
services:
|
||||
blog:
|
||||
|
||||
1
events/config/app-config.sx
Normal file
1
events/config/app-config.sx
Normal file
@@ -0,0 +1 @@
|
||||
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :section-titles ("ingredients" "allergy information" "allergens" "nutritional information" "nutrition" "storage" "directions" "preparation" "serving suggestions" "origin" "country of origin" "recycling" "general information" "additional information" "a note about prices") :blacklist {:category ("branded-goods/alcoholic-drinks" "branded-goods/beers" "branded-goods/ciders" "branded-goods/wines") :product ("list-price-suma-current-suma-price-list-each-bk012-2-html") :product-details ("General Information" "A Note About Prices")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})
|
||||
@@ -159,91 +159,147 @@
|
||||
:btn (~page/tw-plus))))))
|
||||
|
||||
;; Entry card (list view) from data
|
||||
(defcomp ~entries/entry-card-from-data (&key entry-href name day-href
|
||||
page-badge-href page-badge-title cal-name
|
||||
date-str start-time end-time is-page-scoped
|
||||
cost has-ticket ticket-data)
|
||||
(defcomp
|
||||
~entries/entry-card-from-data
|
||||
(&key
|
||||
entry-href
|
||||
name
|
||||
day-href
|
||||
page-badge-href
|
||||
page-badge-title
|
||||
cal-name
|
||||
date-str
|
||||
start-time
|
||||
end-time
|
||||
is-page-scoped
|
||||
cost
|
||||
has-ticket
|
||||
ticket-data)
|
||||
(~entries/entry-card
|
||||
:title (if entry-href
|
||||
:title (if
|
||||
entry-href
|
||||
(~entries/entry-title-linked :href entry-href :name name)
|
||||
(~entries/entry-title-plain :name name))
|
||||
:badges (<>
|
||||
(when page-badge-title
|
||||
(~entries/entry-page-badge :href page-badge-href :title page-badge-title))
|
||||
(when cal-name
|
||||
(~entries/entry-cal-badge :name cal-name)))
|
||||
(when
|
||||
page-badge-title
|
||||
(~entries/entry-page-badge
|
||||
:href page-badge-href
|
||||
:title page-badge-title))
|
||||
(when cal-name (~entries/entry-cal-badge :name cal-name)))
|
||||
:time-parts (<>
|
||||
(when (and day-href (not is-page-scoped))
|
||||
(when
|
||||
(and day-href (not is-page-scoped))
|
||||
(~entries/entry-time-linked :href day-href :date-str date-str))
|
||||
(when (and (not day-href) (not is-page-scoped) date-str)
|
||||
(when
|
||||
(and (not day-href) (not is-page-scoped) date-str)
|
||||
(~entries/entry-time-plain :date-str date-str))
|
||||
start-time
|
||||
(when end-time (str " \u2013 " end-time)))
|
||||
(when end-time (str " – " end-time)))
|
||||
:cost (when cost (~entries/entry-cost :cost cost))
|
||||
:widget (when has-ticket
|
||||
(~entries/entry-widget-wrapper
|
||||
:widget (~entries/tw-widget-from-data
|
||||
:entry-id (get ticket-data "entry-id")
|
||||
:price (get ticket-data "price")
|
||||
:qty (get ticket-data "qty")
|
||||
:ticket-url (get ticket-data "ticket-url")
|
||||
:csrf (get ticket-data "csrf"))))))
|
||||
:widget (when
|
||||
has-ticket
|
||||
(let-match
|
||||
{:csrf csrf :entry-id entry-id :qty qty :price price :ticket-url ticket-url}
|
||||
ticket-data
|
||||
(~entries/entry-widget-wrapper
|
||||
:widget (~entries/tw-widget-from-data
|
||||
:entry-id entry-id
|
||||
:price price
|
||||
:qty qty
|
||||
:ticket-url ticket-url
|
||||
:csrf csrf))))))
|
||||
|
||||
;; Entry card (tile view) from data
|
||||
(defcomp ~entries/entry-card-tile-from-data (&key entry-href name day-href
|
||||
page-badge-href page-badge-title cal-name
|
||||
date-str time-str
|
||||
cost has-ticket ticket-data)
|
||||
(defcomp
|
||||
~entries/entry-card-tile-from-data
|
||||
(&key
|
||||
entry-href
|
||||
name
|
||||
day-href
|
||||
page-badge-href
|
||||
page-badge-title
|
||||
cal-name
|
||||
date-str
|
||||
time-str
|
||||
cost
|
||||
has-ticket
|
||||
ticket-data)
|
||||
(~entries/entry-card-tile
|
||||
:title (if entry-href
|
||||
:title (if
|
||||
entry-href
|
||||
(~entries/entry-title-tile-linked :href entry-href :name name)
|
||||
(~entries/entry-title-tile-plain :name name))
|
||||
:badges (<>
|
||||
(when page-badge-title
|
||||
(~entries/entry-page-badge :href page-badge-href :title page-badge-title))
|
||||
(when cal-name
|
||||
(~entries/entry-cal-badge :name cal-name)))
|
||||
(when
|
||||
page-badge-title
|
||||
(~entries/entry-page-badge
|
||||
:href page-badge-href
|
||||
:title page-badge-title))
|
||||
(when cal-name (~entries/entry-cal-badge :name cal-name)))
|
||||
:time time-str
|
||||
:cost (when cost (~entries/entry-cost :cost cost))
|
||||
:widget (when has-ticket
|
||||
(~entries/entry-tile-widget-wrapper
|
||||
:widget (~entries/tw-widget-from-data
|
||||
:entry-id (get ticket-data "entry-id")
|
||||
:price (get ticket-data "price")
|
||||
:qty (get ticket-data "qty")
|
||||
:ticket-url (get ticket-data "ticket-url")
|
||||
:csrf (get ticket-data "csrf"))))))
|
||||
:widget (when
|
||||
has-ticket
|
||||
(let-match
|
||||
{:csrf csrf :entry-id entry-id :qty qty :price price :ticket-url ticket-url}
|
||||
ticket-data
|
||||
(~entries/entry-tile-widget-wrapper
|
||||
:widget (~entries/tw-widget-from-data
|
||||
:entry-id entry-id
|
||||
:price price
|
||||
:qty qty
|
||||
:ticket-url ticket-url
|
||||
:csrf csrf))))))
|
||||
|
||||
;; Entry cards list (with date separators + sentinel) from data
|
||||
(defcomp ~entries/entry-cards-from-data (&key items view page has-more next-url)
|
||||
(defcomp
|
||||
~entries/entry-cards-from-data
|
||||
(&key items view page has-more next-url)
|
||||
(<>
|
||||
(map (lambda (item)
|
||||
(if (get item "is-separator")
|
||||
(~entries/date-separator :date-str (get item "date-str"))
|
||||
(if (= view "tile")
|
||||
(~entries/entry-card-tile-from-data
|
||||
:entry-href (get item "entry-href") :name (get item "name")
|
||||
:day-href (get item "day-href")
|
||||
:page-badge-href (get item "page-badge-href")
|
||||
:page-badge-title (get item "page-badge-title")
|
||||
:cal-name (get item "cal-name")
|
||||
:date-str (get item "date-str") :time-str (get item "time-str")
|
||||
:cost (get item "cost") :has-ticket (get item "has-ticket")
|
||||
:ticket-data (get item "ticket-data"))
|
||||
(~entries/entry-card-from-data
|
||||
:entry-href (get item "entry-href") :name (get item "name")
|
||||
:day-href (get item "day-href")
|
||||
:page-badge-href (get item "page-badge-href")
|
||||
:page-badge-title (get item "page-badge-title")
|
||||
:cal-name (get item "cal-name")
|
||||
:date-str (get item "date-str")
|
||||
:start-time (get item "start-time") :end-time (get item "end-time")
|
||||
:is-page-scoped (get item "is-page-scoped")
|
||||
:cost (get item "cost") :has-ticket (get item "has-ticket")
|
||||
:ticket-data (get item "ticket-data")))))
|
||||
(map
|
||||
(lambda
|
||||
(item)
|
||||
(let-match
|
||||
{:date-str date-str :time-str time-str :has-ticket has-ticket :is-separator is-separator :ticket-data ticket-data :day-href day-href :page-badge-title page-badge-title :entry-href entry-href :start-time start-time :end-time end-time :is-page-scoped is-page-scoped :page-badge-href page-badge-href :cal-name cal-name :cost cost :name name}
|
||||
item
|
||||
(if
|
||||
is-separator
|
||||
(~entries/date-separator :date-str date-str)
|
||||
(if
|
||||
(= view "tile")
|
||||
(~entries/entry-card-tile-from-data
|
||||
:entry-href entry-href
|
||||
:name name
|
||||
:day-href day-href
|
||||
:page-badge-href page-badge-href
|
||||
:page-badge-title page-badge-title
|
||||
:cal-name cal-name
|
||||
:date-str date-str
|
||||
:time-str time-str
|
||||
:cost cost
|
||||
:has-ticket has-ticket
|
||||
:ticket-data ticket-data)
|
||||
(~entries/entry-card-from-data
|
||||
:entry-href entry-href
|
||||
:name name
|
||||
:day-href day-href
|
||||
:page-badge-href page-badge-href
|
||||
:page-badge-title page-badge-title
|
||||
:cal-name cal-name
|
||||
:date-str date-str
|
||||
:start-time start-time
|
||||
:end-time end-time
|
||||
:is-page-scoped is-page-scoped
|
||||
:cost cost
|
||||
:has-ticket has-ticket
|
||||
:ticket-data ticket-data)))))
|
||||
(or items (list)))
|
||||
(when has-more
|
||||
(~shared:misc/sentinel-simple :id (str "sentinel-" page) :next-url next-url))))
|
||||
(when
|
||||
has-more
|
||||
(~shared:misc/sentinel-simple
|
||||
:id (str "sentinel-" page)
|
||||
:next-url next-url))))
|
||||
|
||||
;; Events main panel (toggle + cards grid) from data
|
||||
(defcomp ~entries/main-panel-from-data (&key toggle items view page has-more next-url)
|
||||
|
||||
@@ -323,28 +323,43 @@
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; Day checkboxes from data — replaces Python loop
|
||||
(defcomp ~forms/day-checkboxes-from-data (&key days-data all-checked)
|
||||
(defcomp
|
||||
~forms/day-checkboxes-from-data
|
||||
(&key days-data all-checked)
|
||||
(<>
|
||||
(~forms/day-all-checkbox :checked (when all-checked "checked"))
|
||||
(map (lambda (d)
|
||||
(~forms/day-checkbox
|
||||
:name (get d "name")
|
||||
:label (get d "label")
|
||||
:checked (when (get d "checked") "checked")))
|
||||
(map
|
||||
(lambda
|
||||
(d)
|
||||
(let-match
|
||||
{:checked checked :label label :name name}
|
||||
d
|
||||
(~forms/day-checkbox
|
||||
:name name
|
||||
:label label
|
||||
:checked (when checked "checked"))))
|
||||
(or days-data (list)))))
|
||||
|
||||
;; Slot options from data — replaces _slot_options_html Python loop
|
||||
(defcomp ~forms/slot-options-from-data (&key slots)
|
||||
(<> (map (lambda (s)
|
||||
(~forms/slot-option
|
||||
:value (get s "value")
|
||||
:data-start (get s "data-start")
|
||||
:data-end (get s "data-end")
|
||||
:data-flexible (get s "data-flexible")
|
||||
:data-cost (get s "data-cost")
|
||||
:selected (get s "selected")
|
||||
:label (get s "label")))
|
||||
(or slots (list)))))
|
||||
(defcomp
|
||||
~forms/slot-options-from-data
|
||||
(&key slots)
|
||||
(<>
|
||||
(map
|
||||
(lambda
|
||||
(s)
|
||||
(let-match
|
||||
{:data-end data-end :data-flexible data-flexible :selected selected :value value :data-cost data-cost :label label :data-start data-start}
|
||||
s
|
||||
(~forms/slot-option
|
||||
:value value
|
||||
:data-start data-start
|
||||
:data-end data-end
|
||||
:data-flexible data-flexible
|
||||
:data-cost data-cost
|
||||
:selected selected
|
||||
:label label)))
|
||||
(or slots (list)))))
|
||||
|
||||
;; Slot picker from data — wraps picker + options
|
||||
(defcomp ~forms/slot-picker-from-data (&key id slots)
|
||||
|
||||
@@ -5,155 +5,247 @@
|
||||
;; Auto-fetching header macros — calendar, day, entry, slot, tickets
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(defmacro ~events-calendar-header-auto (oob)
|
||||
(defmacro
|
||||
~events-calendar-header-auto
|
||||
(oob)
|
||||
"Calendar header row using (events-calendar-ctx)."
|
||||
(quasiquote
|
||||
(let ((__cal (events-calendar-ctx))
|
||||
(__sc (select-colours)))
|
||||
(when (get __cal "slug")
|
||||
(~shared:layout/menu-row-sx :id "calendar-row" :level 3
|
||||
:link-href (url-for "calendar.get"
|
||||
:calendar-slug (get __cal "slug"))
|
||||
:link-label-content (~header/calendar-label
|
||||
:name (get __cal "name")
|
||||
:description (get __cal "description"))
|
||||
:nav (<>
|
||||
(~shared:layout/nav-link :href (url-for "defpage_slots_listing"
|
||||
:calendar-slug (get __cal "slug"))
|
||||
:icon "fa fa-clock" :label "Slots"
|
||||
:select-colours __sc)
|
||||
(let ((__rights (app-rights)))
|
||||
(when (get __rights "admin")
|
||||
(~shared:layout/nav-link :href (url-for "defpage_calendar_admin"
|
||||
:calendar-slug (get __cal "slug"))
|
||||
:icon "fa fa-cog"
|
||||
:select-colours __sc))))
|
||||
:child-id "calendar-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__cal (events-calendar-ctx)) (__sc (select-colours)))
|
||||
(let-match
|
||||
{:description description :slug slug :name name}
|
||||
__cal
|
||||
(when
|
||||
slug
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "calendar-row"
|
||||
:level 3
|
||||
:link-href (url-for "calendar.get" :calendar-slug slug)
|
||||
:link-label-content (~header/calendar-label :name name :description description)
|
||||
:nav (<>
|
||||
(~shared:layout/nav-link
|
||||
:href (url-for "defpage_slots_listing" :calendar-slug slug)
|
||||
:icon "fa fa-clock"
|
||||
:label "Slots"
|
||||
:select-colours __sc)
|
||||
(let
|
||||
((__rights (app-rights)))
|
||||
(when
|
||||
(get __rights "admin")
|
||||
(~shared:layout/nav-link
|
||||
:href (url-for "defpage_calendar_admin" :calendar-slug slug)
|
||||
:icon "fa fa-cog"
|
||||
:select-colours __sc))))
|
||||
:child-id "calendar-header-child"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-calendar-admin-header-auto (oob)
|
||||
(defmacro
|
||||
~events-calendar-admin-header-auto
|
||||
(oob)
|
||||
"Calendar admin header row."
|
||||
(quasiquote
|
||||
(let ((__cal (events-calendar-ctx))
|
||||
(__sc (select-colours)))
|
||||
(when (get __cal "slug")
|
||||
(~shared:layout/menu-row-sx :id "calendar-admin-row" :level 4
|
||||
:link-label "admin" :icon "fa fa-cog"
|
||||
:nav (<>
|
||||
(~shared:layout/nav-link :href (url-for "defpage_slots_listing"
|
||||
:calendar-slug (get __cal "slug"))
|
||||
:label "slots" :select-colours __sc)
|
||||
(~shared:layout/nav-link :href (url-for "calendar.admin.calendar_description_edit"
|
||||
:calendar-slug (get __cal "slug"))
|
||||
:label "description" :select-colours __sc))
|
||||
:child-id "calendar-admin-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__cal (events-calendar-ctx)) (__sc (select-colours)))
|
||||
(let-match
|
||||
{:slug slug}
|
||||
__cal
|
||||
(when
|
||||
slug
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "calendar-admin-row"
|
||||
:level 4
|
||||
:link-label "admin"
|
||||
:icon "fa fa-cog"
|
||||
:nav (<>
|
||||
(~shared:layout/nav-link
|
||||
:href (url-for "defpage_slots_listing" :calendar-slug slug)
|
||||
:label "slots"
|
||||
:select-colours __sc)
|
||||
(~shared:layout/nav-link
|
||||
:href (url-for
|
||||
"calendar.admin.calendar_description_edit"
|
||||
:calendar-slug slug)
|
||||
:label "description"
|
||||
:select-colours __sc))
|
||||
:child-id "calendar-admin-header-child"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-day-header-auto (oob)
|
||||
(defmacro
|
||||
~events-day-header-auto
|
||||
(oob)
|
||||
"Day header row using (events-day-ctx)."
|
||||
(quasiquote
|
||||
(let ((__day (events-day-ctx))
|
||||
(__cal (events-calendar-ctx)))
|
||||
(when (get __day "date-str")
|
||||
(~shared:layout/menu-row-sx :id "day-row" :level 4
|
||||
:link-href (url-for "calendar.day.show_day"
|
||||
:calendar-slug (get __cal "slug")
|
||||
:year (get __day "year")
|
||||
:month (get __day "month")
|
||||
:day (get __day "day"))
|
||||
:link-label-content (~header/day-label
|
||||
:date-str (get __day "date-str"))
|
||||
:nav (get __day "nav")
|
||||
:child-id "day-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__day (events-day-ctx)) (__cal (events-calendar-ctx)))
|
||||
(let-match
|
||||
{:date-str date-str :nav nav :year year :day day :month month}
|
||||
__day
|
||||
(when
|
||||
date-str
|
||||
(let-match
|
||||
{:slug cal-slug}
|
||||
__cal
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "day-row"
|
||||
:level 4
|
||||
:link-href (url-for
|
||||
"calendar.day.show_day"
|
||||
:calendar-slug cal-slug
|
||||
:year year
|
||||
:month month
|
||||
:day day)
|
||||
:link-label-content (~header/day-label :date-str date-str)
|
||||
:nav nav
|
||||
:child-id "day-header-child"
|
||||
:oob (unquote oob))))))))
|
||||
|
||||
(defmacro ~events-day-admin-header-auto (oob)
|
||||
(defmacro
|
||||
~events-day-admin-header-auto
|
||||
(oob)
|
||||
"Day admin header row."
|
||||
(quasiquote
|
||||
(let ((__day (events-day-ctx))
|
||||
(__cal (events-calendar-ctx)))
|
||||
(when (get __day "date-str")
|
||||
(~shared:layout/menu-row-sx :id "day-admin-row" :level 5
|
||||
:link-href (url-for "defpage_day_admin"
|
||||
:calendar-slug (get __cal "slug")
|
||||
:year (get __day "year")
|
||||
:month (get __day "month")
|
||||
:day (get __day "day"))
|
||||
:link-label "admin" :icon "fa fa-cog"
|
||||
:child-id "day-admin-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__day (events-day-ctx)) (__cal (events-calendar-ctx)))
|
||||
(let-match
|
||||
{:date-str date-str :year year :day day :month month}
|
||||
__day
|
||||
(when
|
||||
date-str
|
||||
(let-match
|
||||
{:slug cal-slug}
|
||||
__cal
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "day-admin-row"
|
||||
:level 5
|
||||
:link-href (url-for
|
||||
"defpage_day_admin"
|
||||
:calendar-slug cal-slug
|
||||
:year year
|
||||
:month month
|
||||
:day day)
|
||||
:link-label "admin"
|
||||
:icon "fa fa-cog"
|
||||
:child-id "day-admin-header-child"
|
||||
:oob (unquote oob))))))))
|
||||
|
||||
(defmacro ~events-entry-header-auto (oob)
|
||||
(defmacro
|
||||
~events-entry-header-auto
|
||||
(oob)
|
||||
"Entry header row using (events-entry-ctx)."
|
||||
(quasiquote
|
||||
(let ((__ectx (events-entry-ctx)))
|
||||
(when (get __ectx "id")
|
||||
(~shared:layout/menu-row-sx :id "entry-row" :level 5
|
||||
:link-href (get __ectx "link-href")
|
||||
:link-label-content (~header/entry-label
|
||||
:entry-id (get __ectx "id")
|
||||
:title (~admin/entry-title :name (get __ectx "name"))
|
||||
:times (~admin/entry-times :time-str (get __ectx "time-str")))
|
||||
:nav (get __ectx "nav")
|
||||
:child-id "entry-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__ectx (events-entry-ctx)))
|
||||
(let-match
|
||||
{:time-str time-str :nav nav :link-href link-href :id id :name name}
|
||||
__ectx
|
||||
(when
|
||||
id
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "entry-row"
|
||||
:level 5
|
||||
:link-href link-href
|
||||
:link-label-content (~header/entry-label
|
||||
:entry-id id
|
||||
:title (~admin/entry-title :name name)
|
||||
:times (~admin/entry-times :time-str time-str))
|
||||
:nav nav
|
||||
:child-id "entry-header-child"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-entry-admin-header-auto (oob)
|
||||
(defmacro
|
||||
~events-entry-admin-header-auto
|
||||
(oob)
|
||||
"Entry admin header row."
|
||||
(quasiquote
|
||||
(let ((__ectx (events-entry-ctx)))
|
||||
(when (get __ectx "id")
|
||||
(~shared:layout/menu-row-sx :id "entry-admin-row" :level 6
|
||||
:link-href (get __ectx "admin-href")
|
||||
:link-label "admin" :icon "fa fa-cog"
|
||||
:nav (when (get __ectx "is-admin")
|
||||
(~shared:layout/nav-link :href (get __ectx "ticket-types-href")
|
||||
:label "ticket_types"
|
||||
:select-colours (get __ectx "select-colours")))
|
||||
:child-id "entry-admin-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__ectx (events-entry-ctx)))
|
||||
(let-match
|
||||
{:admin-href admin-href :is-admin is-admin :ticket-types-href ticket-types-href :select-colours select-colours :id id}
|
||||
__ectx
|
||||
(when
|
||||
id
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "entry-admin-row"
|
||||
:level 6
|
||||
:link-href admin-href
|
||||
:link-label "admin"
|
||||
:icon "fa fa-cog"
|
||||
:nav (when
|
||||
is-admin
|
||||
(~shared:layout/nav-link
|
||||
:href ticket-types-href
|
||||
:label "ticket_types"
|
||||
:select-colours select-colours))
|
||||
:child-id "entry-admin-header-child"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-slot-header-auto (oob)
|
||||
(defmacro
|
||||
~events-slot-header-auto
|
||||
(oob)
|
||||
"Slot detail header row using (events-slot-ctx)."
|
||||
(quasiquote
|
||||
(let ((__slot (events-slot-ctx)))
|
||||
(when (get __slot "name")
|
||||
(~shared:layout/menu-row-sx :id "slot-row" :level 5
|
||||
:link-label-content (~header/slot-label
|
||||
:name (get __slot "name")
|
||||
:description (get __slot "description"))
|
||||
:child-id "slot-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__slot (events-slot-ctx)))
|
||||
(let-match
|
||||
{:description description :name name}
|
||||
__slot
|
||||
(when
|
||||
name
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "slot-row"
|
||||
:level 5
|
||||
:link-label-content (~header/slot-label :name name :description description)
|
||||
:child-id "slot-header-child"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-ticket-types-header-auto (oob)
|
||||
(defmacro
|
||||
~events-ticket-types-header-auto
|
||||
(oob)
|
||||
"Ticket types header row."
|
||||
(quasiquote
|
||||
(let ((__ectx (events-entry-ctx))
|
||||
(__cal (events-calendar-ctx)))
|
||||
(when (get __ectx "id")
|
||||
(~shared:layout/menu-row-sx :id "ticket_types-row" :level 7
|
||||
:link-href (get __ectx "ticket-types-href")
|
||||
:link-label-content (<>
|
||||
(i :class "fa fa-ticket")
|
||||
(div :class "shrink-0" "ticket types"))
|
||||
:nav (~forms/admin-placeholder-nav)
|
||||
:child-id "ticket_type-header-child"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__ectx (events-entry-ctx)) (__cal (events-calendar-ctx)))
|
||||
(let-match
|
||||
{:ticket-types-href ticket-types-href :id id}
|
||||
__ectx
|
||||
(when
|
||||
id
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "ticket_types-row"
|
||||
:level 7
|
||||
:link-href ticket-types-href
|
||||
:link-label-content (<>
|
||||
(i :class "fa fa-ticket")
|
||||
(div :class "shrink-0" "ticket types"))
|
||||
:nav (~forms/admin-placeholder-nav)
|
||||
:child-id "ticket_type-header-child"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-ticket-type-header-auto (oob)
|
||||
(defmacro
|
||||
~events-ticket-type-header-auto
|
||||
(oob)
|
||||
"Single ticket type header row using (events-ticket-type-ctx)."
|
||||
(quasiquote
|
||||
(let ((__tt (events-ticket-type-ctx)))
|
||||
(when (get __tt "id")
|
||||
(~shared:layout/menu-row-sx :id "ticket_type-row" :level 8
|
||||
:link-href (get __tt "link-href")
|
||||
:link-label-content (div :class "flex flex-col md:flex-row md:gap-2 items-center"
|
||||
(div :class "flex flex-row items-center gap-2"
|
||||
(i :class "fa fa-ticket")
|
||||
(div :class "shrink-0" (get __tt "name"))))
|
||||
:nav (~forms/admin-placeholder-nav)
|
||||
:child-id "ticket_type-header-child-inner"
|
||||
:oob (unquote oob))))))
|
||||
(let
|
||||
((__tt (events-ticket-type-ctx)))
|
||||
(let-match
|
||||
{:link-href link-href :id id :name name}
|
||||
__tt
|
||||
(when
|
||||
id
|
||||
(~shared:layout/menu-row-sx
|
||||
:id "ticket_type-row"
|
||||
:level 8
|
||||
:link-href link-href
|
||||
:link-label-content (div
|
||||
:class "flex flex-col md:flex-row md:gap-2 items-baseline"
|
||||
(div
|
||||
:class "flex flex-row items-center gap-2"
|
||||
(i :class "fa fa-ticket")
|
||||
(div :class "shrink-0" name)))
|
||||
:nav (~forms/admin-placeholder-nav)
|
||||
:child-id "ticket_type-header-child-inner"
|
||||
:oob (unquote oob)))))))
|
||||
|
||||
(defmacro ~events-markets-header-auto (oob)
|
||||
"Markets section header row."
|
||||
|
||||
@@ -98,24 +98,47 @@
|
||||
(~page/slot-description-oob :description (or description "")))))
|
||||
|
||||
;; Slots table from data
|
||||
(defcomp ~page/slots-table-from-data (&key list-container slots pre-action add-url
|
||||
tr-cls pill-cls action-btn hx-select csrf-hdr)
|
||||
(defcomp
|
||||
~page/slots-table-from-data
|
||||
(&key
|
||||
list-container
|
||||
slots
|
||||
pre-action
|
||||
add-url
|
||||
tr-cls
|
||||
pill-cls
|
||||
action-btn
|
||||
hx-select
|
||||
csrf-hdr)
|
||||
(~page/slots-table
|
||||
:list-container list-container
|
||||
:rows (if (empty? (or slots (list)))
|
||||
:rows (if
|
||||
(empty? (or slots (list)))
|
||||
(~page/slots-empty-row)
|
||||
(<> (map (lambda (s)
|
||||
(~page/slots-row
|
||||
:tr-cls tr-cls :slot-href (get s "slot-href")
|
||||
:pill-cls pill-cls :hx-select hx-select
|
||||
:slot-name (get s "slot-name") :description (get s "description")
|
||||
:flexible (get s "flexible")
|
||||
:days (~page/days-pills-from-data :days (get s "days"))
|
||||
:time-str (get s "time-str")
|
||||
:cost-str (get s "cost-str") :action-btn action-btn
|
||||
:del-url (get s "del-url") :csrf-hdr csrf-hdr))
|
||||
(or slots (list)))))
|
||||
:pre-action pre-action :add-url add-url))
|
||||
(<>
|
||||
(map
|
||||
(lambda
|
||||
(s)
|
||||
(let-match
|
||||
{:slot-name slot-name :time-str time-str :flexible flexible :description description :days days :cost-str cost-str :del-url del-url :slot-href slot-href}
|
||||
s
|
||||
(~page/slots-row
|
||||
:tr-cls tr-cls
|
||||
:slot-href slot-href
|
||||
:pill-cls pill-cls
|
||||
:hx-select hx-select
|
||||
:slot-name slot-name
|
||||
:description description
|
||||
:flexible flexible
|
||||
:days (~page/days-pills-from-data :days days)
|
||||
:time-str time-str
|
||||
:cost-str cost-str
|
||||
:action-btn action-btn
|
||||
:del-url del-url
|
||||
:csrf-hdr csrf-hdr)))
|
||||
(or slots (list)))))
|
||||
:pre-action pre-action
|
||||
:add-url add-url))
|
||||
|
||||
(defcomp ~page/ticket-type-col (&key label value)
|
||||
(div :class "flex flex-col"
|
||||
@@ -203,47 +226,87 @@
|
||||
:onclick hide-js "Cancel"))))
|
||||
|
||||
;; Data-driven buy form — Python passes pre-resolved data, .sx does layout + iteration
|
||||
(defcomp ~page/buy-form (&key entry-id info-sold info-remaining info-basket
|
||||
ticket-types user-ticket-counts-by-type
|
||||
user-ticket-count price-str adjust-url csrf state
|
||||
my-tickets-href)
|
||||
(if (!= state "confirmed")
|
||||
(defcomp
|
||||
~page/buy-form
|
||||
(&key
|
||||
entry-id
|
||||
info-sold
|
||||
info-remaining
|
||||
info-basket
|
||||
ticket-types
|
||||
user-ticket-counts-by-type
|
||||
user-ticket-count
|
||||
price-str
|
||||
adjust-url
|
||||
csrf
|
||||
state
|
||||
my-tickets-href)
|
||||
(if
|
||||
(!= state "confirmed")
|
||||
(~page/buy-not-confirmed :entry-id (str entry-id))
|
||||
(let ((eid-s (str entry-id))
|
||||
(target (str "#ticket-buy-" entry-id)))
|
||||
(div :id (str "ticket-buy-" entry-id) :class "rounded-xl border border-stone-200 bg-white p-4"
|
||||
(h3 :class "text-sm font-semibold text-stone-700 mb-3"
|
||||
(i :class "fa fa-ticket mr-1" :aria-hidden "true") "Tickets")
|
||||
;; Info bar
|
||||
(when (or info-sold info-remaining info-basket)
|
||||
(div :class "flex items-center gap-3 mb-3 text-xs text-stone-500"
|
||||
(let
|
||||
((eid-s (str entry-id)) (target (str "#ticket-buy-" entry-id)))
|
||||
(div
|
||||
:id (str "ticket-buy-" entry-id)
|
||||
:class "rounded-xl border border-stone-200 bg-white p-4"
|
||||
(h3
|
||||
:class "text-sm font-semibold text-stone-700 mb-3"
|
||||
(i :class "fa fa-ticket mr-1" :aria-hidden "true")
|
||||
"Tickets")
|
||||
(when
|
||||
(or info-sold info-remaining info-basket)
|
||||
(div
|
||||
:class "flex items-center gap-3 mb-3 text-xs text-stone-500"
|
||||
(when info-sold (span (str info-sold " sold")))
|
||||
(when info-remaining (span (str info-remaining " remaining")))
|
||||
(when info-basket
|
||||
(span :class "text-emerald-600 font-medium"
|
||||
(i :class "fa fa-shopping-cart text-[0.6rem]" :aria-hidden "true")
|
||||
(when
|
||||
info-basket
|
||||
(span
|
||||
:class "text-emerald-600 font-medium"
|
||||
(i
|
||||
:class "fa fa-shopping-cart text-[0.6rem]"
|
||||
:aria-hidden "true")
|
||||
(str " " info-basket " in basket")))))
|
||||
;; Body — multi-type or default
|
||||
(if (and ticket-types (not (empty? ticket-types)))
|
||||
(div :class "space-y-2"
|
||||
(map (fn (tt)
|
||||
(let ((tt-count (if user-ticket-counts-by-type
|
||||
(get user-ticket-counts-by-type (str (get tt "id")) 0)
|
||||
0))
|
||||
(tt-id (get tt "id")))
|
||||
(div :class "flex items-center justify-between p-3 rounded-lg bg-stone-50 border border-stone-100"
|
||||
(div (div :class "font-medium text-sm" (get tt "name"))
|
||||
(div :class "text-xs text-stone-500" (get tt "cost_str")))
|
||||
(~page/adjust-inline :csrf csrf :adjust-url adjust-url :target target
|
||||
:entry-id eid-s :count tt-count :ticket-type-id tt-id
|
||||
:my-tickets-href my-tickets-href))))
|
||||
(if
|
||||
(and ticket-types (not (empty? ticket-types)))
|
||||
(div
|
||||
:class "space-y-2"
|
||||
(map
|
||||
(fn
|
||||
(tt)
|
||||
(let-match
|
||||
{:cost_str cost-str :id tt-id :name tt-name}
|
||||
tt
|
||||
(let
|
||||
((tt-count (if user-ticket-counts-by-type (get user-ticket-counts-by-type (str tt-id) 0) 0)))
|
||||
(div
|
||||
:class "flex items-center justify-between p-3 rounded-lg bg-stone-50 border border-stone-100"
|
||||
(div
|
||||
(div :class "font-medium text-sm" tt-name)
|
||||
(div :class "text-xs text-stone-500" cost-str))
|
||||
(~page/adjust-inline
|
||||
:csrf csrf
|
||||
:adjust-url adjust-url
|
||||
:target target
|
||||
:entry-id eid-s
|
||||
:count tt-count
|
||||
:ticket-type-id tt-id
|
||||
:my-tickets-href my-tickets-href)))))
|
||||
ticket-types))
|
||||
(<> (div :class "flex items-center justify-between mb-4"
|
||||
(div (span :class "font-medium text-green-600" price-str)
|
||||
(span :class "text-sm text-stone-500 ml-2" "per ticket")))
|
||||
(~page/adjust-inline :csrf csrf :adjust-url adjust-url :target target
|
||||
:entry-id eid-s :count (if user-ticket-count user-ticket-count 0)
|
||||
:ticket-type-id nil :my-tickets-href my-tickets-href)))))))
|
||||
(<>
|
||||
(div
|
||||
:class "flex items-center justify-between mb-4"
|
||||
(div
|
||||
(span :class "font-medium text-green-600" price-str)
|
||||
(span :class "text-sm text-stone-500 ml-2" "per ticket")))
|
||||
(~page/adjust-inline
|
||||
:csrf csrf
|
||||
:adjust-url adjust-url
|
||||
:target target
|
||||
:entry-id eid-s
|
||||
:count (if user-ticket-count user-ticket-count 0)
|
||||
:ticket-type-id nil
|
||||
:my-tickets-href my-tickets-href)))))))
|
||||
|
||||
;; Inline +/- controls (used by both default and per-type)
|
||||
(defcomp ~page/adjust-inline (&key csrf adjust-url target entry-id count ticket-type-id my-tickets-href)
|
||||
@@ -285,26 +348,53 @@
|
||||
"Tickets available once this event is confirmed."))
|
||||
|
||||
|
||||
(defcomp ~page/buy-result (&key entry-id tickets remaining my-tickets-href)
|
||||
(let ((count (len tickets))
|
||||
(suffix (if (= count 1) "" "s")))
|
||||
(div :id (str "ticket-buy-" entry-id) :class "rounded-xl border border-emerald-200 bg-emerald-50 p-4"
|
||||
(div :class "flex items-center gap-2 mb-3"
|
||||
(defcomp
|
||||
~page/buy-result
|
||||
(&key entry-id tickets remaining my-tickets-href)
|
||||
(let
|
||||
((count (len tickets)) (suffix (if (= count 1) "" "s")))
|
||||
(div
|
||||
:id (str "ticket-buy-" entry-id)
|
||||
:class "rounded-xl border border-emerald-200 bg-emerald-50 p-4"
|
||||
(div
|
||||
:class "flex items-center gap-2 mb-3"
|
||||
(i :class "fa fa-check-circle text-emerald-600" :aria-hidden "true")
|
||||
(span :class "font-semibold text-emerald-800" (str count " ticket" suffix " reserved")))
|
||||
(div :class "space-y-2 mb-4"
|
||||
(map (fn (t)
|
||||
(a :href (get t "href") :class "flex items-center justify-between p-2 rounded-lg bg-white border border-emerald-100 hover:border-emerald-300 transition text-sm"
|
||||
(div :class "flex items-center gap-2"
|
||||
(i :class "fa fa-ticket text-emerald-500" :aria-hidden "true")
|
||||
(span :class "font-mono text-xs text-stone-500" (get t "code_short")))
|
||||
(span :class "text-xs text-emerald-600 font-medium" "View ticket")))
|
||||
(span
|
||||
:class "font-semibold text-emerald-800"
|
||||
(str count " ticket" suffix " reserved")))
|
||||
(div
|
||||
:class "space-y-2 mb-4"
|
||||
(map
|
||||
(fn
|
||||
(t)
|
||||
(let-match
|
||||
{:href href :code_short code-short}
|
||||
t
|
||||
(a
|
||||
:href href
|
||||
:class "flex items-center justify-between p-2 rounded-lg bg-white border border-emerald-100 hover:border-emerald-300 transition text-sm"
|
||||
(div
|
||||
:class "flex items-center gap-2"
|
||||
(i
|
||||
:class "fa fa-ticket text-emerald-500"
|
||||
:aria-hidden "true")
|
||||
(span :class "font-mono text-xs text-stone-500" code-short))
|
||||
(span
|
||||
:class "text-xs text-emerald-600 font-medium"
|
||||
"View ticket"))))
|
||||
tickets))
|
||||
(when (not (nil? remaining))
|
||||
(let ((r-suffix (if (= remaining 1) "" "s")))
|
||||
(p :class "text-xs text-stone-500" (str remaining " ticket" r-suffix " remaining"))))
|
||||
(div :class "mt-3 flex gap-2"
|
||||
(a :href my-tickets-href :class "text-sm text-emerald-700 hover:text-emerald-900 underline"
|
||||
(when
|
||||
(not (nil? remaining))
|
||||
(let
|
||||
((r-suffix (if (= remaining 1) "" "s")))
|
||||
(p
|
||||
:class "text-xs text-stone-500"
|
||||
(str remaining " ticket" r-suffix " remaining"))))
|
||||
(div
|
||||
:class "mt-3 flex gap-2"
|
||||
(a
|
||||
:href my-tickets-href
|
||||
:class "text-sm text-emerald-700 hover:text-emerald-900 underline"
|
||||
"View all my tickets")))))
|
||||
|
||||
;; Single response wrappers for POST routes (include OOB cart icon)
|
||||
@@ -477,27 +567,46 @@
|
||||
(~page/post-img-placeholder)))
|
||||
|
||||
;; Entry posts nav OOB from data
|
||||
(defcomp ~page/entry-posts-nav-oob-from-data (&key nav-btn posts)
|
||||
(if (empty? (or posts (list)))
|
||||
(defcomp
|
||||
~page/entry-posts-nav-oob-from-data
|
||||
(&key nav-btn posts)
|
||||
(if
|
||||
(empty? (or posts (list)))
|
||||
(~page/entry-posts-nav-oob-empty)
|
||||
(~page/entry-posts-nav-oob
|
||||
:items (<> (map (lambda (p)
|
||||
(~page/entry-nav-post
|
||||
:href (get p "href") :nav-btn nav-btn
|
||||
:img (~page/post-img-from-data :src (get p "img") :alt (get p "title"))
|
||||
:title (get p "title")))
|
||||
posts)))))
|
||||
:items (<>
|
||||
(map
|
||||
(lambda
|
||||
(p)
|
||||
(let-match
|
||||
{:href href :title title :img img}
|
||||
p
|
||||
(~page/entry-nav-post
|
||||
:href href
|
||||
:nav-btn nav-btn
|
||||
:img (~page/post-img-from-data :src img :alt title)
|
||||
:title title)))
|
||||
posts)))))
|
||||
|
||||
;; Entry posts nav (non-OOB) from data — for desktop nav embedding
|
||||
(defcomp ~page/entry-posts-nav-inner-from-data (&key posts)
|
||||
(when (not (empty? (or posts (list))))
|
||||
(defcomp
|
||||
~page/entry-posts-nav-inner-from-data
|
||||
(&key posts)
|
||||
(when
|
||||
(not (empty? (or posts (list))))
|
||||
(~page/entry-posts-nav-oob
|
||||
:items (<> (map (lambda (p)
|
||||
(~page/entry-nav-post-link
|
||||
:href (get p "href")
|
||||
:img (~page/post-img-from-data :src (get p "img") :alt (get p "title"))
|
||||
:title (get p "title")))
|
||||
posts)))))
|
||||
:items (<>
|
||||
(map
|
||||
(lambda
|
||||
(p)
|
||||
(let-match
|
||||
{:href href :title title :img img}
|
||||
p
|
||||
(~page/entry-nav-post-link
|
||||
:href href
|
||||
:img (~page/post-img-from-data :src img :alt title)
|
||||
:title title)))
|
||||
posts)))))
|
||||
|
||||
;; Post nav entries+calendars OOB from data
|
||||
(defcomp ~page/post-nav-wrapper-from-data (&key nav-btn entries calendars hyperscript)
|
||||
@@ -602,14 +711,23 @@
|
||||
(~shared:layout/nav-link :href admin-href :icon "fa fa-cog"))))
|
||||
|
||||
;; Post search results from data
|
||||
(defcomp ~page/post-search-results-from-data (&key items page next-url has-more)
|
||||
(defcomp
|
||||
~page/post-search-results-from-data
|
||||
(&key items page next-url has-more)
|
||||
(<>
|
||||
(map (lambda (item)
|
||||
(~forms/post-search-item
|
||||
:post-url (get item "post-url") :entry-id (get item "entry-id")
|
||||
:csrf (get item "csrf") :post-id (get item "post-id")
|
||||
:img (~page/post-img-from-data :src (get item "img") :alt (get item "title"))
|
||||
:title (get item "title")))
|
||||
(map
|
||||
(lambda
|
||||
(item)
|
||||
(let-match
|
||||
{:csrf csrf :entry-id entry-id :post-url post-url :title title :img img :post-id post-id}
|
||||
item
|
||||
(~forms/post-search-item
|
||||
:post-url post-url
|
||||
:entry-id entry-id
|
||||
:csrf csrf
|
||||
:post-id post-id
|
||||
:img (~page/post-img-from-data :src img :alt title)
|
||||
:title title)))
|
||||
(or items (list)))
|
||||
(cond
|
||||
(has-more (~forms/post-search-sentinel :page page :next-url next-url))
|
||||
@@ -617,16 +735,26 @@
|
||||
(true ""))))
|
||||
|
||||
;; Entry options from data — state-driven button composition
|
||||
(defcomp ~page/entry-options-from-data (&key entry-id state buttons)
|
||||
(defcomp
|
||||
~page/entry-options-from-data
|
||||
(&key entry-id state buttons)
|
||||
(~admin/entry-options
|
||||
:entry-id entry-id
|
||||
:buttons (<> (map (lambda (b)
|
||||
(~admin/entry-option-button
|
||||
:url (get b "url") :target (str "#calendar_entry_options_" entry-id)
|
||||
:csrf (get b "csrf") :btn-type (get b "btn-type")
|
||||
:action-btn (get b "action-btn")
|
||||
:confirm-title (get b "confirm-title")
|
||||
:confirm-text (get b "confirm-text")
|
||||
:label (get b "label")
|
||||
:is-btn (get b "is-btn")))
|
||||
(or buttons (list))))))
|
||||
:buttons (<>
|
||||
(map
|
||||
(lambda
|
||||
(b)
|
||||
(let-match
|
||||
{:csrf csrf :confirm-title confirm-title :url url :btn-type btn-type :action-btn action-btn :confirm-text confirm-text :label label :is-btn is-btn}
|
||||
b
|
||||
(~admin/entry-option-button
|
||||
:url url
|
||||
:target (str "#calendar_entry_options_" entry-id)
|
||||
:csrf csrf
|
||||
:btn-type btn-type
|
||||
:action-btn action-btn
|
||||
:confirm-title confirm-title
|
||||
:confirm-text confirm-text
|
||||
:label label
|
||||
:is-btn is-btn)))
|
||||
(or buttons (list))))))
|
||||
|
||||
@@ -211,18 +211,28 @@
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; My tickets panel from data
|
||||
(defcomp ~tickets/panel-from-data (&key (list-container :as string) (tickets :as list?))
|
||||
(defcomp
|
||||
~tickets/panel-from-data
|
||||
(&key (list-container :as string) (tickets :as list?))
|
||||
(~tickets/panel
|
||||
:list-container list-container
|
||||
:has-tickets (not (empty? (or tickets (list))))
|
||||
:cards (<> (map (lambda (t)
|
||||
(~tickets/card
|
||||
:href (get t "href") :entry-name (get t "entry-name")
|
||||
:type-name (get t "type-name") :time-str (get t "time-str")
|
||||
:cal-name (get t "cal-name")
|
||||
:badge (~entries/ticket-state-badge :state (get t "state"))
|
||||
:code-prefix (get t "code-prefix")))
|
||||
(or tickets (list))))))
|
||||
:cards (<>
|
||||
(map
|
||||
(lambda
|
||||
(t)
|
||||
(let-match
|
||||
{:time-str time-str :href href :type-name type-name :code-prefix code-prefix :entry-name entry-name :cal-name cal-name :state state}
|
||||
t
|
||||
(~tickets/card
|
||||
:href href
|
||||
:entry-name entry-name
|
||||
:type-name type-name
|
||||
:time-str time-str
|
||||
:cal-name cal-name
|
||||
:badge (~entries/ticket-state-badge :state state)
|
||||
:code-prefix code-prefix)))
|
||||
(or tickets (list))))))
|
||||
|
||||
;; Ticket detail from data — uses lg badge variant
|
||||
(defcomp ~tickets/detail-from-data (&key (list-container :as string) (back-href :as string) (header-bg :as string) (entry-name :as string)
|
||||
@@ -256,54 +266,106 @@
|
||||
(true nil))))
|
||||
|
||||
;; Ticket admin panel from data
|
||||
(defcomp ~tickets/admin-panel-from-data (&key (list-container :as string) (lookup-url :as string) (tickets :as list?)
|
||||
(total :as number?) (confirmed :as number?) (checked-in :as number?) (reserved :as number?))
|
||||
(defcomp
|
||||
~tickets/admin-panel-from-data
|
||||
(&key
|
||||
(list-container :as string)
|
||||
(lookup-url :as string)
|
||||
(tickets :as list?)
|
||||
(total :as number?)
|
||||
(confirmed :as number?)
|
||||
(checked-in :as number?)
|
||||
(reserved :as number?))
|
||||
(~tickets/admin-panel
|
||||
:list-container list-container
|
||||
:stats (<>
|
||||
(~tickets/admin-stat :border "border-stone-200" :bg ""
|
||||
:text-cls "text-stone-900" :label-cls "text-stone-500"
|
||||
:value (str (or total 0)) :label "Total")
|
||||
(~tickets/admin-stat :border "border-emerald-200" :bg "bg-emerald-50"
|
||||
:text-cls "text-emerald-700" :label-cls "text-emerald-600"
|
||||
:value (str (or confirmed 0)) :label "Confirmed")
|
||||
(~tickets/admin-stat :border "border-blue-200" :bg "bg-blue-50"
|
||||
:text-cls "text-blue-700" :label-cls "text-blue-600"
|
||||
:value (str (or checked-in 0)) :label "Checked In")
|
||||
(~tickets/admin-stat :border "border-amber-200" :bg "bg-amber-50"
|
||||
:text-cls "text-amber-700" :label-cls "text-amber-600"
|
||||
:value (str (or reserved 0)) :label "Reserved"))
|
||||
(~tickets/admin-stat
|
||||
:border "border-stone-200"
|
||||
:bg ""
|
||||
:text-cls "text-stone-900"
|
||||
:label-cls "text-stone-500"
|
||||
:value (str (or total 0))
|
||||
:label "Total")
|
||||
(~tickets/admin-stat
|
||||
:border "border-emerald-200"
|
||||
:bg "bg-emerald-50"
|
||||
:text-cls "text-emerald-700"
|
||||
:label-cls "text-emerald-600"
|
||||
:value (str (or confirmed 0))
|
||||
:label "Confirmed")
|
||||
(~tickets/admin-stat
|
||||
:border "border-blue-200"
|
||||
:bg "bg-blue-50"
|
||||
:text-cls "text-blue-700"
|
||||
:label-cls "text-blue-600"
|
||||
:value (str (or checked-in 0))
|
||||
:label "Checked In")
|
||||
(~tickets/admin-stat
|
||||
:border "border-amber-200"
|
||||
:bg "bg-amber-50"
|
||||
:text-cls "text-amber-700"
|
||||
:label-cls "text-amber-600"
|
||||
:value (str (or reserved 0))
|
||||
:label "Reserved"))
|
||||
:lookup-url lookup-url
|
||||
:has-tickets (not (empty? (or tickets (list))))
|
||||
:rows (<> (map (lambda (t)
|
||||
(~tickets/admin-row-from-data
|
||||
:code (get t "code") :code-short (get t "code-short")
|
||||
:entry-name (get t "entry-name") :date-str (get t "date-str")
|
||||
:type-name (get t "type-name") :state (get t "state")
|
||||
:checkin-url (get t "checkin-url") :csrf (get t "csrf")
|
||||
:checked-in-time (get t "checked-in-time")))
|
||||
(or tickets (list))))))
|
||||
:rows (<>
|
||||
(map
|
||||
(lambda
|
||||
(t)
|
||||
(let-match
|
||||
{:date-str date-str :csrf csrf :type-name type-name :code-short code-short :entry-name entry-name :code code :checkin-url checkin-url :checked-in-time checked-in-time :state state}
|
||||
t
|
||||
(~tickets/admin-row-from-data
|
||||
:code code
|
||||
:code-short code-short
|
||||
:entry-name entry-name
|
||||
:date-str date-str
|
||||
:type-name type-name
|
||||
:state state
|
||||
:checkin-url checkin-url
|
||||
:csrf csrf
|
||||
:checked-in-time checked-in-time)))
|
||||
(or tickets (list))))))
|
||||
|
||||
;; Entry tickets admin from data
|
||||
(defcomp ~tickets/entry-tickets-admin-from-data (&key (entry-name :as string) (count-label :as string) (tickets :as list?) (csrf :as string))
|
||||
(defcomp
|
||||
~tickets/entry-tickets-admin-from-data
|
||||
(&key
|
||||
(entry-name :as string)
|
||||
(count-label :as string)
|
||||
(tickets :as list?)
|
||||
(csrf :as string))
|
||||
(~tickets/entry-tickets-admin-panel
|
||||
:entry-name entry-name :count-label count-label
|
||||
:body (if (empty? (or tickets (list)))
|
||||
:entry-name entry-name
|
||||
:count-label count-label
|
||||
:body (if
|
||||
(empty? (or tickets (list)))
|
||||
(~tickets/entry-tickets-admin-empty)
|
||||
(~tickets/entry-tickets-admin-table
|
||||
:rows (<> (map (lambda (t)
|
||||
(~tickets/entry-tickets-admin-row
|
||||
:code (get t "code") :code-short (get t "code-short")
|
||||
:type-name (get t "type-name")
|
||||
:badge (~entries/ticket-state-badge :state (get t "state"))
|
||||
:action (cond
|
||||
((or (= (get t "state") "confirmed") (= (get t "state") "reserved"))
|
||||
(~tickets/entry-tickets-admin-checkin
|
||||
:checkin-url (get t "checkin-url") :code (get t "code") :csrf csrf))
|
||||
((= (get t "state") "checked_in")
|
||||
(~tickets/admin-checked-in :time-str (or (get t "checked-in-time") "")))
|
||||
(true nil))))
|
||||
(or tickets (list))))))))
|
||||
:rows (<>
|
||||
(map
|
||||
(lambda
|
||||
(t)
|
||||
(let-match
|
||||
{:type-name type-name :code-short code-short :code code :checkin-url checkin-url :checked-in-time checked-in-time :state state}
|
||||
t
|
||||
(~tickets/entry-tickets-admin-row
|
||||
:code code
|
||||
:code-short code-short
|
||||
:type-name type-name
|
||||
:badge (~entries/ticket-state-badge :state state)
|
||||
:action (cond
|
||||
((or (= state "confirmed") (= state "paid"))
|
||||
(~tickets/entry-tickets-admin-checkin
|
||||
:checkin-url checkin-url
|
||||
:code code
|
||||
:csrf csrf))
|
||||
((= state "checked-in")
|
||||
(~tickets/admin-checked-in
|
||||
:time-str (or checked-in-time "")))
|
||||
(true nil)))))
|
||||
(or tickets (list))))))))
|
||||
|
||||
;; Checkin success row from data
|
||||
(defcomp ~tickets/checkin-success-row-from-data (&key (code :as string) (code-short :as string) (entry-name :as string) (date-str :as string?) (type-name :as string) (time-str :as string))
|
||||
@@ -316,21 +378,43 @@
|
||||
:time-str time-str))
|
||||
|
||||
;; Ticket types table from data
|
||||
(defcomp ~tickets/types-table-from-data (&key (list-container :as string) (ticket-types :as list?) (action-btn :as string) (add-url :as string)
|
||||
(tr-cls :as string) (pill-cls :as string) (hx-select :as string) (csrf-hdr :as string))
|
||||
(defcomp
|
||||
~tickets/types-table-from-data
|
||||
(&key
|
||||
(list-container :as string)
|
||||
(ticket-types :as list?)
|
||||
(action-btn :as string)
|
||||
(add-url :as string)
|
||||
(tr-cls :as string)
|
||||
(pill-cls :as string)
|
||||
(hx-select :as string)
|
||||
(csrf-hdr :as string))
|
||||
(~page/ticket-types-table
|
||||
:list-container list-container
|
||||
:rows (if (empty? (or ticket-types (list)))
|
||||
:rows (if
|
||||
(empty? (or ticket-types (list)))
|
||||
(~page/ticket-types-empty-row)
|
||||
(<> (map (lambda (tt)
|
||||
(~page/ticket-types-row
|
||||
:tr-cls tr-cls :tt-href (get tt "tt-href")
|
||||
:pill-cls pill-cls :hx-select hx-select
|
||||
:tt-name (get tt "tt-name") :cost-str (get tt "cost-str")
|
||||
:count (get tt "count") :action-btn action-btn
|
||||
:del-url (get tt "del-url") :csrf-hdr csrf-hdr))
|
||||
(or ticket-types (list)))))
|
||||
:action-btn action-btn :add-url add-url))
|
||||
(<>
|
||||
(map
|
||||
(lambda
|
||||
(tt)
|
||||
(let-match
|
||||
{:tt-href tt-href :count count :cost-str cost-str :tt-name tt-name :del-url del-url}
|
||||
tt
|
||||
(~page/ticket-types-row
|
||||
:tr-cls tr-cls
|
||||
:tt-href tt-href
|
||||
:pill-cls pill-cls
|
||||
:hx-select hx-select
|
||||
:tt-name tt-name
|
||||
:cost-str cost-str
|
||||
:count count
|
||||
:action-btn action-btn
|
||||
:del-url del-url
|
||||
:csrf-hdr csrf-hdr)))
|
||||
(or ticket-types (list)))))
|
||||
:action-btn action-btn
|
||||
:add-url add-url))
|
||||
|
||||
;; Lookup result from data
|
||||
(defcomp ~tickets/lookup-result-from-data (&key (entry-name :as string) (type-name :as string?) (date-str :as string?) (cal-name :as string?)
|
||||
|
||||
1
federation/config/app-config.sx
Normal file
1
federation/config/app-config.sx
Normal file
@@ -0,0 +1 @@
|
||||
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :section-titles ("ingredients" "allergy information" "allergens" "nutritional information" "nutrition" "storage" "directions" "preparation" "serving suggestions" "origin" "country of origin" "recycling" "general information" "additional information" "a note about prices") :blacklist {:category ("branded-goods/alcoholic-drinks" "branded-goods/beers" "branded-goods/ciders" "branded-goods/wines") :product ("list-price-suma-current-suma-price-list-each-bk012-2-html") :product-details ("General Information" "A Note About Prices")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})
|
||||
@@ -92,52 +92,95 @@
|
||||
|
||||
;; --- Data-driven post card (replaces Python _post_card_sx loop) ---
|
||||
|
||||
(defcomp ~social/post-card-from-data (&key (d :as dict) (has-actor :as boolean) (csrf :as string)
|
||||
(like-url :as string) (unlike-url :as string)
|
||||
(boost-url :as string) (unboost-url :as string))
|
||||
(let* ((boosted-by (get d "boosted_by"))
|
||||
(actor-icon (get d "actor_icon"))
|
||||
(actor-name (get d "actor_name"))
|
||||
(initial (or (get d "initial") "?"))
|
||||
(avatar (~shared:misc/avatar
|
||||
:src actor-icon
|
||||
:cls (if actor-icon "w-10 h-10 rounded-full"
|
||||
"w-10 h-10 rounded-full bg-stone-300 flex items-center justify-center text-stone-600 font-bold text-sm")
|
||||
:initial (when (not actor-icon) initial)))
|
||||
(boost (when boosted-by (~social/boost-label :name boosted-by)))
|
||||
(content-sx (if (get d "summary")
|
||||
(~social/content :content (get d "content") :summary (get d "summary"))
|
||||
(~social/content :content (get d "content"))))
|
||||
(original (when (get d "original_url")
|
||||
(~social/original-link :url (get d "original_url"))))
|
||||
(safe-id (get d "safe_id"))
|
||||
(interactions (when has-actor
|
||||
(let* ((oid (get d "object_id"))
|
||||
(ainbox (get d "author_inbox"))
|
||||
(target (str "#interactions-" safe-id))
|
||||
(liked (get d "liked_by_me"))
|
||||
(boosted-me (get d "boosted_by_me"))
|
||||
(l-action (if liked unlike-url like-url))
|
||||
(l-cls (str "flex items-center gap-1 " (if liked "text-red-500 hover:text-red-600" "hover:text-red-500")))
|
||||
(l-icon (if liked "\u2665" "\u2661"))
|
||||
(b-action (if boosted-me unboost-url boost-url))
|
||||
(b-cls (str "flex items-center gap-1 " (if boosted-me "text-green-600 hover:text-green-700" "hover:text-green-600")))
|
||||
(reply-url (get d "reply_url"))
|
||||
(reply (when reply-url (~social/reply-link :url reply-url)))
|
||||
(like-form (~social/like-form
|
||||
:action l-action :target target :oid oid :ainbox ainbox
|
||||
:csrf csrf :cls l-cls :icon l-icon :count (get d "like_count")))
|
||||
(boost-form (~social/boost-form
|
||||
:action b-action :target target :oid oid :ainbox ainbox
|
||||
:csrf csrf :cls b-cls :count (get d "boost_count"))))
|
||||
(div :id (str "interactions-" safe-id)
|
||||
(~social/interaction-buttons :like like-form :boost boost-form :reply reply))))))
|
||||
(~social/post-card
|
||||
:boost boost :avatar avatar
|
||||
:actor-name actor-name :actor-username (get d "actor_username")
|
||||
:domain (get d "domain") :time (get d "time")
|
||||
:content content-sx :original original
|
||||
:interactions interactions)))
|
||||
(defcomp
|
||||
~social/post-card-from-data
|
||||
(&key
|
||||
(d :as dict)
|
||||
(has-actor :as boolean)
|
||||
(csrf :as string)
|
||||
(like-url :as string)
|
||||
(unlike-url :as string)
|
||||
(boost-url :as string)
|
||||
(unboost-url :as string))
|
||||
(let-match
|
||||
{:actor_name actor-name :liked_by_me liked :boosted_by_me boosted-me :time time :actor_username actor-username :domain domain :content content :object_id oid :boosted_by boosted-by :summary summary :original_url original-url :safe_id safe-id :author_inbox ainbox :reply_url reply-url :like_count like-count :boost_count boost-count :actor_icon actor-icon :initial initial*}
|
||||
d
|
||||
(let*
|
||||
((initial (or initial* "?"))
|
||||
(avatar
|
||||
(~shared:misc/avatar
|
||||
:src actor-icon
|
||||
:cls (if
|
||||
actor-icon
|
||||
"w-10 h-10 rounded-full"
|
||||
"w-10 h-10 rounded-full bg-stone-300 flex items-center justify-center text-stone-600 font-bold text-sm")
|
||||
:initial (when (not actor-icon) initial)))
|
||||
(boost (when boosted-by (~social/boost-label :name boosted-by)))
|
||||
(content-sx
|
||||
(if
|
||||
summary
|
||||
(~social/content :content content :summary summary)
|
||||
(~social/content :content content)))
|
||||
(original
|
||||
(when original-url (~social/original-link :url original-url)))
|
||||
(interactions
|
||||
(when
|
||||
has-actor
|
||||
(let*
|
||||
((target (str "#interactions-" safe-id))
|
||||
(l-action (if liked unlike-url like-url))
|
||||
(l-cls
|
||||
(str
|
||||
"flex items-center gap-1 "
|
||||
(if
|
||||
liked
|
||||
"text-red-500 hover:text-red-600"
|
||||
"hover:text-red-500")))
|
||||
(l-icon (if liked "♥" "♡"))
|
||||
(b-action (if boosted-me unboost-url boost-url))
|
||||
(b-cls
|
||||
(str
|
||||
"flex items-center gap-1 "
|
||||
(if
|
||||
boosted-me
|
||||
"text-green-600 hover:text-green-700"
|
||||
"hover:text-green-600")))
|
||||
(reply (when reply-url (~social/reply-link :url reply-url)))
|
||||
(like-form
|
||||
(~social/like-form
|
||||
:action l-action
|
||||
:target target
|
||||
:oid oid
|
||||
:ainbox ainbox
|
||||
:csrf csrf
|
||||
:cls l-cls
|
||||
:icon l-icon
|
||||
:count like-count))
|
||||
(boost-form
|
||||
(~social/boost-form
|
||||
:action b-action
|
||||
:target target
|
||||
:oid oid
|
||||
:ainbox ainbox
|
||||
:csrf csrf
|
||||
:cls b-cls
|
||||
:count boost-count)))
|
||||
(div
|
||||
:id (str "interactions-" safe-id)
|
||||
(~social/interaction-buttons
|
||||
:like like-form
|
||||
:boost boost-form
|
||||
:reply reply))))))
|
||||
(~social/post-card
|
||||
:boost boost
|
||||
:avatar avatar
|
||||
:actor-name actor-name
|
||||
:actor-username actor-username
|
||||
:domain domain
|
||||
:time time
|
||||
:content content-sx
|
||||
:original original
|
||||
:interactions interactions))))
|
||||
|
||||
;; Data-driven timeline items (replaces Python _timeline_items_sx loop)
|
||||
(defcomp ~social/timeline-items-from-data (&key (items :as list) (next-url :as string?) (has-actor :as boolean) (csrf :as string)
|
||||
@@ -174,35 +217,53 @@
|
||||
;; Assembled social nav — replaces Python _social_nav_sx
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(defcomp ~social/nav (&key actor)
|
||||
(if (not actor)
|
||||
(~social/nav-choose-username :url (url-for "identity.choose_username_form"))
|
||||
(let* ((rp (request-path))
|
||||
(links (list
|
||||
(dict :endpoint "social.defpage_home_timeline" :label "Timeline")
|
||||
(dict :endpoint "social.defpage_public_timeline" :label "Public")
|
||||
(dict :endpoint "social.defpage_compose_form" :label "Compose")
|
||||
(dict :endpoint "social.defpage_following_list" :label "Following")
|
||||
(dict :endpoint "social.defpage_followers_list" :label "Followers")
|
||||
(dict :endpoint "social.defpage_search" :label "Search"))))
|
||||
(defcomp
|
||||
~social/nav
|
||||
(&key actor)
|
||||
(if
|
||||
(not actor)
|
||||
(~social/nav-choose-username
|
||||
:url (url-for "identity.choose_username_form"))
|
||||
(let*
|
||||
((rp (request-path))
|
||||
(links
|
||||
(list
|
||||
(dict :endpoint "social.defpage_home_timeline" :label "Timeline")
|
||||
(dict :endpoint "social.defpage_public_timeline" :label "Public")
|
||||
(dict :endpoint "social.defpage_compose_form" :label "Compose")
|
||||
(dict :endpoint "social.defpage_following_list" :label "Following")
|
||||
(dict :endpoint "social.defpage_followers_list" :label "Followers")
|
||||
(dict :endpoint "social.defpage_search" :label "Search"))))
|
||||
(~social/nav-bar
|
||||
:items (<>
|
||||
(map (lambda (lnk)
|
||||
(let* ((href (url-for (get lnk "endpoint")))
|
||||
(bold (if (= rp href) " font-bold" "")))
|
||||
(a :href href
|
||||
:class (str "px-2 py-1 rounded hover:bg-stone-200" bold)
|
||||
(get lnk "label"))))
|
||||
(map
|
||||
(lambda
|
||||
(lnk)
|
||||
(let-match
|
||||
{:label label :endpoint endpoint}
|
||||
lnk
|
||||
(let*
|
||||
((href (url-for endpoint))
|
||||
(bold (if (= rp href) " font-bold" "")))
|
||||
(a
|
||||
:href href
|
||||
:class (str "px-2 py-1 rounded hover:bg-stone-200" bold)
|
||||
label))))
|
||||
links)
|
||||
(let* ((notif-url (url-for "social.defpage_notifications"))
|
||||
(notif-bold (if (= rp notif-url) " font-bold" "")))
|
||||
(let*
|
||||
((notif-url (url-for "social.defpage_notifications"))
|
||||
(notif-bold (if (= rp notif-url) " font-bold" "")))
|
||||
(~social/nav-notification-link
|
||||
:href notif-url
|
||||
:cls (str "px-2 py-1 rounded hover:bg-stone-200 relative" notif-bold)
|
||||
:count-url (url-for "social.notification_count")))
|
||||
(a :href (url-for "activitypub.actor_profile" :username (get actor "preferred_username"))
|
||||
:class "px-2 py-1 rounded hover:bg-stone-200"
|
||||
(str "@" (get actor "preferred_username"))))))))
|
||||
(let-match
|
||||
{:preferred_username username}
|
||||
actor
|
||||
(a
|
||||
:href (url-for "activitypub.actor_profile" :username username)
|
||||
:class "px-2 py-1 rounded hover:bg-stone-200"
|
||||
(str "@" username))))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Assembled post card — replaces Python _post_card_sx
|
||||
|
||||
@@ -20,8 +20,8 @@ _PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
if _PROJECT not in sys.path:
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
import tempfile
|
||||
from shared.sx.parser import serialize
|
||||
from hosts.javascript.platform import (
|
||||
extract_defines,
|
||||
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, SPEC_MODULE_ORDER, EXTENSION_NAMES,
|
||||
@@ -35,29 +35,23 @@ from hosts.javascript.platform import (
|
||||
)
|
||||
|
||||
|
||||
_js_sx_env = None # cached
|
||||
_bridge = None # cached OcamlSync instance
|
||||
|
||||
|
||||
def load_js_sx() -> dict:
|
||||
"""Load js.sx into an evaluator environment and return it."""
|
||||
global _js_sx_env
|
||||
if _js_sx_env is not None:
|
||||
return _js_sx_env
|
||||
def _get_bridge():
|
||||
"""Get or create the OCaml sync bridge with transpiler loaded."""
|
||||
global _bridge
|
||||
if _bridge is not None:
|
||||
return _bridge
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
_bridge = OcamlSync()
|
||||
_bridge.load(os.path.join(_HERE, "transpiler.sx"))
|
||||
return _bridge
|
||||
|
||||
js_sx_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(js_sx_path) as f:
|
||||
source = f.read()
|
||||
|
||||
exprs = parse_all(source)
|
||||
|
||||
from shared.sx.ref.sx_ref import evaluate, make_env
|
||||
|
||||
env = make_env()
|
||||
for expr in exprs:
|
||||
evaluate(expr, env)
|
||||
|
||||
_js_sx_env = env
|
||||
return env
|
||||
def load_js_sx():
|
||||
"""Load js.sx transpiler into the OCaml kernel. Returns the bridge."""
|
||||
return _get_bridge()
|
||||
|
||||
|
||||
def compile_ref_to_js(
|
||||
@@ -75,16 +69,14 @@ def compile_ref_to_js(
|
||||
spec_modules: List of spec modules (deps, router, signals). None = auto.
|
||||
"""
|
||||
from datetime import datetime, timezone
|
||||
from shared.sx.ref.sx_ref import evaluate
|
||||
|
||||
ref_dir = os.path.join(_PROJECT, "shared", "sx", "ref")
|
||||
# Source directories: core spec, web framework, and legacy ref (for bootstrapper tools)
|
||||
# Source directories: core spec, standard library, web framework
|
||||
_source_dirs = [
|
||||
os.path.join(_PROJECT, "spec"), # Core spec
|
||||
os.path.join(_PROJECT, "web"), # Web framework
|
||||
ref_dir, # Legacy location (fallback)
|
||||
os.path.join(_PROJECT, "spec"), # Core language spec
|
||||
os.path.join(_PROJECT, "lib"), # Standard library (stdlib, compiler, vm, ...)
|
||||
os.path.join(_PROJECT, "web"), # Web framework
|
||||
]
|
||||
env = load_js_sx()
|
||||
bridge = _get_bridge()
|
||||
|
||||
# Resolve adapter set
|
||||
if adapters is None:
|
||||
@@ -107,21 +99,18 @@ def compile_ref_to_js(
|
||||
spec_mod_set.add(sm)
|
||||
if "dom" in adapter_set and "signals" in SPEC_MODULES:
|
||||
spec_mod_set.add("signals")
|
||||
if "signals-web" in SPEC_MODULES:
|
||||
spec_mod_set.add("signals-web")
|
||||
if "boot" in adapter_set:
|
||||
spec_mod_set.add("router")
|
||||
spec_mod_set.add("deps")
|
||||
if "page-helpers" in SPEC_MODULES:
|
||||
spec_mod_set.add("page-helpers")
|
||||
# CEK is the canonical evaluator — always included
|
||||
spec_mod_set.add("cek")
|
||||
spec_mod_set.add("frames")
|
||||
# cek module requires frames
|
||||
if "cek" in spec_mod_set:
|
||||
spec_mod_set.add("frames")
|
||||
# CEK is always included (part of evaluator.sx core file)
|
||||
has_cek = True
|
||||
has_deps = "deps" in spec_mod_set
|
||||
has_router = "router" in spec_mod_set
|
||||
has_page_helpers = "page-helpers" in spec_mod_set
|
||||
has_cek = "cek" in spec_mod_set
|
||||
|
||||
# Resolve extensions
|
||||
ext_set = set()
|
||||
@@ -132,12 +121,18 @@ def compile_ref_to_js(
|
||||
ext_set.add(e)
|
||||
has_continuations = "continuations" in ext_set
|
||||
|
||||
# Build file list: core + adapters + spec modules
|
||||
# Build file list: core evaluator + adapters + spec modules
|
||||
# evaluator.sx = merged frames + eval utilities + CEK machine
|
||||
sx_files = [
|
||||
("eval.sx", "eval"),
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
# stdlib.sx is loaded at runtime via eval, not transpiled —
|
||||
# transpiling it would shadow native PRIMITIVES in module scope.
|
||||
("freeze.sx", "freeze (serializable state boundaries)"),
|
||||
("content.sx", "content (content-addressed computation)"),
|
||||
("render.sx", "render (core)"),
|
||||
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
|
||||
]
|
||||
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):
|
||||
for name in ("parser", "html", "sx", "dom-lib", "browser-lib", "dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set:
|
||||
sx_files.append(ADAPTER_FILES[name])
|
||||
# Use explicit ordering for spec modules (respects dependencies)
|
||||
@@ -218,11 +213,16 @@ def compile_ref_to_js(
|
||||
sx_defines = [[name, expr] for name, expr in defines]
|
||||
|
||||
parts.append(f"\n // === Transpiled from {label} ===\n")
|
||||
env["_defines"] = sx_defines
|
||||
result = evaluate(
|
||||
[Symbol("js-translate-file"), Symbol("_defines")],
|
||||
env,
|
||||
)
|
||||
# Serialize defines to SX, write to temp file, load into OCaml kernel
|
||||
defines_sx = serialize(sx_defines)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines \'{defines_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
result = bridge.eval("(js-translate-file _defines)")
|
||||
parts.append(result)
|
||||
|
||||
# Platform JS for selected adapters
|
||||
@@ -234,6 +234,28 @@ def compile_ref_to_js(
|
||||
if has_cek:
|
||||
parts.append(CEK_FIXUPS_JS)
|
||||
|
||||
# Load stdlib.sx via eval (NOT transpiled) so defines go into the eval
|
||||
# env, not the module scope. This prevents stdlib functions from
|
||||
# shadowing native PRIMITIVES aliases used by transpiled evaluator code.
|
||||
stdlib_path = _find_sx("stdlib.sx")
|
||||
if stdlib_path:
|
||||
with open(stdlib_path) as f:
|
||||
stdlib_src = f.read()
|
||||
# Escape for JS string literal
|
||||
stdlib_escaped = stdlib_src.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n")
|
||||
parts.append(f'\n // === stdlib.sx (eval\'d at runtime, not transpiled) ===')
|
||||
parts.append(f' (function() {{')
|
||||
parts.append(f' var src = "{stdlib_escaped}";')
|
||||
parts.append(f' var forms = sxParse(src);')
|
||||
parts.append(f' var tmpEnv = merge({{}}, PRIMITIVES);')
|
||||
parts.append(f' for (var i = 0; i < forms.length; i++) {{')
|
||||
parts.append(f' trampoline(evalExpr(forms[i], tmpEnv));')
|
||||
parts.append(f' }}')
|
||||
parts.append(f' for (var k in tmpEnv) {{')
|
||||
parts.append(f' if (!PRIMITIVES[k]) PRIMITIVES[k] = tmpEnv[k];')
|
||||
parts.append(f' }}')
|
||||
parts.append(f' }})();\n')
|
||||
|
||||
for name in ("dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set and name in adapter_platform:
|
||||
parts.append(adapter_platform[name])
|
||||
|
||||
95
hosts/javascript/manifest.py
Normal file
95
hosts/javascript/manifest.py
Normal file
@@ -0,0 +1,95 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Output JS build manifest as structured text for the MCP server."""
|
||||
from __future__ import annotations
|
||||
|
||||
import json
|
||||
import os
|
||||
import re
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
if _PROJECT not in sys.path:
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from hosts.javascript.platform import (
|
||||
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, SPEC_MODULE_ORDER,
|
||||
PRIMITIVES_JS_MODULES, _ALL_JS_MODULES, EXTENSION_NAMES,
|
||||
)
|
||||
|
||||
|
||||
def extract_primitives(js_code: str) -> list[str]:
|
||||
"""Extract PRIMITIVES["name"] registrations from JS code."""
|
||||
return sorted(set(re.findall(r'PRIMITIVES\["([^"]+)"\]', js_code)))
|
||||
|
||||
|
||||
def main():
|
||||
# Core spec files (always included)
|
||||
core_files = [
|
||||
"evaluator.sx (frames + eval + CEK)",
|
||||
"freeze.sx (serializable state)",
|
||||
"content.sx (content-addressed computation)",
|
||||
"render.sx (core renderer)",
|
||||
"web-forms.sx (defstyle, deftype, defeffect)",
|
||||
]
|
||||
|
||||
# Adapters
|
||||
adapter_lines = []
|
||||
for name, (filename, label) in sorted(ADAPTER_FILES.items()):
|
||||
deps = ADAPTER_DEPS.get(name, [])
|
||||
dep_str = f" (deps: {', '.join(deps)})" if deps else ""
|
||||
adapter_lines.append(f" {name:18s} {filename:22s} {label}{dep_str}")
|
||||
|
||||
# Spec modules
|
||||
module_lines = []
|
||||
for name in SPEC_MODULE_ORDER:
|
||||
if name in SPEC_MODULES:
|
||||
filename, label = SPEC_MODULES[name]
|
||||
module_lines.append(f" {name:18s} {filename:22s} {label}")
|
||||
|
||||
# Extensions
|
||||
ext_lines = [f" {name}" for name in sorted(EXTENSION_NAMES)]
|
||||
|
||||
# Primitive modules
|
||||
prim_lines = []
|
||||
for mod_name in sorted(_ALL_JS_MODULES):
|
||||
if mod_name in PRIMITIVES_JS_MODULES:
|
||||
prims = extract_primitives(PRIMITIVES_JS_MODULES[mod_name])
|
||||
prim_lines.append(f" {mod_name} ({len(prims)}): {', '.join(prims)}")
|
||||
|
||||
# Current build file
|
||||
build_path = os.path.join(_PROJECT, "shared", "static", "scripts", "sx-browser.js")
|
||||
build_info = ""
|
||||
if os.path.exists(build_path):
|
||||
size = os.path.getsize(build_path)
|
||||
mtime = os.path.getmtime(build_path)
|
||||
from datetime import datetime
|
||||
ts = datetime.fromtimestamp(mtime).strftime("%Y-%m-%d %H:%M:%S")
|
||||
# Count PRIMITIVES in actual build
|
||||
with open(build_path) as f:
|
||||
content = f.read()
|
||||
actual_prims = extract_primitives(content)
|
||||
build_info = f"\nCurrent build: {size:,} bytes, {ts}, {len(actual_prims)} primitives registered"
|
||||
|
||||
print(f"""JS Build Manifest
|
||||
=================
|
||||
{build_info}
|
||||
|
||||
Core files (always included):
|
||||
{chr(10).join(' ' + f for f in core_files)}
|
||||
|
||||
Adapters ({len(ADAPTER_FILES)}):
|
||||
{chr(10).join(adapter_lines)}
|
||||
|
||||
Spec modules ({len(SPEC_MODULES)}, order: {' → '.join(SPEC_MODULE_ORDER)}):
|
||||
{chr(10).join(module_lines)}
|
||||
|
||||
Extensions ({len(EXTENSION_NAMES)}):
|
||||
{chr(10).join(ext_lines)}
|
||||
|
||||
Primitive modules ({len(_ALL_JS_MODULES)}):
|
||||
{chr(10).join(prim_lines)}""")
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
@@ -13,7 +13,14 @@ from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
"""Parse .sx source, return list of (name, expr) for top-level forms.
|
||||
|
||||
Extracts (define name ...) forms with their name, plus selected
|
||||
non-define top-level expressions (e.g. register-special-form! calls)
|
||||
with a synthetic name for the comment.
|
||||
"""
|
||||
# Top-level calls that should be transpiled (not special forms)
|
||||
_TOPLEVEL_CALLS = {"register-special-form!"}
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
@@ -21,12 +28,18 @@ def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
elif expr[0].name in _TOPLEVEL_CALLS:
|
||||
# Top-level call expression (e.g. register-special-form!)
|
||||
call_name = expr[0].name
|
||||
defines.append((f"({call_name} ...)", expr))
|
||||
return defines
|
||||
|
||||
ADAPTER_FILES = {
|
||||
"parser": ("parser.sx", "parser"),
|
||||
"html": ("adapter-html.sx", "adapter-html"),
|
||||
"sx": ("adapter-sx.sx", "adapter-sx"),
|
||||
"dom-lib": ("lib/dom.sx", "lib/dom (DOM library)"),
|
||||
"browser-lib": ("lib/browser.sx", "lib/browser (browser API library)"),
|
||||
"dom": ("adapter-dom.sx", "adapter-dom"),
|
||||
"engine": ("engine.sx", "engine"),
|
||||
"orchestration": ("orchestration.sx","orchestration"),
|
||||
@@ -35,6 +48,9 @@ ADAPTER_FILES = {
|
||||
|
||||
# Dependencies
|
||||
ADAPTER_DEPS = {
|
||||
"dom-lib": [],
|
||||
"browser-lib": ["dom-lib"],
|
||||
"dom": ["dom-lib", "browser-lib"],
|
||||
"engine": ["dom"],
|
||||
"orchestration": ["engine", "dom"],
|
||||
"boot": ["dom", "engine", "orchestration", "parser"],
|
||||
@@ -45,15 +61,15 @@ SPEC_MODULES = {
|
||||
"deps": ("deps.sx", "deps (component dependency analysis)"),
|
||||
"router": ("router.sx", "router (client-side route matching)"),
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"signals-web": ("web-signals.sx", "signals-web (stores, events, resources)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"frames": ("frames.sx", "frames (CEK continuation frames)"),
|
||||
"cek": ("cek.sx", "cek (explicit CEK machine evaluator)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"vm": ("vm.sx", "vm (bytecode virtual machine)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
# Modules listed here are emitted in this order; any not listed use alphabetical.
|
||||
SPEC_MODULE_ORDER = ["deps", "frames", "page-helpers", "router", "cek", "signals", "types"]
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "signals-web", "types", "vm"]
|
||||
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
@@ -285,9 +301,11 @@ ASYNC_IO_JS = '''
|
||||
if (hname === "map-indexed") return asyncRenderMapIndexed(expr, env, ns);
|
||||
if (hname === "for-each") return asyncRenderMap(expr, env, ns);
|
||||
|
||||
// define/defcomp/defmacro — eval for side effects
|
||||
// define/defcomp/defmacro and custom special forms — eval for side effects
|
||||
if (hname === "define" || hname === "defcomp" || hname === "defmacro" ||
|
||||
hname === "defstyle" || hname === "defhandler") {
|
||||
hname === "defstyle" || hname === "defhandler" ||
|
||||
hname === "deftype" || hname === "defeffect" ||
|
||||
(typeof _customSpecialForms !== "undefined" && _customSpecialForms[hname])) {
|
||||
trampoline(evalExpr(expr, env));
|
||||
return null;
|
||||
}
|
||||
@@ -817,6 +835,16 @@ PREAMBLE = '''\
|
||||
;(function(global) {
|
||||
"use strict";
|
||||
|
||||
// =========================================================================
|
||||
// Equality — used by transpiled code (= a b) → sxEq(a, b)
|
||||
// =========================================================================
|
||||
function sxEq(a, b) {
|
||||
if (a === b) return true;
|
||||
if (a && b && a._sym && b._sym) return a.name === b.name;
|
||||
if (a && b && a._kw && b._kw) return a.name === b.name;
|
||||
return false;
|
||||
}
|
||||
|
||||
// =========================================================================
|
||||
// Types
|
||||
// =========================================================================
|
||||
@@ -926,8 +954,8 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
|
||||
"core.comparison": '''
|
||||
// core.comparison
|
||||
PRIMITIVES["="] = function(a, b) { return a === b; };
|
||||
PRIMITIVES["!="] = function(a, b) { return a !== b; };
|
||||
PRIMITIVES["="] = sxEq;
|
||||
PRIMITIVES["!="] = function(a, b) { return !sxEq(a, b); };
|
||||
PRIMITIVES["<"] = function(a, b) { return a < b; };
|
||||
PRIMITIVES[">"] = function(a, b) { return a > b; };
|
||||
PRIMITIVES["<="] = function(a, b) { return a <= b; };
|
||||
@@ -1009,7 +1037,7 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["len"] = function(c) { return Array.isArray(c) ? c.length : typeof c === "string" ? c.length : Object.keys(c).length; };
|
||||
PRIMITIVES["first"] = function(c) { return c && c.length > 0 ? c[0] : NIL; };
|
||||
PRIMITIVES["last"] = function(c) { return c && c.length > 0 ? c[c.length - 1] : NIL; };
|
||||
PRIMITIVES["rest"] = function(c) { if (c && typeof c.slice !== "function") { console.error("[sx-debug] rest called on non-sliceable:", typeof c, c, new Error().stack); return []; } return c ? c.slice(1) : []; };
|
||||
PRIMITIVES["rest"] = function(c) { if (!c || c._nil) return []; if (typeof c.slice !== "function") return []; return c.slice(1); };
|
||||
PRIMITIVES["nth"] = function(c, n) { return c && n >= 0 && n < c.length ? c[n] : NIL; };
|
||||
PRIMITIVES["cons"] = function(x, c) { return [x].concat(c || []); };
|
||||
PRIMITIVES["append"] = function(c, x) { return (c || []).concat(Array.isArray(x) ? x : [x]); };
|
||||
@@ -1050,6 +1078,8 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["dict-set!"] = function(d, k, v) { d[k] = v; return v; };
|
||||
PRIMITIVES["has-key?"] = function(d, k) { return d !== null && d !== undefined && k in d; };
|
||||
PRIMITIVES["into"] = function(target, coll) {
|
||||
if (target === "list") return Array.isArray(coll) ? coll.slice() : Object.entries(coll).map(function(e) { return [e[0], e[1]]; });
|
||||
if (target === "dict") { var r = {}; for (var i = 0; i < coll.length; i++) { var p = coll[i]; if (Array.isArray(p) && p.length >= 2) r[p[0]] = p[1]; } return r; }
|
||||
if (Array.isArray(target)) return Array.isArray(coll) ? coll.slice() : Object.entries(coll);
|
||||
var r = {}; for (var i = 0; i < coll.length; i++) { var p = coll[i]; if (Array.isArray(p) && p.length >= 2) r[p[0]] = p[1]; }
|
||||
return r;
|
||||
@@ -1113,6 +1143,58 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["context"] = sxContext;
|
||||
PRIMITIVES["emit!"] = sxEmit;
|
||||
PRIMITIVES["emitted"] = sxEmitted;
|
||||
// Aliases for aser adapter (avoids CEK special form conflict on server)
|
||||
var scopeEmit = sxEmit;
|
||||
function scopePeek(name) {
|
||||
if (_scopeStacks[name] && _scopeStacks[name].length) {
|
||||
return _scopeStacks[name][_scopeStacks[name].length - 1].value;
|
||||
}
|
||||
return NIL;
|
||||
}
|
||||
PRIMITIVES["scope-emit!"] = scopeEmit;
|
||||
PRIMITIVES["scope-peek"] = scopePeek;
|
||||
PRIMITIVES["scope-emitted"] = sxEmitted;
|
||||
PRIMITIVES["scope-collected"] = sxCollected;
|
||||
PRIMITIVES["scope-clear-collected!"] = sxClearCollected;
|
||||
|
||||
// ---- VM stack primitives ----
|
||||
// The VM spec (vm.sx) requires these array-like operations.
|
||||
// In JS, a plain Array serves as the stack.
|
||||
PRIMITIVES["make-vm-stack"] = function(size) {
|
||||
var a = new Array(size);
|
||||
for (var i = 0; i < size; i++) a[i] = NIL;
|
||||
return a;
|
||||
};
|
||||
PRIMITIVES["vm-stack-get"] = function(stack, idx) { return stack[idx]; };
|
||||
PRIMITIVES["vm-stack-set!"] = function(stack, idx, value) { stack[idx] = value; return NIL; };
|
||||
PRIMITIVES["vm-stack-length"] = function(stack) { return stack.length; };
|
||||
PRIMITIVES["vm-stack-copy!"] = function(src, dst, count) {
|
||||
for (var i = 0; i < count; i++) dst[i] = src[i];
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["get-primitive"] = function(name) {
|
||||
if (name in PRIMITIVES) return PRIMITIVES[name];
|
||||
throw new Error("VM undefined: " + name);
|
||||
};
|
||||
PRIMITIVES["call-primitive"] = function(name, args) {
|
||||
if (!(name in PRIMITIVES)) throw new Error("VM undefined: " + name);
|
||||
var fn = PRIMITIVES[name];
|
||||
return fn.apply(null, Array.isArray(args) ? args : []);
|
||||
};
|
||||
PRIMITIVES["primitive?"] = function(name) {
|
||||
return name in PRIMITIVES;
|
||||
};
|
||||
PRIMITIVES["set-nth!"] = function(lst, idx, val) {
|
||||
lst[idx] = val;
|
||||
return NIL;
|
||||
};
|
||||
|
||||
PRIMITIVES["env-parent"] = function(env) {
|
||||
if (env && Object.getPrototypeOf(env) !== Object.prototype &&
|
||||
Object.getPrototypeOf(env) !== null)
|
||||
return Object.getPrototypeOf(env);
|
||||
return NIL;
|
||||
};
|
||||
''',
|
||||
}
|
||||
# Modules to include by default (all)
|
||||
@@ -1151,6 +1233,7 @@ PLATFORM_JS_PRE = '''
|
||||
if (x._spread) return "spread";
|
||||
if (x._macro) return "macro";
|
||||
if (x._raw) return "raw-html";
|
||||
if (x._sx_expr) return "sx-expr";
|
||||
if (typeof Node !== "undefined" && x instanceof Node) return "dom-node";
|
||||
if (Array.isArray(x)) return "list";
|
||||
if (typeof x === "object") return "dict";
|
||||
@@ -1235,6 +1318,7 @@ PLATFORM_JS_PRE = '''
|
||||
function componentClosure(c) { return c.closure; }
|
||||
function componentHasChildren(c) { return c.hasChildren; }
|
||||
function componentName(c) { return c.name; }
|
||||
function componentFile(c) { return (c && c.file) ? c.file : NIL; }
|
||||
function componentAffinity(c) { return c.affinity || "auto"; }
|
||||
function componentParamTypes(c) { return (c && c._paramTypes) ? c._paramTypes : NIL; }
|
||||
function componentSetParamTypes_b(c, t) { if (c) c._paramTypes = t; return NIL; }
|
||||
@@ -1396,6 +1480,11 @@ PLATFORM_JS_POST = '''
|
||||
var get = PRIMITIVES["get"];
|
||||
var assoc = PRIMITIVES["assoc"];
|
||||
var range = PRIMITIVES["range"];
|
||||
var floor = PRIMITIVES["floor"];
|
||||
var pow = PRIMITIVES["pow"];
|
||||
var mod = PRIMITIVES["mod"];
|
||||
var indexOf_ = PRIMITIVES["index-of"];
|
||||
var hasKey = PRIMITIVES["has-key?"];
|
||||
function zip(a, b) { var r = []; for (var i = 0; i < Math.min(a.length, b.length); i++) r.push([a[i], b[i]]); return r; }
|
||||
function append_b(arr, x) { arr.push(x); return arr; }
|
||||
var apply = function(f, args) {
|
||||
@@ -1414,12 +1503,10 @@ PLATFORM_JS_POST = '''
|
||||
var dict_fn = PRIMITIVES["dict"];
|
||||
|
||||
// HTML rendering helpers
|
||||
function escapeHtml(s) {
|
||||
return String(s).replace(/&/g,"&").replace(/</g,"<").replace(/>/g,">").replace(/"/g,""");
|
||||
}
|
||||
function escapeAttr(s) { return escapeHtml(s); }
|
||||
// escape-html and escape-attr are now library functions defined in render.sx
|
||||
function rawHtmlContent(r) { return r.html; }
|
||||
function makeRawHtml(s) { return { _raw: true, html: s }; }
|
||||
function makeSxExpr(s) { return { _sx_expr: true, source: s }; }
|
||||
function sxExprSource(x) { return x && x.source ? x.source : String(x); }
|
||||
|
||||
// Placeholders — overridden by transpiled spec from parser.sx / adapter-sx.sx
|
||||
@@ -1427,11 +1514,102 @@ PLATFORM_JS_POST = '''
|
||||
function isSpecialForm(n) { return false; }
|
||||
function isHoForm(n) { return false; }
|
||||
|
||||
// -----------------------------------------------------------------------
|
||||
// Host FFI — the irreducible web platform primitives
|
||||
// All DOM/browser operations are built on these in web/lib/dom.sx
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["host-global"] = function(name) {
|
||||
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
|
||||
if (typeof window !== "undefined" && name in window) return window[name];
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["host-get"] = function(obj, prop) {
|
||||
if (obj == null || obj === NIL) return NIL;
|
||||
var v = obj[prop];
|
||||
return v === undefined || v === null ? NIL : v;
|
||||
};
|
||||
PRIMITIVES["host-set!"] = function(obj, prop, val) {
|
||||
if (obj != null && obj !== NIL) obj[prop] = val === NIL ? null : val;
|
||||
};
|
||||
PRIMITIVES["host-call"] = function() {
|
||||
var obj = arguments[0], method = arguments[1];
|
||||
var args = [];
|
||||
for (var i = 2; i < arguments.length; i++) {
|
||||
var a = arguments[i];
|
||||
args.push(a === NIL ? null : a);
|
||||
}
|
||||
if (obj == null || obj === NIL) {
|
||||
// Global function call
|
||||
var fn = typeof globalThis !== "undefined" ? globalThis[method] : window[method];
|
||||
if (typeof fn === "function") return fn.apply(null, args);
|
||||
return NIL;
|
||||
}
|
||||
if (typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, args); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["host-new"] = function() {
|
||||
var name = arguments[0];
|
||||
var args = Array.prototype.slice.call(arguments, 1).map(function(a) { return a === NIL ? null : a; });
|
||||
var Ctor = typeof globalThis !== "undefined" ? globalThis[name] : window[name];
|
||||
if (typeof Ctor !== "function") return NIL;
|
||||
// Support 0-4 args (covers all practical cases)
|
||||
switch (args.length) {
|
||||
case 0: return new Ctor();
|
||||
case 1: return new Ctor(args[0]);
|
||||
case 2: return new Ctor(args[0], args[1]);
|
||||
case 3: return new Ctor(args[0], args[1], args[2]);
|
||||
default: return new Ctor(args[0], args[1], args[2], args[3]);
|
||||
}
|
||||
};
|
||||
PRIMITIVES["host-callback"] = function(fn) {
|
||||
// Wrap SX function/lambda as a native JS callback
|
||||
if (typeof fn === "function") return fn;
|
||||
if (fn && fn._type === "lambda") {
|
||||
return function() {
|
||||
var a = Array.prototype.slice.call(arguments);
|
||||
return cekCall(fn, a);
|
||||
};
|
||||
}
|
||||
return function() {};
|
||||
};
|
||||
PRIMITIVES["host-typeof"] = function(obj) {
|
||||
if (obj == null || obj === NIL) return "nil";
|
||||
if (obj instanceof Element) return "element";
|
||||
if (obj instanceof Text) return "text";
|
||||
if (obj instanceof DocumentFragment) return "fragment";
|
||||
if (obj instanceof Document) return "document";
|
||||
if (obj instanceof Event) return "event";
|
||||
if (obj instanceof Promise) return "promise";
|
||||
if (obj instanceof AbortController) return "abort-controller";
|
||||
return typeof obj;
|
||||
};
|
||||
PRIMITIVES["host-await"] = function(promise, callback) {
|
||||
if (promise && typeof promise.then === "function") {
|
||||
var cb = typeof callback === "function" ? callback :
|
||||
(callback && callback._type === "lambda") ?
|
||||
function(v) { return cekCall(callback, [v]); } : function() {};
|
||||
promise.then(cb);
|
||||
}
|
||||
};
|
||||
// Aliases for transpiled dom.sx / browser.sx code (transpiler mangles host-* names)
|
||||
var hostGlobal = PRIMITIVES["host-global"];
|
||||
var hostGet = PRIMITIVES["host-get"];
|
||||
var hostSet = PRIMITIVES["host-set!"];
|
||||
var hostCall = PRIMITIVES["host-call"];
|
||||
var hostNew = PRIMITIVES["host-new"];
|
||||
var hostCallback = PRIMITIVES["host-callback"];
|
||||
var hostTypeof = PRIMITIVES["host-typeof"];
|
||||
var hostAwait = PRIMITIVES["host-await"];
|
||||
|
||||
// processBindings and evalCond — now specced in render.sx, bootstrapped above
|
||||
|
||||
function isDefinitionForm(name) {
|
||||
return name === "define" || name === "defcomp" || name === "defmacro" ||
|
||||
name === "defstyle" || name === "defhandler";
|
||||
name === "defstyle" || name === "defhandler" ||
|
||||
name === "deftype" || name === "defeffect";
|
||||
}
|
||||
|
||||
function indexOf_(s, ch) {
|
||||
@@ -1536,7 +1714,8 @@ PLATFORM_CEK_JS = '''
|
||||
CEK_FIXUPS_JS = '''
|
||||
// Override recursive cekRun with iterative loop (avoids stack overflow)
|
||||
cekRun = function(state) {
|
||||
while (!cekTerminal_p(state)) { state = cekStep(state); }
|
||||
while (!cekTerminal_p(state) && !cekSuspended_p(state)) { state = cekStep(state); }
|
||||
if (cekSuspended_p(state)) { throw new Error("IO suspension in non-IO context"); }
|
||||
return cekValue(state);
|
||||
};
|
||||
|
||||
@@ -1566,21 +1745,8 @@ CEK_FIXUPS_JS = '''
|
||||
PRIMITIVES["island?"] = isIsland;
|
||||
PRIMITIVES["make-symbol"] = function(n) { return new Symbol(n); };
|
||||
PRIMITIVES["is-html-tag?"] = function(n) { return HTML_TAGS.indexOf(n) >= 0; };
|
||||
PRIMITIVES["make-env"] = function() { return merge(componentEnv, PRIMITIVES); };
|
||||
|
||||
// localStorage — defined here (before boot) so islands can use at hydration
|
||||
PRIMITIVES["local-storage-get"] = function(key) {
|
||||
try { var v = localStorage.getItem(key); return v === null ? NIL : v; }
|
||||
catch (e) { return NIL; }
|
||||
};
|
||||
PRIMITIVES["local-storage-set"] = function(key, val) {
|
||||
try { localStorage.setItem(key, val); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["local-storage-remove"] = function(key) {
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
function makeEnv() { return merge(componentEnv, PRIMITIVES); }
|
||||
PRIMITIVES["make-env"] = makeEnv;
|
||||
'''
|
||||
|
||||
|
||||
@@ -1689,7 +1855,7 @@ PLATFORM_PARSER_JS = r"""
|
||||
function escapeString(s) {
|
||||
return s.replace(/\\/g, "\\\\").replace(/"/g, '\\"').replace(/\n/g, "\\n").replace(/\t/g, "\\t");
|
||||
}
|
||||
function sxExprSource(e) { return typeof e === "string" ? e : String(e); }
|
||||
function sxExprSource(e) { return typeof e === "string" ? e : (e && e.source ? e.source : String(e)); }
|
||||
var charFromCode = PRIMITIVES["char-from-code"];
|
||||
"""
|
||||
|
||||
@@ -1705,6 +1871,11 @@ PLATFORM_DOM_JS = """
|
||||
_renderExprFn = function(expr, env) { return renderToDom(expr, env, null); };
|
||||
_renderMode = true; // Browser always evaluates in render context.
|
||||
|
||||
// Wire CEK render hooks — evaluator checks _renderCheck/_renderFn instead of
|
||||
// the old renderActiveP()/isRenderExpr()/renderExpr() triple.
|
||||
_renderCheck = function(expr, env) { return _renderMode && isRenderExpr(expr); };
|
||||
_renderFn = function(expr, env) { return renderToDom(expr, env, null); };
|
||||
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
var MATH_NS = "http://www.w3.org/1998/Math/MathML";
|
||||
|
||||
@@ -1871,12 +2042,14 @@ PLATFORM_DOM_JS = """
|
||||
// If lambda takes 0 params, call without event arg (convenience for on-click handlers)
|
||||
var wrapped = isLambda(handler)
|
||||
? (lambdaParams(handler).length === 0
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } finally { runPostRenderHooks(); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } finally { runPostRenderHooks(); } })
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
|
||||
: handler;
|
||||
if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
|
||||
var opts = passiveEvents[name] ? { passive: true } : undefined;
|
||||
el.addEventListener(name, wrapped, opts);
|
||||
return function() { el.removeEventListener(name, wrapped, opts); };
|
||||
}
|
||||
|
||||
function eventDetail(e) {
|
||||
@@ -2190,7 +2363,10 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
}
|
||||
}
|
||||
});
|
||||
}).catch(function() { location.reload(); });
|
||||
}).catch(function(err) {
|
||||
logWarn("sx:popstate fetch error " + url + " — " + (err && err.message ? err.message : err));
|
||||
location.reload();
|
||||
});
|
||||
}
|
||||
|
||||
function fetchStreaming(target, url, headers) {
|
||||
@@ -2328,7 +2504,9 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
return resp.text().then(function(text) {
|
||||
preloadCacheSet(cache, url, text, ct);
|
||||
});
|
||||
}).catch(function() { /* ignore */ });
|
||||
}).catch(function(err) {
|
||||
logInfo("sx:preload error " + url + " — " + (err && err.message ? err.message : err));
|
||||
});
|
||||
}
|
||||
|
||||
// --- Request body building ---
|
||||
@@ -2493,6 +2671,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function preventDefault_(e) { if (e && e.preventDefault) e.preventDefault(); }
|
||||
function stopPropagation_(e) { if (e && e.stopPropagation) e.stopPropagation(); }
|
||||
function eventModifierKey_p(e) { return !!(e && (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey)); }
|
||||
function domFocus(el) { if (el && el.focus) el.focus(); }
|
||||
function tryCatch(tryFn, catchFn) {
|
||||
var t = _wrapSxFn(tryFn);
|
||||
@@ -2501,6 +2680,17 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
: catchFn;
|
||||
try { return t(); } catch (e) { return c(e); }
|
||||
}
|
||||
function cekTry(thunkFn, handlerFn) {
|
||||
try {
|
||||
var result = _wrapSxFn(thunkFn)();
|
||||
if (!handlerFn || handlerFn === NIL) return [makeSymbol("ok"), result];
|
||||
return result;
|
||||
} catch (e) {
|
||||
var msg = (e && e.message) ? e.message : String(e);
|
||||
if (handlerFn && handlerFn !== NIL) return _wrapSxFn(handlerFn)(msg);
|
||||
return [makeSymbol("error"), msg];
|
||||
}
|
||||
}
|
||||
function errorMessage(e) {
|
||||
return e && e.message ? e.message : String(e);
|
||||
}
|
||||
@@ -2596,6 +2786,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function bindBoostLink(el, _href) {
|
||||
el.addEventListener("click", function(e) {
|
||||
if (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey) return;
|
||||
e.preventDefault();
|
||||
// Re-read href from element at click time (not closed-over value)
|
||||
var liveHref = el.getAttribute("href") || _href;
|
||||
@@ -2617,6 +2808,8 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
var liveAction = form.getAttribute("action") || _action || location.href;
|
||||
executeRequest(form, { method: liveMethod, url: liveAction }).then(function() {
|
||||
try { history.pushState({ sxUrl: liveAction, scrollY: window.scrollY }, "", liveAction); } catch (err) {}
|
||||
}).catch(function(err) {
|
||||
logWarn("sx:boost form error " + liveMethod + " " + liveAction + " — " + (err && err.message ? err.message : err));
|
||||
});
|
||||
});
|
||||
}
|
||||
@@ -2625,6 +2818,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function bindClientRouteClick(link, _href, fallbackFn) {
|
||||
link.addEventListener("click", function(e) {
|
||||
if (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey) return;
|
||||
e.preventDefault();
|
||||
// Re-read href from element at click time (not closed-over value)
|
||||
var liveHref = link.getAttribute("href") || _href;
|
||||
@@ -2775,7 +2969,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
} else {
|
||||
fn();
|
||||
}
|
||||
});
|
||||
}, { passive: true });
|
||||
});
|
||||
}
|
||||
|
||||
@@ -2785,6 +2979,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function markProcessed(el, key) { el[PROCESSED + key] = true; }
|
||||
function isProcessed(el, key) { return !!el[PROCESSED + key]; }
|
||||
function clearProcessed(el, key) { delete el[PROCESSED + key]; }
|
||||
|
||||
// --- Script cloning ---
|
||||
|
||||
@@ -2908,7 +3103,7 @@ PLATFORM_BOOT_JS = """
|
||||
}
|
||||
|
||||
function getRenderEnv(extraEnv) {
|
||||
return extraEnv ? merge(componentEnv, extraEnv) : componentEnv;
|
||||
return extraEnv ? merge(componentEnv, PRIMITIVES, extraEnv) : merge(componentEnv, PRIMITIVES);
|
||||
}
|
||||
|
||||
function mergeEnvs(base, newEnv) {
|
||||
@@ -3038,57 +3233,45 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
return _rawCallLambda(f, args, callerEnv);
|
||||
};
|
||||
|
||||
// Expose render functions as primitives so SX code can call them''']
|
||||
if has_html:
|
||||
lines.append(' if (typeof renderToHtml === "function") PRIMITIVES["render-to-html"] = renderToHtml;')
|
||||
if has_sx:
|
||||
lines.append(' if (typeof renderToSx === "function") PRIMITIVES["render-to-sx"] = renderToSx;')
|
||||
lines.append(' if (typeof aser === "function") PRIMITIVES["aser"] = aser;')
|
||||
if has_dom:
|
||||
lines.append(' if (typeof renderToDom === "function") PRIMITIVES["render-to-dom"] = renderToDom;')
|
||||
if has_signals:
|
||||
lines.append('''
|
||||
// Expose signal functions as primitives so runtime-evaluated SX code
|
||||
// (e.g. island bodies from .sx files) can call them
|
||||
PRIMITIVES["signal"] = signal;
|
||||
PRIMITIVES["signal?"] = isSignal;
|
||||
PRIMITIVES["deref"] = deref;
|
||||
PRIMITIVES["reset!"] = reset_b;
|
||||
PRIMITIVES["swap!"] = swap_b;
|
||||
PRIMITIVES["computed"] = computed;
|
||||
PRIMITIVES["effect"] = effect;
|
||||
PRIMITIVES["batch"] = batch;
|
||||
// Timer primitives for island code
|
||||
PRIMITIVES["set-interval"] = setInterval_;
|
||||
PRIMITIVES["clear-interval"] = clearInterval_;
|
||||
// Reactive DOM helpers for island code
|
||||
PRIMITIVES["reactive-text"] = reactiveText;
|
||||
PRIMITIVES["create-text-node"] = createTextNode;
|
||||
PRIMITIVES["dom-set-text-content"] = domSetTextContent;
|
||||
PRIMITIVES["dom-listen"] = domListen;
|
||||
PRIMITIVES["dom-dispatch"] = domDispatch;
|
||||
PRIMITIVES["event-detail"] = eventDetail;
|
||||
PRIMITIVES["resource"] = resource;
|
||||
PRIMITIVES["promise-delayed"] = promiseDelayed;
|
||||
PRIMITIVES["promise-then"] = promiseThen;
|
||||
PRIMITIVES["def-store"] = defStore;
|
||||
PRIMITIVES["use-store"] = useStore;
|
||||
PRIMITIVES["emit-event"] = emitEvent;
|
||||
PRIMITIVES["on-event"] = onEvent;
|
||||
PRIMITIVES["bridge-event"] = bridgeEvent;
|
||||
// DOM primitives for island code
|
||||
PRIMITIVES["dom-focus"] = domFocus;
|
||||
PRIMITIVES["dom-tag-name"] = domTagName;
|
||||
PRIMITIVES["dom-get-prop"] = domGetProp;
|
||||
PRIMITIVES["dom-set-prop"] = domSetProp;
|
||||
PRIMITIVES["dom-call-method"] = domCallMethod;
|
||||
PRIMITIVES["dom-post-message"] = domPostMessage;
|
||||
// -----------------------------------------------------------------------
|
||||
// Core primitives that require native JS (cannot be expressed via FFI)
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
PRIMITIVES["sort"] = function(lst) {
|
||||
if (!Array.isArray(lst)) return lst;
|
||||
return lst.slice().sort(function(a, b) {
|
||||
if (a < b) return -1; if (a > b) return 1; return 0;
|
||||
});
|
||||
};
|
||||
|
||||
// Aliases for VM bytecode compatibility
|
||||
PRIMITIVES["length"] = PRIMITIVES["len"];
|
||||
// FFI library functions — defined in dom.sx/browser.sx but not transpiled.
|
||||
// Registered here so runtime-evaluated SX code (data-init, islands) can use them.
|
||||
PRIMITIVES["prevent-default"] = preventDefault_;
|
||||
PRIMITIVES["stop-propagation"] = stopPropagation_;
|
||||
PRIMITIVES["event-modifier-key?"] = eventModifierKey_p;
|
||||
PRIMITIVES["element-value"] = elementValue;
|
||||
PRIMITIVES["error-message"] = errorMessage;
|
||||
PRIMITIVES["schedule-idle"] = scheduleIdle;
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
PRIMITIVES["filter"] = filter;
|
||||
// DOM primitives for sx-on:* handlers and data-init scripts
|
||||
PRIMITIVES["console-log"] = function() {
|
||||
var args = Array.prototype.slice.call(arguments);
|
||||
console.log.apply(console, ["[sx]"].concat(args));
|
||||
return args.length > 0 ? args[0] : NIL;
|
||||
};
|
||||
PRIMITIVES["set-cookie"] = function(name, value, days) {
|
||||
var d = days || 365;
|
||||
var expires = new Date(Date.now() + d * 864e5).toUTCString();
|
||||
document.cookie = name + "=" + encodeURIComponent(value) + ";expires=" + expires + ";path=/;SameSite=Lax";
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["get-cookie"] = function(name) {
|
||||
var m = document.cookie.match(new RegExp("(?:^|;\\\\s*)" + name + "=([^;]*)"));
|
||||
return m ? decodeURIComponent(m[1]) : NIL;
|
||||
};
|
||||
|
||||
// dom.sx / browser.sx library functions — not transpiled, registered from
|
||||
// native platform implementations so runtime-eval'd SX code can use them.
|
||||
if (typeof domBody === "function") PRIMITIVES["dom-body"] = domBody;
|
||||
if (typeof domQuery === "function") PRIMITIVES["dom-query"] = domQuery;
|
||||
if (typeof domQueryAll === "function") PRIMITIVES["dom-query-all"] = domQueryAll;
|
||||
@@ -3102,8 +3285,6 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
if (typeof domHasClass === "function") PRIMITIVES["dom-has-class?"] = domHasClass;
|
||||
if (typeof domClosest === "function") PRIMITIVES["dom-closest"] = domClosest;
|
||||
if (typeof domMatches === "function") PRIMITIVES["dom-matches?"] = domMatches;
|
||||
if (typeof preventDefault_ === "function") PRIMITIVES["prevent-default"] = preventDefault_;
|
||||
if (typeof elementValue === "function") PRIMITIVES["element-value"] = elementValue;
|
||||
if (typeof domOuterHtml === "function") PRIMITIVES["dom-outer-html"] = domOuterHtml;
|
||||
if (typeof domInnerHtml === "function") PRIMITIVES["dom-inner-html"] = domInnerHtml;
|
||||
if (typeof domTextContent === "function") PRIMITIVES["dom-text-content"] = domTextContent;
|
||||
@@ -3112,52 +3293,70 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
if (typeof domAppendToHead === "function") PRIMITIVES["dom-append-to-head"] = domAppendToHead;
|
||||
if (typeof jsonParse === "function") PRIMITIVES["json-parse"] = jsonParse;
|
||||
if (typeof nowMs === "function") PRIMITIVES["now-ms"] = nowMs;
|
||||
PRIMITIVES["sx-parse"] = sxParse;
|
||||
PRIMITIVES["console-log"] = function() { console.log.apply(console, ["[sx]"].concat(Array.prototype.slice.call(arguments))); return arguments.length > 0 ? arguments[0] : NIL; };''')
|
||||
PRIMITIVES["log-info"] = logInfo;
|
||||
PRIMITIVES["log-warn"] = logWarn;
|
||||
PRIMITIVES["dom-listen"] = domListen;
|
||||
PRIMITIVES["dom-dispatch"] = domDispatch;
|
||||
PRIMITIVES["event-detail"] = eventDetail;
|
||||
PRIMITIVES["create-text-node"] = createTextNode;
|
||||
PRIMITIVES["dom-set-text-content"] = domSetTextContent;
|
||||
PRIMITIVES["dom-focus"] = domFocus;
|
||||
PRIMITIVES["dom-tag-name"] = domTagName;
|
||||
PRIMITIVES["dom-get-prop"] = domGetProp;
|
||||
PRIMITIVES["dom-set-prop"] = domSetProp;
|
||||
PRIMITIVES["reactive-text"] = reactiveText;
|
||||
PRIMITIVES["set-interval"] = setInterval_;
|
||||
PRIMITIVES["clear-interval"] = clearInterval_;
|
||||
PRIMITIVES["promise-then"] = promiseThen;
|
||||
PRIMITIVES["promise-delayed"] = promiseDelayed;
|
||||
PRIMITIVES["local-storage-get"] = function(key) {
|
||||
try { var v = localStorage.getItem(key); return v === null ? NIL : v; }
|
||||
catch (e) { return NIL; }
|
||||
};
|
||||
PRIMITIVES["local-storage-set"] = function(key, val) {
|
||||
try { localStorage.setItem(key, val); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["local-storage-remove"] = function(key) {
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
if (typeof sxParse === "function") PRIMITIVES["sx-parse"] = sxParse;
|
||||
PRIMITIVES["cek-try"] = function(thunkFn, handlerFn) {
|
||||
try {
|
||||
var result = _wrapSxFn(thunkFn)();
|
||||
if (!handlerFn || handlerFn === NIL) return [makeSymbol("ok"), result];
|
||||
return result;
|
||||
} catch (e) {
|
||||
var msg = (e && e.message) ? e.message : String(e);
|
||||
if (handlerFn && handlerFn !== NIL) return _wrapSxFn(handlerFn)(msg);
|
||||
return [makeSymbol("error"), msg];
|
||||
}
|
||||
};
|
||||
// Named stores — global mutable registry (mirrors OCaml sx_primitives.ml)
|
||||
var _storeRegistry = {};
|
||||
function defStore(name, initFn) {
|
||||
if (!_storeRegistry.hasOwnProperty(name)) {
|
||||
_storeRegistry[name] = _wrapSxFn(initFn)();
|
||||
}
|
||||
return _storeRegistry[name];
|
||||
}
|
||||
function useStore(name) {
|
||||
if (!_storeRegistry.hasOwnProperty(name)) throw new Error("Store not found: " + name);
|
||||
return _storeRegistry[name];
|
||||
}
|
||||
function clearStores() { _storeRegistry = {}; return NIL; }
|
||||
PRIMITIVES["def-store"] = defStore;
|
||||
PRIMITIVES["use-store"] = useStore;
|
||||
PRIMITIVES["clear-stores"] = clearStores;''']
|
||||
if has_deps:
|
||||
lines.append('''
|
||||
// Expose deps module functions as primitives so runtime-evaluated SX code
|
||||
// (e.g. test-deps.sx in browser) can call them
|
||||
// Platform functions (from PLATFORM_DEPS_JS)
|
||||
// Platform deps functions (native JS, not transpiled — need explicit registration)
|
||||
PRIMITIVES["component-deps"] = componentDeps;
|
||||
PRIMITIVES["component-set-deps!"] = componentSetDeps;
|
||||
PRIMITIVES["component-css-classes"] = componentCssClasses;
|
||||
PRIMITIVES["env-components"] = envComponents;
|
||||
PRIMITIVES["regex-find-all"] = regexFindAll;
|
||||
PRIMITIVES["scan-css-classes"] = scanCssClasses;
|
||||
// Transpiled functions (from deps.sx)
|
||||
PRIMITIVES["scan-refs"] = scanRefs;
|
||||
PRIMITIVES["scan-refs-walk"] = scanRefsWalk;
|
||||
PRIMITIVES["transitive-deps"] = transitiveDeps;
|
||||
PRIMITIVES["transitive-deps-walk"] = transitiveDepsWalk;
|
||||
PRIMITIVES["compute-all-deps"] = computeAllDeps;
|
||||
PRIMITIVES["scan-components-from-source"] = scanComponentsFromSource;
|
||||
PRIMITIVES["components-needed"] = componentsNeeded;
|
||||
PRIMITIVES["page-component-bundle"] = pageComponentBundle;
|
||||
PRIMITIVES["page-css-classes"] = pageCssClasses;
|
||||
PRIMITIVES["scan-io-refs-walk"] = scanIoRefsWalk;
|
||||
PRIMITIVES["scan-io-refs"] = scanIoRefs;
|
||||
PRIMITIVES["transitive-io-refs-walk"] = transitiveIoRefsWalk;
|
||||
PRIMITIVES["transitive-io-refs"] = transitiveIoRefs;
|
||||
PRIMITIVES["compute-all-io-refs"] = computeAllIoRefs;
|
||||
PRIMITIVES["component-io-refs-cached"] = componentIoRefsCached;
|
||||
PRIMITIVES["component-pure?"] = componentPure_p;
|
||||
PRIMITIVES["render-target"] = renderTarget;
|
||||
PRIMITIVES["page-render-plan"] = pageRenderPlan;''')
|
||||
if has_page_helpers:
|
||||
lines.append('''
|
||||
// Expose page-helper functions as primitives
|
||||
PRIMITIVES["categorize-special-forms"] = categorizeSpecialForms;
|
||||
PRIMITIVES["extract-define-kwargs"] = extractDefineKwargs;
|
||||
PRIMITIVES["build-reference-data"] = buildReferenceData;
|
||||
PRIMITIVES["build-ref-items-with-href"] = buildRefItemsWithHref;
|
||||
PRIMITIVES["build-attr-detail"] = buildAttrDetail;
|
||||
PRIMITIVES["build-header-detail"] = buildHeaderDetail;
|
||||
PRIMITIVES["build-event-detail"] = buildEventDetail;
|
||||
PRIMITIVES["build-component-source"] = buildComponentSource;
|
||||
PRIMITIVES["build-bundle-analysis"] = buildBundleAnalysis;
|
||||
PRIMITIVES["build-routing-analysis"] = buildRoutingAnalysis;
|
||||
PRIMITIVES["build-affinity-analysis"] = buildAffinityAnalysis;''')
|
||||
PRIMITIVES["scan-css-classes"] = scanCssClasses;''')
|
||||
return "\n".join(lines)
|
||||
|
||||
|
||||
|
||||
@@ -81,6 +81,19 @@ env["env-extend"] = function(e) { return Object.create(e); };
|
||||
env["env-merge"] = function(a, b) { return Object.assign({}, a, b); };
|
||||
|
||||
// Missing primitives referenced by tests
|
||||
// primitive? is now in platform.py PRIMITIVES
|
||||
env["contains-char?"] = function(s, c) { return typeof s === "string" && typeof c === "string" && s.indexOf(c) >= 0; };
|
||||
env["escape-string"] = function(s) { return s.replace(/\\/g, "\\\\").replace(/"/g, '\\"').replace(/\n/g, "\\n").replace(/\t/g, "\\t"); };
|
||||
env["trim-right"] = function(s) { return typeof s === "string" ? s.trimEnd() : s; };
|
||||
env["sha3-256"] = function(s) {
|
||||
// Simple hash stub for testing — not real SHA3
|
||||
var h = 0;
|
||||
for (var i = 0; i < s.length; i++) { h = ((h << 5) - h + s.charCodeAt(i)) | 0; }
|
||||
h = Math.abs(h);
|
||||
var hex = h.toString(16);
|
||||
while (hex.length < 64) hex = "0" + hex;
|
||||
return hex;
|
||||
};
|
||||
env["upcase"] = function(s) { return s.toUpperCase(); };
|
||||
env["downcase"] = function(s) { return s.toLowerCase(); };
|
||||
env["make-keyword"] = function(name) { return new Sx.Keyword(name); };
|
||||
@@ -218,6 +231,33 @@ env["component-has-children"] = function(c) {
|
||||
return c && c.has_children ? c.has_children : false;
|
||||
};
|
||||
|
||||
// Aser test helper: parse SX source, evaluate via aser, return wire format string
|
||||
env["render-sx"] = function(source) {
|
||||
const exprs = Sx.parse(source);
|
||||
const parts = [];
|
||||
for (const expr of exprs) {
|
||||
const result = Sx.renderToSx(expr, env);
|
||||
if (result !== null && result !== undefined && result !== Sx.NIL) {
|
||||
parts.push(typeof result === "string" ? result : Sx.serialize(result));
|
||||
}
|
||||
}
|
||||
return parts.join("");
|
||||
};
|
||||
|
||||
// Mock request/state primitives for test-handlers.sx
|
||||
const _mockState = {};
|
||||
env["now"] = function(fmt) { return new Date().toISOString(); };
|
||||
env["state-get"] = function(key, dflt) { return key in _mockState ? _mockState[key] : (dflt !== undefined ? dflt : null); };
|
||||
env["state-set!"] = function(key, val) { _mockState[key] = val; return val; };
|
||||
env["state-clear!"] = function(key) { delete _mockState[key]; return null; };
|
||||
env["request-method"] = function() { return "GET"; };
|
||||
env["request-arg"] = function(name, dflt) { return dflt !== undefined ? dflt : null; };
|
||||
env["request-form"] = function(name, dflt) { return dflt !== undefined ? dflt : ""; };
|
||||
env["request-headers-all"] = function() { return {}; };
|
||||
env["request-form-all"] = function() { return {}; };
|
||||
env["request-args-all"] = function() { return {}; };
|
||||
env["request-content-type"] = function() { return "text/html"; };
|
||||
|
||||
// Platform test functions
|
||||
env["try-call"] = function(thunk) {
|
||||
try {
|
||||
@@ -256,6 +296,7 @@ env["pop-suite"] = function() {
|
||||
// Load test framework
|
||||
const projectDir = path.join(__dirname, "..", "..");
|
||||
const specTests = path.join(projectDir, "spec", "tests");
|
||||
const libTests = path.join(projectDir, "lib", "tests");
|
||||
const webTests = path.join(projectDir, "web", "tests");
|
||||
|
||||
const frameworkSrc = fs.readFileSync(path.join(specTests, "test-framework.sx"), "utf8");
|
||||
@@ -264,33 +305,130 @@ for (const expr of frameworkExprs) {
|
||||
Sx.eval(expr, env);
|
||||
}
|
||||
|
||||
// Load test harness (mock IO platform)
|
||||
const harnessPath = path.join(projectDir, "spec", "harness.sx");
|
||||
if (fs.existsSync(harnessPath)) {
|
||||
const harnessSrc = fs.readFileSync(harnessPath, "utf8");
|
||||
const harnessExprs = Sx.parse(harnessSrc);
|
||||
for (const expr of harnessExprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading harness.sx: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Load canonical.sx (content-addressing, serialization)
|
||||
const canonicalPath = path.join(projectDir, "spec", "canonical.sx");
|
||||
if (fs.existsSync(canonicalPath)) {
|
||||
const canonicalSrc = fs.readFileSync(canonicalPath, "utf8");
|
||||
const canonicalExprs = Sx.parse(canonicalSrc);
|
||||
for (const expr of canonicalExprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading canonical.sx: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Load sx-swap.sx (needed by spec/tests/test-sx-swap.sx)
|
||||
const swapPath = path.join(projectDir, "lib", "sx-swap.sx");
|
||||
if (fs.existsSync(swapPath)) {
|
||||
const swapSrc = fs.readFileSync(swapPath, "utf8");
|
||||
const swapExprs = Sx.parse(swapSrc);
|
||||
for (const expr of swapExprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading sx-swap.sx: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Load tw system (needed by spec/tests/test-tw.sx)
|
||||
const twDir = path.join(projectDir, "shared", "sx", "templates");
|
||||
for (const twFile of ["tw-type.sx", "tw-layout.sx", "tw.sx"]) {
|
||||
const twPath = path.join(twDir, twFile);
|
||||
if (fs.existsSync(twPath)) {
|
||||
const twSrc = fs.readFileSync(twPath, "utf8");
|
||||
const twExprs = Sx.parse(twSrc);
|
||||
for (const expr of twExprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading ${twFile}: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Load compiler + VM from lib/ when running full tests
|
||||
if (fullBuild) {
|
||||
const libDir = path.join(projectDir, "lib");
|
||||
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx", "tree-tools.sx"]) {
|
||||
const libPath = path.join(libDir, libFile);
|
||||
if (fs.existsSync(libPath)) {
|
||||
const src = fs.readFileSync(libPath, "utf8");
|
||||
const exprs = Sx.parse(src);
|
||||
for (const expr of exprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading ${libFile}: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
// Load web harnesses (DOM mocking, signals, rendering awareness)
|
||||
const webDir = path.join(projectDir, "web");
|
||||
for (const webFile of ["harness-web.sx", "harness-reactive.sx"]) {
|
||||
const wp = path.join(webDir, webFile);
|
||||
if (fs.existsSync(wp)) {
|
||||
const src = fs.readFileSync(wp, "utf8");
|
||||
const exprs = Sx.parse(src);
|
||||
for (const expr of exprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading ${webFile}: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
// Load stepper-lib (shared stepper functions used by lib/tests/test-stepper.sx)
|
||||
const stepperLibPath = path.join(projectDir, "sx", "sx", "stepper-lib.sx");
|
||||
if (fs.existsSync(stepperLibPath)) {
|
||||
const src = fs.readFileSync(stepperLibPath, "utf8");
|
||||
const exprs = Sx.parse(src);
|
||||
for (const expr of exprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading stepper-lib.sx: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Determine which tests to run
|
||||
const args = process.argv.slice(2).filter(a => !a.startsWith("--"));
|
||||
let testFiles = [];
|
||||
|
||||
if (args.length > 0) {
|
||||
// Specific test files
|
||||
// Specific test files — search spec, lib, and web test dirs
|
||||
for (const arg of args) {
|
||||
const name = arg.endsWith(".sx") ? arg : `${arg}.sx`;
|
||||
const specPath = path.join(specTests, name);
|
||||
const libPath = path.join(libTests, name);
|
||||
const webPath = path.join(webTests, name);
|
||||
if (fs.existsSync(specPath)) testFiles.push(specPath);
|
||||
else if (fs.existsSync(libPath)) testFiles.push(libPath);
|
||||
else if (fs.existsSync(webPath)) testFiles.push(webPath);
|
||||
else console.error(`Test file not found: ${name}`);
|
||||
}
|
||||
} else {
|
||||
// Tests requiring optional modules (only run with --full)
|
||||
const requiresFull = new Set(["test-continuations.sx", "test-types.sx", "test-freeze.sx"]);
|
||||
// All spec tests
|
||||
// All spec tests (core language — always run)
|
||||
for (const f of fs.readdirSync(specTests).sort()) {
|
||||
if (f.startsWith("test-") && f.endsWith(".sx") && f !== "test-framework.sx") {
|
||||
if (!fullBuild && requiresFull.has(f)) {
|
||||
console.log(`Skipping ${f} (requires --full)`);
|
||||
continue;
|
||||
}
|
||||
testFiles.push(path.join(specTests, f));
|
||||
}
|
||||
}
|
||||
// Library tests (only with --full — require compiler, vm, signals, etc.)
|
||||
if (fullBuild) {
|
||||
for (const f of fs.readdirSync(libTests).sort()) {
|
||||
if (f.startsWith("test-") && f.endsWith(".sx")) {
|
||||
testFiles.push(path.join(libTests, f));
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Run tests
|
||||
|
||||
File diff suppressed because one or more lines are too long
3
hosts/native/bin/dune
Normal file
3
hosts/native/bin/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(executable
|
||||
(name sx_native_app)
|
||||
(libraries sx sx_native cairo2 tsdl unix))
|
||||
276
hosts/native/bin/sx_native_app.ml
Normal file
276
hosts/native/bin/sx_native_app.ml
Normal file
@@ -0,0 +1,276 @@
|
||||
(** SX Native Browser -- renders s-expressions directly to pixels.
|
||||
|
||||
A proof-of-concept desktop browser that parses .sx files and
|
||||
renders them using SDL2 + Cairo, with no HTML/CSS/JS engine. *)
|
||||
|
||||
open Tsdl
|
||||
open Sx_native
|
||||
open Sx_native_types
|
||||
|
||||
(* -- Helpers for SDL result handling -- *)
|
||||
|
||||
let sdl_ok = function
|
||||
| Ok v -> v
|
||||
| Error (`Msg e) -> failwith ("SDL error: " ^ e)
|
||||
|
||||
(* -- State -- *)
|
||||
|
||||
type app_state = {
|
||||
mutable current_url : string;
|
||||
mutable root : node;
|
||||
mutable needs_repaint : bool;
|
||||
mutable win_w : int;
|
||||
mutable win_h : int;
|
||||
mutable scroll_y : float;
|
||||
}
|
||||
|
||||
(* -- Parse and build render tree -- *)
|
||||
|
||||
let load_content (state : app_state) (source : string) (cr : Cairo.context) =
|
||||
let values = Sx_parser.parse_all source in
|
||||
let navigate href =
|
||||
(* Simple navigation: if href starts with / or is a relative path, reload *)
|
||||
Printf.printf "[navigate] %s\n%!" href;
|
||||
state.current_url <- href;
|
||||
(* In a full implementation, this would trigger a re-fetch and re-render *)
|
||||
in
|
||||
let root = Sx_native_render.render_page ~navigate values in
|
||||
Sx_native_layout.measure cr root;
|
||||
let w = float_of_int state.win_w in
|
||||
let h = float_of_int state.win_h -. 36. in (* subtract URL bar *)
|
||||
Sx_native_layout.layout root 0. 0. w h;
|
||||
state.root <- root;
|
||||
state.needs_repaint <- true
|
||||
|
||||
(* -- Hit testing -- *)
|
||||
|
||||
let rec hit_test (node : node) (x : float) (y : float) : node option =
|
||||
let b = node.box in
|
||||
if x >= b.x && x <= b.x +. b.w && y >= b.y && y <= b.y +. b.h then begin
|
||||
(* Check children in reverse order (topmost first) *)
|
||||
let child_hit = List.fold_left (fun acc child ->
|
||||
match acc with
|
||||
| Some _ -> acc
|
||||
| None -> hit_test child x y
|
||||
) None (List.rev node.children) in
|
||||
match child_hit with
|
||||
| Some _ -> child_hit
|
||||
| None -> Some node
|
||||
end
|
||||
else None
|
||||
|
||||
let handle_click (state : app_state) (root : node) (x : float) (y : float) =
|
||||
(* Offset y by URL bar height for hit testing *)
|
||||
let adjusted_y = y -. 36. -. state.scroll_y in
|
||||
match hit_test root x adjusted_y with
|
||||
| Some node ->
|
||||
(match node.on_click with
|
||||
| Some f -> f ()
|
||||
| None ->
|
||||
match node.href with
|
||||
| Some href ->
|
||||
Printf.printf "[click] link: %s\n%!" href;
|
||||
state.current_url <- href
|
||||
| None ->
|
||||
Printf.printf "[click] %s at (%.0f, %.0f)\n%!" node.tag x y)
|
||||
| None ->
|
||||
Printf.printf "[click] miss at (%.0f, %.0f)\n%!" x y
|
||||
|
||||
(* -- Default demo content -- *)
|
||||
|
||||
let demo_sx = {|
|
||||
(div :class "flex flex-col items-center gap-6 p-8 bg-stone-50"
|
||||
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
|
||||
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
|
||||
(div :class "flex gap-4 items-center"
|
||||
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No HTML")
|
||||
(p :class "text-sm text-stone-500" "This is not a web page"))
|
||||
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No CSS")
|
||||
(p :class "text-sm text-stone-500" "Tailwind classes parsed to native styles"))
|
||||
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No JavaScript")
|
||||
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
|
||||
(div :class "p-6 rounded-lg bg-violet-600"
|
||||
(p :class "text-white text-lg font-bold" "5,000 lines of OCaml instead of 35 million lines of browser engine")))
|
||||
|}
|
||||
|
||||
(* -- Main -- *)
|
||||
|
||||
let () =
|
||||
(* Parse command line *)
|
||||
let source = ref "" in
|
||||
let url = ref "sx://demo" in
|
||||
let args = Array.to_list Sys.argv in
|
||||
(match args with
|
||||
| _ :: file :: _ when Sys.file_exists file ->
|
||||
source := Sx_native_fetch.read_file file;
|
||||
url := "file://" ^ file
|
||||
| _ :: path :: _ when String.length path > 0 ->
|
||||
(try
|
||||
source := Sx_native_fetch.fetch_page path;
|
||||
url := path
|
||||
with _ ->
|
||||
Printf.eprintf "Failed to fetch %s, using demo content\n%!" path;
|
||||
source := demo_sx;
|
||||
url := "sx://demo")
|
||||
| _ ->
|
||||
source := demo_sx);
|
||||
|
||||
(* Initialize SDL2 *)
|
||||
sdl_ok (Sdl.init Sdl.Init.(video + events));
|
||||
at_exit Sdl.quit;
|
||||
|
||||
let initial_w = 1024 in
|
||||
let initial_h = 768 in
|
||||
|
||||
let window = sdl_ok (Sdl.create_window "SX Browser"
|
||||
~x:Sdl.Window.pos_centered ~y:Sdl.Window.pos_centered
|
||||
~w:initial_w ~h:initial_h
|
||||
Sdl.Window.(shown + resizable + allow_highdpi)) in
|
||||
|
||||
let renderer = sdl_ok (Sdl.create_renderer window
|
||||
~flags:Sdl.Renderer.(accelerated + presentvsync)) in
|
||||
|
||||
(* Create SDL texture for Cairo to draw into *)
|
||||
let create_texture w h =
|
||||
sdl_ok (Sdl.create_texture renderer Sdl.Pixel.format_argb8888
|
||||
Sdl.Texture.access_streaming ~w ~h)
|
||||
in
|
||||
let texture = ref (create_texture initial_w initial_h) in
|
||||
|
||||
(* Create Cairo surface *)
|
||||
let create_cairo_surface w h =
|
||||
Cairo.Image.create Cairo.Image.ARGB32 ~w ~h
|
||||
in
|
||||
let surface = ref (create_cairo_surface initial_w initial_h) in
|
||||
let cr = ref (Cairo.create !surface) in
|
||||
|
||||
(* App state *)
|
||||
let state = {
|
||||
current_url = !url;
|
||||
root = { tag = "root"; style = default_style; children = [];
|
||||
text = None; box = make_box (); href = None; on_click = None };
|
||||
needs_repaint = true;
|
||||
win_w = initial_w;
|
||||
win_h = initial_h;
|
||||
scroll_y = 0.;
|
||||
} in
|
||||
|
||||
(* Initial load *)
|
||||
load_content state !source !cr;
|
||||
|
||||
(* Main event loop *)
|
||||
let event = Sdl.Event.create () in
|
||||
let running = ref true in
|
||||
while !running do
|
||||
(* Process all pending events *)
|
||||
while Sdl.poll_event (Some event) do
|
||||
let typ = Sdl.Event.get event Sdl.Event.typ in
|
||||
|
||||
if typ = Sdl.Event.quit then
|
||||
running := false
|
||||
|
||||
else if typ = Sdl.Event.key_down then begin
|
||||
let scancode = Sdl.Event.get event Sdl.Event.keyboard_scancode in
|
||||
if scancode = Sdl.Scancode.escape then
|
||||
running := false
|
||||
else if scancode = Sdl.Scancode.up then begin
|
||||
state.scroll_y <- Float.min 0. (state.scroll_y +. 40.);
|
||||
state.needs_repaint <- true
|
||||
end
|
||||
else if scancode = Sdl.Scancode.down then begin
|
||||
state.scroll_y <- state.scroll_y -. 40.;
|
||||
state.needs_repaint <- true
|
||||
end
|
||||
else if scancode = Sdl.Scancode.home then begin
|
||||
state.scroll_y <- 0.;
|
||||
state.needs_repaint <- true
|
||||
end
|
||||
end
|
||||
|
||||
else if typ = Sdl.Event.mouse_button_down then begin
|
||||
let mx = Float.of_int (Sdl.Event.get event Sdl.Event.mouse_button_x) in
|
||||
let my = Float.of_int (Sdl.Event.get event Sdl.Event.mouse_button_y) in
|
||||
handle_click state state.root mx my
|
||||
end
|
||||
|
||||
else if typ = Sdl.Event.mouse_wheel then begin
|
||||
let wy = Sdl.Event.get event Sdl.Event.mouse_wheel_y in
|
||||
state.scroll_y <- state.scroll_y +. (float_of_int wy *. 40.);
|
||||
if state.scroll_y > 0. then state.scroll_y <- 0.;
|
||||
state.needs_repaint <- true
|
||||
end
|
||||
|
||||
else if typ = Sdl.Event.window_event then begin
|
||||
let wev = Sdl.Event.get event Sdl.Event.window_event_id in
|
||||
if wev = Sdl.Event.window_event_resized
|
||||
|| wev = Sdl.Event.window_event_size_changed
|
||||
|| wev = Sdl.Event.window_event_exposed then begin
|
||||
let (new_w, new_h) = Sdl.get_window_size window in
|
||||
if new_w <> state.win_w || new_h <> state.win_h then begin
|
||||
state.win_w <- new_w;
|
||||
state.win_h <- new_h;
|
||||
(* Recreate texture and surface at new size *)
|
||||
Sdl.destroy_texture !texture;
|
||||
texture := create_texture new_w new_h;
|
||||
Cairo.Surface.finish !surface;
|
||||
surface := create_cairo_surface new_w new_h;
|
||||
cr := Cairo.create !surface;
|
||||
(* Re-layout *)
|
||||
Sx_native_layout.measure !cr state.root;
|
||||
let w = float_of_int new_w in
|
||||
let h = float_of_int new_h -. 36. in
|
||||
Sx_native_layout.layout state.root 0. 0. w h
|
||||
end;
|
||||
state.needs_repaint <- true
|
||||
end
|
||||
end
|
||||
done;
|
||||
|
||||
(* Paint if needed *)
|
||||
if state.needs_repaint then begin
|
||||
state.needs_repaint <- false;
|
||||
let w = float_of_int state.win_w in
|
||||
let h = float_of_int state.win_h in
|
||||
|
||||
(* Apply scroll offset to root *)
|
||||
state.root.box.y <- state.scroll_y;
|
||||
|
||||
Sx_native_paint.paint_scene !cr state.root state.current_url w h;
|
||||
Cairo.Surface.flush !surface;
|
||||
|
||||
(* Restore root position *)
|
||||
state.root.box.y <- 0.;
|
||||
|
||||
(* Copy Cairo surface data to SDL texture *)
|
||||
let data = Cairo.Image.get_data8 !surface in
|
||||
let stride = Bigarray.Array1.dim data / state.win_h in
|
||||
(* Lock texture, copy data, unlock *)
|
||||
(match Sdl.lock_texture !texture None Bigarray.int8_unsigned with
|
||||
| Ok (pixels, _pitch) ->
|
||||
let src_len = Bigarray.Array1.dim data in
|
||||
let dst_len = Bigarray.Array1.dim pixels in
|
||||
let copy_len = min src_len dst_len in
|
||||
for i = 0 to copy_len - 1 do
|
||||
Bigarray.Array1.set pixels i (Bigarray.Array1.get data i)
|
||||
done;
|
||||
ignore stride;
|
||||
Sdl.unlock_texture !texture
|
||||
| Error (`Msg e) ->
|
||||
Printf.eprintf "lock_texture error: %s\n%!" e);
|
||||
|
||||
(* Present *)
|
||||
ignore (Sdl.render_clear renderer);
|
||||
ignore (Sdl.render_copy renderer !texture);
|
||||
Sdl.render_present renderer
|
||||
end;
|
||||
|
||||
Sdl.delay 16l (* ~60 fps cap *)
|
||||
done;
|
||||
|
||||
(* Cleanup *)
|
||||
Sdl.destroy_texture !texture;
|
||||
Sdl.destroy_renderer renderer;
|
||||
Sdl.destroy_window window
|
||||
25
hosts/native/demo/counter.sx
Normal file
25
hosts/native/demo/counter.sx
Normal file
@@ -0,0 +1,25 @@
|
||||
(div
|
||||
:class "flex flex-col items-center gap-6 p-8 bg-stone-50"
|
||||
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
|
||||
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
|
||||
(div
|
||||
:class "flex gap-4 items-center"
|
||||
(div
|
||||
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No HTML")
|
||||
(p :class "text-sm text-stone-500" "This is not a web page"))
|
||||
(div
|
||||
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No CSS")
|
||||
(p
|
||||
:class "text-sm text-stone-500"
|
||||
"Tailwind classes parsed to native styles"))
|
||||
(div
|
||||
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No JavaScript")
|
||||
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
|
||||
(div
|
||||
:class "p-6 rounded-lg bg-violet-600"
|
||||
(p
|
||||
:class "text-white text-lg font-bold"
|
||||
"5,000 lines of OCaml instead of 35 million lines of browser engine")))
|
||||
2
hosts/native/dune-project
Normal file
2
hosts/native/dune-project
Normal file
@@ -0,0 +1,2 @@
|
||||
(lang dune 3.19)
|
||||
(name sx_native)
|
||||
2
hosts/native/dune-workspace
Normal file
2
hosts/native/dune-workspace
Normal file
@@ -0,0 +1,2 @@
|
||||
(lang dune 3.19)
|
||||
(context default)
|
||||
3
hosts/native/lib/dune
Normal file
3
hosts/native/lib/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(library
|
||||
(name sx_native)
|
||||
(libraries sx cairo2 unix))
|
||||
37
hosts/native/lib/sx_native_fetch.ml
Normal file
37
hosts/native/lib/sx_native_fetch.ml
Normal file
@@ -0,0 +1,37 @@
|
||||
(** HTTP fetcher for SX pages.
|
||||
|
||||
Uses curl via Unix.open_process_in for simplicity.
|
||||
Fetches pages from sx.rose-ash.com with SX-Request headers. *)
|
||||
|
||||
let base_url = "https://sx.rose-ash.com"
|
||||
|
||||
(** Fetch a URL and return the response body as a string. *)
|
||||
let fetch_url (url : string) : string =
|
||||
let cmd = Printf.sprintf
|
||||
"curl -s -L -H 'Accept: text/sx' -H 'SX-Request: true' '%s'" url in
|
||||
let ic = Unix.open_process_in cmd in
|
||||
let buf = Buffer.create 8192 in
|
||||
(try while true do Buffer.add_char buf (input_char ic) done
|
||||
with End_of_file -> ());
|
||||
ignore (Unix.close_process_in ic);
|
||||
Buffer.contents buf
|
||||
|
||||
(** Fetch an SX page by path (e.g. "/sx/" or "/sx/language"). *)
|
||||
let fetch_page (path : string) : string =
|
||||
let url = if String.length path > 0 && path.[0] = '/' then
|
||||
base_url ^ path
|
||||
else if String.length path > 4 && String.sub path 0 4 = "http" then
|
||||
path
|
||||
else
|
||||
base_url ^ "/" ^ path
|
||||
in
|
||||
fetch_url url
|
||||
|
||||
(** Read a local .sx file. *)
|
||||
let read_file (path : string) : string =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let buf = Bytes.create n in
|
||||
really_input ic buf 0 n;
|
||||
close_in ic;
|
||||
Bytes.to_string buf
|
||||
232
hosts/native/lib/sx_native_layout.ml
Normal file
232
hosts/native/lib/sx_native_layout.ml
Normal file
@@ -0,0 +1,232 @@
|
||||
(** Pure flexbox layout engine.
|
||||
|
||||
Two-pass algorithm:
|
||||
1. Measure (bottom-up): compute intrinsic sizes from text extents
|
||||
and children accumulation.
|
||||
2. Layout (top-down): allocate space starting from window bounds,
|
||||
distributing via flex-grow and handling alignment/gap. *)
|
||||
|
||||
open Sx_native_types
|
||||
|
||||
(* -- Text measurement -- *)
|
||||
|
||||
let measure_text (cr : Cairo.context) (family : [`Sans | `Mono]) (weight : [`Normal | `Bold])
|
||||
(slant : [`Normal | `Italic]) (size : float) (text : string) : float * float =
|
||||
let font_name = match family with `Sans -> "sans-serif" | `Mono -> "monospace" in
|
||||
let cairo_weight = match weight with `Normal -> Cairo.Normal | `Bold -> Cairo.Bold in
|
||||
let cairo_slant = match slant with `Normal -> Cairo.Upright | `Italic -> Cairo.Italic in
|
||||
Cairo.select_font_face cr ~slant:cairo_slant ~weight:cairo_weight font_name;
|
||||
Cairo.set_font_size cr size;
|
||||
let fe = Cairo.font_extents cr in
|
||||
if String.length text = 0 then (0., fe.ascent +. fe.descent)
|
||||
else begin
|
||||
(* Word wrap not needed for POC -- measure as single line *)
|
||||
let te = Cairo.text_extents cr text in
|
||||
(te.Cairo.width +. te.Cairo.x_bearing, fe.ascent +. fe.descent)
|
||||
end
|
||||
|
||||
(* -- Measure pass (bottom-up) -- *)
|
||||
|
||||
(** Set intrinsic [box.w] and [box.h] on each node based on text extents
|
||||
and children accumulation. Does NOT set x/y. *)
|
||||
let rec measure (cr : Cairo.context) (node : node) : unit =
|
||||
(* Measure children first *)
|
||||
List.iter (measure cr) node.children;
|
||||
|
||||
let pad = node.style.padding in
|
||||
let pad_h = pad.left +. pad.right in
|
||||
let pad_v = pad.top +. pad.bottom in
|
||||
|
||||
match node.text with
|
||||
| Some txt ->
|
||||
(* Leaf text node: measure the text *)
|
||||
let (tw, th) = measure_text cr node.style.font_family node.style.font_weight
|
||||
node.style.font_style node.style.font_size txt in
|
||||
node.box.w <- tw +. pad_h;
|
||||
node.box.h <- th +. pad_v
|
||||
| None ->
|
||||
if node.style.display = `None then begin
|
||||
node.box.w <- 0.;
|
||||
node.box.h <- 0.
|
||||
end else begin
|
||||
let visible_children = List.filter (fun c -> c.style.display <> `None) node.children in
|
||||
let n_children = List.length visible_children in
|
||||
let total_gap = if n_children > 1 then node.style.gap *. float_of_int (n_children - 1) else 0. in
|
||||
match node.style.flex_direction with
|
||||
| `Column ->
|
||||
(* Stack vertically: width = max child width, height = sum of child heights + gaps *)
|
||||
let max_w = List.fold_left (fun acc c ->
|
||||
let cm = c.style.margin in
|
||||
Float.max acc (c.box.w +. cm.left +. cm.right)
|
||||
) 0. visible_children in
|
||||
let sum_h = List.fold_left (fun acc c ->
|
||||
let cm = c.style.margin in
|
||||
acc +. c.box.h +. cm.top +. cm.bottom
|
||||
) 0. visible_children in
|
||||
node.box.w <- max_w +. pad_h;
|
||||
node.box.h <- sum_h +. total_gap +. pad_v
|
||||
| `Row ->
|
||||
(* Stack horizontally: height = max child height, width = sum of child widths + gaps *)
|
||||
let sum_w = List.fold_left (fun acc c ->
|
||||
let cm = c.style.margin in
|
||||
acc +. c.box.w +. cm.left +. cm.right
|
||||
) 0. visible_children in
|
||||
let max_h = List.fold_left (fun acc c ->
|
||||
let cm = c.style.margin in
|
||||
Float.max acc (c.box.h +. cm.top +. cm.bottom)
|
||||
) 0. visible_children in
|
||||
node.box.w <- sum_w +. total_gap +. pad_h;
|
||||
node.box.h <- max_h +. pad_v
|
||||
end;
|
||||
|
||||
(* Apply explicit width/height constraints *)
|
||||
(match node.style.width with
|
||||
| `Px w -> node.box.w <- w
|
||||
| `Full | `Auto -> ());
|
||||
(match node.style.height with
|
||||
| `Px h -> node.box.h <- h
|
||||
| `Full | `Auto -> ())
|
||||
|
||||
|
||||
(* -- Layout pass (top-down) -- *)
|
||||
|
||||
(** Position all nodes within the given bounds [x, y, w, h].
|
||||
Distributes space according to flex-grow and handles alignment. *)
|
||||
let rec layout (node : node) (x : float) (y : float) (avail_w : float) (avail_h : float) : unit =
|
||||
let margin = node.style.margin in
|
||||
let x = x +. margin.left in
|
||||
let y = y +. margin.top in
|
||||
let avail_w = avail_w -. margin.left -. margin.right in
|
||||
let avail_h = avail_h -. margin.top -. margin.bottom in
|
||||
|
||||
node.box.x <- x;
|
||||
node.box.y <- y;
|
||||
|
||||
(* Determine actual width/height.
|
||||
Container nodes with Auto width stretch to fill available space
|
||||
(like CSS block-level elements), while text nodes keep intrinsic width. *)
|
||||
let is_text_node = node.text <> None in
|
||||
let w = match node.style.width with
|
||||
| `Full -> avail_w
|
||||
| `Px pw -> Float.min pw avail_w
|
||||
| `Auto ->
|
||||
if is_text_node then Float.min node.box.w avail_w
|
||||
else avail_w (* containers expand to fill *)
|
||||
in
|
||||
let h = match node.style.height with
|
||||
| `Full -> avail_h
|
||||
| `Px ph -> Float.min ph avail_h
|
||||
| `Auto -> node.box.h (* Use intrinsic height *)
|
||||
in
|
||||
|
||||
node.box.w <- w;
|
||||
node.box.h <- h;
|
||||
|
||||
if node.style.display = `None then ()
|
||||
else begin
|
||||
let pad = node.style.padding in
|
||||
let inner_x = x +. pad.left in
|
||||
let inner_y = y +. pad.top in
|
||||
let inner_w = w -. pad.left -. pad.right in
|
||||
let inner_h = h -. pad.top -. pad.bottom in
|
||||
|
||||
let visible_children = List.filter (fun c -> c.style.display <> `None) node.children in
|
||||
|
||||
match visible_children with
|
||||
| [] -> () (* Leaf or empty container *)
|
||||
| children ->
|
||||
let n_children = List.length children in
|
||||
let total_gap = if n_children > 1 then node.style.gap *. float_of_int (n_children - 1) else 0. in
|
||||
|
||||
match node.style.flex_direction with
|
||||
| `Column ->
|
||||
(* Calculate total intrinsic height and flex-grow sum *)
|
||||
let total_intrinsic = List.fold_left (fun acc c ->
|
||||
let cm = c.style.margin in
|
||||
acc +. c.box.h +. cm.top +. cm.bottom
|
||||
) 0. children in
|
||||
let total_grow = List.fold_left (fun acc c -> acc +. c.style.flex_grow) 0. children in
|
||||
let remaining = Float.max 0. (inner_h -. total_intrinsic -. total_gap) in
|
||||
|
||||
(* justify-content: space-between *)
|
||||
let (start_offset, between_extra) = match node.style.justify_content with
|
||||
| `Between when n_children > 1 ->
|
||||
(0., remaining /. float_of_int (n_children - 1))
|
||||
| `Center -> (remaining /. 2., 0.)
|
||||
| `End -> (remaining, 0.)
|
||||
| _ -> (0., 0.)
|
||||
in
|
||||
|
||||
let cur_y = ref (inner_y +. start_offset) in
|
||||
List.iter (fun child ->
|
||||
let cm = child.style.margin in
|
||||
let child_w = match child.style.width with
|
||||
| `Full -> inner_w -. cm.left -. cm.right
|
||||
| _ -> Float.min child.box.w (inner_w -. cm.left -. cm.right)
|
||||
in
|
||||
let extra_h = if total_grow > 0. then remaining *. child.style.flex_grow /. total_grow else 0. in
|
||||
let child_h = child.box.h +. extra_h in
|
||||
|
||||
(* align-items: cross-axis alignment *)
|
||||
let child_x = match node.style.align_items with
|
||||
| `Center -> inner_x +. (inner_w -. child_w -. cm.left -. cm.right) /. 2.
|
||||
| `End -> inner_x +. inner_w -. child_w -. cm.right
|
||||
| `Stretch ->
|
||||
(* Stretch: child takes full width *)
|
||||
layout child (inner_x) !cur_y (inner_w) child_h;
|
||||
cur_y := !cur_y +. child.box.h +. cm.top +. cm.bottom +. node.style.gap +. between_extra;
|
||||
(* skip the normal layout below *)
|
||||
inner_x (* dummy, won't be used *)
|
||||
| _ -> inner_x
|
||||
in
|
||||
|
||||
if node.style.align_items <> `Stretch then begin
|
||||
layout child child_x !cur_y child_w child_h;
|
||||
cur_y := !cur_y +. child.box.h +. cm.top +. cm.bottom +. node.style.gap +. between_extra
|
||||
end
|
||||
) children
|
||||
|
||||
| `Row ->
|
||||
(* Calculate total intrinsic width and flex-grow sum *)
|
||||
let total_intrinsic = List.fold_left (fun acc c ->
|
||||
let cm = c.style.margin in
|
||||
acc +. c.box.w +. cm.left +. cm.right
|
||||
) 0. children in
|
||||
let total_grow = List.fold_left (fun acc c -> acc +. c.style.flex_grow) 0. children in
|
||||
let remaining = Float.max 0. (inner_w -. total_intrinsic -. total_gap) in
|
||||
|
||||
let (start_offset, between_extra) = match node.style.justify_content with
|
||||
| `Between when n_children > 1 ->
|
||||
(0., remaining /. float_of_int (n_children - 1))
|
||||
| `Center -> (remaining /. 2., 0.)
|
||||
| `End -> (remaining, 0.)
|
||||
| _ -> (0., 0.)
|
||||
in
|
||||
|
||||
let cur_x = ref (inner_x +. start_offset) in
|
||||
List.iter (fun child ->
|
||||
let cm = child.style.margin in
|
||||
let extra_w = if total_grow > 0. then remaining *. child.style.flex_grow /. total_grow else 0. in
|
||||
let child_w = child.box.w +. extra_w in
|
||||
let child_h = match child.style.height with
|
||||
| `Full -> inner_h -. cm.top -. cm.bottom
|
||||
| _ -> Float.min child.box.h (inner_h -. cm.top -. cm.bottom)
|
||||
in
|
||||
|
||||
(* align-items: cross-axis alignment *)
|
||||
let child_y = match node.style.align_items with
|
||||
| `Center -> inner_y +. (inner_h -. child_h -. cm.top -. cm.bottom) /. 2.
|
||||
| `End -> inner_y +. inner_h -. child_h -. cm.bottom
|
||||
| `Stretch ->
|
||||
layout child !cur_x inner_y child_w inner_h;
|
||||
cur_x := !cur_x +. child.box.w +. cm.left +. cm.right +. node.style.gap +. between_extra;
|
||||
inner_y (* dummy *)
|
||||
| _ -> inner_y
|
||||
in
|
||||
|
||||
if node.style.align_items <> `Stretch then begin
|
||||
layout child !cur_x child_y child_w child_h;
|
||||
cur_x := !cur_x +. child.box.w +. cm.left +. cm.right +. node.style.gap +. between_extra
|
||||
end
|
||||
) children
|
||||
end
|
||||
156
hosts/native/lib/sx_native_paint.ml
Normal file
156
hosts/native/lib/sx_native_paint.ml
Normal file
@@ -0,0 +1,156 @@
|
||||
(** Walk a positioned node tree and issue Cairo draw commands.
|
||||
|
||||
Handles backgrounds with rounded corners, borders, shadows,
|
||||
and text rendering with proper font face/size/weight. *)
|
||||
|
||||
open Sx_native_types
|
||||
open Sx_native_style
|
||||
|
||||
(* -- Rounded rectangle path -- *)
|
||||
|
||||
let rounded_rect (cr : Cairo.context) (x : float) (y : float) (w : float) (h : float) (r : float) =
|
||||
let r = Float.min r (Float.min (w /. 2.) (h /. 2.)) in
|
||||
if r <= 0. then
|
||||
Cairo.rectangle cr x y ~w ~h
|
||||
else begin
|
||||
let pi = Float.pi in
|
||||
Cairo.Path.sub cr;
|
||||
Cairo.arc cr (x +. w -. r) (y +. r) ~r ~a1:(-.pi /. 2.) ~a2:0.;
|
||||
Cairo.arc cr (x +. w -. r) (y +. h -. r) ~r ~a1:0. ~a2:(pi /. 2.);
|
||||
Cairo.arc cr (x +. r) (y +. h -. r) ~r ~a1:(pi /. 2.) ~a2:pi;
|
||||
Cairo.arc cr (x +. r) (y +. r) ~r ~a1:pi ~a2:(-.pi /. 2.);
|
||||
Cairo.Path.close cr
|
||||
end
|
||||
|
||||
(* -- Shadow painting -- *)
|
||||
|
||||
let paint_shadow (cr : Cairo.context) (b : box) (radius : float) (level : [`Sm | `Md]) =
|
||||
let (offset, blur_passes, alpha) = match level with
|
||||
| `Sm -> (1., 2, 0.04)
|
||||
| `Md -> (2., 3, 0.05)
|
||||
in
|
||||
for i = 1 to blur_passes do
|
||||
let spread = float_of_int i *. 2. in
|
||||
Cairo.save cr;
|
||||
Cairo.set_source_rgba cr 0. 0. 0. (alpha /. float_of_int i);
|
||||
rounded_rect cr
|
||||
(b.x -. spread)
|
||||
(b.y +. offset -. spread +. float_of_int i)
|
||||
(b.w +. spread *. 2.)
|
||||
(b.h +. spread *. 2.)
|
||||
(radius +. spread);
|
||||
Cairo.fill cr;
|
||||
Cairo.restore cr
|
||||
done
|
||||
|
||||
(* -- Main paint function -- *)
|
||||
|
||||
(** Paint a positioned node tree to a Cairo context. *)
|
||||
let rec paint (cr : Cairo.context) (node : node) : unit =
|
||||
let s = node.style in
|
||||
let b = node.box in
|
||||
|
||||
if s.display = `None then ()
|
||||
else begin
|
||||
(* Save state for potential clip *)
|
||||
Cairo.save cr;
|
||||
|
||||
(* Shadow *)
|
||||
(match s.shadow with
|
||||
| `None -> ()
|
||||
| `Sm -> paint_shadow cr b s.border_radius `Sm
|
||||
| `Md -> paint_shadow cr b s.border_radius `Md);
|
||||
|
||||
(* Background *)
|
||||
(match s.bg_color with
|
||||
| Some c ->
|
||||
Cairo.set_source_rgba cr c.r c.g c.b c.a;
|
||||
rounded_rect cr b.x b.y b.w b.h s.border_radius;
|
||||
Cairo.fill cr
|
||||
| None -> ());
|
||||
|
||||
(* Border *)
|
||||
if s.border_width > 0. then begin
|
||||
let bc = match s.border_color with Some c -> c | None -> stone_800 in
|
||||
Cairo.set_source_rgba cr bc.r bc.g bc.b bc.a;
|
||||
Cairo.set_line_width cr s.border_width;
|
||||
rounded_rect cr
|
||||
(b.x +. s.border_width /. 2.)
|
||||
(b.y +. s.border_width /. 2.)
|
||||
(b.w -. s.border_width)
|
||||
(b.h -. s.border_width)
|
||||
(Float.max 0. (s.border_radius -. s.border_width /. 2.));
|
||||
Cairo.stroke cr
|
||||
end;
|
||||
|
||||
(* Clip for overflow *)
|
||||
if s.overflow_hidden then begin
|
||||
rounded_rect cr b.x b.y b.w b.h s.border_radius;
|
||||
Cairo.clip cr
|
||||
end;
|
||||
|
||||
(* Text *)
|
||||
(match node.text with
|
||||
| Some txt when String.length txt > 0 ->
|
||||
let font_name = match s.font_family with `Sans -> "sans-serif" | `Mono -> "monospace" in
|
||||
let weight = match s.font_weight with `Normal -> Cairo.Normal | `Bold -> Cairo.Bold in
|
||||
let slant = match s.font_style with `Normal -> Cairo.Upright | `Italic -> Cairo.Italic in
|
||||
Cairo.select_font_face cr ~slant ~weight font_name;
|
||||
Cairo.set_font_size cr s.font_size;
|
||||
let fe = Cairo.font_extents cr in
|
||||
Cairo.set_source_rgba cr s.text_color.r s.text_color.g s.text_color.b s.text_color.a;
|
||||
Cairo.move_to cr (b.x +. s.padding.left) (b.y +. s.padding.top +. fe.ascent);
|
||||
Cairo.show_text cr txt
|
||||
| _ -> ());
|
||||
|
||||
(* Children *)
|
||||
List.iter (paint cr) node.children;
|
||||
|
||||
Cairo.restore cr
|
||||
end
|
||||
|
||||
(** Paint a horizontal URL bar at the top of the window. *)
|
||||
let paint_url_bar (cr : Cairo.context) (url : string) (width : float) : float =
|
||||
let bar_height = 36. in
|
||||
(* Bar background *)
|
||||
Cairo.set_source_rgba cr stone_100.r stone_100.g stone_100.b 1.0;
|
||||
Cairo.rectangle cr 0. 0. ~w:width ~h:bar_height;
|
||||
Cairo.fill cr;
|
||||
|
||||
(* Bottom border *)
|
||||
Cairo.set_source_rgba cr stone_200.r stone_200.g stone_200.b 1.0;
|
||||
Cairo.set_line_width cr 1.;
|
||||
Cairo.move_to cr 0. bar_height;
|
||||
Cairo.line_to cr width bar_height;
|
||||
Cairo.stroke cr;
|
||||
|
||||
(* URL text *)
|
||||
Cairo.select_font_face cr ~slant:Cairo.Upright ~weight:Cairo.Normal "monospace";
|
||||
Cairo.set_font_size cr 13.;
|
||||
Cairo.set_source_rgba cr stone_600.r stone_600.g stone_600.b 1.0;
|
||||
Cairo.move_to cr 12. 23.;
|
||||
Cairo.show_text cr url;
|
||||
|
||||
bar_height
|
||||
|
||||
(** Paint the entire scene: clear, URL bar, then content. *)
|
||||
let paint_scene (cr : Cairo.context) (root : node) (url : string) (width : float) (height : float) : unit =
|
||||
(* Clear to white *)
|
||||
Cairo.set_source_rgba cr 1. 1. 1. 1.;
|
||||
Cairo.rectangle cr 0. 0. ~w:width ~h:height;
|
||||
Cairo.fill cr;
|
||||
|
||||
(* URL bar *)
|
||||
let bar_h = paint_url_bar cr url width in
|
||||
|
||||
(* Content area *)
|
||||
Cairo.save cr;
|
||||
Cairo.rectangle cr 0. bar_h ~w:width ~h:(height -. bar_h);
|
||||
Cairo.clip cr;
|
||||
|
||||
(* Offset layout by bar height *)
|
||||
root.box.y <- root.box.y +. bar_h;
|
||||
paint cr root;
|
||||
root.box.y <- root.box.y -. bar_h; (* restore for hit testing *)
|
||||
|
||||
Cairo.restore cr
|
||||
221
hosts/native/lib/sx_native_render.ml
Normal file
221
hosts/native/lib/sx_native_render.ml
Normal file
@@ -0,0 +1,221 @@
|
||||
(** Convert an [Sx_types.value] tree into a native [node] render tree.
|
||||
|
||||
Walks the parsed SX AST and produces nodes for HTML-like tags
|
||||
(div, p, h1-h6, span, etc.), extracting :class attributes for
|
||||
styling and string content for text nodes. Unknown forms are
|
||||
rendered as gray placeholders. *)
|
||||
|
||||
open Sx_native_types
|
||||
open Sx_native_style
|
||||
|
||||
(* -- Tag default styles -- *)
|
||||
|
||||
let tag_base_style (tag : string) : style =
|
||||
match tag with
|
||||
| "h1" -> { default_style with font_size = 36.; font_weight = `Bold }
|
||||
| "h2" -> { default_style with font_size = 30.; font_weight = `Bold }
|
||||
| "h3" -> { default_style with font_size = 24.; font_weight = `Bold }
|
||||
| "h4" -> { default_style with font_size = 20.; font_weight = `Bold }
|
||||
| "h5" -> { default_style with font_size = 18.; font_weight = `Bold }
|
||||
| "h6" -> { default_style with font_size = 16.; font_weight = `Bold }
|
||||
| "p" -> { default_style with flex_direction = `Row }
|
||||
| "span" -> { default_style with flex_direction = `Row }
|
||||
| "div" -> default_style
|
||||
| "section" -> default_style
|
||||
| "article" -> default_style
|
||||
| "main" -> default_style
|
||||
| "header" -> default_style
|
||||
| "footer" -> default_style
|
||||
| "nav" -> { default_style with flex_direction = `Row }
|
||||
| "button" ->
|
||||
{ default_style with
|
||||
flex_direction = `Row;
|
||||
padding = { top = 8.; right = 16.; bottom = 8.; left = 16. };
|
||||
bg_color = Some violet_600;
|
||||
text_color = white;
|
||||
border_radius = 6.;
|
||||
align_items = `Center;
|
||||
justify_content = `Center }
|
||||
| "a" -> { default_style with flex_direction = `Row; text_color = violet_600 }
|
||||
| "code" ->
|
||||
{ default_style with
|
||||
font_family = `Mono;
|
||||
font_size = 14.;
|
||||
bg_color = Some stone_100;
|
||||
padding = { top = 2.; right = 4.; bottom = 2.; left = 4. };
|
||||
border_radius = 4. }
|
||||
| "pre" ->
|
||||
{ default_style with
|
||||
font_family = `Mono;
|
||||
font_size = 14.;
|
||||
bg_color = Some stone_100;
|
||||
padding = { top = 12.; right = 16.; bottom = 12.; left = 16. };
|
||||
border_radius = 8. }
|
||||
| "strong" | "b" -> { default_style with font_weight = `Bold; flex_direction = `Row }
|
||||
| "em" | "i" -> { default_style with font_style = `Italic; flex_direction = `Row }
|
||||
| "ul" -> { default_style with padding = { zero_edges with left = 16. } }
|
||||
| "ol" -> { default_style with padding = { zero_edges with left = 16. } }
|
||||
| "li" -> { default_style with flex_direction = `Row; gap = 4. }
|
||||
| "table" -> default_style
|
||||
| "thead" | "tbody" -> default_style
|
||||
| "tr" -> { default_style with flex_direction = `Row; gap = 0. }
|
||||
| "th" -> { default_style with font_weight = `Bold; padding = { top = 4.; right = 8.; bottom = 4.; left = 8. } }
|
||||
| "td" -> { default_style with padding = { top = 4.; right = 8.; bottom = 4.; left = 8. } }
|
||||
| "hr" ->
|
||||
{ default_style with
|
||||
height = `Px 1.;
|
||||
bg_color = Some stone_200;
|
||||
width = `Full }
|
||||
| "br" -> { default_style with height = `Px 16. }
|
||||
| "img" ->
|
||||
{ default_style with
|
||||
width = `Px 200.;
|
||||
height = `Px 150.;
|
||||
bg_color = Some stone_200;
|
||||
border_radius = 4. }
|
||||
| _ -> default_style
|
||||
|
||||
(* -- Known HTML tags -- *)
|
||||
|
||||
let is_html_tag = function
|
||||
| "div" | "span" | "p" | "section" | "article" | "main" | "header"
|
||||
| "footer" | "nav" | "aside"
|
||||
| "h1" | "h2" | "h3" | "h4" | "h5" | "h6"
|
||||
| "button" | "a" | "input" | "form" | "label" | "select" | "textarea"
|
||||
| "ul" | "ol" | "li"
|
||||
| "table" | "thead" | "tbody" | "tr" | "th" | "td"
|
||||
| "strong" | "b" | "em" | "i" | "u" | "s"
|
||||
| "code" | "pre" | "blockquote"
|
||||
| "img" | "video" | "audio" | "source"
|
||||
| "hr" | "br"
|
||||
| "head" | "body" | "html" | "title" | "meta" | "link" | "script" | "style"
|
||||
| "small" | "mark" | "sup" | "sub" | "abbr" | "time"
|
||||
| "figure" | "figcaption" | "details" | "summary"
|
||||
| "dl" | "dt" | "dd" -> true
|
||||
| _ -> false
|
||||
|
||||
(* Void/skip tags -- don't render these *)
|
||||
let is_skip_tag = function
|
||||
| "head" | "meta" | "link" | "script" | "style" | "title"
|
||||
| "source" | "input" -> true
|
||||
| _ -> false
|
||||
|
||||
(* -- Extract keyword args from SX list -- *)
|
||||
|
||||
(** Extract keyword arguments and children from an SX element's argument list.
|
||||
Returns [(attrs, children)] where attrs is a (key, value) list. *)
|
||||
let extract_attrs (items : Sx_types.value list) : (string * Sx_types.value) list * Sx_types.value list =
|
||||
let rec go attrs children = function
|
||||
| [] -> (List.rev attrs, List.rev children)
|
||||
| Sx_types.Keyword k :: v :: rest ->
|
||||
go ((k, v) :: attrs) children rest
|
||||
| other :: rest ->
|
||||
go attrs (other :: children) rest
|
||||
in
|
||||
go [] [] items
|
||||
|
||||
(** Get a string attribute from keyword args. *)
|
||||
let get_string_attr (attrs : (string * Sx_types.value) list) (key : string) : string option =
|
||||
match List.assoc_opt key attrs with
|
||||
| Some (Sx_types.String s) -> Some s
|
||||
| _ -> None
|
||||
|
||||
(* -- Render SX values to native nodes -- *)
|
||||
|
||||
(** Make a text leaf node with inherited style. *)
|
||||
let make_text_node (style : style) (text : string) : node =
|
||||
{ tag = "#text"; style; children = []; text = Some text;
|
||||
box = make_box (); href = None; on_click = None }
|
||||
|
||||
(** Render an SX value tree to a native node tree.
|
||||
[~navigate] callback is invoked when a link is clicked. *)
|
||||
let rec render ?(navigate : (string -> unit) option) (value : Sx_types.value) : node option =
|
||||
match value with
|
||||
| Sx_types.String s ->
|
||||
Some (make_text_node default_style s)
|
||||
| Sx_types.Number n ->
|
||||
let s = if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n in
|
||||
Some (make_text_node default_style s)
|
||||
| Sx_types.Bool true -> Some (make_text_node default_style "true")
|
||||
| Sx_types.Bool false -> Some (make_text_node default_style "false")
|
||||
| Sx_types.Nil -> None
|
||||
| Sx_types.Keyword _ -> None (* bare keywords are attr markers *)
|
||||
| Sx_types.Symbol _ -> None (* bare symbols are not renderable *)
|
||||
|
||||
| Sx_types.List (Sx_types.Symbol tag :: rest) when is_html_tag tag ->
|
||||
if is_skip_tag tag then None
|
||||
else begin
|
||||
let (attrs, children_sx) = extract_attrs rest in
|
||||
let class_str = get_string_attr attrs "class" in
|
||||
let href = get_string_attr attrs "href" in
|
||||
|
||||
(* Build style: tag defaults + class overrides *)
|
||||
let base = tag_base_style tag in
|
||||
let style = match class_str with
|
||||
| Some cls -> parse_classes ~base cls
|
||||
| None -> base
|
||||
in
|
||||
|
||||
(* Special: li gets a bullet prefix *)
|
||||
let extra_children = if tag = "li" then
|
||||
[make_text_node { style with flex_direction = `Row } "\xe2\x80\xa2 "]
|
||||
else [] in
|
||||
|
||||
(* Render children *)
|
||||
let children = extra_children @ List.filter_map (render ?navigate) children_sx in
|
||||
|
||||
(* For link nodes, set up navigation *)
|
||||
let on_click = match href, navigate with
|
||||
| Some h, Some nav -> Some (fun () -> nav h)
|
||||
| _ -> None
|
||||
in
|
||||
|
||||
Some { tag; style; children; text = None;
|
||||
box = make_box (); href; on_click }
|
||||
end
|
||||
|
||||
(* Component calls (~name ...) -- render as placeholder *)
|
||||
| Sx_types.List (Sx_types.Symbol name :: rest) when String.length name > 0 && name.[0] = '~' ->
|
||||
let (attrs, children_sx) = extract_attrs rest in
|
||||
let class_str = get_string_attr attrs "class" in
|
||||
let base = { default_style with
|
||||
border_width = 1.;
|
||||
border_color = Some violet_200;
|
||||
border_radius = 4.;
|
||||
padding = { top = 8.; right = 8.; bottom = 8.; left = 8. } } in
|
||||
let style = match class_str with
|
||||
| Some cls -> parse_classes ~base cls
|
||||
| None -> base
|
||||
in
|
||||
let label = make_text_node
|
||||
{ default_style with font_size = 12.; text_color = violet_500; font_family = `Mono }
|
||||
name in
|
||||
let children = label :: List.filter_map (render ?navigate) children_sx in
|
||||
Some { tag = "component"; style; children; text = None;
|
||||
box = make_box (); href = None; on_click = None }
|
||||
|
||||
(* Unknown list forms -- try to render children *)
|
||||
| Sx_types.List items ->
|
||||
let children = List.filter_map (render ?navigate) items in
|
||||
if children = [] then None
|
||||
else if List.length children = 1 then Some (List.hd children)
|
||||
else
|
||||
Some { tag = "group"; style = default_style; children; text = None;
|
||||
box = make_box (); href = None; on_click = None }
|
||||
|
||||
| _ -> None (* Lambda, Dict, etc. -- skip *)
|
||||
|
||||
(** Render a list of top-level SX values into a single root node. *)
|
||||
let render_page ?(navigate : (string -> unit) option) (values : Sx_types.value list) : node =
|
||||
let children = List.filter_map (render ?navigate) values in
|
||||
(* Wrap everything in a root container *)
|
||||
{ tag = "root";
|
||||
style = { default_style with
|
||||
width = `Full;
|
||||
padding = { top = 0.; right = 0.; bottom = 0.; left = 0. } };
|
||||
children;
|
||||
text = None;
|
||||
box = make_box ();
|
||||
href = None;
|
||||
on_click = None }
|
||||
277
hosts/native/lib/sx_native_style.ml
Normal file
277
hosts/native/lib/sx_native_style.ml
Normal file
@@ -0,0 +1,277 @@
|
||||
(** Parse Tailwind CSS class strings into native style records.
|
||||
|
||||
Supports ~50 common utility classes covering layout, spacing,
|
||||
sizing, typography, colors, borders, and effects. *)
|
||||
|
||||
open Sx_native_types
|
||||
|
||||
(* -- Color palette (Tailwind stone + violet) -- *)
|
||||
|
||||
let white = { r = 1.0; g = 1.0; b = 1.0; a = 1.0 }
|
||||
let black = { r = 0.0; g = 0.0; b = 0.0; a = 1.0 }
|
||||
|
||||
let stone_50 = { r = 0.980; g = 0.976; b = 0.973; a = 1.0 }
|
||||
let stone_100 = { r = 0.961; g = 0.953; b = 0.945; a = 1.0 }
|
||||
let stone_200 = { r = 0.906; g = 0.890; b = 0.875; a = 1.0 }
|
||||
let stone_300 = { r = 0.839; g = 0.812; b = 0.788; a = 1.0 }
|
||||
let stone_400 = { r = 0.659; g = 0.616; b = 0.576; a = 1.0 }
|
||||
let stone_500 = { r = 0.471; g = 0.431; b = 0.396; a = 1.0 }
|
||||
let stone_600 = { r = 0.341; g = 0.306; b = 0.275; a = 1.0 }
|
||||
let stone_700 = { r = 0.267; g = 0.231; b = 0.208; a = 1.0 }
|
||||
(* stone_800 is already in sx_native_types *)
|
||||
let stone_900 = { r = 0.106; g = 0.098; b = 0.090; a = 1.0 }
|
||||
|
||||
let violet_50 = { r = 0.961; g = 0.953; b = 1.0; a = 1.0 }
|
||||
let violet_100 = { r = 0.929; g = 0.906; b = 0.996; a = 1.0 }
|
||||
let violet_200 = { r = 0.867; g = 0.820; b = 0.992; a = 1.0 }
|
||||
let violet_300 = { r = 0.769; g = 0.686; b = 0.984; a = 1.0 }
|
||||
let violet_400 = { r = 0.655; g = 0.525; b = 0.969; a = 1.0 }
|
||||
let violet_500 = { r = 0.545; g = 0.361; b = 0.945; a = 1.0 }
|
||||
let violet_600 = { r = 0.486; g = 0.227; b = 0.929; a = 1.0 }
|
||||
let violet_700 = { r = 0.427; g = 0.176; b = 0.831; a = 1.0 }
|
||||
let violet_800 = { r = 0.357; g = 0.153; b = 0.694; a = 1.0 }
|
||||
let violet_900 = { r = 0.298; g = 0.133; b = 0.576; a = 1.0 }
|
||||
|
||||
let red_500 = { r = 0.937; g = 0.267; b = 0.267; a = 1.0 }
|
||||
let red_600 = { r = 0.863; g = 0.145; b = 0.145; a = 1.0 }
|
||||
let blue_500 = { r = 0.231; g = 0.510; b = 0.965; a = 1.0 }
|
||||
let blue_600 = { r = 0.145; g = 0.388; b = 0.922; a = 1.0 }
|
||||
let green_500 = { r = 0.133; g = 0.773; b = 0.369; a = 1.0 }
|
||||
let green_600 = { r = 0.086; g = 0.635; b = 0.290; a = 1.0 }
|
||||
let amber_500 = { r = 0.961; g = 0.718; b = 0.078; a = 1.0 }
|
||||
|
||||
(* -- Spacing scale (Tailwind: 1 unit = 4px) -- *)
|
||||
|
||||
let spacing n = float_of_int n *. 4.0
|
||||
|
||||
(* -- Font sizes (Tailwind) -- *)
|
||||
|
||||
let font_size_of = function
|
||||
| "text-xs" -> 12.
|
||||
| "text-sm" -> 14.
|
||||
| "text-base" -> 16.
|
||||
| "text-lg" -> 18.
|
||||
| "text-xl" -> 20.
|
||||
| "text-2xl" -> 24.
|
||||
| "text-3xl" -> 30.
|
||||
| "text-4xl" -> 36.
|
||||
| "text-5xl" -> 48.
|
||||
| _ -> 16.
|
||||
|
||||
(* -- Parse a single Tailwind class, mutating a style -- *)
|
||||
|
||||
let parse_spacing_value s =
|
||||
(* Extract numeric value from strings like "p-4", "gap-2" *)
|
||||
match int_of_string_opt s with
|
||||
| Some n -> spacing n
|
||||
| None -> 0.
|
||||
|
||||
let bg_color_of cls =
|
||||
match cls with
|
||||
| "bg-white" -> Some white
|
||||
| "bg-black" -> Some black
|
||||
| "bg-stone-50" -> Some stone_50
|
||||
| "bg-stone-100" -> Some stone_100
|
||||
| "bg-stone-200" -> Some stone_200
|
||||
| "bg-stone-300" -> Some stone_300
|
||||
| "bg-stone-400" -> Some stone_400
|
||||
| "bg-stone-500" -> Some stone_500
|
||||
| "bg-stone-600" -> Some stone_600
|
||||
| "bg-stone-700" -> Some stone_700
|
||||
| "bg-stone-800" -> Some stone_800
|
||||
| "bg-stone-900" -> Some stone_900
|
||||
| "bg-violet-50" -> Some violet_50
|
||||
| "bg-violet-100" -> Some violet_100
|
||||
| "bg-violet-200" -> Some violet_200
|
||||
| "bg-violet-300" -> Some violet_300
|
||||
| "bg-violet-400" -> Some violet_400
|
||||
| "bg-violet-500" -> Some violet_500
|
||||
| "bg-violet-600" -> Some violet_600
|
||||
| "bg-violet-700" -> Some violet_700
|
||||
| "bg-violet-800" -> Some violet_800
|
||||
| "bg-violet-900" -> Some violet_900
|
||||
| "bg-red-500" -> Some red_500
|
||||
| "bg-red-600" -> Some red_600
|
||||
| "bg-blue-500" -> Some blue_500
|
||||
| "bg-blue-600" -> Some blue_600
|
||||
| "bg-green-500" -> Some green_500
|
||||
| "bg-green-600" -> Some green_600
|
||||
| "bg-amber-500" -> Some amber_500
|
||||
| _ -> None
|
||||
|
||||
let text_color_of cls =
|
||||
match cls with
|
||||
| "text-white" -> Some white
|
||||
| "text-black" -> Some black
|
||||
| "text-stone-50" -> Some stone_50
|
||||
| "text-stone-100" -> Some stone_100
|
||||
| "text-stone-200" -> Some stone_200
|
||||
| "text-stone-300" -> Some stone_300
|
||||
| "text-stone-400" -> Some stone_400
|
||||
| "text-stone-500" -> Some stone_500
|
||||
| "text-stone-600" -> Some stone_600
|
||||
| "text-stone-700" -> Some stone_700
|
||||
| "text-stone-800" -> Some stone_800
|
||||
| "text-stone-900" -> Some stone_900
|
||||
| "text-violet-50" -> Some violet_50
|
||||
| "text-violet-100" -> Some violet_100
|
||||
| "text-violet-200" -> Some violet_200
|
||||
| "text-violet-300" -> Some violet_300
|
||||
| "text-violet-400" -> Some violet_400
|
||||
| "text-violet-500" -> Some violet_500
|
||||
| "text-violet-600" -> Some violet_600
|
||||
| "text-violet-700" -> Some violet_700
|
||||
| "text-violet-800" -> Some violet_800
|
||||
| "text-violet-900" -> Some violet_900
|
||||
| "text-red-500" -> Some red_500
|
||||
| "text-red-600" -> Some red_600
|
||||
| "text-blue-500" -> Some blue_500
|
||||
| "text-blue-600" -> Some blue_600
|
||||
| "text-green-500" -> Some green_500
|
||||
| "text-green-600" -> Some green_600
|
||||
| "text-amber-500" -> Some amber_500
|
||||
| _ -> None
|
||||
|
||||
let border_color_of cls =
|
||||
match cls with
|
||||
| "border-stone-100" -> Some stone_100
|
||||
| "border-stone-200" -> Some stone_200
|
||||
| "border-stone-300" -> Some stone_300
|
||||
| "border-violet-200" -> Some violet_200
|
||||
| "border-violet-300" -> Some violet_300
|
||||
| "border-white" -> Some white
|
||||
| _ -> None
|
||||
|
||||
(** Apply a single Tailwind class to a style, returning the updated style. *)
|
||||
let apply_class (s : style) (cls : string) : style =
|
||||
(* Layout *)
|
||||
if cls = "flex" then { s with display = `Flex; flex_direction = `Row }
|
||||
else if cls = "flex-col" then { s with display = `Flex; flex_direction = `Column }
|
||||
else if cls = "flex-row" then { s with display = `Flex; flex_direction = `Row }
|
||||
else if cls = "block" then { s with display = `Block }
|
||||
else if cls = "hidden" then { s with display = `None }
|
||||
else if cls = "items-center" then { s with align_items = `Center }
|
||||
else if cls = "items-start" then { s with align_items = `Start }
|
||||
else if cls = "items-end" then { s with align_items = `End }
|
||||
else if cls = "items-stretch" then { s with align_items = `Stretch }
|
||||
else if cls = "justify-center" then { s with justify_content = `Center }
|
||||
else if cls = "justify-between" then { s with justify_content = `Between }
|
||||
else if cls = "justify-start" then { s with justify_content = `Start }
|
||||
else if cls = "justify-end" then { s with justify_content = `End }
|
||||
else if cls = "flex-grow" || cls = "grow" then { s with flex_grow = 1. }
|
||||
(* Gap *)
|
||||
else if String.length cls > 4 && String.sub cls 0 4 = "gap-" then
|
||||
let n = String.sub cls 4 (String.length cls - 4) in
|
||||
{ s with gap = parse_spacing_value n }
|
||||
(* Padding *)
|
||||
else if String.length cls > 2 && String.sub cls 0 2 = "p-" && cls.[2] <> 'x' && cls.[2] <> 'y' && cls.[2] <> 'l' && cls.[2] <> 'r' && cls.[2] <> 't' && cls.[2] <> 'b' then
|
||||
let n = String.sub cls 2 (String.length cls - 2) in
|
||||
let v = parse_spacing_value n in
|
||||
{ s with padding = { top = v; right = v; bottom = v; left = v } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "px-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
let v = parse_spacing_value n in
|
||||
{ s with padding = { s.padding with left = v; right = v } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "py-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
let v = parse_spacing_value n in
|
||||
{ s with padding = { s.padding with top = v; bottom = v } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "pt-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
{ s with padding = { s.padding with top = parse_spacing_value n } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "pb-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
{ s with padding = { s.padding with bottom = parse_spacing_value n } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "pl-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
{ s with padding = { s.padding with left = parse_spacing_value n } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "pr-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
{ s with padding = { s.padding with right = parse_spacing_value n } }
|
||||
(* Margin *)
|
||||
else if String.length cls > 2 && String.sub cls 0 2 = "m-" && cls.[2] <> 'x' && cls.[2] <> 'y' && cls.[2] <> 'l' && cls.[2] <> 'r' && cls.[2] <> 't' && cls.[2] <> 'b' then
|
||||
let n = String.sub cls 2 (String.length cls - 2) in
|
||||
let v = parse_spacing_value n in
|
||||
{ s with margin = { top = v; right = v; bottom = v; left = v } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "mx-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
let v = parse_spacing_value n in
|
||||
{ s with margin = { s.margin with left = v; right = v } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "my-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
let v = parse_spacing_value n in
|
||||
{ s with margin = { s.margin with top = v; bottom = v } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "mt-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
{ s with margin = { s.margin with top = parse_spacing_value n } }
|
||||
else if String.length cls > 3 && String.sub cls 0 3 = "mb-" then
|
||||
let n = String.sub cls 3 (String.length cls - 3) in
|
||||
{ s with margin = { s.margin with bottom = parse_spacing_value n } }
|
||||
(* Sizing *)
|
||||
else if cls = "w-full" then { s with width = `Full }
|
||||
else if cls = "h-full" then { s with height = `Full }
|
||||
else if String.length cls > 2 && String.sub cls 0 2 = "w-" then
|
||||
let n = String.sub cls 2 (String.length cls - 2) in
|
||||
(match int_of_string_opt n with
|
||||
| Some v -> { s with width = `Px (float_of_int v *. 4.) }
|
||||
| None -> s)
|
||||
else if String.length cls > 2 && String.sub cls 0 2 = "h-" then
|
||||
let n = String.sub cls 2 (String.length cls - 2) in
|
||||
(match int_of_string_opt n with
|
||||
| Some v -> { s with height = `Px (float_of_int v *. 4.) }
|
||||
| None -> s)
|
||||
(* Typography *)
|
||||
else if cls = "font-bold" then { s with font_weight = `Bold }
|
||||
else if cls = "font-semibold" then { s with font_weight = `Bold }
|
||||
else if cls = "font-normal" then { s with font_weight = `Normal }
|
||||
else if cls = "italic" then { s with font_style = `Italic }
|
||||
else if cls = "font-mono" then { s with font_family = `Mono }
|
||||
else if String.length cls >= 5 && String.sub cls 0 5 = "text-" then
|
||||
(* Could be text color or text size *)
|
||||
let rest = String.sub cls 5 (String.length cls - 5) in
|
||||
if rest = "xs" || rest = "sm" || rest = "base" || rest = "lg"
|
||||
|| rest = "xl" || rest = "2xl" || rest = "3xl" || rest = "4xl"
|
||||
|| rest = "5xl" then
|
||||
{ s with font_size = font_size_of cls }
|
||||
else
|
||||
(match text_color_of cls with
|
||||
| Some c -> { s with text_color = c }
|
||||
| None -> s)
|
||||
(* Background *)
|
||||
else if String.length cls >= 3 && String.sub cls 0 3 = "bg-" then
|
||||
(match bg_color_of cls with
|
||||
| Some c -> { s with bg_color = Some c }
|
||||
| None -> s)
|
||||
(* Borders *)
|
||||
else if cls = "rounded" then { s with border_radius = 4. }
|
||||
else if cls = "rounded-md" then { s with border_radius = 6. }
|
||||
else if cls = "rounded-lg" then { s with border_radius = 8. }
|
||||
else if cls = "rounded-xl" then { s with border_radius = 12. }
|
||||
else if cls = "rounded-2xl" then { s with border_radius = 16. }
|
||||
else if cls = "rounded-full" then { s with border_radius = 9999. }
|
||||
else if cls = "border" then
|
||||
{ s with border_width = 1.;
|
||||
border_color = (if s.border_color = None then Some stone_200 else s.border_color) }
|
||||
else if cls = "border-2" then
|
||||
{ s with border_width = 2.;
|
||||
border_color = (if s.border_color = None then Some stone_200 else s.border_color) }
|
||||
else if String.length cls >= 7 && String.sub cls 0 7 = "border-" then
|
||||
(match border_color_of cls with
|
||||
| Some c -> { s with border_color = Some c;
|
||||
border_width = (if s.border_width = 0. then 1. else s.border_width) }
|
||||
| None -> s)
|
||||
(* Shadow *)
|
||||
else if cls = "shadow" then { s with shadow = `Sm }
|
||||
else if cls = "shadow-md" then { s with shadow = `Md }
|
||||
else if cls = "shadow-lg" then { s with shadow = `Md }
|
||||
(* Overflow *)
|
||||
else if cls = "overflow-hidden" then { s with overflow_hidden = true }
|
||||
else s (* unknown class: ignore *)
|
||||
|
||||
(** Parse a space-separated Tailwind class string into a [style]. *)
|
||||
let parse_classes ?(base = default_style) (classes : string) : style =
|
||||
let parts = String.split_on_char ' ' classes in
|
||||
List.fold_left (fun s cls ->
|
||||
let cls = String.trim cls in
|
||||
if cls = "" then s else apply_class s cls
|
||||
) base parts
|
||||
79
hosts/native/lib/sx_native_types.ml
Normal file
79
hosts/native/lib/sx_native_types.ml
Normal file
@@ -0,0 +1,79 @@
|
||||
(** Types for the SX native render tree.
|
||||
|
||||
Every SX element is converted to a [node] with a [style] record
|
||||
that the layout engine positions and the painter draws. *)
|
||||
|
||||
type color = { r: float; g: float; b: float; a: float }
|
||||
|
||||
type edges = { top: float; right: float; bottom: float; left: float }
|
||||
|
||||
type style = {
|
||||
display: [`Flex | `Block | `None];
|
||||
flex_direction: [`Row | `Column];
|
||||
gap: float;
|
||||
padding: edges;
|
||||
margin: edges;
|
||||
align_items: [`Start | `Center | `End | `Stretch];
|
||||
justify_content: [`Start | `Center | `End | `Between];
|
||||
flex_grow: float;
|
||||
bg_color: color option;
|
||||
text_color: color;
|
||||
font_size: float;
|
||||
font_weight: [`Normal | `Bold];
|
||||
font_style: [`Normal | `Italic];
|
||||
font_family: [`Sans | `Mono];
|
||||
border_radius: float;
|
||||
border_width: float;
|
||||
border_color: color option;
|
||||
width: [`Auto | `Px of float | `Full];
|
||||
height: [`Auto | `Px of float | `Full];
|
||||
shadow: [`None | `Sm | `Md];
|
||||
overflow_hidden: bool;
|
||||
}
|
||||
|
||||
type box = {
|
||||
mutable x: float;
|
||||
mutable y: float;
|
||||
mutable w: float;
|
||||
mutable h: float;
|
||||
}
|
||||
|
||||
type node = {
|
||||
tag: string;
|
||||
style: style;
|
||||
children: node list;
|
||||
text: string option;
|
||||
box: box;
|
||||
href: string option;
|
||||
on_click: (unit -> unit) option;
|
||||
}
|
||||
|
||||
let zero_edges = { top = 0.; right = 0.; bottom = 0.; left = 0. }
|
||||
|
||||
let stone_800 = { r = 0.114; g = 0.094; b = 0.082; a = 1.0 }
|
||||
|
||||
let default_style = {
|
||||
display = `Flex;
|
||||
flex_direction = `Column;
|
||||
gap = 0.;
|
||||
padding = zero_edges;
|
||||
margin = zero_edges;
|
||||
align_items = `Stretch;
|
||||
justify_content = `Start;
|
||||
flex_grow = 0.;
|
||||
bg_color = None;
|
||||
text_color = stone_800;
|
||||
font_size = 16.;
|
||||
font_weight = `Normal;
|
||||
font_style = `Normal;
|
||||
font_family = `Sans;
|
||||
border_radius = 0.;
|
||||
border_width = 0.;
|
||||
border_color = None;
|
||||
width = `Auto;
|
||||
height = `Auto;
|
||||
shadow = `None;
|
||||
overflow_hidden = false;
|
||||
}
|
||||
|
||||
let make_box () = { x = 0.; y = 0.; w = 0.; h = 0. }
|
||||
1
hosts/native/lib_sx
Symbolic link
1
hosts/native/lib_sx
Symbolic link
@@ -0,0 +1 @@
|
||||
../../hosts/ocaml/lib
|
||||
3
hosts/native/test/dune
Normal file
3
hosts/native/test/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(executable
|
||||
(name test_render)
|
||||
(libraries sx sx_native cairo2 unix))
|
||||
75
hosts/native/test/test_render.ml
Normal file
75
hosts/native/test/test_render.ml
Normal file
@@ -0,0 +1,75 @@
|
||||
(** Smoke test: parse SX, render to node tree, measure, layout, paint to PNG. *)
|
||||
|
||||
open Sx_native.Sx_native_types
|
||||
|
||||
let demo_sx = {|
|
||||
(div :class "flex flex-col items-center gap-6 p-8 bg-stone-50"
|
||||
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
|
||||
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
|
||||
(div :class "flex gap-4 items-center"
|
||||
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No HTML")
|
||||
(p :class "text-sm text-stone-500" "This is not a web page"))
|
||||
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No CSS")
|
||||
(p :class "text-sm text-stone-500" "Tailwind classes parsed to native styles"))
|
||||
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
|
||||
(h3 :class "font-bold text-stone-700" "No JavaScript")
|
||||
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
|
||||
(div :class "p-6 rounded-lg bg-violet-600"
|
||||
(p :class "text-white text-lg font-bold" "5000 lines of OCaml instead of 35 million lines of browser engine")))
|
||||
|}
|
||||
|
||||
let rec count_nodes (node : node) : int =
|
||||
1 + List.fold_left (fun acc c -> acc + count_nodes c) 0 node.children
|
||||
|
||||
let rec print_tree indent (node : node) =
|
||||
let prefix = String.make (indent * 2) ' ' in
|
||||
let text_info = match node.text with
|
||||
| Some t -> Printf.sprintf " \"%s\"" (if String.length t > 30 then String.sub t 0 30 ^ "..." else t)
|
||||
| None -> ""
|
||||
in
|
||||
let size_info = Printf.sprintf " [%.0fx%.0f @ (%.0f,%.0f)]" node.box.w node.box.h node.box.x node.box.y in
|
||||
Printf.printf "%s<%s>%s%s\n" prefix node.tag text_info size_info;
|
||||
List.iter (print_tree (indent + 1)) node.children
|
||||
|
||||
let () =
|
||||
Printf.printf "=== SX Native Browser Smoke Test ===\n\n";
|
||||
|
||||
(* 1. Parse *)
|
||||
let values = Sx_parser.parse_all demo_sx in
|
||||
Printf.printf "1. Parsed %d top-level form(s)\n" (List.length values);
|
||||
|
||||
(* 2. Render to node tree *)
|
||||
let root = Sx_native.Sx_native_render.render_page values in
|
||||
let n = count_nodes root in
|
||||
Printf.printf "2. Render tree: %d nodes, root tag=%s\n" n root.tag;
|
||||
|
||||
(* 3. Create Cairo surface for measurement *)
|
||||
let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w:1024 ~h:768 in
|
||||
let cr = Cairo.create surface in
|
||||
|
||||
(* 4. Measure *)
|
||||
Sx_native.Sx_native_layout.measure cr root;
|
||||
Printf.printf "3. Measured intrinsic size: %.0f x %.0f\n" root.box.w root.box.h;
|
||||
|
||||
(* 5. Layout *)
|
||||
Sx_native.Sx_native_layout.layout root 0. 0. 1024. 732.;
|
||||
Printf.printf "4. Layout complete, root positioned at (%.0f, %.0f) size %.0f x %.0f\n"
|
||||
root.box.x root.box.y root.box.w root.box.h;
|
||||
|
||||
(* 6. Paint *)
|
||||
Sx_native.Sx_native_paint.paint_scene cr root "sx://demo" 1024. 768.;
|
||||
Cairo.Surface.flush surface;
|
||||
|
||||
(* 7. Write PNG *)
|
||||
let png_path = "/tmp/sx_browser_test.png" in
|
||||
Cairo.PNG.write surface png_path;
|
||||
Printf.printf "5. Rendered to %s\n\n" png_path;
|
||||
|
||||
(* Print tree *)
|
||||
Printf.printf "=== Render Tree ===\n";
|
||||
print_tree 0 root;
|
||||
|
||||
Cairo.Surface.finish surface;
|
||||
Printf.printf "\n=== All OK! ===\n"
|
||||
25
hosts/ocaml/Dockerfile
Normal file
25
hosts/ocaml/Dockerfile
Normal file
@@ -0,0 +1,25 @@
|
||||
# OCaml SX kernel build image.
|
||||
#
|
||||
# Produces a statically-linked sx_server binary that can be COPY'd
|
||||
# into any service's Docker image.
|
||||
#
|
||||
# Usage:
|
||||
# docker build -t sx-kernel -f hosts/ocaml/Dockerfile .
|
||||
# docker build --target=export -o hosts/ocaml/_build/export -f hosts/ocaml/Dockerfile .
|
||||
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2 AS build
|
||||
|
||||
USER opam
|
||||
WORKDIR /home/opam/sx
|
||||
|
||||
# Copy only what's needed for the OCaml build
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/ ./bin/
|
||||
|
||||
# Build the server binary
|
||||
RUN eval $(opam env) && dune build bin/sx_server.exe
|
||||
|
||||
# Export stage — just the binary
|
||||
FROM scratch AS export
|
||||
COPY --from=build /home/opam/sx/_build/default/bin/sx_server.exe /sx_server
|
||||
36
hosts/ocaml/bin/debug_set.ml
Normal file
36
hosts/ocaml/bin/debug_set.ml
Normal file
@@ -0,0 +1,36 @@
|
||||
module T = Sx_types
|
||||
module P = Sx_parser
|
||||
module R = Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
let env = T.make_env () in
|
||||
let eval src =
|
||||
let exprs = P.parse_all src in
|
||||
let result = ref Nil in
|
||||
List.iter (fun e -> result := R.eval_expr e (Env env)) exprs;
|
||||
!result
|
||||
in
|
||||
(* Test 1: basic set! in closure *)
|
||||
let r = eval "(let ((x 0)) (set! x 42) x)" in
|
||||
Printf.printf "basic set!: %s (expect 42)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 2: set! through lambda call *)
|
||||
let r = eval "(let ((x 0)) (let ((f (fn () (set! x 99)))) (f) x))" in
|
||||
Printf.printf "set! via lambda: %s (expect 99)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 3: counter pattern *)
|
||||
let r = eval "(do (define make-counter (fn () (let ((c 0)) (fn () (set! c (+ c 1)) c)))) (let ((counter (make-counter))) (counter) (counter) (counter)))" in
|
||||
Printf.printf "counter: %s (expect 3)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 4: set! in for-each *)
|
||||
let r = eval "(let ((total 0)) (for-each (fn (n) (set! total (+ total n))) (list 1 2 3 4 5)) total)" in
|
||||
Printf.printf "set! in for-each: %s (expect 15)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 5: append! in for-each *)
|
||||
ignore (T.env_bind env "append!" (NativeFn ("append!", fun args ->
|
||||
match args with
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"))));
|
||||
let r = eval "(let ((log (list))) (for-each (fn (x) (append! log x)) (list 1 2 3)) log)" in
|
||||
Printf.printf "append! in for-each: %s (expect (1 2 3))\n%!" (T.inspect r)
|
||||
11
hosts/ocaml/bin/dune
Normal file
11
hosts/ocaml/bin/dune
Normal file
@@ -0,0 +1,11 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server integration_tests)
|
||||
(libraries sx unix))
|
||||
|
||||
(executable
|
||||
(name mcp_tree)
|
||||
(libraries sx unix yojson str))
|
||||
|
||||
(executable
|
||||
(name test_cst)
|
||||
(libraries sx))
|
||||
1
hosts/ocaml/bin/dune_debug
Normal file
1
hosts/ocaml/bin/dune_debug
Normal file
@@ -0,0 +1 @@
|
||||
(executable (name debug_macro) (libraries sx))
|
||||
651
hosts/ocaml/bin/integration_tests.ml
Normal file
651
hosts/ocaml/bin/integration_tests.ml
Normal file
@@ -0,0 +1,651 @@
|
||||
(** Integration tests — exercises the full rendering pipeline.
|
||||
|
||||
Loads spec files + web adapters into a server-like env, then renders
|
||||
HTML expressions. Catches "Undefined symbol" errors that only surface
|
||||
when the full stack is loaded (not caught by spec unit tests).
|
||||
|
||||
Usage:
|
||||
dune exec bin/integration_tests.exe *)
|
||||
|
||||
(* Modules accessed directly — library is unwrapped *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
let pass_count = ref 0
|
||||
let fail_count = ref 0
|
||||
|
||||
let assert_eq name expected actual =
|
||||
if expected = actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s\n expected: %s\n got: %s\n%!" name expected actual
|
||||
end
|
||||
|
||||
let assert_contains name needle haystack =
|
||||
let rec find i =
|
||||
if i + String.length needle > String.length haystack then false
|
||||
else if String.sub haystack i (String.length needle) = needle then true
|
||||
else find (i + 1)
|
||||
in
|
||||
if String.length needle > 0 && find 0 then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected to contain %S in %S\n%!" name needle haystack
|
||||
end
|
||||
|
||||
let assert_no_error name f =
|
||||
try
|
||||
ignore (f ());
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
with
|
||||
| Eval_error msg ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name msg
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name (Printexc.to_string exn)
|
||||
|
||||
(* Build a server-like env with rendering support *)
|
||||
let make_integration_env () =
|
||||
let env = make_env () in
|
||||
let bind (n : string) fn =
|
||||
ignore (Sx_types.env_bind env n (NativeFn (n, fn)))
|
||||
in
|
||||
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* HTML tag functions — same as sx_server.ml *)
|
||||
List.iter (fun tag ->
|
||||
ignore (env_bind env tag
|
||||
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
||||
) Sx_render.html_tags;
|
||||
|
||||
(* Platform primitives needed by spec/render.sx and adapters *)
|
||||
bind "make-raw-html" (fun args ->
|
||||
match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
|
||||
bind "raw-html-content" (fun args ->
|
||||
match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
|
||||
bind "escape-html" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-attr" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-string" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "is-html-tag?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
||||
bind "is-void-element?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_void s) | _ -> Bool false);
|
||||
bind "is-boolean-attr?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_boolean_attr s) | _ -> Bool false);
|
||||
|
||||
(* Mutable operations needed by adapter code *)
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
bind "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
|
||||
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
|
||||
| _ -> Nil);
|
||||
bind "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (Hashtbl.mem d k)
|
||||
| [Dict d; Keyword k] -> Bool (Hashtbl.mem d k)
|
||||
| _ -> Bool false);
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| [Dict d; Keyword k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| _ -> Nil);
|
||||
bind "empty-dict?" (fun args ->
|
||||
match args with
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| _ -> Bool true);
|
||||
bind "mutable-list" (fun _args -> ListRef (ref []));
|
||||
|
||||
(* Symbol/keyword accessors needed by adapter-html.sx *)
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with [String s] -> Symbol s | _ -> raise (Eval_error "make-symbol: expected string"));
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* Type predicates needed by adapters *)
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args -> match args with [Component _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "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);
|
||||
bind "component-name" (fun args -> match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> Nil);
|
||||
bind "component-params" (fun args -> match args with [Component c] -> List (List.map (fun s -> String s) c.c_params) | _ -> List []);
|
||||
bind "component-body" (fun args -> match args with [Component c] -> c.c_body | _ -> Nil);
|
||||
bind "component-closure" (fun args -> match args with [Component c] -> Env c.c_closure | _ -> Nil);
|
||||
bind "component-has-children?" (fun args -> match args with [Component c] -> Bool c.c_has_children | _ -> Bool false);
|
||||
bind "component-affinity" (fun args -> match args with [Component c] -> String c.c_affinity | _ -> String "auto");
|
||||
bind "lambda-params" (fun args -> match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args -> match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
||||
bind "lambda-name" (fun args -> match args with [Lambda l] -> (match l.l_name with Some n -> String n | None -> Nil) | _ -> Nil);
|
||||
bind "set-lambda-name!" (fun args -> match args with [Lambda l; String n] -> l.l_name <- Some n; Nil | _ -> Nil);
|
||||
|
||||
(* Environment operations *)
|
||||
bind "env-extend" (fun args ->
|
||||
match args with [Env e] -> Env (env_extend e) | _ -> Env (env_extend env));
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_bind e k v | _ -> Nil);
|
||||
bind "env-set!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_set e k v | _ -> Nil);
|
||||
bind "env-get" (fun args ->
|
||||
match args with [Env e; String k] -> env_get e k | _ -> Nil);
|
||||
bind "env-has?" (fun args ->
|
||||
match args with [Env e; String k] -> Bool (env_has e k) | _ -> Bool false);
|
||||
bind "env-merge" (fun args ->
|
||||
match args with [Env a; Env b] -> Env (env_merge a b) | _ -> Nil);
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
(* Eval/trampoline — needed by adapters *)
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| _ -> Nil);
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [Thunk (e, env)] -> Sx_ref.eval_expr e (Env env)
|
||||
| [v] -> v | _ -> Nil);
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [f; List a] -> Sx_runtime.sx_call f a
|
||||
| [f; a] -> Sx_runtime.sx_call f [a]
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; _env] ->
|
||||
let local = env_extend m.m_closure in
|
||||
let rec bind_params ps as' = match ps, as' with
|
||||
| [], rest ->
|
||||
(match m.m_rest_param with Some rp -> ignore (env_bind local rp (List rest)) | None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (env_bind local p a); bind_params ps_rest as_rest
|
||||
| _ :: _, [] -> ()
|
||||
in
|
||||
bind_params m.m_params macro_args;
|
||||
Sx_ref.eval_expr m.m_body (Env local)
|
||||
| _ -> Nil);
|
||||
|
||||
(* Scope/provide — needed by adapter-html.sx and the CEK evaluator.
|
||||
Must be registered as primitives (prim_call) not just env bindings. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_emitted : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_push name v =
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (v :: stack); Nil in
|
||||
let scope_pop name =
|
||||
(match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (_ :: rest) -> Hashtbl.replace scope_stacks name rest
|
||||
| _ -> ()); Nil in
|
||||
let scope_peek name =
|
||||
match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (v :: _) -> v | _ -> Nil in
|
||||
let scope_emit name v =
|
||||
let items = try Hashtbl.find scope_emitted name with Not_found -> [] in
|
||||
Hashtbl.replace scope_emitted name (items @ [v]); Nil in
|
||||
let emitted name =
|
||||
match Hashtbl.find_opt scope_emitted name with Some l -> List l | None -> List [] in
|
||||
(* Register as both env bindings AND primitives *)
|
||||
bind "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
bind "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
bind "emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "scope-emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
bind "collect!" (fun _args -> Nil);
|
||||
bind "collected" (fun _args -> List []);
|
||||
bind "clear-collected!" (fun _args -> Nil);
|
||||
bind "scope-collected" (fun _args -> List []);
|
||||
bind "scope-clear-collected!" (fun _args -> Nil);
|
||||
bind "provide-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "provide-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
bind "sx-context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
(* Also register as primitives for prim_call *)
|
||||
Sx_primitives.register "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
Sx_primitives.register "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
Sx_primitives.register "emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
Sx_primitives.register "collect!" (fun _args -> Nil);
|
||||
Sx_primitives.register "collected" (fun _args -> List []);
|
||||
Sx_primitives.register "clear-collected!" (fun _args -> Nil);
|
||||
Sx_primitives.register "scope-collected" (fun _args -> List []);
|
||||
Sx_primitives.register "scope-clear-collected!" (fun _args -> Nil);
|
||||
Sx_primitives.register "provide-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "provide-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
|
||||
(* Render-mode flags *)
|
||||
ignore (env_bind env "*render-active*" (Bool false));
|
||||
bind "set-render-active!" (fun args ->
|
||||
match args with [v] -> ignore (env_set env "*render-active*" v); Nil | _ -> Nil);
|
||||
bind "render-active?" (fun _args ->
|
||||
try env_get env "*render-active*" with _ -> Bool false);
|
||||
bind "definition-form?" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Bool (List.mem s ["define"; "defcomp"; "defisland"; "defmacro";
|
||||
"defstyle"; "defhandler"; "deftype"; "defeffect"; "defquery"; "defaction"; "defrelation"])
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Signal stubs for SSR — overridden when signals.sx is loaded *)
|
||||
bind "signal" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "computed" (fun args -> match args with [f] -> Sx_runtime.sx_call f [] | _ -> Nil);
|
||||
bind "deref" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "reset!" (fun _args -> Nil);
|
||||
bind "swap!" (fun _args -> Nil);
|
||||
bind "effect" (fun _args -> Nil);
|
||||
bind "batch" (fun _args -> Nil);
|
||||
|
||||
(* Type predicates — needed by adapter-sx.sx *)
|
||||
bind "callable?" (fun args ->
|
||||
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args ->
|
||||
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda-params" (fun args ->
|
||||
match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args ->
|
||||
match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-name" (fun args ->
|
||||
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
|
||||
bind "component-closure" (fun args ->
|
||||
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> Nil);
|
||||
bind "component-body" (fun args ->
|
||||
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with [Component c] -> String c.c_affinity
|
||||
| [Island _] -> Nil | _ -> Nil);
|
||||
bind "component-has-children?" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool (List.mem "children" c.c_params)
|
||||
| [Island i] -> Bool (List.mem "children" i.i_params)
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Evaluator bridge — needed by adapter-sx.sx *)
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List call_args; Env _e] ->
|
||||
Sx_ref.cek_call fn_val (List call_args)
|
||||
| [fn_val; List call_args] ->
|
||||
Sx_ref.cek_call fn_val (List call_args)
|
||||
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List call_args] -> Sx_ref.cek_call fn_val (List call_args)
|
||||
| [fn_val; Nil] -> Sx_ref.cek_call fn_val (List [])
|
||||
| [fn_val] -> Sx_ref.cek_call fn_val (List [])
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; Env e] ->
|
||||
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
|
||||
List.iteri (fun i p ->
|
||||
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
|
||||
Hashtbl.replace body_env.bindings (Sx_types.intern p) v
|
||||
) m.m_params;
|
||||
Sx_ref.eval_expr m.m_body (Env body_env)
|
||||
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
let rec resolve v = match v with
|
||||
| Thunk (body, closure_env) -> resolve (Sx_ref.eval_expr body (Env closure_env))
|
||||
| _ -> v
|
||||
in resolve v
|
||||
| _ -> raise (Eval_error "trampoline: expected 1 arg"));
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "register-special-form!" (fun args ->
|
||||
match args with
|
||||
| [String name; handler] ->
|
||||
ignore (Sx_ref.register_special_form (String name) handler); Nil
|
||||
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
|
||||
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
|
||||
|
||||
(* DOM stubs *)
|
||||
bind "create-text-node" (fun args -> match args with [String s] -> String s | _ -> Nil);
|
||||
bind "create-fragment" (fun _args -> Nil);
|
||||
bind "dom-create-element" (fun _args -> Nil);
|
||||
bind "dom-append" (fun _args -> Nil);
|
||||
bind "dom-set-attr" (fun _args -> Nil);
|
||||
bind "dom-set-prop" (fun _args -> Nil);
|
||||
bind "dom-get-attr" (fun _args -> Nil);
|
||||
bind "dom-query" (fun _args -> Nil);
|
||||
bind "dom-body" (fun _args -> Nil);
|
||||
|
||||
(* Misc stubs *)
|
||||
bind "random-int" (fun args ->
|
||||
match args with
|
||||
| [Number lo; Number hi] -> Number (lo +. Float.round (Random.float (hi -. lo)))
|
||||
| _ -> Number 0.0);
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "freeze-scope" (fun _args -> Nil);
|
||||
bind "freeze-signal" (fun _args -> Nil);
|
||||
bind "thaw-from-sx" (fun _args -> Nil);
|
||||
bind "local-storage-get" (fun _args -> Nil);
|
||||
bind "local-storage-set" (fun _args -> Nil);
|
||||
bind "schedule-idle" (fun _args -> Nil);
|
||||
bind "run-post-render-hooks" (fun _args -> Nil);
|
||||
bind "freeze-to-sx" (fun _args -> String "");
|
||||
|
||||
env
|
||||
|
||||
|
||||
let () =
|
||||
Printexc.record_backtrace true;
|
||||
|
||||
(* Find project root *)
|
||||
let rec find_root dir =
|
||||
let candidate = Filename.concat dir "spec/render.sx" in
|
||||
if Sys.file_exists candidate then dir
|
||||
else let parent = Filename.dirname dir in
|
||||
if parent = dir then Sys.getcwd () else find_root parent
|
||||
in
|
||||
let root = find_root (Sys.getcwd ()) in
|
||||
let spec p = Filename.concat (Filename.concat root "spec") p in
|
||||
let lib p = Filename.concat (Filename.concat root "lib") p in
|
||||
let web p = Filename.concat (Filename.concat root "web") p in
|
||||
|
||||
let env = make_integration_env () in
|
||||
|
||||
(* Load spec + lib + adapters *)
|
||||
Printf.printf "Loading spec + lib + adapters...\n%!";
|
||||
let load path =
|
||||
if Sys.file_exists path then begin
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
List.iter (fun expr -> ignore (Sx_ref.eval_expr expr (Env env))) exprs;
|
||||
Printf.printf " loaded %s (%d defs)\n%!" (Filename.basename path) (List.length exprs)
|
||||
end else
|
||||
Printf.printf " SKIP %s (not found)\n%!" path
|
||||
in
|
||||
load (spec "parser.sx");
|
||||
load (spec "render.sx");
|
||||
load (web "signals.sx");
|
||||
load (web "adapter-html.sx");
|
||||
load (web "adapter-sx.sx");
|
||||
ignore lib; (* available for future library loading *)
|
||||
|
||||
(* Helper: render SX source string to HTML *)
|
||||
let render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
Sx_render.sx_render_to_html env expr env
|
||||
in
|
||||
|
||||
(* Helper: call SX render-to-html via the adapter *)
|
||||
let sx_render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "render-to-html"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | RawHTML s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: native renderer — HTML tags\n%!";
|
||||
assert_eq "div" "<div>hello</div>" (render_html "(div \"hello\")");
|
||||
assert_eq "div with class" "<div class=\"card\">text</div>" (render_html "(div :class \"card\" \"text\")");
|
||||
assert_eq "nested tags" "<div><p>inner</p></div>" (render_html "(div (p \"inner\"))");
|
||||
assert_eq "void element" "<br />" (render_html "(br)");
|
||||
assert_eq "h1" "<h1>Title</h1>" (render_html "(h1 \"Title\")");
|
||||
assert_eq "span with attrs" "<span class=\"bold\">text</span>" (render_html "(span :class \"bold\" \"text\")");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter render-to-html — HTML tags\n%!";
|
||||
assert_no_error "div doesn't throw" (fun () -> sx_render_html "(div \"hello\")");
|
||||
assert_contains "div produces tag" "<div" (sx_render_html "(div \"hello\")");
|
||||
assert_contains "div with class" "class=\"card\"" (sx_render_html "(div :class \"card\" \"text\")");
|
||||
assert_contains "nested tags" "<p>" (sx_render_html "(div (p \"inner\"))");
|
||||
assert_no_error "h1 doesn't throw" (fun () -> sx_render_html "(h1 \"Title\")");
|
||||
assert_no_error "span doesn't throw" (fun () -> sx_render_html "(span :class \"bold\" \"text\")");
|
||||
assert_no_error "table doesn't throw" (fun () -> sx_render_html "(table (tr (td \"cell\")))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — special forms in HTML context\n%!";
|
||||
assert_contains "when true renders" "<p>" (sx_render_html "(when true (p \"yes\"))");
|
||||
assert_eq "when false empty" "" (sx_render_html "(when false (p \"no\"))");
|
||||
assert_contains "if true branch" "yes" (sx_render_html "(if true (span \"yes\") (span \"no\"))");
|
||||
assert_contains "if false branch" "no" (sx_render_html "(if false (span \"yes\") (span \"no\"))");
|
||||
assert_contains "let in render" "hello" (sx_render_html "(let ((x \"hello\")) (p x))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — letrec in HTML context\n%!";
|
||||
assert_no_error "letrec with div body" (fun () ->
|
||||
sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_contains "letrec renders body" "<div>" (sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_no_error "letrec with side effects then div" (fun () ->
|
||||
sx_render_html "(letrec ((x 1) (y 2)) (let ((z (+ x y))) (div (str z))))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — components\n%!";
|
||||
(try
|
||||
assert_no_error "defcomp + render" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all "(defcomp ~test-card (&key title &rest children) (div :class \"card\" (h2 title) children))"))
|
||||
(Env env));
|
||||
sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders div" "<div" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders title" "Hi" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))")
|
||||
with Eval_error msg -> incr fail_count; Printf.printf " FAIL: components — %s\n%!" msg);
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: eval-expr with HTML tag functions\n%!";
|
||||
assert_no_error "eval (div) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "div"; Keyword "class"; String "foo"; String "hi"]) (Env env));
|
||||
assert_no_error "eval (span) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "span"; String "text"]) (Env env));
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Regression: call-lambda re-evaluated Dict args through eval_expr,
|
||||
which copies dicts. Mutations inside the lambda (e.g. signal
|
||||
reset!) operated on the copy, not the original. This broke
|
||||
island SSR where aser processes multi-body let forms. *)
|
||||
Printf.printf "\nSuite: call-lambda dict identity (aser mode)\n%!";
|
||||
let aser_eval src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "aser"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | SxExpr s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
assert_eq "lambda dict mutation in aser multi-body let"
|
||||
"99"
|
||||
(aser_eval
|
||||
"(let ((mutate! (fn (d k v) (dict-set! d k v)))
|
||||
(d (dict \"x\" 1)))
|
||||
(mutate! d \"x\" 99)
|
||||
(get d \"x\"))");
|
||||
assert_eq "signal reset! in aser multi-body let"
|
||||
"99"
|
||||
(aser_eval
|
||||
"(let ((s (signal 42)))
|
||||
(reset! s 99)
|
||||
(deref s))");
|
||||
assert_eq "signal reset! then len of deref"
|
||||
"3"
|
||||
(aser_eval
|
||||
"(let ((s (signal (list))))
|
||||
(reset! s (list 1 2 3))
|
||||
(len (deref s)))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: JIT closure scoping\n%!";
|
||||
|
||||
(* The JIT bug: when a lambda captures closure vars (e.g. from let/letrec),
|
||||
the VM must use the closure's vm_env_ref (which has the merged bindings),
|
||||
not the caller's globals (which lacks them). This test reproduces the
|
||||
exact pattern that broke the home stepper: a component with a letrec
|
||||
binding referenced inside a map callback. *)
|
||||
|
||||
(* 1. Define a component whose body uses letrec + map with closure var *)
|
||||
assert_no_error "defcomp with letrec+map closure var" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defcomp ~jit-test (&key)
|
||||
(let ((items (list \"a\" \"b\" \"c\")))
|
||||
(letrec ((fmt (fn (x) (str \"[\" x \"]\"))))
|
||||
(div (map (fn (item) (span (fmt item))) items)))))"))
|
||||
(Env env)));
|
||||
|
||||
(* 2. Render it — this triggers JIT compilation of the map callback *)
|
||||
assert_contains "jit closure: first render"
|
||||
"[a]" (sx_render_html "(~jit-test)");
|
||||
|
||||
(* 3. Render something ELSE — tests that the JIT-compiled closure
|
||||
still works when called in a different context *)
|
||||
assert_contains "jit closure: unrelated render between"
|
||||
"<p>" (sx_render_html "(p \"hello\")");
|
||||
|
||||
(* 4. Render the component AGAIN — the JIT-compiled map callback
|
||||
must still find 'fmt' via its closure env, not the caller's globals *)
|
||||
assert_contains "jit closure: second render still works"
|
||||
"[b]" (sx_render_html "(~jit-test)");
|
||||
|
||||
(* 5. Test with signal (the actual stepper pattern) *)
|
||||
assert_no_error "defcomp with signal+map closure" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defcomp ~jit-signal-test (&key)
|
||||
(let ((data (signal (list 1 2 3))))
|
||||
(letrec ((double (fn (x) (* x 2))))
|
||||
(div (map (fn (item) (span (str (double item)))) (deref data))))))"))
|
||||
(Env env)));
|
||||
|
||||
assert_contains "jit signal closure: renders" "4" (sx_render_html "(~jit-signal-test)");
|
||||
assert_contains "jit signal closure: after other render"
|
||||
"4" (let _ = sx_render_html "(div \"break\")" in sx_render_html "(~jit-signal-test)");
|
||||
|
||||
(* 6. Nested closures — lambda inside lambda, both with closure vars *)
|
||||
assert_no_error "defcomp with nested closures" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defcomp ~jit-nested (&key)
|
||||
(let ((prefix \">\"))
|
||||
(letrec ((wrap (fn (x)
|
||||
(let ((suffix \"<\"))
|
||||
(str prefix x suffix)))))
|
||||
(div (map (fn (item) (span (wrap item)))
|
||||
(list \"a\" \"b\"))))))"))
|
||||
(Env env)));
|
||||
assert_contains "nested closure: inner sees outer var"
|
||||
">a<" (sx_render_html "(~jit-nested)");
|
||||
assert_contains "nested closure: second item"
|
||||
">b<" (sx_render_html "(~jit-nested)");
|
||||
(* After unrelated render, nested closures still work *)
|
||||
assert_contains "nested closure: survives context switch"
|
||||
">a<" (let _ = sx_render_html "(p \"x\")" in sx_render_html "(~jit-nested)");
|
||||
|
||||
(* 7. Mutual recursion in letrec *)
|
||||
assert_no_error "defcomp with mutual recursion" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defcomp ~jit-mutual (&key)
|
||||
(letrec ((is-even (fn (n)
|
||||
(if (= n 0) true (is-odd (- n 1)))))
|
||||
(is-odd (fn (n)
|
||||
(if (= n 0) false (is-even (- n 1))))))
|
||||
(div
|
||||
(span (str (is-even 4)))
|
||||
(span (str (is-odd 3))))))"))
|
||||
(Env env)));
|
||||
assert_contains "mutual recursion: is-even 4" "true" (sx_render_html "(~jit-mutual)");
|
||||
assert_contains "mutual recursion: is-odd 3" "true" (sx_render_html "(~jit-mutual)");
|
||||
assert_contains "mutual recursion: survives context switch"
|
||||
"true" (let _ = sx_render_html "(div \"y\")" in sx_render_html "(~jit-mutual)");
|
||||
|
||||
(* 8. set! modifying closure var after JIT compilation *)
|
||||
assert_no_error "defcomp with set! mutation" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defcomp ~jit-setbang (&key)
|
||||
(let ((counter 0))
|
||||
(letrec ((bump (fn () (set! counter (+ counter 1)) counter))
|
||||
(get-count (fn () counter)))
|
||||
(div (span (str (bump)))
|
||||
(span (str (bump)))
|
||||
(span (str (get-count)))))))"))
|
||||
(Env env)));
|
||||
(* Each render should restart counter at 0 since it's a fresh let *)
|
||||
assert_contains "set! mutation: first bump" "1" (sx_render_html "(~jit-setbang)");
|
||||
assert_contains "set! mutation: second bump" "2" (sx_render_html "(~jit-setbang)");
|
||||
|
||||
(* 9. Island with signal + effect + letrec — the stepper pattern *)
|
||||
assert_no_error "defisland with signal+letrec+map" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defisland ~jit-island-test ()
|
||||
(let ((items (signal (list \"x\" \"y\" \"z\")))
|
||||
(label (signal \"test\")))
|
||||
(letrec ((format-item (fn (item)
|
||||
(str (deref label) \":\" item))))
|
||||
(div (map (fn (i) (span (format-item i)))
|
||||
(deref items))))))"))
|
||||
(Env env)));
|
||||
assert_contains "island signal+letrec: renders"
|
||||
"test:x" (sx_render_html "(~jit-island-test)");
|
||||
assert_contains "island signal+letrec: after other render"
|
||||
"test:y" (let _ = sx_render_html "(p \"z\")" in sx_render_html "(~jit-island-test)");
|
||||
|
||||
(* 10. Deep nesting — for-each inside map inside letrec inside let *)
|
||||
assert_no_error "defcomp with deep nesting" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all
|
||||
"(defcomp ~jit-deep (&key)
|
||||
(let ((rows (list (list 1 2) (list 3 4))))
|
||||
(letrec ((sum-row (fn (row)
|
||||
(reduce + 0 row))))
|
||||
(div (map (fn (row)
|
||||
(span (str (sum-row row))))
|
||||
rows)))))"))
|
||||
(Env env)));
|
||||
assert_contains "deep nesting: first row sum" "3" (sx_render_html "(~jit-deep)");
|
||||
assert_contains "deep nesting: second row sum" "7" (sx_render_html "(~jit-deep)");
|
||||
assert_contains "deep nesting: survives context switch"
|
||||
"3" (let _ = sx_render_html "(div \"w\")" in sx_render_html "(~jit-deep)");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\n";
|
||||
Printf.printf "============================================================\n";
|
||||
Printf.printf "Integration: %d passed, %d failed\n" !pass_count !fail_count;
|
||||
Printf.printf "============================================================\n";
|
||||
if !fail_count > 0 then exit 1
|
||||
2562
hosts/ocaml/bin/mcp_tree.ml
Normal file
2562
hosts/ocaml/bin/mcp_tree.ml
Normal file
File diff suppressed because it is too large
Load Diff
1528
hosts/ocaml/bin/run_tests.ml
Normal file
1528
hosts/ocaml/bin/run_tests.ml
Normal file
File diff suppressed because it is too large
Load Diff
3204
hosts/ocaml/bin/sx_server.ml
Normal file
3204
hosts/ocaml/bin/sx_server.ml
Normal file
File diff suppressed because it is too large
Load Diff
91
hosts/ocaml/bin/test_cst.ml
Normal file
91
hosts/ocaml/bin/test_cst.ml
Normal file
@@ -0,0 +1,91 @@
|
||||
let () =
|
||||
let test_sources = [
|
||||
"(define foo 42)";
|
||||
";; comment\n(define bar 1)\n\n;; another\n(define baz 2)\n";
|
||||
"(define my-fn\n (fn (x)\n ;; check nil\n (if (nil? x) 0 x)))";
|
||||
"(list 1 2 3)";
|
||||
"{:key \"value\" :num 42}";
|
||||
"'(a b c)";
|
||||
"`(a ,b ,@c)";
|
||||
"(define x \"hello\\nworld\")";
|
||||
";; top\n;; multi-line\n(define a 1)\n";
|
||||
"";
|
||||
" \n ";
|
||||
"(a)\n(b)\n(c)";
|
||||
"(a ;; inline\n b)";
|
||||
] in
|
||||
let pass = ref 0 in
|
||||
let fail = ref 0 in
|
||||
List.iter (fun src ->
|
||||
let cst = Sx_parser.parse_all_cst src in
|
||||
let roundtrip = Sx_cst.cst_file_to_source cst.nodes cst.trailing_trivia in
|
||||
if roundtrip = src then begin
|
||||
incr pass;
|
||||
Printf.printf "PASS: %S\n" (if String.length src > 40 then String.sub src 0 40 ^ "..." else src)
|
||||
end else begin
|
||||
incr fail;
|
||||
Printf.printf "FAIL: %S\n expected: %S\n got: %S\n"
|
||||
(if String.length src > 40 then String.sub src 0 40 ^ "..." else src)
|
||||
src roundtrip
|
||||
end
|
||||
) test_sources;
|
||||
(* Also test CST→AST matches AST parser *)
|
||||
let ast_tests = [
|
||||
"(define foo 42)";
|
||||
"(list 1 2 3)";
|
||||
"{:key \"value\"}";
|
||||
";; comment\n(define bar 1)";
|
||||
] in
|
||||
Printf.printf "\nCST→AST equivalence:\n";
|
||||
List.iter (fun src ->
|
||||
let ast_direct = Sx_parser.parse_all src in
|
||||
let cst = Sx_parser.parse_all_cst src in
|
||||
let ast_via_cst = List.map Sx_cst.cst_to_ast cst.nodes in
|
||||
let s1 = String.concat " " (List.map Sx_types.inspect ast_direct) in
|
||||
let s2 = String.concat " " (List.map Sx_types.inspect ast_via_cst) in
|
||||
if s1 = s2 then begin
|
||||
incr pass;
|
||||
Printf.printf "PASS: %S\n" src
|
||||
end else begin
|
||||
incr fail;
|
||||
Printf.printf "FAIL: %S\n AST: %s\n CST→AST: %s\n" src s1 s2
|
||||
end
|
||||
) ast_tests;
|
||||
(* Test real .sx files from the codebase *)
|
||||
Printf.printf "\nReal file round-trips:\n";
|
||||
let test_file path =
|
||||
try
|
||||
let src = In_channel.with_open_text path In_channel.input_all in
|
||||
let cst = Sx_parser.parse_all_cst src in
|
||||
let roundtrip = Sx_cst.cst_file_to_source cst.nodes cst.trailing_trivia in
|
||||
if roundtrip = src then begin
|
||||
incr pass;
|
||||
Printf.printf "PASS: %s (%d bytes)\n" path (String.length src)
|
||||
end else begin
|
||||
incr fail;
|
||||
(* Find first difference *)
|
||||
let len = min (String.length src) (String.length roundtrip) in
|
||||
let diff_pos = ref len in
|
||||
for i = 0 to len - 1 do
|
||||
if src.[i] <> roundtrip.[i] && !diff_pos = len then diff_pos := i
|
||||
done;
|
||||
Printf.printf "FAIL: %s (diff at byte %d, src=%d rt=%d)\n" path !diff_pos (String.length src) (String.length roundtrip)
|
||||
end
|
||||
with e ->
|
||||
incr fail;
|
||||
Printf.printf "ERROR: %s — %s\n" path (Printexc.to_string e)
|
||||
in
|
||||
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
||||
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> "." in
|
||||
List.iter test_file [
|
||||
spec_dir ^ "/evaluator.sx";
|
||||
spec_dir ^ "/parser.sx";
|
||||
spec_dir ^ "/primitives.sx";
|
||||
spec_dir ^ "/render.sx";
|
||||
project_dir ^ "/lib/tree-tools.sx";
|
||||
project_dir ^ "/web/engine.sx";
|
||||
project_dir ^ "/web/io.sx";
|
||||
];
|
||||
|
||||
Printf.printf "\n%d/%d passed\n" !pass (!pass + !fail);
|
||||
if !fail > 0 then exit 1
|
||||
247
hosts/ocaml/bootstrap.py
Normal file
247
hosts/ocaml/bootstrap.py
Normal file
@@ -0,0 +1,247 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap compiler: SX spec -> OCaml.
|
||||
|
||||
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it the spec files,
|
||||
and produces sx_ref.ml — the transpiled evaluator as native OCaml.
|
||||
|
||||
Usage:
|
||||
python3 hosts/ocaml/bootstrap.py --output hosts/ocaml/lib/sx_ref.ml
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
return defines
|
||||
|
||||
|
||||
# OCaml preamble — opens and runtime helpers
|
||||
PREAMBLE = """\
|
||||
(* sx_ref.ml — Auto-generated from SX spec by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* Trampoline — forward ref, resolved after eval_expr is defined. *)
|
||||
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
|
||||
let trampoline v = !trampoline_fn v
|
||||
|
||||
|
||||
|
||||
(* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *)
|
||||
let _strict_ref = ref (Bool false)
|
||||
let _prim_param_types_ref = ref Nil
|
||||
let _last_error_kont_ref = ref Nil
|
||||
let _protocol_registry_ = Dict (Hashtbl.create 0)
|
||||
|
||||
"""
|
||||
|
||||
|
||||
# OCaml fixups — wire up trampoline + iterative CEK run + JIT hook
|
||||
FIXUPS = """\
|
||||
|
||||
(* Wire up trampoline to resolve thunks via the CEK machine *)
|
||||
let () = trampoline_fn := (fun v ->
|
||||
match v with
|
||||
| Thunk (expr, env) -> eval_expr expr (Env env)
|
||||
| _ -> v)
|
||||
|
||||
(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
|
||||
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
|
||||
|
||||
(* Override recursive cek_run with iterative loop.
|
||||
On error, capture the kont from the last state for comp-trace. *)
|
||||
let cek_run_iterative state =
|
||||
let s = ref state in
|
||||
(try
|
||||
while not (match cek_terminal_p !s with Bool true -> true | _ -> false)
|
||||
&& not (match cek_suspended_p !s with Bool true -> true | _ -> false) do
|
||||
s := cek_step !s
|
||||
done;
|
||||
(match cek_suspended_p !s with
|
||||
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
|
||||
| _ -> cek_value !s)
|
||||
with Eval_error msg ->
|
||||
_last_error_kont_ref := cek_kont !s;
|
||||
raise (Eval_error msg))
|
||||
|
||||
(* Collect component trace from a kont value *)
|
||||
let collect_comp_trace kont =
|
||||
let trace = ref [] in
|
||||
let k = ref kont in
|
||||
while (match !k with List (_::_) -> true | _ -> false) do
|
||||
(match !k with
|
||||
| List (frame :: rest) ->
|
||||
(match frame with
|
||||
| CekFrame f when f.cf_type = "comp-trace" ->
|
||||
let name = match f.cf_name with String s -> s | _ -> "?" in
|
||||
let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in
|
||||
trace := (name, file) :: !trace
|
||||
| Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) ->
|
||||
let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in
|
||||
let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in
|
||||
trace := (name, file) :: !trace
|
||||
| _ -> ());
|
||||
k := List rest
|
||||
| _ -> k := List [])
|
||||
done;
|
||||
List.rev !trace
|
||||
|
||||
(* Format a comp-trace into a human-readable string *)
|
||||
let format_comp_trace trace =
|
||||
match trace with
|
||||
| [] -> ""
|
||||
| entries ->
|
||||
let lines = List.mapi (fun i (name, file) ->
|
||||
let prefix = if i = 0 then " in " else " called from " in
|
||||
if file = "" then prefix ^ "~" ^ name
|
||||
else prefix ^ "~" ^ name ^ " (" ^ file ^ ")"
|
||||
) entries in
|
||||
"\n" ^ String.concat "\n" lines
|
||||
|
||||
(* Enhance an error message with component trace *)
|
||||
let enhance_error_with_trace msg =
|
||||
let trace = collect_comp_trace !_last_error_kont_ref in
|
||||
_last_error_kont_ref := Nil;
|
||||
msg ^ (format_comp_trace trace)
|
||||
|
||||
|
||||
|
||||
"""
|
||||
|
||||
|
||||
def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
"""Compile the SX spec to OCaml source."""
|
||||
import tempfile
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
from shared.sx.parser import serialize
|
||||
|
||||
if spec_dir is None:
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
|
||||
# Load the transpiler into OCaml kernel
|
||||
bridge = OcamlSync()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
bridge.load(transpiler_path)
|
||||
|
||||
# Spec files to transpile (in dependency order)
|
||||
# stdlib.sx functions are already registered as OCaml primitives —
|
||||
# only the evaluator needs transpilation.
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
]
|
||||
|
||||
parts = [PREAMBLE]
|
||||
|
||||
for filename, label in sx_files:
|
||||
filepath = os.path.join(spec_dir, filename)
|
||||
if not os.path.exists(filepath):
|
||||
print(f"Warning: {filepath} not found, skipping", file=sys.stderr)
|
||||
continue
|
||||
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Skip defines provided by preamble, fixups, or already-registered primitives
|
||||
# Skip: preamble-provided, math primitives, and stdlib functions
|
||||
# that use loop/named-let (transpiler can't handle those yet)
|
||||
skip = {"trampoline", "ceil", "floor", "round", "abs", "min", "max",
|
||||
"debug-log", "debug_log", "range", "chunk-every", "zip-pairs",
|
||||
"string-contains?", "starts-with?", "ends-with?",
|
||||
"string-replace", "trim", "split", "index-of",
|
||||
"pad-left", "pad-right", "char-at", "substring"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
|
||||
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
# Build the defines list and known names for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
known_names = [name for name, _ in defines]
|
||||
|
||||
# Serialize defines + known names to temp file, load into kernel
|
||||
defines_sx = serialize(defines_list)
|
||||
known_sx = serialize(known_names)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines \'{defines_sx})\n")
|
||||
tmp.write(f"(define _known_defines \'{known_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
result = bridge.eval("(ml-translate-file _defines)")
|
||||
|
||||
parts.append(f"\n(* === Transpiled from {label} === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
bridge.stop()
|
||||
parts.append(FIXUPS)
|
||||
output = "\n".join(parts)
|
||||
|
||||
# Mutable globals (*strict*, *prim-param-types*) are now handled by
|
||||
# the transpiler directly — it emits !_ref for reads, _ref := for writes.
|
||||
import re
|
||||
|
||||
# Remove `and _protocol_registry_ = (Dict ...)` from the let rec block —
|
||||
# it's defined in the preamble as a top-level let, and Hashtbl.create
|
||||
# is not allowed as a let rec right-hand side.
|
||||
output = re.sub(
|
||||
r'\n\(\* \*protocol-registry\*.*?\nand _protocol_registry_ =\n \(Dict \(Hashtbl\.create 0\)\)\n',
|
||||
'\n',
|
||||
output
|
||||
)
|
||||
|
||||
return output
|
||||
|
||||
|
||||
def main():
|
||||
import argparse
|
||||
parser = argparse.ArgumentParser(description="Bootstrap SX spec -> OCaml")
|
||||
parser.add_argument(
|
||||
"--output", "-o",
|
||||
default=None,
|
||||
help="Output file (default: stdout)",
|
||||
)
|
||||
args = parser.parse_args()
|
||||
|
||||
result = compile_spec_to_ml()
|
||||
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
153
hosts/ocaml/bootstrap_compiler.py
Normal file
153
hosts/ocaml/bootstrap_compiler.py
Normal file
@@ -0,0 +1,153 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap the SX bytecode compiler to native OCaml.
|
||||
|
||||
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it compiler.sx,
|
||||
and produces sx_compiler.ml — the bytecode compiler as native OCaml.
|
||||
|
||||
Usage:
|
||||
python3 hosts/ocaml/bootstrap_compiler.py
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
return defines
|
||||
|
||||
|
||||
PREAMBLE = """\
|
||||
(* sx_compiler.ml — Auto-generated from lib/compiler.sx *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_compiler.py *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* The compiler uses cek_call from the evaluator for runtime dispatch *)
|
||||
let cek_call = Sx_ref.cek_call
|
||||
let eval_expr = Sx_ref.eval_expr
|
||||
let trampoline v = match v with
|
||||
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
|
||||
| other -> other
|
||||
|
||||
(* Bindings for external functions the compiler calls.
|
||||
Some shadow OCaml stdlib names — the SX versions operate on values. *)
|
||||
let serialize v = String (Sx_types.inspect v)
|
||||
let sx_parse v = match v with
|
||||
| String s -> (match Sx_parser.parse_all s with [e] -> e | es -> List es)
|
||||
| v -> v
|
||||
let floor v = prim_call "floor" [v]
|
||||
let abs v = prim_call "abs" [v]
|
||||
let min a b = prim_call "min" [a; b]
|
||||
let max a b = prim_call "max" [a; b]
|
||||
let set_nth_b lst idx v = prim_call "set-nth!" [lst; idx; v]
|
||||
let init lst = prim_call "init" [lst]
|
||||
|
||||
(* skip_annotations: strips :keyword value pairs from a list (type annotations) *)
|
||||
let rec skip_annotations items =
|
||||
match items with
|
||||
| List [] | Nil -> Nil
|
||||
| List (Keyword _ :: _ :: rest) -> skip_annotations (List rest)
|
||||
| ListRef { contents = [] } -> Nil
|
||||
| ListRef { contents = Keyword _ :: _ :: rest } -> skip_annotations (List rest)
|
||||
| List (first :: _) -> first
|
||||
| ListRef { contents = first :: _ } -> first
|
||||
| _ -> Nil
|
||||
|
||||
(* compile_match: uses local recursion (letrec) that the transpiler can't handle.
|
||||
Falls back to CEK evaluation at runtime. *)
|
||||
let compile_match em args scope tail_p =
|
||||
let fn = Sx_ref.eval_expr (Symbol "compile-match") (Env (Sx_types.make_env ())) in
|
||||
ignore (Sx_ref.cek_call fn (List [em; args; scope; tail_p]));
|
||||
Nil
|
||||
|
||||
"""
|
||||
|
||||
|
||||
def main():
|
||||
import tempfile
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
from shared.sx.parser import serialize
|
||||
|
||||
# Load the transpiler into OCaml kernel
|
||||
bridge = OcamlSync()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
bridge.load(transpiler_path)
|
||||
|
||||
# Read compiler.sx
|
||||
compiler_path = os.path.join(_PROJECT, "lib", "compiler.sx")
|
||||
with open(compiler_path) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Skip functions that use letrec/named-let (transpiler can't handle)
|
||||
skip = {"compile-match"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
# Deduplicate (keep last definition)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
print(f"Transpiling {len(defines)} defines from compiler.sx...", file=sys.stderr)
|
||||
|
||||
# Build the defines list and known names for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
known_names = [name for name, _ in defines]
|
||||
|
||||
# Serialize to temp file, load into kernel
|
||||
defines_sx = serialize(defines_list)
|
||||
known_sx = serialize(known_names)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines '{defines_sx})\n")
|
||||
tmp.write(f"(define _known_defines '{known_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
result = bridge.eval("(ml-translate-file _defines)")
|
||||
|
||||
bridge.stop()
|
||||
|
||||
output = PREAMBLE + "\n(* === Transpiled from bytecode compiler === *)\n" + result + "\n"
|
||||
|
||||
# Post-process: fix skip_annotations local NativeFn → use top-level
|
||||
old = 'then (let skip_annotations = (NativeFn ('
|
||||
if old in output:
|
||||
idx = output.index(old)
|
||||
end_marker = 'in (skip_annotations (rest_args)))'
|
||||
end_idx = output.index(end_marker, idx)
|
||||
output = output[:idx] + 'then (skip_annotations (rest_args))' + output[end_idx + len(end_marker):]
|
||||
|
||||
# Write output
|
||||
out_path = os.path.join(_HERE, "lib", "sx_compiler.ml")
|
||||
with open(out_path, "w") as f:
|
||||
f.write(output)
|
||||
print(f"Wrote {len(output)} bytes to {out_path}", file=sys.stderr)
|
||||
print(f" {len(defines)} functions transpiled", file=sys.stderr)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
480
hosts/ocaml/bootstrap_render.py
Normal file
480
hosts/ocaml/bootstrap_render.py
Normal file
@@ -0,0 +1,480 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap the SX HTML renderer to native OCaml.
|
||||
|
||||
Reads spec/render.sx (helpers) and web/adapter-html.sx (dispatch),
|
||||
combines them, and transpiles to sx_render.ml.
|
||||
|
||||
Performance-critical functions (escape_html, render_attrs) are provided
|
||||
as native OCaml in the PREAMBLE. Web-specific renderers (lake, marsh,
|
||||
island) are appended in FIXUPS.
|
||||
|
||||
Usage:
|
||||
python3 hosts/ocaml/bootstrap_render.py
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all, serialize
|
||||
from shared.sx.types import Symbol, Keyword
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
return defines
|
||||
|
||||
|
||||
def strip_type_annotations(expr):
|
||||
"""Recursively strip :as type annotations from param lists.
|
||||
Transforms (name :as type) → name in function parameter positions."""
|
||||
if isinstance(expr, list):
|
||||
# Check if this is a typed param: (name :as type)
|
||||
if (len(expr) == 3 and isinstance(expr[0], Symbol)
|
||||
and isinstance(expr[1], Keyword) and expr[1].name == "as"):
|
||||
return expr[0] # just the name
|
||||
|
||||
# Check for param list patterns — list where first element is a symbol
|
||||
# and contains :as keywords
|
||||
new = []
|
||||
for item in expr:
|
||||
new.append(strip_type_annotations(item))
|
||||
return new
|
||||
return expr
|
||||
|
||||
|
||||
PREAMBLE = """\
|
||||
(* sx_render.ml — Auto-generated from spec/render.sx + web/adapter-html.sx *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_render.py *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Platform bindings — native OCaml for performance and type access *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let eval_expr expr env = Sx_ref.eval_expr expr env
|
||||
let cond_scheme_p = Sx_ref.cond_scheme_p
|
||||
|
||||
(* Primitive wrappers needed as direct OCaml functions *)
|
||||
let raw_html_content v = match v with RawHTML s -> String s | _ -> String ""
|
||||
let make_raw_html v = match v with String s -> RawHTML s | _ -> Nil
|
||||
let scope_emit v1 v2 = prim_call "scope-emit!" [v1; v2]
|
||||
let init v = prim_call "init" [v]
|
||||
let dict_has a b = prim_call "dict-has?" [a; b]
|
||||
let dict_get a b = prim_call "dict-get" [a; b]
|
||||
let is_component v = prim_call "component?" [v]
|
||||
let is_island v = prim_call "island?" [v]
|
||||
let is_macro v = prim_call "macro?" [v]
|
||||
let is_lambda v = prim_call "lambda?" [v]
|
||||
let is_nil v = prim_call "nil?" [v]
|
||||
|
||||
(* Forward refs for web-specific renderers — set in FIXUPS or by caller *)
|
||||
let render_html_lake_ref : (value -> value -> value) ref = ref (fun _ _ -> String "")
|
||||
let render_html_marsh_ref : (value -> value -> value) ref = ref (fun _ _ -> String "")
|
||||
let render_html_island_ref : (value -> value -> value -> value) ref = ref (fun _ _ _ -> String "")
|
||||
|
||||
let render_html_lake args env = !render_html_lake_ref args env
|
||||
let render_html_marsh args env = !render_html_marsh_ref args env
|
||||
let render_html_island comp args env = !render_html_island_ref comp args env
|
||||
let cek_call = Sx_ref.cek_call
|
||||
|
||||
let trampoline v = match v with
|
||||
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
|
||||
| other -> other
|
||||
|
||||
let expand_macro m args_val _env = match m with
|
||||
| Macro mac ->
|
||||
let args = match args_val with List l | ListRef { contents = l } -> l | _ -> [] in
|
||||
let local = env_extend (Env mac.m_closure) in
|
||||
let rec bind_params ps as' = match ps, as' with
|
||||
| [], rest ->
|
||||
(match mac.m_rest_param with
|
||||
| Some rp -> ignore (env_bind local (String rp) (List rest))
|
||||
| None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (env_bind local p a);
|
||||
bind_params ps_rest as_rest
|
||||
| _ :: _, [] ->
|
||||
List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps)
|
||||
in
|
||||
bind_params (List.map (fun p -> String p) mac.m_params) args;
|
||||
Sx_ref.eval_expr mac.m_body local
|
||||
| _ -> Nil
|
||||
|
||||
(** try-catch: wraps a try body fn and catch handler fn.
|
||||
Maps to OCaml exception handling. *)
|
||||
let try_catch try_fn catch_fn =
|
||||
try sx_call try_fn []
|
||||
with
|
||||
| Eval_error msg -> sx_call catch_fn [String msg]
|
||||
| e -> sx_call catch_fn [String (Printexc.to_string e)]
|
||||
|
||||
(** set-render-active! — no-op on OCaml (always active). *)
|
||||
let set_render_active_b _v = Nil
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Performance-critical: native Buffer-based HTML escaping *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Tag registries — native string lists for callers, value Lists for SX *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let boolean_attrs_set = [
|
||||
"async"; "autofocus"; "autoplay"; "checked"; "controls"; "default";
|
||||
"defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap";
|
||||
"loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open";
|
||||
"playsinline"; "readonly"; "required"; "reversed"; "selected"
|
||||
]
|
||||
let is_boolean_attr name = List.mem name boolean_attrs_set
|
||||
|
||||
let html_tags_list = [
|
||||
"html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript";
|
||||
"header"; "nav"; "main"; "section"; "article"; "aside"; "footer";
|
||||
"h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup";
|
||||
"div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr";
|
||||
"ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu"; "details"; "summary"; "dialog";
|
||||
"a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup";
|
||||
"mark"; "abbr"; "cite"; "code"; "kbd"; "samp"; "var"; "time"; "br"; "wbr";
|
||||
"table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col";
|
||||
"form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label";
|
||||
"fieldset"; "legend"; "datalist"; "output";
|
||||
"img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe";
|
||||
"svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse";
|
||||
"g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern";
|
||||
"linearGradient"; "radialGradient"; "stop"; "filter";
|
||||
"feGaussianBlur"; "feOffset"; "feBlend"; "feColorMatrix"; "feComposite";
|
||||
"feMerge"; "feMergeNode"; "feTurbulence"; "feComponentTransfer";
|
||||
"feFuncR"; "feFuncG"; "feFuncB"; "feFuncA"; "feDisplacementMap"; "feFlood";
|
||||
"feImage"; "feMorphology"; "feSpecularLighting"; "feDiffuseLighting";
|
||||
"fePointLight"; "feSpotLight"; "feDistantLight";
|
||||
"animate"; "animateTransform"; "foreignObject"; "template"; "slot"
|
||||
]
|
||||
let html_tags = html_tags_list (* callers expect string list *)
|
||||
let html_tags_val = List (List.map (fun s -> String s) html_tags_list)
|
||||
|
||||
let void_elements_list = [
|
||||
"area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input";
|
||||
"link"; "meta"; "param"; "source"; "track"; "wbr"
|
||||
]
|
||||
let void_elements = void_elements_list (* callers expect string list *)
|
||||
let void_elements_val = List (List.map (fun s -> String s) void_elements_list)
|
||||
|
||||
let boolean_attrs = boolean_attrs_set (* callers expect string list *)
|
||||
let boolean_attrs_val = List (List.map (fun s -> String s) boolean_attrs_set)
|
||||
|
||||
(* Native escape for internal use — returns raw OCaml string *)
|
||||
let escape_html_raw s =
|
||||
let buf = Buffer.create (String.length s) in
|
||||
String.iter (function
|
||||
| '&' -> Buffer.add_string buf "&"
|
||||
| '<' -> Buffer.add_string buf "<"
|
||||
| '>' -> Buffer.add_string buf ">"
|
||||
| '"' -> Buffer.add_string buf """
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.contents buf
|
||||
|
||||
(* escape_html: native string -> string for callers *)
|
||||
let escape_html = escape_html_raw
|
||||
|
||||
(* escape_html_val / escape_attr_val — take a value, return String value (for transpiled code) *)
|
||||
let escape_html_val v =
|
||||
let s = match v with String s -> s | v -> value_to_string v in
|
||||
String (escape_html_raw s)
|
||||
|
||||
let escape_attr_val v = escape_html_val v
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Performance-critical: native attribute rendering *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let render_attrs attrs = match attrs with
|
||||
| Dict d ->
|
||||
let buf = Buffer.create 64 in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if is_boolean_attr k then begin
|
||||
if sx_truthy v then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k
|
||||
end
|
||||
end else if v <> Nil then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k;
|
||||
Buffer.add_string buf "=\\"";
|
||||
Buffer.add_string buf (escape_html_raw (value_to_string v));
|
||||
Buffer.add_char buf '"'
|
||||
end) d;
|
||||
String (Buffer.contents buf)
|
||||
| _ -> String ""
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Forward ref — used by setup_render_env and buffer renderer *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let render_to_html_ref : (value -> value -> value) ref =
|
||||
ref (fun _expr _env -> String "")
|
||||
|
||||
(* scope-emitted is a prim alias *)
|
||||
let scope_emitted name = prim_call "scope-emitted" [name]
|
||||
|
||||
(* RENDER_HTML_FORMS — list of special form names handled by dispatch-html-form *)
|
||||
let render_html_forms = List [
|
||||
String "if"; String "when"; String "cond"; String "case";
|
||||
String "let"; String "let*"; String "letrec";
|
||||
String "begin"; String "do";
|
||||
String "define"; String "defcomp"; String "defmacro"; String "defisland";
|
||||
String "defpage"; String "defhandler"; String "defquery"; String "defaction";
|
||||
String "defrelation"; String "deftype"; String "defeffect"; String "defstyle";
|
||||
String "map"; String "map-indexed"; String "filter"; String "for-each";
|
||||
String "scope"; String "provide"
|
||||
]
|
||||
|
||||
"""
|
||||
|
||||
|
||||
FIXUPS = """
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Wire up forward ref *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () = render_to_html_ref := render_to_html
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Buffer-based streaming renderer — zero intermediate string allocation *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** Escape HTML directly into a buffer. *)
|
||||
let escape_html_buf buf s =
|
||||
for i = 0 to String.length s - 1 do
|
||||
match String.unsafe_get s i with
|
||||
| '&' -> Buffer.add_string buf "&"
|
||||
| '<' -> Buffer.add_string buf "<"
|
||||
| '>' -> Buffer.add_string buf ">"
|
||||
| '"' -> Buffer.add_string buf """
|
||||
| c -> Buffer.add_char buf c
|
||||
done
|
||||
|
||||
let render_attrs_buf buf attrs =
|
||||
Hashtbl.iter (fun k v ->
|
||||
if is_boolean_attr k then begin
|
||||
if sx_truthy v then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k
|
||||
end
|
||||
end else if v <> Nil then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k;
|
||||
Buffer.add_string buf "=\\"";
|
||||
escape_html_buf buf (value_to_string v);
|
||||
Buffer.add_char buf '"'
|
||||
end) attrs
|
||||
|
||||
(** Render to pre-allocated buffer — delegates to transpiled render_to_html
|
||||
and extracts the string result. *)
|
||||
let render_to_buf buf expr (env : env) =
|
||||
match !render_to_html_ref expr (Env env) with
|
||||
| String s -> Buffer.add_string buf s
|
||||
| RawHTML s -> Buffer.add_string buf s
|
||||
| v -> Buffer.add_string buf (value_to_str v)
|
||||
|
||||
(** Public API: render to a pre-allocated buffer. *)
|
||||
let render_to_buffer buf expr env = render_to_buf buf expr env
|
||||
|
||||
(** Convenience: render to string. *)
|
||||
let render_to_html_streaming expr (env : env) =
|
||||
match !render_to_html_ref expr (Env env) with
|
||||
| String s -> s
|
||||
| RawHTML s -> s
|
||||
| v -> value_to_str v
|
||||
|
||||
(** The native OCaml renderer — used by sx_server when SX adapter isn't loaded. *)
|
||||
let do_render_to_html expr (env_val : value) =
|
||||
match !render_to_html_ref expr env_val with
|
||||
| String s -> s
|
||||
| RawHTML s -> s
|
||||
| v -> value_to_str v
|
||||
|
||||
(** Render via the SX adapter (render-to-html from adapter-html.sx).
|
||||
Falls back to the native ref if the SX adapter isn't loaded. *)
|
||||
let sx_render_to_html (render_env : env) expr (eval_env : env) =
|
||||
if Sx_types.env_has render_env "render-to-html" then
|
||||
let fn = Sx_types.env_get render_env "render-to-html" in
|
||||
let result = Sx_ref.cek_call fn (List [expr; Env eval_env]) in
|
||||
match result with String s -> s | RawHTML s -> s | _ -> value_to_str result
|
||||
else
|
||||
do_render_to_html expr (Env eval_env)
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Setup — bind render primitives in an env and wire up the ref *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let is_html_tag name = List.mem name html_tags_list
|
||||
let is_void name = List.mem name void_elements_list
|
||||
|
||||
(* escape_html_str: takes raw OCaml string, returns raw string — for callers *)
|
||||
let escape_html_str = escape_html_raw
|
||||
|
||||
let setup_render_env (raw_env : env) =
|
||||
let env = Env raw_env in
|
||||
let bind name fn =
|
||||
ignore (Sx_types.env_bind raw_env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "render-html" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
!render_to_html_ref expr env
|
||||
| [expr] ->
|
||||
!render_to_html_ref expr env
|
||||
| [expr; Env e] ->
|
||||
!render_to_html_ref expr (Env e)
|
||||
| _ -> String "");
|
||||
|
||||
bind "render-to-html" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
!render_to_html_ref expr env
|
||||
| [expr] ->
|
||||
!render_to_html_ref expr env
|
||||
| [expr; Env e] ->
|
||||
!render_to_html_ref expr (Env e)
|
||||
| _ -> String "")
|
||||
"""
|
||||
|
||||
|
||||
def main():
|
||||
import tempfile
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
|
||||
# Load the transpiler into OCaml kernel
|
||||
bridge = OcamlSync()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
bridge.load(transpiler_path)
|
||||
|
||||
# Read source files
|
||||
spec_path = os.path.join(_PROJECT, "spec", "render.sx")
|
||||
adapter_path = os.path.join(_PROJECT, "web", "adapter-html.sx")
|
||||
|
||||
with open(spec_path) as f:
|
||||
spec_src = f.read()
|
||||
with open(adapter_path) as f:
|
||||
adapter_src = f.read()
|
||||
|
||||
spec_defines = extract_defines(spec_src)
|
||||
adapter_defines = extract_defines(adapter_src)
|
||||
|
||||
# Skip: performance-critical (native in PREAMBLE) and web-specific (in FIXUPS)
|
||||
skip = {
|
||||
# Native in PREAMBLE for performance
|
||||
"escape-html", "escape-attr", "render-attrs",
|
||||
# OCaml can't have uppercase let bindings; registries need dual types
|
||||
"RENDER_HTML_FORMS",
|
||||
"HTML_TAGS", "VOID_ELEMENTS", "BOOLEAN_ATTRS",
|
||||
# Web-specific — provided as stubs or in FIXUPS
|
||||
"render-html-lake", "render-html-marsh",
|
||||
"render-html-island", "serialize-island-state",
|
||||
}
|
||||
|
||||
# Combine: spec helpers first (dependency order), then adapter dispatch
|
||||
all_defines = []
|
||||
for name, expr in spec_defines:
|
||||
if name not in skip:
|
||||
all_defines.append((name, expr))
|
||||
for name, expr in adapter_defines:
|
||||
if name not in skip:
|
||||
all_defines.append((name, expr))
|
||||
|
||||
# Deduplicate — keep last definition for each name
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(all_defines):
|
||||
seen[n] = i
|
||||
all_defines = [(n, e) for i, (n, e) in enumerate(all_defines) if seen[n] == i]
|
||||
|
||||
# Strip type annotations from params: (name :as type) → name
|
||||
all_defines = [(name, strip_type_annotations(expr)) for name, expr in all_defines]
|
||||
|
||||
print(f"Transpiling {len(all_defines)} defines from render spec + adapter...",
|
||||
file=sys.stderr)
|
||||
|
||||
# Build the defines list and known names for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in all_defines]
|
||||
known_names = [name for name, _ in all_defines]
|
||||
# Add PREAMBLE-provided names so transpiler emits them as direct calls
|
||||
known_names.extend([
|
||||
"escape-html", "escape-attr", "render-attrs",
|
||||
"eval-expr", "trampoline", "expand-macro",
|
||||
"try-catch", "set-render-active!",
|
||||
"render-html-lake", "render-html-marsh",
|
||||
"render-html-island", "serialize-island-state",
|
||||
"scope-emitted",
|
||||
"RENDER_HTML_FORMS",
|
||||
"cond-scheme?",
|
||||
])
|
||||
|
||||
# Serialize to temp file, load into kernel
|
||||
defines_sx = serialize(defines_list)
|
||||
known_sx = serialize(known_names)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines '{defines_sx})\n")
|
||||
tmp.write(f"(define _known_defines '{known_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
|
||||
# Add renames for uppercase constants and dual-form registries
|
||||
bridge.eval('(dict-set! ml-renames "RENDER_HTML_FORMS" "render_html_forms")')
|
||||
bridge.eval('(dict-set! ml-renames "HTML_TAGS" "html_tags_val")')
|
||||
bridge.eval('(dict-set! ml-renames "VOID_ELEMENTS" "void_elements_val")')
|
||||
bridge.eval('(dict-set! ml-renames "BOOLEAN_ATTRS" "boolean_attrs_val")')
|
||||
bridge.eval('(dict-set! ml-renames "escape-html" "escape_html_val")')
|
||||
bridge.eval('(dict-set! ml-renames "escape-attr" "escape_attr_val")')
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
result = bridge.eval("(ml-translate-file _defines)")
|
||||
|
||||
bridge.stop()
|
||||
|
||||
output = PREAMBLE + "\n(* === Transpiled from render spec + adapter === *)\n" + result + "\n" + FIXUPS
|
||||
|
||||
# Write output
|
||||
output_path = os.path.join(_HERE, "lib", "sx_render.ml")
|
||||
with open(output_path, "w") as f:
|
||||
f.write(output)
|
||||
print(f"Wrote {len(output)} bytes to {output_path}", file=sys.stderr)
|
||||
print(f" {len(all_defines)} functions transpiled", file=sys.stderr)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
648
hosts/ocaml/bootstrap_vm.py
Normal file
648
hosts/ocaml/bootstrap_vm.py
Normal file
@@ -0,0 +1,648 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap the SX bytecode VM to native OCaml.
|
||||
|
||||
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it the logic
|
||||
functions from lib/vm.sx, and produces sx_vm_ref.ml.
|
||||
|
||||
Type construction and performance-critical functions stay as native OCaml
|
||||
in the preamble. Logic (opcode dispatch, call routing, execution loop)
|
||||
is transpiled from SX.
|
||||
|
||||
Usage:
|
||||
python3 hosts/ocaml/bootstrap_vm.py
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import sys
|
||||
import tempfile
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all, serialize
|
||||
from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines_from_library(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source with define-library wrapper, extract defines from begin body."""
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if not (isinstance(expr, list) and expr and isinstance(expr[0], Symbol)):
|
||||
continue
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
elif expr[0].name == "define-library":
|
||||
# Extract defines from (begin ...) declarations
|
||||
for decl in expr[2:]:
|
||||
if isinstance(decl, list) and decl and isinstance(decl[0], Symbol) and decl[0].name == "begin":
|
||||
for form in decl[1:]:
|
||||
if isinstance(form, list) and form and isinstance(form[0], Symbol) and form[0].name == "define":
|
||||
name = form[1].name if isinstance(form[1], Symbol) else str(form[1])
|
||||
defines.append((name, form))
|
||||
return defines
|
||||
|
||||
|
||||
# Functions provided by the native OCaml preamble — skip from transpilation.
|
||||
# These handle type construction and performance-critical ops.
|
||||
SKIP = {
|
||||
# Type construction
|
||||
"make-upvalue-cell", "uv-get", "uv-set!",
|
||||
"make-vm-code", "make-vm-closure", "make-vm-frame", "make-vm",
|
||||
# Stack ops
|
||||
"vm-push", "vm-pop", "vm-peek",
|
||||
# Frame ops
|
||||
"frame-read-u8", "frame-read-u16", "frame-read-i16",
|
||||
"frame-local-get", "frame-local-set",
|
||||
"frame-upvalue-get", "frame-upvalue-set",
|
||||
# Accessors (native OCaml field access)
|
||||
"frame-ip", "frame-set-ip!", "frame-base", "frame-closure",
|
||||
"closure-code", "closure-upvalues", "closure-env",
|
||||
"code-bytecode", "code-constants", "code-locals",
|
||||
"vm-sp", "vm-set-sp!", "vm-stack", "vm-set-stack!",
|
||||
"vm-frames", "vm-set-frames!", "vm-globals-ref",
|
||||
# Global ops
|
||||
"vm-global-get", "vm-global-set",
|
||||
# Complex native ops
|
||||
"vm-push-frame", "code-from-value", "vm-closure?",
|
||||
"vm-create-closure",
|
||||
# Lambda accessors (native type)
|
||||
"lambda?", "lambda-compiled", "lambda-set-compiled!", "lambda-name",
|
||||
# JIT dispatch + active VM (platform-specific)
|
||||
"*active-vm*", "*jit-compile-fn*",
|
||||
"try-jit-call", "vm-call-closure",
|
||||
# Module execution (thin wrappers over native execute_module)
|
||||
"vm-execute-module", "vm-resume-module",
|
||||
# Env access (used by env-walk)
|
||||
"env-walk", "env-walk-set!",
|
||||
# CEK interop
|
||||
"cek-call-or-suspend",
|
||||
# Collection helpers (use mutable state + recursion)
|
||||
"collect-n-from-stack", "collect-n-pairs", "pad-n-nils",
|
||||
}
|
||||
|
||||
|
||||
PREAMBLE = """\
|
||||
(* sx_vm_ref.ml — Auto-generated from lib/vm.sx *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_vm.py *)
|
||||
|
||||
[@@@warning "-26-27-39"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* ================================================================
|
||||
Forward references for CEK interop
|
||||
================================================================ *)
|
||||
|
||||
let cek_call = Sx_ref.cek_call
|
||||
let eval_expr = Sx_ref.eval_expr
|
||||
let trampoline v = match v with
|
||||
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
|
||||
| other -> other
|
||||
|
||||
(* SX List → OCaml list *)
|
||||
let to_ocaml_list v = match v with List l -> l | Nil -> [] | _ -> [v]
|
||||
|
||||
(* str as NativeFn value — transpiled code passes it to sx_apply *)
|
||||
let str = NativeFn ("str", fun args -> String (sx_str args))
|
||||
|
||||
(* Primitive call dispatch — transpiled code uses this for CALL_PRIM *)
|
||||
let call_primitive name args =
|
||||
let n = value_to_string name in
|
||||
prim_call n (to_ocaml_list args)
|
||||
|
||||
(* ================================================================
|
||||
Preamble: 48 native OCaml functions for VM type access.
|
||||
These are SKIPPED from transpilation — the transpiled logic
|
||||
functions call them for all type construction and field access.
|
||||
================================================================ *)
|
||||
|
||||
(* --- Unwrap helpers --- *)
|
||||
let unwrap_vm v = match v with VmMachine m -> m | _ -> raise (Eval_error "not a vm")
|
||||
let unwrap_frame v = match v with VmFrame f -> f | _ -> raise (Eval_error "not a frame")
|
||||
let unwrap_closure v = match v with VmClosure c -> c | _ -> raise (Eval_error "not a closure")
|
||||
|
||||
(* --- Upvalue cells (internal to preamble — never SX values) --- *)
|
||||
let _make_uv_cell v : vm_upvalue_cell = { uv_value = v }
|
||||
let _uv_get (c : vm_upvalue_cell) = c.uv_value
|
||||
let _uv_set (c : vm_upvalue_cell) v = c.uv_value <- v
|
||||
|
||||
(* SX-facing stubs (in skip set, never called from transpiled code) *)
|
||||
let make_upvalue_cell v = Nil
|
||||
let uv_get _ = Nil
|
||||
let uv_set_b _ _ = Nil
|
||||
|
||||
(* --- VM code construction --- *)
|
||||
let code_from_value v = Sx_vm.code_from_value v
|
||||
|
||||
let make_vm_code arity locals bytecode constants =
|
||||
(* Build a Dict that code_from_value can parse *)
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "arity" arity;
|
||||
Hashtbl.replace d "bytecode" bytecode;
|
||||
Hashtbl.replace d "constants" constants;
|
||||
Dict d
|
||||
|
||||
(* --- VM closure --- *)
|
||||
let make_vm_closure code upvalues name globals closure_env =
|
||||
let uv = match upvalues with
|
||||
| List l -> Array.of_list (List.map (fun v -> { uv_value = v }) l)
|
||||
| _ -> [||] in
|
||||
VmClosure { vm_code = code_from_value code;
|
||||
vm_upvalues = uv;
|
||||
vm_name = (match name with String s -> Some s | Nil -> None | _ -> None);
|
||||
vm_env_ref = (match globals with Dict d -> d | _ -> Hashtbl.create 0);
|
||||
vm_closure_env = (match closure_env with Env e -> Some e | _ -> None) }
|
||||
|
||||
(* --- VM frame --- *)
|
||||
let make_vm_frame closure base =
|
||||
let cl = unwrap_closure closure in
|
||||
VmFrame { vf_closure = cl; vf_ip = 0;
|
||||
vf_base = val_to_int base;
|
||||
vf_local_cells = Hashtbl.create 4 }
|
||||
|
||||
(* --- VM machine --- *)
|
||||
let make_vm globals =
|
||||
let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
|
||||
VmMachine { vm_stack = Array.make 4096 Nil; vm_sp = 0;
|
||||
vm_frames = []; vm_globals = g; vm_pending_cek = None }
|
||||
|
||||
(* --- Stack ops --- *)
|
||||
let vm_push vm_val v =
|
||||
let m = unwrap_vm vm_val in
|
||||
if m.vm_sp >= Array.length m.vm_stack then begin
|
||||
let ns = Array.make (m.vm_sp * 2) Nil in
|
||||
Array.blit m.vm_stack 0 ns 0 m.vm_sp;
|
||||
m.vm_stack <- ns
|
||||
end;
|
||||
m.vm_stack.(m.vm_sp) <- v;
|
||||
m.vm_sp <- m.vm_sp + 1;
|
||||
Nil
|
||||
|
||||
let vm_pop vm_val =
|
||||
let m = unwrap_vm vm_val in
|
||||
m.vm_sp <- m.vm_sp - 1;
|
||||
m.vm_stack.(m.vm_sp)
|
||||
|
||||
let vm_peek vm_val =
|
||||
let m = unwrap_vm vm_val in
|
||||
m.vm_stack.(m.vm_sp - 1)
|
||||
|
||||
(* --- Frame operand reading --- *)
|
||||
let frame_read_u8 frame_val =
|
||||
let f = unwrap_frame frame_val in
|
||||
let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
|
||||
f.vf_ip <- f.vf_ip + 1;
|
||||
Number (float_of_int v)
|
||||
|
||||
let frame_read_u16 frame_val =
|
||||
let f = unwrap_frame frame_val in
|
||||
let lo = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
|
||||
let hi = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip + 1) in
|
||||
f.vf_ip <- f.vf_ip + 2;
|
||||
Number (float_of_int (lo lor (hi lsl 8)))
|
||||
|
||||
let frame_read_i16 frame_val =
|
||||
let f = unwrap_frame frame_val in
|
||||
let lo = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
|
||||
let hi = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip + 1) in
|
||||
f.vf_ip <- f.vf_ip + 2;
|
||||
let v = lo lor (hi lsl 8) in
|
||||
Number (float_of_int (if v >= 32768 then v - 65536 else v))
|
||||
|
||||
(* --- Local variable access --- *)
|
||||
let frame_local_get vm_val frame_val slot =
|
||||
let m = unwrap_vm vm_val in
|
||||
let f = unwrap_frame frame_val in
|
||||
let idx = f.vf_base + val_to_int slot in
|
||||
(* Check for shared upvalue cell *)
|
||||
match Hashtbl.find_opt f.vf_local_cells (val_to_int slot) with
|
||||
| Some cell -> cell.uv_value
|
||||
| None -> m.vm_stack.(idx)
|
||||
|
||||
let frame_local_set vm_val frame_val slot v =
|
||||
let m = unwrap_vm vm_val in
|
||||
let f = unwrap_frame frame_val in
|
||||
let s = val_to_int slot in
|
||||
(* If slot has a shared cell, write through cell *)
|
||||
(match Hashtbl.find_opt f.vf_local_cells s with
|
||||
| Some cell -> cell.uv_value <- v
|
||||
| None -> m.vm_stack.(f.vf_base + s) <- v);
|
||||
Nil
|
||||
|
||||
(* --- Upvalue access --- *)
|
||||
let frame_upvalue_get frame_val idx =
|
||||
let f = unwrap_frame frame_val in
|
||||
f.vf_closure.vm_upvalues.(val_to_int idx).uv_value
|
||||
|
||||
let frame_upvalue_set frame_val idx v =
|
||||
let f = unwrap_frame frame_val in
|
||||
f.vf_closure.vm_upvalues.(val_to_int idx).uv_value <- v;
|
||||
Nil
|
||||
|
||||
(* --- Field accessors --- *)
|
||||
let frame_ip f = let fr = unwrap_frame f in Number (float_of_int fr.vf_ip)
|
||||
let frame_set_ip_b f v = let fr = unwrap_frame f in fr.vf_ip <- val_to_int v; Nil
|
||||
let frame_base f = let fr = unwrap_frame f in Number (float_of_int fr.vf_base)
|
||||
let frame_closure f = let fr = unwrap_frame f in VmClosure fr.vf_closure
|
||||
|
||||
let closure_code cl = let c = unwrap_closure cl in
|
||||
(* Return as Dict for code_bytecode/code_constants/code_locals *)
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode)));
|
||||
Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants));
|
||||
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity));
|
||||
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals));
|
||||
Dict d
|
||||
|
||||
let closure_upvalues cl = let c = unwrap_closure cl in
|
||||
List (Array.to_list (Array.map (fun cell -> cell.uv_value) c.vm_upvalues))
|
||||
|
||||
let closure_env cl = match cl with
|
||||
| VmClosure c -> (match c.vm_closure_env with Some e -> Env e | None -> Nil)
|
||||
| _ -> Nil
|
||||
|
||||
let code_bytecode code = get_val code (String "vc-bytecode")
|
||||
let code_constants code = get_val code (String "vc-constants")
|
||||
let code_locals code = get_val code (String "vc-locals")
|
||||
|
||||
let vm_sp v = let m = unwrap_vm v in Number (float_of_int m.vm_sp)
|
||||
let vm_set_sp_b v s = let m = unwrap_vm v in m.vm_sp <- val_to_int s; Nil
|
||||
let vm_stack v = let _m = unwrap_vm v in Nil (* opaque — use vm_push/pop *)
|
||||
let vm_set_stack_b v _s = Nil
|
||||
let vm_frames v = let m = unwrap_vm v in List (List.map (fun f -> VmFrame f) m.vm_frames)
|
||||
let vm_set_frames_b v fs = let m = unwrap_vm v in
|
||||
m.vm_frames <- (match fs with
|
||||
| List l -> List.map unwrap_frame l
|
||||
| _ -> []);
|
||||
Nil
|
||||
let vm_globals_ref v = let m = unwrap_vm v in Dict m.vm_globals
|
||||
|
||||
(* --- Global variable access --- *)
|
||||
let vm_global_get vm_val frame_val name =
|
||||
let m = unwrap_vm vm_val in
|
||||
let n = value_to_string name in
|
||||
(* Try globals table first *)
|
||||
match Hashtbl.find_opt m.vm_globals n with
|
||||
| Some v -> v
|
||||
| None ->
|
||||
(* Walk closure env chain *)
|
||||
let f = unwrap_frame frame_val in
|
||||
(match f.vf_closure.vm_closure_env with
|
||||
| Some env ->
|
||||
let id = intern n in
|
||||
let rec find_env e =
|
||||
match Hashtbl.find_opt e.bindings id with
|
||||
| Some v -> v
|
||||
| None -> (match e.parent with Some p -> find_env p | None ->
|
||||
(* Try evaluator's primitive table as last resort *)
|
||||
(try prim_call n [] with _ ->
|
||||
raise (Eval_error ("VM undefined: " ^ n))))
|
||||
in find_env env
|
||||
| None ->
|
||||
(try prim_call n [] with _ ->
|
||||
raise (Eval_error ("VM undefined: " ^ n))))
|
||||
|
||||
let vm_global_set vm_val frame_val name v =
|
||||
let m = unwrap_vm vm_val in
|
||||
let n = value_to_string name in
|
||||
let f = unwrap_frame frame_val in
|
||||
(* Write to closure env if name exists there *)
|
||||
let written = match f.vf_closure.vm_closure_env with
|
||||
| Some env ->
|
||||
let id = intern n in
|
||||
let rec find_env e =
|
||||
if Hashtbl.mem e.bindings id then
|
||||
(Hashtbl.replace e.bindings id v; true)
|
||||
else match e.parent with Some p -> find_env p | None -> false
|
||||
in find_env env
|
||||
| None -> false
|
||||
in
|
||||
if not written then begin
|
||||
Hashtbl.replace m.vm_globals n v;
|
||||
(match !_vm_global_set_hook with Some f -> f n v | None -> ())
|
||||
end;
|
||||
Nil
|
||||
|
||||
(* --- Frame push --- *)
|
||||
let vm_push_frame vm_val closure_val args =
|
||||
let m = unwrap_vm vm_val in
|
||||
let cl = unwrap_closure closure_val in
|
||||
let f = { vf_closure = cl; vf_ip = 0; vf_base = m.vm_sp; vf_local_cells = Hashtbl.create 4 } in
|
||||
let arg_list = to_ocaml_list args in
|
||||
List.iter (fun a ->
|
||||
m.vm_stack.(m.vm_sp) <- a; m.vm_sp <- m.vm_sp + 1
|
||||
) arg_list;
|
||||
(* Pad remaining locals *)
|
||||
for _ = List.length arg_list to cl.vm_code.vc_locals - 1 do
|
||||
m.vm_stack.(m.vm_sp) <- Nil; m.vm_sp <- m.vm_sp + 1
|
||||
done;
|
||||
m.vm_frames <- f :: m.vm_frames;
|
||||
Nil
|
||||
|
||||
(* --- Closure type check --- *)
|
||||
let vm_closure_p v = match v with VmClosure _ -> Bool true | _ -> Bool false
|
||||
|
||||
(* --- Closure creation (upvalue capture) --- *)
|
||||
let vm_create_closure vm_val frame_val code_val =
|
||||
let m = unwrap_vm vm_val in
|
||||
let f = unwrap_frame frame_val in
|
||||
let uv_count = match code_val with
|
||||
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
|
||||
| Some (Number n) -> int_of_float n | _ -> 0)
|
||||
| _ -> 0
|
||||
in
|
||||
let upvalues = Array.init uv_count (fun _ ->
|
||||
let is_local = let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in f.vf_ip <- f.vf_ip + 1; v in
|
||||
let index = let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in f.vf_ip <- f.vf_ip + 1; v in
|
||||
if is_local = 1 then begin
|
||||
match Hashtbl.find_opt f.vf_local_cells index with
|
||||
| Some existing -> existing
|
||||
| None ->
|
||||
let c = { uv_value = m.vm_stack.(f.vf_base + index) } in
|
||||
Hashtbl.replace f.vf_local_cells index c;
|
||||
c
|
||||
end else
|
||||
f.vf_closure.vm_upvalues.(index)
|
||||
) in
|
||||
let code = code_from_value code_val in
|
||||
VmClosure { vm_code = code; vm_upvalues = upvalues; vm_name = None;
|
||||
vm_env_ref = m.vm_globals; vm_closure_env = f.vf_closure.vm_closure_env }
|
||||
|
||||
(* --- JIT sentinel --- *)
|
||||
let _jit_failed_sentinel = {
|
||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
|
||||
vc_bytecode_list = None; vc_constants_list = None };
|
||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||
}
|
||||
let _is_jit_failed cl = cl.vm_code.vc_arity = -1
|
||||
|
||||
(* --- Lambda accessors --- *)
|
||||
let is_lambda v = match v with Lambda _ -> Bool true | _ -> Bool false
|
||||
let lambda_compiled v = match v with
|
||||
| Lambda l -> (match l.l_compiled with Some c -> VmClosure c | None -> Nil)
|
||||
| _ -> Nil
|
||||
let lambda_set_compiled_b v c = match v with
|
||||
| Lambda l -> (match c with
|
||||
| VmClosure cl -> l.l_compiled <- Some cl; Nil
|
||||
| String "jit-failed" -> l.l_compiled <- Some _jit_failed_sentinel; Nil
|
||||
| _ -> l.l_compiled <- None; Nil)
|
||||
| _ -> Nil
|
||||
let lambda_name v = match v with
|
||||
| Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
|
||||
| _ -> Nil
|
||||
|
||||
(* --- CEK call with suspension awareness --- *)
|
||||
let cek_call_or_suspend vm_val f args =
|
||||
let a = to_ocaml_list args in
|
||||
let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
|
||||
let final = Sx_ref.cek_step_loop state in
|
||||
match get_val final (String "phase") with
|
||||
| String "io-suspended" ->
|
||||
let m = unwrap_vm vm_val in
|
||||
m.vm_pending_cek <- Some final;
|
||||
raise (Sx_vm.VmSuspended (get_val final (String "request"), Sx_vm.create m.vm_globals))
|
||||
| _ -> Sx_ref.cek_value final
|
||||
|
||||
(* --- Env walking (for global variable resolution) --- *)
|
||||
let rec env_walk env name =
|
||||
match env with
|
||||
| Env e ->
|
||||
let id = intern (value_to_string name) in
|
||||
let rec find e =
|
||||
match Hashtbl.find_opt e.bindings id with
|
||||
| Some v -> v
|
||||
| None -> (match e.parent with Some p -> find p | None -> Nil)
|
||||
in find e
|
||||
| Nil -> Nil
|
||||
| _ -> Nil
|
||||
|
||||
let env_walk_set_b env name value =
|
||||
match env with
|
||||
| Env e ->
|
||||
let id = intern (value_to_string name) in
|
||||
let rec find e =
|
||||
if Hashtbl.mem e.bindings id then
|
||||
(Hashtbl.replace e.bindings id value; true)
|
||||
else match e.parent with Some p -> find p | None -> false
|
||||
in
|
||||
if find e then Nil else Nil
|
||||
| _ -> Nil
|
||||
|
||||
(* --- Active VM tracking (module-level mutable state) --- *)
|
||||
let _active_vm : vm_machine option ref = ref None
|
||||
|
||||
(* Forward ref — resolved after transpiled let rec block *)
|
||||
let _vm_run_fn : (value -> value) ref = ref (fun _ -> Nil)
|
||||
let _vm_call_fn : (value -> value -> value -> value) ref = ref (fun _ _ _ -> Nil)
|
||||
|
||||
(* vm-call-closure: creates fresh VM, runs closure, returns result *)
|
||||
let vm_call_closure closure_val args globals =
|
||||
let cl = unwrap_closure closure_val in
|
||||
let prev_vm = !_active_vm in
|
||||
let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
|
||||
let m = { vm_stack = Array.make 4096 Nil; vm_sp = 0;
|
||||
vm_frames = []; vm_globals = g; vm_pending_cek = None } in
|
||||
let vm_val = VmMachine m in
|
||||
_active_vm := Some m;
|
||||
ignore (vm_push_frame vm_val closure_val args);
|
||||
(try ignore (!_vm_run_fn vm_val) with e -> _active_vm := prev_vm; raise e);
|
||||
_active_vm := prev_vm;
|
||||
vm_pop vm_val
|
||||
|
||||
(* --- JIT dispatch (platform-specific) --- *)
|
||||
let try_jit_call vm_val f args =
|
||||
let m = unwrap_vm vm_val in
|
||||
match f with
|
||||
| Lambda l ->
|
||||
(match l.l_compiled with
|
||||
| Some cl when not (_is_jit_failed cl) ->
|
||||
(try vm_push vm_val (vm_call_closure (VmClosure cl) args (Dict cl.vm_env_ref))
|
||||
with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args))
|
||||
| Some _ ->
|
||||
vm_push vm_val (cek_call_or_suspend vm_val f args)
|
||||
| None ->
|
||||
if l.l_name <> None then begin
|
||||
l.l_compiled <- Some _jit_failed_sentinel;
|
||||
match !Sx_vm.jit_compile_ref l m.vm_globals with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
(try vm_push vm_val (vm_call_closure (VmClosure cl) args (Dict cl.vm_env_ref))
|
||||
with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args))
|
||||
| None ->
|
||||
vm_push vm_val (cek_call_or_suspend vm_val f args)
|
||||
end else
|
||||
vm_push vm_val (cek_call_or_suspend vm_val f args))
|
||||
| _ -> vm_push vm_val (cek_call_or_suspend vm_val f args)
|
||||
|
||||
(* --- Collection helpers --- *)
|
||||
let collect_n_from_stack vm_val n =
|
||||
let m = unwrap_vm vm_val in
|
||||
let count = val_to_int n in
|
||||
let result = ref [] in
|
||||
for _ = 1 to count do
|
||||
m.vm_sp <- m.vm_sp - 1;
|
||||
result := m.vm_stack.(m.vm_sp) :: !result
|
||||
done;
|
||||
List !result
|
||||
|
||||
let collect_n_pairs vm_val n =
|
||||
let m = unwrap_vm vm_val in
|
||||
let count = val_to_int n in
|
||||
let d = Hashtbl.create count in
|
||||
for _ = 1 to count do
|
||||
m.vm_sp <- m.vm_sp - 1;
|
||||
let v = m.vm_stack.(m.vm_sp) in
|
||||
m.vm_sp <- m.vm_sp - 1;
|
||||
let k = value_to_string m.vm_stack.(m.vm_sp) in
|
||||
Hashtbl.replace d k v
|
||||
done;
|
||||
Dict d
|
||||
|
||||
let pad_n_nils vm_val n =
|
||||
let m = unwrap_vm vm_val in
|
||||
let count = val_to_int n in
|
||||
for _ = 1 to count do
|
||||
m.vm_stack.(m.vm_sp) <- Nil;
|
||||
m.vm_sp <- m.vm_sp + 1
|
||||
done;
|
||||
Nil
|
||||
|
||||
"""
|
||||
|
||||
|
||||
def main():
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
|
||||
# Load the transpiler into OCaml kernel
|
||||
bridge = OcamlSync()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
bridge.load(transpiler_path)
|
||||
|
||||
# Read vm.sx
|
||||
vm_path = os.path.join(_PROJECT, "lib", "vm.sx")
|
||||
with open(vm_path) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines_from_library(src)
|
||||
|
||||
# Filter out preamble functions
|
||||
defines = [(n, e) for n, e in defines if n not in SKIP]
|
||||
|
||||
# Deduplicate (keep last definition)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
print(f"Transpiling {len(defines)} defines from vm.sx...", file=sys.stderr)
|
||||
print(f" Skipped {len(SKIP)} preamble functions", file=sys.stderr)
|
||||
for name, _ in defines:
|
||||
print(f" -> {name}", file=sys.stderr)
|
||||
|
||||
# Build the defines list and known names for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
known_names = [name for name, _ in defines]
|
||||
|
||||
# Serialize to temp file, load into kernel
|
||||
defines_sx = serialize(defines_list)
|
||||
known_sx = serialize(known_names)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines '{defines_sx})\n")
|
||||
tmp.write(f"(define _known_defines '{known_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
result = bridge.eval("(ml-translate-file _defines)")
|
||||
|
||||
bridge.stop()
|
||||
|
||||
fixups = """
|
||||
|
||||
(* Wire forward references to transpiled functions *)
|
||||
let () = _vm_run_fn := vm_run
|
||||
let () = _vm_call_fn := vm_call
|
||||
|
||||
(* ================================================================
|
||||
Public API — matches Sx_vm interface for drop-in replacement
|
||||
================================================================ *)
|
||||
|
||||
(** Build a suspension dict from __io_request in globals. *)
|
||||
let check_io_suspension globals vm_val =
|
||||
match Hashtbl.find_opt globals "__io_request" with
|
||||
| Some req when sx_truthy req ->
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "suspended" (Bool true);
|
||||
Hashtbl.replace d "op" (String "import");
|
||||
Hashtbl.replace d "request" req;
|
||||
Hashtbl.replace d "vm" vm_val;
|
||||
Some (Dict d)
|
||||
| _ -> None
|
||||
|
||||
(** Execute a compiled module — entry point for load-sxbc, compile-blob.
|
||||
Returns the result value, or a suspension dict if OP_PERFORM fired. *)
|
||||
let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
|
||||
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module";
|
||||
vm_env_ref = globals; vm_closure_env = None } in
|
||||
let m = { vm_stack = Array.make 4096 Nil; vm_sp = 0;
|
||||
vm_frames = []; vm_globals = globals; vm_pending_cek = None } in
|
||||
let vm_val = VmMachine m in
|
||||
let frame = { vf_closure = cl; vf_ip = 0; vf_base = 0; vf_local_cells = Hashtbl.create 4 } in
|
||||
for _ = 0 to code.vc_locals - 1 do
|
||||
m.vm_stack.(m.vm_sp) <- Nil; m.vm_sp <- m.vm_sp + 1
|
||||
done;
|
||||
m.vm_frames <- [frame];
|
||||
ignore (vm_run vm_val);
|
||||
match check_io_suspension globals vm_val with
|
||||
| Some suspension -> suspension
|
||||
| None -> vm_pop vm_val
|
||||
|
||||
(** Resume a suspended module. Clears __io_request, pushes nil, re-runs. *)
|
||||
let resume_module (suspended : value) =
|
||||
match suspended with
|
||||
| Dict d ->
|
||||
let vm_val = Hashtbl.find d "vm" in
|
||||
let globals = match vm_val with
|
||||
| VmMachine m -> m.vm_globals
|
||||
| _ -> raise (Eval_error "resume_module: expected VmMachine") in
|
||||
Hashtbl.replace globals "__io_request" Nil;
|
||||
ignore (vm_push vm_val Nil);
|
||||
ignore (vm_run vm_val);
|
||||
(match check_io_suspension globals vm_val with
|
||||
| Some suspension -> suspension
|
||||
| None -> vm_pop vm_val)
|
||||
| _ -> raise (Eval_error "resume_module: expected suspension dict")
|
||||
|
||||
(** Execute a closure with args — entry point for JIT Lambda calls. *)
|
||||
let call_closure (cl : vm_closure) (args : value list) (globals : (string, value) Hashtbl.t) =
|
||||
vm_call_closure (VmClosure cl) (List args) (Dict globals)
|
||||
|
||||
(** Reexport code_from_value for callers *)
|
||||
let code_from_value = code_from_value
|
||||
|
||||
(** Reexport jit refs *)
|
||||
let jit_compile_ref = Sx_vm.jit_compile_ref
|
||||
let jit_failed_sentinel = _jit_failed_sentinel
|
||||
let is_jit_failed = _is_jit_failed
|
||||
|
||||
"""
|
||||
output = PREAMBLE + "\n(* === Transpiled from lib/vm.sx === *)\n" + result + "\n" + fixups
|
||||
|
||||
# Write output
|
||||
out_path = os.path.join(_HERE, "sx_vm_ref.ml")
|
||||
with open(out_path, "w") as f:
|
||||
f.write(output)
|
||||
print(f"Wrote {len(output)} bytes to {out_path}", file=sys.stderr)
|
||||
print(f" {len(defines)} functions transpiled", file=sys.stderr)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
105
hosts/ocaml/browser/bisect_sxbc.sh
Executable file
105
hosts/ocaml/browser/bisect_sxbc.sh
Executable file
@@ -0,0 +1,105 @@
|
||||
#!/bin/bash
|
||||
# bisect_sxbc.sh — Binary search for which .sxbc file breaks reactive rendering.
|
||||
# Runs test_wasm.sh with SX_TEST_BYTECODE=1, toggling individual files between
|
||||
# bytecode and source to find the culprit.
|
||||
set -euo pipefail
|
||||
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
SXBC_DIR="shared/static/wasm/sx"
|
||||
BACKUP_DIR="/tmp/sxbc-bisect-backup"
|
||||
|
||||
# All .sxbc files in load order
|
||||
FILES=(
|
||||
render core-signals signals deps router page-helpers freeze
|
||||
bytecode compiler vm dom browser
|
||||
adapter-html adapter-sx adapter-dom
|
||||
boot-helpers hypersx
|
||||
harness harness-reactive harness-web
|
||||
engine orchestration boot
|
||||
)
|
||||
|
||||
# Backup all sxbc files
|
||||
mkdir -p "$BACKUP_DIR"
|
||||
for f in "${FILES[@]}"; do
|
||||
cp "$SXBC_DIR/$f.sxbc" "$BACKUP_DIR/$f.sxbc" 2>/dev/null || true
|
||||
done
|
||||
|
||||
# Test function: returns 0 if the reactive scoped test passes
|
||||
test_passes() {
|
||||
local result
|
||||
result=$(SX_TEST_BYTECODE=1 bash hosts/ocaml/browser/test_wasm.sh 2>&1) || true
|
||||
if echo "$result" | grep -q "scoped static class"; then
|
||||
# Test mentioned = it failed
|
||||
return 1
|
||||
else
|
||||
return 0
|
||||
fi
|
||||
}
|
||||
|
||||
# Restore all bytecodes
|
||||
restore_all() {
|
||||
for f in "${FILES[@]}"; do
|
||||
cp "$BACKUP_DIR/$f.sxbc" "$SXBC_DIR/$f.sxbc" 2>/dev/null || true
|
||||
done
|
||||
}
|
||||
|
||||
# Remove specific bytecodes (force source loading for those)
|
||||
remove_sxbc() {
|
||||
for f in "$@"; do
|
||||
rm -f "$SXBC_DIR/$f.sxbc"
|
||||
done
|
||||
}
|
||||
|
||||
echo "=== Bytecode bisect: finding which .sxbc breaks reactive rendering ==="
|
||||
echo " ${#FILES[@]} files to search"
|
||||
echo ""
|
||||
|
||||
# First: verify all-bytecode fails
|
||||
restore_all
|
||||
echo "--- All bytecode (should fail) ---"
|
||||
if test_passes; then
|
||||
echo "UNEXPECTED: all-bytecode passes! Nothing to bisect."
|
||||
exit 0
|
||||
fi
|
||||
echo " Confirmed: fails with all bytecode"
|
||||
|
||||
# Second: verify all-source passes
|
||||
for f in "${FILES[@]}"; do rm -f "$SXBC_DIR/$f.sxbc"; done
|
||||
echo "--- All source (should pass) ---"
|
||||
if ! test_passes; then
|
||||
echo "UNEXPECTED: all-source also fails! Bug is not bytecode-specific."
|
||||
restore_all
|
||||
exit 1
|
||||
fi
|
||||
echo " Confirmed: passes with all source"
|
||||
|
||||
# Binary search: find minimal set of bytecode files that causes failure
|
||||
# Strategy: start with all source, add bytecode files one at a time
|
||||
echo ""
|
||||
echo "=== Individual file test ==="
|
||||
culprits=()
|
||||
for f in "${FILES[@]}"; do
|
||||
# Start from all-source, add just this one file as bytecode
|
||||
for g in "${FILES[@]}"; do rm -f "$SXBC_DIR/$g.sxbc"; done
|
||||
cp "$BACKUP_DIR/$f.sxbc" "$SXBC_DIR/$f.sxbc"
|
||||
|
||||
if test_passes; then
|
||||
printf " %-20s bytecode OK\n" "$f"
|
||||
else
|
||||
printf " %-20s *** BREAKS ***\n" "$f"
|
||||
culprits+=("$f")
|
||||
fi
|
||||
done
|
||||
|
||||
# Restore
|
||||
restore_all
|
||||
|
||||
echo ""
|
||||
if [ ${#culprits[@]} -eq 0 ]; then
|
||||
echo "No single file causes the failure — it's a combination."
|
||||
echo "Run with groups to narrow down."
|
||||
else
|
||||
echo "=== CULPRIT FILE(S): ${culprits[*]} ==="
|
||||
echo "These .sxbc files individually cause the reactive rendering to break."
|
||||
fi
|
||||
38
hosts/ocaml/browser/build-all.sh
Executable file
38
hosts/ocaml/browser/build-all.sh
Executable file
@@ -0,0 +1,38 @@
|
||||
#!/bin/bash
|
||||
# Full build: OCaml WASM kernel + bundle + bytecode compile + deploy to shared/static/wasm/
|
||||
#
|
||||
# Usage: bash hosts/ocaml/browser/build-all.sh
|
||||
# Or via MCP: sx_build target="wasm"
|
||||
set -e
|
||||
cd "$(dirname "$0")"
|
||||
|
||||
echo "=== 1. Build WASM kernel ==="
|
||||
# Remove assets dir that conflicts with dune's output target
|
||||
rm -rf sx_browser.bc.wasm.assets
|
||||
eval $(opam env 2>/dev/null)
|
||||
cd ..
|
||||
dune build browser/sx_browser.bc.wasm.js browser/sx_browser.bc.js bin/sx_server.exe 2>&1
|
||||
cd browser
|
||||
|
||||
echo "=== 2. Bundle ==="
|
||||
bash bundle.sh
|
||||
|
||||
echo "=== 3. Compile .sxbc bytecode ==="
|
||||
node compile-modules.js dist
|
||||
|
||||
echo "=== 4. Deploy to shared/static/wasm/ ==="
|
||||
DEST=../../../shared/static/wasm
|
||||
cp dist/sx_browser.bc.wasm.js "$DEST/"
|
||||
cp dist/sx_browser.bc.js "$DEST/"
|
||||
rm -rf "$DEST/sx_browser.bc.wasm.assets"
|
||||
cp -r dist/sx_browser.bc.wasm.assets "$DEST/"
|
||||
cp dist/sx-platform.js "$DEST/sx-platform.js"
|
||||
cp dist/sx/*.sx "$DEST/sx/"
|
||||
cp dist/sx/*.sxbc "$DEST/sx/" 2>/dev/null || true
|
||||
# Keep assets dir for Node.js WASM tests
|
||||
cp -r dist/sx_browser.bc.wasm.assets ./ 2>/dev/null || true
|
||||
|
||||
echo "=== 5. Run WASM tests ==="
|
||||
node test_wasm_native.js
|
||||
|
||||
echo "=== Done ==="
|
||||
87
hosts/ocaml/browser/bundle.sh
Executable file
87
hosts/ocaml/browser/bundle.sh
Executable file
@@ -0,0 +1,87 @@
|
||||
#!/bin/bash
|
||||
# Bundle the WASM SX kernel + platform + .sx files for serving.
|
||||
#
|
||||
# Output goes to hosts/ocaml/browser/dist/
|
||||
# Serve dist/ at /wasm/ or similar path.
|
||||
|
||||
set -e
|
||||
cd "$(dirname "$0")"
|
||||
|
||||
BUILD=../_build/default/browser
|
||||
DIST=dist
|
||||
ROOT=../../..
|
||||
|
||||
echo "=== Bundling SX WASM browser engine ==="
|
||||
|
||||
rm -rf "$DIST"
|
||||
mkdir -p "$DIST/sx"
|
||||
|
||||
# 1. WASM kernel
|
||||
cp "$BUILD/sx_browser.bc.wasm.js" "$DIST/"
|
||||
cp -r "$BUILD/sx_browser.bc.wasm.assets" "$DIST/"
|
||||
|
||||
# Also copy js_of_ocaml version as fallback
|
||||
cp "$BUILD/sx_browser.bc.js" "$DIST/"
|
||||
|
||||
# 2. Platform JS
|
||||
cp sx-platform.js "$DIST/"
|
||||
|
||||
# 3. Spec modules
|
||||
cp "$ROOT/spec/signals.sx" "$DIST/sx/core-signals.sx"
|
||||
cp "$ROOT/spec/render.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/web-signals.sx" "$DIST/sx/signals.sx"
|
||||
cp "$ROOT/web/deps.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/router.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/page-helpers.sx" "$DIST/sx/"
|
||||
|
||||
# 3b. Freeze scope (signal persistence) + highlight (syntax coloring)
|
||||
cp "$ROOT/lib/freeze.sx" "$DIST/sx/"
|
||||
cp "$ROOT/lib/highlight.sx" "$DIST/sx/"
|
||||
|
||||
# 4. Bytecode compiler + VM
|
||||
cp "$ROOT/lib/bytecode.sx" "$DIST/sx/"
|
||||
cp "$ROOT/lib/compiler.sx" "$DIST/sx/"
|
||||
cp "$ROOT/lib/vm.sx" "$DIST/sx/"
|
||||
|
||||
# 5. Web libraries (8 FFI primitives)
|
||||
cp "$ROOT/web/lib/dom.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/lib/browser.sx" "$DIST/sx/"
|
||||
|
||||
# 6. Web adapters
|
||||
cp "$ROOT/web/adapter-html.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/adapter-sx.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/adapter-dom.sx" "$DIST/sx/"
|
||||
|
||||
# 7. Boot helpers (platform functions in pure SX)
|
||||
cp "$ROOT/web/lib/boot-helpers.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/lib/hypersx.sx" "$DIST/sx/"
|
||||
|
||||
# 7b. Test harness (for inline test runners)
|
||||
cp "$ROOT/spec/harness.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/harness-reactive.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/harness-web.sx" "$DIST/sx/"
|
||||
|
||||
# 8. Web framework
|
||||
cp "$ROOT/web/engine.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/orchestration.sx" "$DIST/sx/"
|
||||
cp "$ROOT/web/boot.sx" "$DIST/sx/"
|
||||
|
||||
# 9. Styling (tw token engine)
|
||||
cp "$ROOT/shared/sx/templates/tw-layout.sx" "$DIST/sx/"
|
||||
cp "$ROOT/shared/sx/templates/tw-type.sx" "$DIST/sx/"
|
||||
cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/"
|
||||
|
||||
# Summary
|
||||
WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1)
|
||||
JS_SIZE=$(du -sh "$DIST/sx_browser.bc.js" | cut -f1)
|
||||
SX_SIZE=$(du -sh "$DIST/sx" | cut -f1)
|
||||
echo " WASM kernel: $WASM_SIZE (assets)"
|
||||
echo " JS fallback: $JS_SIZE"
|
||||
echo " SX sources: $SX_SIZE ($(ls "$DIST/sx/" | wc -l) files)"
|
||||
echo " Platform JS: $(du -sh "$DIST/sx-platform.js" | cut -f1)"
|
||||
echo ""
|
||||
echo " dist/ ready to serve"
|
||||
echo ""
|
||||
echo " HTML usage:"
|
||||
echo ' <script src="/wasm/sx_browser.bc.wasm.js"></script>'
|
||||
echo ' <script src="/wasm/sx-platform.js"></script>'
|
||||
396
hosts/ocaml/browser/compile-modules.js
Normal file
396
hosts/ocaml/browser/compile-modules.js
Normal file
@@ -0,0 +1,396 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* compile-modules.js — Pre-compile .sx files to bytecode s-expressions.
|
||||
*
|
||||
* Uses the native OCaml sx_server binary for compilation (~5x faster than
|
||||
* the js_of_ocaml kernel). Sends source via the blob protocol, receives
|
||||
* compiled bytecode as SX text.
|
||||
*
|
||||
* Usage: node compile-modules.js [dist-dir]
|
||||
*/
|
||||
|
||||
const fs = require('fs');
|
||||
const path = require('path');
|
||||
const crypto = require('crypto');
|
||||
const { execSync, spawnSync } = require('child_process');
|
||||
|
||||
const distDir = process.argv[2] || path.join(__dirname, 'dist');
|
||||
const sxDir = path.join(distDir, 'sx');
|
||||
const projectRoot = path.resolve(__dirname, '..', '..', '..');
|
||||
|
||||
if (!fs.existsSync(sxDir)) {
|
||||
console.error('sx dir not found:', sxDir);
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Sync source .sx files to dist/sx/ before compiling.
|
||||
// Source locations: spec/ for core, lib/ for compiler/vm, web/ and web/lib/ for web stack.
|
||||
const SOURCE_MAP = {
|
||||
// spec/
|
||||
'render.sx': 'spec/render.sx',
|
||||
'core-signals.sx': 'spec/signals.sx',
|
||||
// lib/
|
||||
'bytecode.sx': 'lib/bytecode.sx', 'compiler.sx': 'lib/compiler.sx',
|
||||
'vm.sx': 'lib/vm.sx', 'freeze.sx': 'lib/freeze.sx',
|
||||
'highlight.sx': 'lib/highlight.sx',
|
||||
// web/lib/
|
||||
'dom.sx': 'web/lib/dom.sx', 'browser.sx': 'web/lib/browser.sx',
|
||||
// web/
|
||||
'signals.sx': 'web/signals.sx', 'deps.sx': 'web/deps.sx',
|
||||
'router.sx': 'web/router.sx', 'page-helpers.sx': 'web/page-helpers.sx',
|
||||
'adapter-html.sx': 'web/adapter-html.sx', 'adapter-sx.sx': 'web/adapter-sx.sx',
|
||||
'adapter-dom.sx': 'web/adapter-dom.sx',
|
||||
'boot-helpers.sx': 'web/lib/boot-helpers.sx',
|
||||
'hypersx.sx': 'web/hypersx.sx',
|
||||
'harness.sx': 'spec/harness.sx', 'harness-reactive.sx': 'web/harness-reactive.sx',
|
||||
'harness-web.sx': 'web/harness-web.sx',
|
||||
'engine.sx': 'web/engine.sx', 'orchestration.sx': 'web/orchestration.sx',
|
||||
'boot.sx': 'web/boot.sx',
|
||||
'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
|
||||
};
|
||||
let synced = 0;
|
||||
for (const [dist, src] of Object.entries(SOURCE_MAP)) {
|
||||
const srcPath = path.join(projectRoot, src);
|
||||
const dstPath = path.join(sxDir, dist);
|
||||
if (fs.existsSync(srcPath)) {
|
||||
const srcContent = fs.readFileSync(srcPath);
|
||||
const dstExists = fs.existsSync(dstPath);
|
||||
if (!dstExists || !fs.readFileSync(dstPath).equals(srcContent)) {
|
||||
fs.writeFileSync(dstPath, srcContent);
|
||||
synced++;
|
||||
}
|
||||
}
|
||||
}
|
||||
if (synced > 0) console.log('Synced ' + synced + ' source files to dist/sx/');
|
||||
|
||||
// Find the native OCaml binary
|
||||
const binPaths = [
|
||||
path.join(__dirname, '..', '_build', 'default', 'bin', 'sx_server.exe'),
|
||||
'/app/bin/sx_server',
|
||||
];
|
||||
const binPath = binPaths.find(p => fs.existsSync(p));
|
||||
if (!binPath) {
|
||||
console.error('sx_server binary not found at:', binPaths.join(', '));
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
const FILES = [
|
||||
'render.sx', 'core-signals.sx', 'signals.sx', 'deps.sx', 'router.sx',
|
||||
'page-helpers.sx', 'freeze.sx', 'bytecode.sx', 'compiler.sx', 'vm.sx',
|
||||
'dom.sx', 'browser.sx', 'adapter-html.sx', 'adapter-sx.sx', 'adapter-dom.sx',
|
||||
'tw-layout.sx', 'tw-type.sx', 'tw.sx',
|
||||
'boot-helpers.sx', 'hypersx.sx', 'harness.sx', 'harness-reactive.sx',
|
||||
'harness-web.sx', 'engine.sx', 'orchestration.sx', 'boot.sx',
|
||||
];
|
||||
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Build the full input script — all commands in one batch
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
const t0 = Date.now();
|
||||
console.log('Building compilation script...');
|
||||
|
||||
let epoch = 1;
|
||||
let script = '';
|
||||
|
||||
// Load compiler
|
||||
script += `(epoch ${epoch++})\n(load "lib/compiler.sx")\n`;
|
||||
|
||||
// JIT pre-compile the compiler (skipped: vm-compile-adapter hangs with
|
||||
// define-library wrappers in some lambda JIT paths. Compilation still
|
||||
// works via CEK — just ~2x slower per file.)
|
||||
// script += `(epoch ${epoch++})\n(vm-compile-adapter)\n`;
|
||||
|
||||
// Load all modules into env
|
||||
for (const file of FILES) {
|
||||
const src = fs.readFileSync(path.join(sxDir, file), 'utf8');
|
||||
const buf = Buffer.from(src, 'utf8');
|
||||
script += `(epoch ${epoch++})\n(eval-blob)\n(blob ${buf.length})\n`;
|
||||
script += src + '\n';
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Strip define-library wrapper for bytecode compilation.
|
||||
//
|
||||
// Keeps (import ...) forms — the compiler emits OP_PERFORM for these, enabling
|
||||
// lazy loading: when the VM hits an import for an unloaded library, it suspends
|
||||
// to the JS platform which fetches the library on demand.
|
||||
//
|
||||
// Strips define-library header (name, export) and (begin ...) wrapper, leaving
|
||||
// the body defines + import instructions as top-level forms.
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
function stripLibraryWrapper(source) {
|
||||
// Line-based stripping: unwrap (define-library ... (begin BODY)), keep (import ...).
|
||||
const lines = source.split('\n');
|
||||
const result = [];
|
||||
let skip = false; // inside header region (define-library, export)
|
||||
|
||||
for (let i = 0; i < lines.length; i++) {
|
||||
const line = lines[i];
|
||||
const trimmed = line.trim();
|
||||
|
||||
// Skip (define-library ...) header lines until (begin
|
||||
if (trimmed.startsWith('(define-library ')) { skip = true; continue; }
|
||||
if (skip && trimmed.startsWith('(export')) { continue; }
|
||||
if (skip && trimmed.match(/^\(begin/)) { skip = false; continue; }
|
||||
if (skip) continue;
|
||||
|
||||
// Skip closing )) of define-library — line is just ) or )) optionally with comments
|
||||
if (trimmed.match(/^\)+(\s*;.*)?$/)) {
|
||||
// Check if this is the end-of-define-library closer (only `)` chars + optional comment)
|
||||
// vs a regular body closer like ` )` inside a nested form
|
||||
// Only skip if at column 0 (not indented = top-level closer)
|
||||
if (line.match(/^\)/)) continue;
|
||||
}
|
||||
|
||||
// Skip standalone comments that are just structural markers
|
||||
if (trimmed.match(/^;;\s*(end define-library|Re-export)/)) continue;
|
||||
|
||||
result.push(line);
|
||||
}
|
||||
|
||||
return result.join('\n');
|
||||
}
|
||||
|
||||
// Compile each module (stripped of define-library/import wrappers)
|
||||
const compileEpochs = {};
|
||||
for (const file of FILES) {
|
||||
const rawSrc = fs.readFileSync(path.join(sxDir, file), 'utf8');
|
||||
const src = stripLibraryWrapper(rawSrc);
|
||||
const buf = Buffer.from(src, 'utf8');
|
||||
const ep = epoch++;
|
||||
compileEpochs[ep] = file;
|
||||
script += `(epoch ${ep})\n(compile-blob)\n(blob ${buf.length})\n`;
|
||||
script += src + '\n';
|
||||
}
|
||||
|
||||
// Write script to temp file and pipe to server
|
||||
const tmpFile = '/tmp/sx-compile-script.txt';
|
||||
fs.writeFileSync(tmpFile, script);
|
||||
|
||||
console.log('Running native OCaml compiler (' + FILES.length + ' files)...');
|
||||
const t1 = Date.now();
|
||||
|
||||
const result = spawnSync(binPath, [], {
|
||||
input: fs.readFileSync(tmpFile),
|
||||
maxBuffer: 100 * 1024 * 1024, // 100MB
|
||||
timeout: 600000, // 10 min
|
||||
stdio: ['pipe', 'pipe', 'pipe'],
|
||||
});
|
||||
|
||||
if (result.error) {
|
||||
console.error('Server error:', result.error);
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
const stderr = result.stderr.toString();
|
||||
process.stderr.write(stderr);
|
||||
|
||||
// Use latin1 to preserve byte positions (UTF-8 multi-byte chars stay as-is in length)
|
||||
const stdoutBuf = result.stdout;
|
||||
const stdout = stdoutBuf.toString('latin1');
|
||||
const dt = Date.now() - t1;
|
||||
console.log('Server finished in ' + Math.round(dt / 1000) + 's');
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Parse responses — extract compiled bytecode for each file
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
// Parse responses — stdout is latin1 so byte positions match string positions
|
||||
let compiled = 0, skipped = 0;
|
||||
let pos = 0;
|
||||
|
||||
function nextLine() {
|
||||
const nl = stdout.indexOf('\n', pos);
|
||||
if (nl === -1) return null;
|
||||
const line = stdout.slice(pos, nl);
|
||||
pos = nl + 1;
|
||||
return line;
|
||||
}
|
||||
|
||||
while (pos < stdout.length) {
|
||||
const line = nextLine();
|
||||
if (line === null) break;
|
||||
const trimmed = line.trim();
|
||||
|
||||
// ok-len EPOCH LEN — read LEN bytes as value
|
||||
const lenMatch = trimmed.match(/^\(ok-len (\d+) (\d+)\)$/);
|
||||
if (lenMatch) {
|
||||
const ep = parseInt(lenMatch[1]);
|
||||
const len = parseInt(lenMatch[2]);
|
||||
// Read exactly len bytes — latin1 encoding preserves byte positions
|
||||
const rawValue = stdout.slice(pos, pos + len);
|
||||
// Re-encode to proper UTF-8
|
||||
const value = Buffer.from(rawValue, 'latin1').toString('utf8');
|
||||
pos += len;
|
||||
// skip trailing newline
|
||||
if (pos < stdout.length && stdout.charCodeAt(pos) === 10) pos++;
|
||||
|
||||
const file = compileEpochs[ep];
|
||||
if (file) {
|
||||
if (value === 'nil' || value.startsWith('(error')) {
|
||||
console.error(' SKIP', file, '—', value.slice(0, 60));
|
||||
skipped++;
|
||||
} else {
|
||||
const hash = crypto.createHash('sha256')
|
||||
.update(fs.readFileSync(path.join(sxDir, file), 'utf8'))
|
||||
.digest('hex').slice(0, 16);
|
||||
|
||||
const sxbc = '(sxbc 1 "' + hash + '"\n (code\n ' +
|
||||
value.replace(/^\{/, '').replace(/\}$/, '').trim() + '))\n';
|
||||
|
||||
const outPath = path.join(sxDir, file.replace(/\.sx$/, '.sxbc'));
|
||||
fs.writeFileSync(outPath, sxbc);
|
||||
|
||||
const size = fs.statSync(outPath).size;
|
||||
console.log(' ok', file, '→', Math.round(size / 1024) + 'K');
|
||||
compiled++;
|
||||
}
|
||||
}
|
||||
continue;
|
||||
}
|
||||
|
||||
// Simple ok or error — skip
|
||||
if (trimmed.match(/^\(ok \d+/) || trimmed.match(/^\(error \d+/)) {
|
||||
if (trimmed.match(/^\(error/)) {
|
||||
const epMatch = trimmed.match(/^\(error (\d+)/);
|
||||
if (epMatch) {
|
||||
const ep = parseInt(epMatch[1]);
|
||||
const file = compileEpochs[ep];
|
||||
if (file) {
|
||||
console.error(' SKIP', file, '—', trimmed.slice(0, 80));
|
||||
skipped++;
|
||||
}
|
||||
}
|
||||
}
|
||||
continue;
|
||||
}
|
||||
}
|
||||
|
||||
// Copy compiled files to shared/static/wasm/sx/ for web serving
|
||||
const staticSxDir = path.resolve(__dirname, '..', '..', '..', 'shared', 'static', 'wasm', 'sx');
|
||||
if (fs.existsSync(staticSxDir)) {
|
||||
let copied = 0;
|
||||
for (const file of FILES) {
|
||||
// Copy bytecode
|
||||
for (const ext of ['.sxbc', '.sxbc.json']) {
|
||||
const src = path.join(sxDir, file.replace(/\.sx$/, ext));
|
||||
const dst = path.join(staticSxDir, file.replace(/\.sx$/, ext));
|
||||
if (fs.existsSync(src)) {
|
||||
fs.copyFileSync(src, dst);
|
||||
copied++;
|
||||
}
|
||||
}
|
||||
// Also sync .sx source files (fallback when .sxbc missing)
|
||||
const sxSrc = path.join(sxDir, file);
|
||||
const sxDst = path.join(staticSxDir, file);
|
||||
if (fs.existsSync(sxSrc) && !fs.lstatSync(sxSrc).isSymbolicLink()) {
|
||||
fs.copyFileSync(sxSrc, sxDst);
|
||||
copied++;
|
||||
}
|
||||
}
|
||||
console.log('Copied', copied, 'files to', staticSxDir);
|
||||
}
|
||||
|
||||
// ---------------------------------------------------------------------------
|
||||
// Generate module-manifest.json — dependency graph for lazy loading
|
||||
// ---------------------------------------------------------------------------
|
||||
|
||||
console.log('Generating module manifest...');
|
||||
|
||||
// Extract library name from (define-library (namespace name) ...) in source
|
||||
function extractLibraryName(source) {
|
||||
const m = source.match(/\(define-library\s+(\([^)]+\))/);
|
||||
return m ? m[1] : null;
|
||||
}
|
||||
|
||||
// Extract top-level (import (namespace name)) deps from source
|
||||
// Only matches imports BEFORE define-library (dependency declarations)
|
||||
function extractImportDeps(source) {
|
||||
const deps = [];
|
||||
const lines = source.split('\n');
|
||||
for (const line of lines) {
|
||||
// Stop at define-library — imports after that are self-imports
|
||||
if (line.startsWith('(define-library')) break;
|
||||
const m = line.match(/^\(import\s+(\([^)]+\))\)/);
|
||||
if (m) deps.push(m[1]);
|
||||
}
|
||||
return deps;
|
||||
}
|
||||
|
||||
// Extract exported symbol names from (export name1 name2 ...) clause
|
||||
function extractExports(source) {
|
||||
const exports = [];
|
||||
const m = source.match(/\(export\s+([\s\S]*?)\)\s*\(/);
|
||||
if (!m) return exports;
|
||||
// Parse symbol names from the export list (skip keywords, nested forms)
|
||||
const tokens = m[1].split(/\s+/).filter(t => t && !t.startsWith(':') && !t.startsWith('(') && !t.startsWith(')'));
|
||||
for (const t of tokens) {
|
||||
const clean = t.replace(/[()]/g, '');
|
||||
if (clean && !clean.startsWith(':')) exports.push(clean);
|
||||
}
|
||||
return exports;
|
||||
}
|
||||
|
||||
// Flatten library spec: "(sx dom)" → "sx dom"
|
||||
function libKey(spec) {
|
||||
return spec.replace(/^\(/, '').replace(/\)$/, '');
|
||||
}
|
||||
|
||||
const manifest = {};
|
||||
let entryFile = null;
|
||||
|
||||
for (const file of FILES) {
|
||||
const srcPath = path.join(sxDir, file);
|
||||
if (!fs.existsSync(srcPath)) continue;
|
||||
const src = fs.readFileSync(srcPath, 'utf8');
|
||||
const libName = extractLibraryName(src);
|
||||
const deps = extractImportDeps(src);
|
||||
const sxbcFile = file.replace(/\.sx$/, '.sxbc');
|
||||
|
||||
if (libName) {
|
||||
const exports = extractExports(src);
|
||||
manifest[libKey(libName)] = {
|
||||
file: sxbcFile,
|
||||
deps: deps.map(libKey),
|
||||
exports: exports,
|
||||
};
|
||||
} else if (deps.length > 0) {
|
||||
// Entry point (no define-library, has imports)
|
||||
entryFile = { file: sxbcFile, deps: deps.map(libKey) };
|
||||
}
|
||||
}
|
||||
|
||||
if (entryFile) {
|
||||
// Partition entry deps into eager (needed at boot) and lazy (loaded on demand).
|
||||
// Lazy deps are fetched by the suspension handler when the kernel requests them.
|
||||
const LAZY_ENTRY_DEPS = new Set([
|
||||
'sx bytecode', // JIT-only — enable-jit! runs after boot
|
||||
]);
|
||||
const eagerDeps = entryFile.deps.filter(d => !LAZY_ENTRY_DEPS.has(d));
|
||||
const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d));
|
||||
manifest['_entry'] = {
|
||||
file: entryFile.file,
|
||||
deps: eagerDeps,
|
||||
};
|
||||
if (lazyDeps.length > 0) {
|
||||
manifest['_entry'].lazy_deps = lazyDeps;
|
||||
}
|
||||
}
|
||||
|
||||
const manifestPath = path.join(sxDir, 'module-manifest.json');
|
||||
fs.writeFileSync(manifestPath, JSON.stringify(manifest, null, 2) + '\n');
|
||||
console.log(' Wrote', manifestPath, '(' + Object.keys(manifest).length + ' modules)');
|
||||
|
||||
// Copy manifest to static dir
|
||||
if (fs.existsSync(staticSxDir)) {
|
||||
fs.copyFileSync(manifestPath, path.join(staticSxDir, 'module-manifest.json'));
|
||||
console.log(' Copied manifest to', staticSxDir);
|
||||
}
|
||||
|
||||
const total = Date.now() - t0;
|
||||
console.log('Done:', compiled, 'compiled,', skipped, 'skipped in', Math.round(total / 1000) + 's');
|
||||
|
||||
fs.unlinkSync(tmpFile);
|
||||
5
hosts/ocaml/browser/dune
Normal file
5
hosts/ocaml/browser/dune
Normal file
@@ -0,0 +1,5 @@
|
||||
(executable
|
||||
(name sx_browser)
|
||||
(libraries sx js_of_ocaml)
|
||||
(modes byte js wasm)
|
||||
(preprocess (pps js_of_ocaml-ppx)))
|
||||
697
hosts/ocaml/browser/sx-platform.js
Normal file
697
hosts/ocaml/browser/sx-platform.js
Normal file
@@ -0,0 +1,697 @@
|
||||
/**
|
||||
* sx-platform.js — Browser platform layer for the SX WASM kernel.
|
||||
*
|
||||
* Registers the 8 FFI host primitives and loads web adapter .sx files.
|
||||
* This is the only JS needed beyond the WASM kernel itself.
|
||||
*
|
||||
* Usage:
|
||||
* <script src="sx_browser.bc.wasm.js"></script>
|
||||
* <script src="sx-platform.js"></script>
|
||||
*
|
||||
* Or for js_of_ocaml mode:
|
||||
* <script src="sx_browser.bc.js"></script>
|
||||
* <script src="sx-platform.js"></script>
|
||||
*/
|
||||
|
||||
(function() {
|
||||
"use strict";
|
||||
|
||||
function boot(K) {
|
||||
|
||||
// ================================================================
|
||||
// FFI Host Primitives
|
||||
// ================================================================
|
||||
|
||||
// Lazy module loading — islands/components call this to declare dependencies
|
||||
K.registerNative("load-library!", function(args) {
|
||||
var name = args[0];
|
||||
if (!name) return false;
|
||||
return __sxLoadLibrary(name) || false;
|
||||
});
|
||||
|
||||
K.registerNative("host-global", function(args) {
|
||||
var name = args[0];
|
||||
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
|
||||
if (typeof window !== "undefined" && name in window) return window[name];
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("host-get", function(args) {
|
||||
var obj = args[0], prop = args[1];
|
||||
if (obj == null) return null;
|
||||
var v = obj[prop];
|
||||
return v === undefined ? null : v;
|
||||
});
|
||||
|
||||
K.registerNative("host-set!", function(args) {
|
||||
var obj = args[0], prop = args[1], val = args[2];
|
||||
if (obj != null) obj[prop] = val;
|
||||
});
|
||||
|
||||
K.registerNative("host-call", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = [];
|
||||
for (var i = 2; i < args.length; i++) callArgs.push(args[i]);
|
||||
if (obj == null) {
|
||||
// Global function call
|
||||
var fn = typeof globalThis !== "undefined" ? globalThis[method] : window[method];
|
||||
if (typeof fn === "function") return fn.apply(null, callArgs);
|
||||
return null;
|
||||
}
|
||||
if (typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, callArgs); }
|
||||
catch(e) { console.error("[sx] host-call error:", e); return null; }
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("host-new", function(args) {
|
||||
var name = args[0];
|
||||
var cArgs = args.slice(1);
|
||||
var Ctor = typeof globalThis !== "undefined" ? globalThis[name] : window[name];
|
||||
if (typeof Ctor !== "function") return null;
|
||||
switch (cArgs.length) {
|
||||
case 0: return new Ctor();
|
||||
case 1: return new Ctor(cArgs[0]);
|
||||
case 2: return new Ctor(cArgs[0], cArgs[1]);
|
||||
case 3: return new Ctor(cArgs[0], cArgs[1], cArgs[2]);
|
||||
default: return new Ctor(cArgs[0], cArgs[1], cArgs[2], cArgs[3]);
|
||||
}
|
||||
});
|
||||
|
||||
K.registerNative("host-callback", function(args) {
|
||||
var fn = args[0];
|
||||
// Native JS function — pass through
|
||||
if (typeof fn === "function") return fn;
|
||||
// SX callable (has __sx_handle) — wrap as JS function
|
||||
if (fn && fn.__sx_handle !== undefined) {
|
||||
return function() {
|
||||
var a = Array.prototype.slice.call(arguments);
|
||||
return K.callFn(fn, a);
|
||||
};
|
||||
}
|
||||
return function() {};
|
||||
});
|
||||
|
||||
K.registerNative("host-typeof", function(args) {
|
||||
var obj = args[0];
|
||||
if (obj == null) return "nil";
|
||||
if (obj instanceof Element) return "element";
|
||||
if (obj instanceof Text) return "text";
|
||||
if (obj instanceof DocumentFragment) return "fragment";
|
||||
if (obj instanceof Document) return "document";
|
||||
if (obj instanceof Event) return "event";
|
||||
if (obj instanceof Promise) return "promise";
|
||||
if (obj instanceof AbortController) return "abort-controller";
|
||||
return typeof obj;
|
||||
});
|
||||
|
||||
K.registerNative("host-await", function(args) {
|
||||
var promise = args[0], callback = args[1];
|
||||
if (promise && typeof promise.then === "function") {
|
||||
var cb;
|
||||
if (typeof callback === "function") cb = callback;
|
||||
else if (callback && callback.__sx_handle !== undefined)
|
||||
cb = function(v) { return K.callFn(callback, [v]); };
|
||||
else cb = function() {};
|
||||
promise.then(cb);
|
||||
}
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// Constants expected by .sx files
|
||||
// ================================================================
|
||||
|
||||
K.eval('(define SX_VERSION "wasm-1.0")');
|
||||
K.eval('(define SX_ENGINE "ocaml-vm-wasm")');
|
||||
K.eval('(define parse sx-parse)');
|
||||
K.eval('(define serialize sx-serialize)');
|
||||
|
||||
// ================================================================
|
||||
// DOM query helpers used by boot.sx / orchestration.sx
|
||||
// (These are JS-native in the transpiled bundle; here via FFI.)
|
||||
// ================================================================
|
||||
|
||||
K.registerNative("query-sx-scripts", function(args) {
|
||||
var root = (args[0] && args[0] !== null) ? args[0] : document;
|
||||
if (typeof root.querySelectorAll !== "function") root = document;
|
||||
return Array.prototype.slice.call(root.querySelectorAll('script[type="text/sx"]'));
|
||||
});
|
||||
|
||||
K.registerNative("query-page-scripts", function(args) {
|
||||
return Array.prototype.slice.call(document.querySelectorAll('script[type="text/sx-pages"]'));
|
||||
});
|
||||
|
||||
K.registerNative("query-component-scripts", function(args) {
|
||||
var root = (args[0] && args[0] !== null) ? args[0] : document;
|
||||
if (typeof root.querySelectorAll !== "function") root = document;
|
||||
return Array.prototype.slice.call(root.querySelectorAll('script[type="text/sx"][data-components]'));
|
||||
});
|
||||
|
||||
// localStorage
|
||||
K.registerNative("local-storage-get", function(args) {
|
||||
try { var v = localStorage.getItem(args[0]); return v === null ? null : v; }
|
||||
catch(e) { return null; }
|
||||
});
|
||||
K.registerNative("local-storage-set", function(args) {
|
||||
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
|
||||
});
|
||||
K.registerNative("local-storage-remove", function(args) {
|
||||
try { localStorage.removeItem(args[0]); } catch(e) {}
|
||||
});
|
||||
|
||||
// log-info/log-warn defined in browser.sx; log-error as native fallback
|
||||
K.registerNative("log-error", function(args) { console.error.apply(console, ["[sx]"].concat(args)); });
|
||||
|
||||
// Cookie access (browser-side)
|
||||
K.registerNative("get-cookie", function(args) {
|
||||
var name = args[0];
|
||||
var match = document.cookie.match(new RegExp('(?:^|; )' + name.replace(/[.*+?^${}()|[\]\\]/g, '\\$&') + '=([^;]*)'));
|
||||
return match ? decodeURIComponent(match[1]) : null;
|
||||
});
|
||||
K.registerNative("set-cookie", function(args) {
|
||||
document.cookie = args[0] + "=" + encodeURIComponent(args[1] || "") + ";path=/;max-age=31536000;SameSite=Lax";
|
||||
});
|
||||
|
||||
// IntersectionObserver — native JS to avoid bytecode callback issues
|
||||
K.registerNative("observe-intersection", function(args) {
|
||||
var el = args[0], callback = args[1], once = args[2], delay = args[3];
|
||||
var obs = new IntersectionObserver(function(entries) {
|
||||
for (var i = 0; i < entries.length; i++) {
|
||||
if (entries[i].isIntersecting) {
|
||||
var d = (delay && delay !== null) ? delay : 0;
|
||||
setTimeout(function() { K.callFn(callback, []); }, d);
|
||||
if (once) obs.unobserve(el);
|
||||
}
|
||||
}
|
||||
});
|
||||
obs.observe(el);
|
||||
return obs;
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// Load SX web libraries and adapters
|
||||
// ================================================================
|
||||
|
||||
// Load order follows dependency graph:
|
||||
// 1. Core spec files (parser, render, primitives already compiled into WASM kernel)
|
||||
// 2. Spec modules: signals, deps, router, page-helpers
|
||||
// 3. Bytecode compiler + VM (for JIT in browser)
|
||||
// 4. Web libraries: dom.sx, browser.sx (built on 8 FFI primitives)
|
||||
// 5. Web adapters: adapter-html, adapter-sx, adapter-dom
|
||||
// 6. Web framework: engine, orchestration, boot
|
||||
|
||||
var _baseUrl = "";
|
||||
|
||||
// Detect base URL and cache-bust params from current script tag.
|
||||
// _cacheBust comes from the script's own ?v= query string (used for .sx source fallback).
|
||||
// _sxbcCacheBust comes from data-sxbc-hash attribute — a separate content hash
|
||||
// covering all .sxbc files so each file gets its own correct cache buster.
|
||||
var _cacheBust = "";
|
||||
var _sxbcCacheBust = "";
|
||||
(function() {
|
||||
if (typeof document !== "undefined") {
|
||||
var scripts = document.getElementsByTagName("script");
|
||||
for (var i = scripts.length - 1; i >= 0; i--) {
|
||||
var src = scripts[i].src || "";
|
||||
if (src.indexOf("sx-platform") !== -1) {
|
||||
_baseUrl = src.substring(0, src.lastIndexOf("/") + 1);
|
||||
var qi = src.indexOf("?");
|
||||
if (qi !== -1) _cacheBust = src.substring(qi);
|
||||
var sxbcHash = scripts[i].getAttribute("data-sxbc-hash");
|
||||
if (sxbcHash) _sxbcCacheBust = "?v=" + sxbcHash;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
})();
|
||||
|
||||
/**
|
||||
* Deserialize type-tagged JSON constant back to JS value for loadModule.
|
||||
*/
|
||||
function deserializeConstant(c) {
|
||||
if (!c || !c.t) return null;
|
||||
switch (c.t) {
|
||||
case 's': return c.v;
|
||||
case 'n': return c.v;
|
||||
case 'b': return c.v;
|
||||
case 'nil': return null;
|
||||
case 'sym': return { _type: 'symbol', name: c.v };
|
||||
case 'kw': return { _type: 'keyword', name: c.v };
|
||||
case 'list': return { _type: 'list', items: (c.v || []).map(deserializeConstant) };
|
||||
case 'code': return {
|
||||
_type: 'dict',
|
||||
bytecode: { _type: 'list', items: c.v.bytecode },
|
||||
constants: { _type: 'list', items: (c.v.constants || []).map(deserializeConstant) },
|
||||
arity: c.v.arity || 0,
|
||||
'upvalue-count': c.v['upvalue-count'] || 0,
|
||||
locals: c.v.locals || 0,
|
||||
};
|
||||
case 'dict': {
|
||||
var d = { _type: 'dict' };
|
||||
for (var k in c.v) d[k] = deserializeConstant(c.v[k]);
|
||||
return d;
|
||||
}
|
||||
default: return null;
|
||||
}
|
||||
}
|
||||
|
||||
/**
|
||||
* Convert a parsed SX code form ({_type:"list", items:[symbol"code", ...]})
|
||||
* into the dict format that K.loadModule / js_to_value expects.
|
||||
* Mirrors the OCaml convert_code/convert_const in sx_browser.ml.
|
||||
*/
|
||||
function convertCodeForm(form) {
|
||||
if (!form || form._type !== "list" || !form.items || !form.items.length) return null;
|
||||
var items = form.items;
|
||||
if (!items[0] || items[0]._type !== "symbol" || items[0].name !== "code") return null;
|
||||
|
||||
var d = { _type: "dict", arity: 0, "upvalue-count": 0 };
|
||||
for (var i = 1; i < items.length; i++) {
|
||||
var item = items[i];
|
||||
if (item && item._type === "keyword" && i + 1 < items.length) {
|
||||
var val = items[i + 1];
|
||||
if (item.name === "arity" || item.name === "upvalue-count") {
|
||||
d[item.name] = (typeof val === "number") ? val : 0;
|
||||
} else if (item.name === "bytecode" && val && val._type === "list") {
|
||||
d.bytecode = val; // {_type:"list", items:[numbers...]}
|
||||
} else if (item.name === "constants" && val && val._type === "list") {
|
||||
d.constants = { _type: "list", items: (val.items || []).map(convertConst) };
|
||||
}
|
||||
i++; // skip value
|
||||
}
|
||||
}
|
||||
return d;
|
||||
}
|
||||
|
||||
function convertConst(c) {
|
||||
if (!c || typeof c !== "object") return c; // number, string, boolean, null pass through
|
||||
if (c._type === "list" && c.items && c.items.length > 0) {
|
||||
var head = c.items[0];
|
||||
if (head && head._type === "symbol" && head.name === "code") {
|
||||
return convertCodeForm(c);
|
||||
}
|
||||
if (head && head._type === "symbol" && head.name === "list") {
|
||||
return { _type: "list", items: c.items.slice(1).map(convertConst) };
|
||||
}
|
||||
}
|
||||
return c; // symbols, keywords, etc. pass through
|
||||
}
|
||||
|
||||
/**
|
||||
* Try loading a pre-compiled .sxbc bytecode module (SX text format).
|
||||
* Uses K.loadModule which handles VM suspension (import requests).
|
||||
* Returns true on success, null on failure (caller falls back to .sx source).
|
||||
*/
|
||||
function loadBytecodeFile(path) {
|
||||
var sxbcPath = path.replace(/\.sx$/, '.sxbc');
|
||||
var url = _baseUrl + sxbcPath + _sxbcCacheBust;
|
||||
try {
|
||||
var xhr = new XMLHttpRequest();
|
||||
xhr.open("GET", url, false);
|
||||
xhr.send();
|
||||
if (xhr.status !== 200) return null;
|
||||
|
||||
// Parse the sxbc text to get the SX tree
|
||||
var parsed = K.parse(xhr.responseText);
|
||||
if (!parsed || !parsed.length) return null;
|
||||
var sxbc = parsed[0]; // (sxbc version hash (code ...))
|
||||
if (!sxbc || sxbc._type !== "list" || !sxbc.items) return null;
|
||||
|
||||
// Extract the code form — 3rd or 4th item (after sxbc, version, optional hash)
|
||||
var codeForm = null;
|
||||
for (var i = 1; i < sxbc.items.length; i++) {
|
||||
var item = sxbc.items[i];
|
||||
if (item && item._type === "list" && item.items && item.items.length > 0 &&
|
||||
item.items[0] && item.items[0]._type === "symbol" && item.items[0].name === "code") {
|
||||
codeForm = item;
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (!codeForm) return null;
|
||||
|
||||
// Convert the SX code form to a dict for loadModule
|
||||
var moduleDict = convertCodeForm(codeForm);
|
||||
if (!moduleDict) return null;
|
||||
|
||||
// Load via K.loadModule which handles VmSuspended
|
||||
var result = K.loadModule(moduleDict);
|
||||
|
||||
// Handle import suspensions — fetch missing libraries on demand
|
||||
while (result && result.suspended && result.op === "import") {
|
||||
var req = result.request;
|
||||
var libName = req && req.library;
|
||||
if (libName) {
|
||||
// Try to find and load the library from the manifest
|
||||
var loaded = handleImportSuspension(libName);
|
||||
if (!loaded) {
|
||||
console.warn("[sx-platform] lazy import: library not found:", libName);
|
||||
}
|
||||
}
|
||||
// Resume the suspended module (null = library is now in env)
|
||||
result = result.resume(null);
|
||||
}
|
||||
|
||||
if (typeof result === 'string' && result.indexOf('Error') === 0) {
|
||||
console.warn("[sx-platform] bytecode FAIL " + path + ":", result);
|
||||
return null;
|
||||
}
|
||||
return true;
|
||||
} catch(e) {
|
||||
console.warn("[sx-platform] bytecode FAIL " + path + ":", e.message || e);
|
||||
return null;
|
||||
}
|
||||
}
|
||||
|
||||
/**
|
||||
* Handle an import suspension by finding and loading the library.
|
||||
* The library name may be an SX value (list/string) — normalize to manifest key.
|
||||
*/
|
||||
function handleImportSuspension(libSpec) {
|
||||
// libSpec from the kernel is the library name spec, e.g. {_type:"list", items:[{name:"sx"},{name:"dom"}]}
|
||||
// or a string like "sx dom"
|
||||
var key;
|
||||
if (typeof libSpec === "string") {
|
||||
key = libSpec;
|
||||
} else if (libSpec && libSpec._type === "list" && libSpec.items) {
|
||||
key = libSpec.items.map(function(item) {
|
||||
return (item && item.name) ? item.name : String(item);
|
||||
}).join(" ");
|
||||
} else if (libSpec && libSpec._type === "dict") {
|
||||
// Dict with key/name fields
|
||||
key = libSpec.key || libSpec.name || "";
|
||||
} else {
|
||||
key = String(libSpec);
|
||||
}
|
||||
|
||||
if (_loadedLibs[key]) return true; // already loaded
|
||||
|
||||
if (!_manifest) loadManifest();
|
||||
if (!_manifest || !_manifest[key]) {
|
||||
console.warn("[sx-platform] lazy import: unknown library key '" + key + "'");
|
||||
return false;
|
||||
}
|
||||
|
||||
// Load the library (and its deps) on demand
|
||||
return loadLibrary(key, {});
|
||||
}
|
||||
|
||||
/**
|
||||
* Load an .sx file synchronously via XHR (boot-time only).
|
||||
* Returns the number of expressions loaded, or an error string.
|
||||
*/
|
||||
function loadSxFile(path) {
|
||||
var url = _baseUrl + path + _cacheBust;
|
||||
try {
|
||||
var xhr = new XMLHttpRequest();
|
||||
xhr.open("GET", url, false); // synchronous
|
||||
xhr.send();
|
||||
if (xhr.status === 200) {
|
||||
var result = K.load(xhr.responseText);
|
||||
if (typeof result === "string" && result.indexOf("Error") === 0) {
|
||||
console.error("[sx-platform] FAIL " + path + ":", result);
|
||||
return 0;
|
||||
}
|
||||
console.log("[sx-platform] ok " + path + " (" + result + " exprs)");
|
||||
return result;
|
||||
} else {
|
||||
console.error("[sx] Failed to fetch " + path + ": HTTP " + xhr.status);
|
||||
return null;
|
||||
}
|
||||
} catch(e) {
|
||||
console.error("[sx] Failed to load " + path + ":", e);
|
||||
return null;
|
||||
}
|
||||
}
|
||||
|
||||
// ================================================================
|
||||
// Manifest-driven module loader — only loads what's needed
|
||||
// ================================================================
|
||||
|
||||
var _manifest = null;
|
||||
var _loadedLibs = {};
|
||||
|
||||
/**
|
||||
* Fetch and parse the module manifest (library deps + file paths).
|
||||
*/
|
||||
function loadManifest() {
|
||||
if (_manifest) return _manifest;
|
||||
try {
|
||||
var xhr = new XMLHttpRequest();
|
||||
xhr.open("GET", _baseUrl + "sx/module-manifest.json" + _cacheBust, false);
|
||||
xhr.send();
|
||||
if (xhr.status === 200) {
|
||||
_manifest = JSON.parse(xhr.responseText);
|
||||
return _manifest;
|
||||
}
|
||||
} catch(e) {}
|
||||
console.warn("[sx-platform] No manifest found, falling back to full load");
|
||||
return null;
|
||||
}
|
||||
|
||||
/**
|
||||
* Load a single library and all its dependencies (recursive).
|
||||
* Cycle-safe: tracks in-progress loads to break circular deps.
|
||||
* Functions in cyclic modules resolve symbols at call time via global env.
|
||||
*/
|
||||
function loadLibrary(name, loading) {
|
||||
if (_loadedLibs[name]) return true;
|
||||
if (loading[name]) return true; // cycle — skip
|
||||
loading[name] = true;
|
||||
|
||||
var info = _manifest[name];
|
||||
if (!info) {
|
||||
console.warn("[sx-platform] Unknown library: " + name);
|
||||
return false;
|
||||
}
|
||||
|
||||
// Resolve deps first
|
||||
for (var i = 0; i < info.deps.length; i++) {
|
||||
loadLibrary(info.deps[i], loading);
|
||||
}
|
||||
|
||||
// Mark as loaded BEFORE executing — self-imports (define-library re-exports)
|
||||
// will see it as already loaded and skip rather than infinite-looping.
|
||||
_loadedLibs[name] = true;
|
||||
|
||||
// Load this module
|
||||
var ok = loadBytecodeFile("sx/" + info.file);
|
||||
if (!ok) {
|
||||
var sxFile = info.file.replace(/\.sxbc$/, '.sx');
|
||||
ok = loadSxFile("sx/" + sxFile);
|
||||
}
|
||||
return !!ok;
|
||||
}
|
||||
|
||||
/**
|
||||
* Load web stack using the module manifest.
|
||||
* Only downloads libraries that the entry point transitively depends on.
|
||||
*/
|
||||
function loadWebStack() {
|
||||
var manifest = loadManifest();
|
||||
if (!manifest) return loadWebStackFallback();
|
||||
|
||||
var entry = manifest["_entry"];
|
||||
if (!entry) {
|
||||
console.warn("[sx-platform] No _entry in manifest, falling back");
|
||||
return loadWebStackFallback();
|
||||
}
|
||||
|
||||
var loading = {};
|
||||
var t0 = performance.now();
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
|
||||
// Load all entry point deps recursively
|
||||
for (var i = 0; i < entry.deps.length; i++) {
|
||||
loadLibrary(entry.deps[i], loading);
|
||||
}
|
||||
|
||||
// Load entry point itself (boot.sx — not a library, just defines + init)
|
||||
loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx'));
|
||||
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
var count = Object.keys(_loadedLibs).length + 1; // +1 for entry
|
||||
var dt = Math.round(performance.now() - t0);
|
||||
console.log("[sx-platform] Loaded " + count + " modules in " + dt + "ms (manifest-driven)");
|
||||
}
|
||||
|
||||
/**
|
||||
* Fallback: load all files in hardcoded order (pre-manifest compat).
|
||||
*/
|
||||
function loadWebStackFallback() {
|
||||
var files = [
|
||||
"sx/render.sx", "sx/core-signals.sx", "sx/signals.sx", "sx/deps.sx",
|
||||
"sx/router.sx", "sx/page-helpers.sx", "sx/freeze.sx", "sx/highlight.sx",
|
||||
"sx/bytecode.sx", "sx/compiler.sx", "sx/vm.sx", "sx/dom.sx", "sx/browser.sx",
|
||||
"sx/adapter-html.sx", "sx/adapter-sx.sx", "sx/adapter-dom.sx",
|
||||
"sx/boot-helpers.sx", "sx/hypersx.sx", "sx/harness.sx",
|
||||
"sx/harness-reactive.sx", "sx/harness-web.sx",
|
||||
"sx/engine.sx", "sx/orchestration.sx", "sx/boot.sx",
|
||||
];
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
for (var i = 0; i < files.length; i++) {
|
||||
if (!loadBytecodeFile(files[i])) loadSxFile(files[i]);
|
||||
}
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
console.log("[sx-platform] Loaded " + files.length + " files (fallback)");
|
||||
}
|
||||
|
||||
/**
|
||||
* Load an optional library on demand (e.g., highlight, harness).
|
||||
* Can be called after boot for pages that need extra modules.
|
||||
*/
|
||||
globalThis.__sxLoadLibrary = function(name) {
|
||||
if (!_manifest) loadManifest();
|
||||
if (!_manifest) return false;
|
||||
if (_loadedLibs[name]) return true;
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
var ok = loadLibrary(name, {});
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
return ok;
|
||||
};
|
||||
|
||||
// ================================================================
|
||||
// Transparent lazy loading — symbol → library index
|
||||
//
|
||||
// When the VM hits an undefined symbol, the resolve hook checks this
|
||||
// index, loads the library that exports it, and returns the value.
|
||||
// The programmer just calls the function — loading is invisible.
|
||||
// ================================================================
|
||||
|
||||
var _symbolIndex = null; // symbol name → library key
|
||||
|
||||
function buildSymbolIndex() {
|
||||
if (_symbolIndex) return _symbolIndex;
|
||||
if (!_manifest) loadManifest();
|
||||
if (!_manifest) return null;
|
||||
_symbolIndex = {};
|
||||
for (var key in _manifest) {
|
||||
if (key.startsWith('_')) continue;
|
||||
var entry = _manifest[key];
|
||||
if (entry.exports) {
|
||||
for (var i = 0; i < entry.exports.length; i++) {
|
||||
_symbolIndex[entry.exports[i]] = key;
|
||||
}
|
||||
}
|
||||
}
|
||||
return _symbolIndex;
|
||||
}
|
||||
|
||||
// Register the resolve hook — called by the VM when GLOBAL_GET fails
|
||||
K.registerNative("__resolve-symbol", function(args) {
|
||||
var name = args[0];
|
||||
if (!name) return null;
|
||||
var idx = buildSymbolIndex();
|
||||
if (!idx || !idx[name]) return null;
|
||||
var lib = idx[name];
|
||||
if (_loadedLibs[lib]) return null; // already loaded but symbol still missing — real error
|
||||
// Load the library
|
||||
__sxLoadLibrary(lib);
|
||||
// Return null — the VM will re-lookup in globals after the hook loads the module
|
||||
return null;
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// Compatibility shim — expose Sx global matching current JS API
|
||||
// ================================================================
|
||||
|
||||
globalThis.Sx = {
|
||||
VERSION: "wasm-1.0",
|
||||
parse: function(src) { return K.parse(src); },
|
||||
eval: function(src) { return K.eval(src); },
|
||||
load: function(src) { return K.load(src); },
|
||||
renderToHtml: function(expr) { return K.renderToHtml(expr); },
|
||||
callFn: function(fn, args) { return K.callFn(fn, args); },
|
||||
engine: function() { return K.engine(); },
|
||||
// Boot entry point (called by auto-init or manually)
|
||||
init: function() {
|
||||
if (typeof K.eval === "function") {
|
||||
// Check boot-init exists
|
||||
// Step through boot manually
|
||||
console.log("[sx] init-css-tracking...");
|
||||
K.eval("(init-css-tracking)");
|
||||
console.log("[sx] process-page-scripts...");
|
||||
K.eval("(process-page-scripts)");
|
||||
console.log("[sx] routes after pages:", K.eval("(len _page-routes)"));
|
||||
console.log("[sx] process-sx-scripts...");
|
||||
K.eval("(process-sx-scripts nil)");
|
||||
console.log("[sx] sx-hydrate-elements...");
|
||||
K.eval("(sx-hydrate-elements nil)");
|
||||
console.log("[sx] sx-hydrate-islands...");
|
||||
K.eval("(sx-hydrate-islands nil)");
|
||||
console.log("[sx] process-elements...");
|
||||
K.eval("(process-elements nil)");
|
||||
// Debug islands
|
||||
console.log("[sx] ~home/stepper defined?", K.eval("(type-of ~home/stepper)"));
|
||||
console.log("[sx] ~layouts/header defined?", K.eval("(type-of ~layouts/header)"));
|
||||
// Island count (JS-side, avoids VM overhead)
|
||||
console.log("[sx] manual island query:", document.querySelectorAll("[data-sx-island]").length);
|
||||
// Try hydrating again
|
||||
console.log("[sx] retry hydrate-islands...");
|
||||
K.eval("(sx-hydrate-islands nil)");
|
||||
// Check if links are boosted
|
||||
var links = document.querySelectorAll("a[href]");
|
||||
var boosted = 0;
|
||||
for (var i = 0; i < links.length; i++) {
|
||||
if (links[i]._sxBoundboost) boosted++;
|
||||
}
|
||||
console.log("[sx] boosted links:", boosted, "/", links.length);
|
||||
// Check island state
|
||||
var islands = document.querySelectorAll("[data-sx-island]");
|
||||
console.log("[sx] islands:", islands.length);
|
||||
for (var j = 0; j < islands.length; j++) {
|
||||
console.log("[sx] island:", islands[j].getAttribute("data-sx-island"),
|
||||
"hydrated:", !!islands[j]._sxBoundislandhydrated || !!islands[j]["_sxBound" + "island-hydrated"],
|
||||
"children:", islands[j].children.length);
|
||||
}
|
||||
// Register popstate handler for back/forward navigation
|
||||
window.addEventListener("popstate", function(e) {
|
||||
var state = e.state;
|
||||
var scrollY = (state && state.scrollY) ? state.scrollY : 0;
|
||||
K.eval("(handle-popstate " + scrollY + ")");
|
||||
});
|
||||
// Signal boot complete
|
||||
document.documentElement.setAttribute("data-sx-ready", "true");
|
||||
console.log("[sx] boot done");
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
// ================================================================
|
||||
// Auto-init: load web stack and boot on DOMContentLoaded
|
||||
// ================================================================
|
||||
|
||||
if (typeof document !== "undefined") {
|
||||
var _doInit = function() {
|
||||
loadWebStack();
|
||||
Sx.init();
|
||||
// Enable JIT after all boot code has run.
|
||||
// Lazy-load the compiler first — JIT needs it to compile functions.
|
||||
setTimeout(function() {
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
loadLibrary("sx compiler", {});
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
K.eval('(enable-jit!)');
|
||||
}, 0);
|
||||
};
|
||||
|
||||
if (document.readyState === "loading") {
|
||||
document.addEventListener("DOMContentLoaded", _doInit);
|
||||
} else {
|
||||
_doInit();
|
||||
}
|
||||
}
|
||||
|
||||
} // end boot
|
||||
|
||||
// SxKernel is available synchronously (js_of_ocaml) or after async
|
||||
// WASM init. Poll briefly to handle both cases.
|
||||
var K = globalThis.SxKernel;
|
||||
if (K) { boot(K); return; }
|
||||
var tries = 0;
|
||||
var poll = setInterval(function() {
|
||||
K = globalThis.SxKernel;
|
||||
if (K) { clearInterval(poll); boot(K); }
|
||||
else if (++tries > 100) { clearInterval(poll); console.error("[sx-platform] SxKernel not found after 5s"); }
|
||||
}, 50);
|
||||
})();
|
||||
995
hosts/ocaml/browser/sx_browser.ml
Normal file
995
hosts/ocaml/browser/sx_browser.ml
Normal file
@@ -0,0 +1,995 @@
|
||||
(** sx_browser.ml — OCaml SX kernel compiled to WASM/JS for browser use.
|
||||
|
||||
Exposes the CEK machine, bytecode VM, parser, and primitives as a
|
||||
global [SxKernel] object that the JS platform layer binds to.
|
||||
|
||||
Fresh implementation on the ocaml-vm branch — builds on the bytecode
|
||||
VM + lazy JIT infrastructure. *)
|
||||
|
||||
open Js_of_ocaml
|
||||
open Sx_types
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Opaque value handle table *)
|
||||
(* *)
|
||||
(* Non-primitive SX values (lambdas, components, signals, etc.) are *)
|
||||
(* stored here and represented on the JS side as objects with an *)
|
||||
(* __sx_handle integer key. Preserves identity across JS↔OCaml. *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let _next_handle = ref 0
|
||||
let _handle_table : (int, value) Hashtbl.t = Hashtbl.create 256
|
||||
|
||||
let alloc_handle (v : value) : int =
|
||||
let id = !_next_handle in
|
||||
incr _next_handle;
|
||||
Hashtbl.replace _handle_table id v;
|
||||
id
|
||||
|
||||
let get_handle (id : int) : value =
|
||||
match Hashtbl.find_opt _handle_table id with
|
||||
| Some v -> v
|
||||
| None -> raise (Eval_error (Printf.sprintf "Invalid SX handle: %d" id))
|
||||
|
||||
(* JS-side opaque host object table.
|
||||
Host objects (DOM elements, console, etc.) are stored here to preserve
|
||||
identity across the OCaml↔JS boundary. Represented as Dict with
|
||||
__host_handle key on the OCaml side. *)
|
||||
let _next_host_handle = ref 0
|
||||
let _alloc_host_handle = Js.Unsafe.pure_js_expr
|
||||
"(function() { var t = {}; var n = 0; return { put: function(obj) { var id = n++; t[id] = obj; return id; }, get: function(id) { return t[id]; } }; })()"
|
||||
let host_put (obj : Js.Unsafe.any) : int =
|
||||
let id = !_next_host_handle in
|
||||
incr _next_host_handle;
|
||||
ignore (Js.Unsafe.meth_call _alloc_host_handle "put" [| obj |]);
|
||||
id
|
||||
let host_get_js (id : int) : Js.Unsafe.any =
|
||||
Js.Unsafe.meth_call _alloc_host_handle "get" [| Js.Unsafe.inject id |]
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Global environment *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* Clear scope stacks at startup *)
|
||||
let () = Sx_primitives.scope_clear_all ()
|
||||
|
||||
let global_env = make_env ()
|
||||
let _sx_render_mode = ref false
|
||||
|
||||
let call_sx_fn (fn : value) (args : value list) : value =
|
||||
let result = Sx_runtime.sx_call fn args in
|
||||
!Sx_primitives._sx_trampoline_fn result
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Value conversion: OCaml <-> JS *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(** Tag a JS function with __sx_handle and _type properties. *)
|
||||
let _tag_fn = Js.Unsafe.pure_js_expr
|
||||
"(function(fn, handle, type) { fn.__sx_handle = handle; fn._type = type; return fn; })"
|
||||
|
||||
let rec value_to_js (v : value) : Js.Unsafe.any =
|
||||
match v with
|
||||
| Nil -> Js.Unsafe.inject Js.null
|
||||
| Bool b -> Js.Unsafe.inject (Js.bool b)
|
||||
| Number n -> Js.Unsafe.inject (Js.number_of_float n)
|
||||
| String s -> Js.Unsafe.inject (Js.string s)
|
||||
| RawHTML s -> Js.Unsafe.inject (Js.string s)
|
||||
| Symbol s ->
|
||||
Js.Unsafe.inject (Js.Unsafe.obj [|
|
||||
("_type", Js.Unsafe.inject (Js.string "symbol"));
|
||||
("name", Js.Unsafe.inject (Js.string s)) |])
|
||||
| Keyword k ->
|
||||
Js.Unsafe.inject (Js.Unsafe.obj [|
|
||||
("_type", Js.Unsafe.inject (Js.string "keyword"));
|
||||
("name", Js.Unsafe.inject (Js.string k)) |])
|
||||
| List items | ListRef { contents = items } ->
|
||||
let arr = items |> List.map value_to_js |> Array.of_list in
|
||||
Js.Unsafe.inject (Js.Unsafe.obj [|
|
||||
("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject (Js.array arr)) |])
|
||||
| Dict d ->
|
||||
(* Check for __host_handle — return original JS object *)
|
||||
(match Hashtbl.find_opt d "__host_handle" with
|
||||
| Some (Number n) -> host_get_js (int_of_float n)
|
||||
| _ ->
|
||||
let obj = Js.Unsafe.obj [||] in
|
||||
Js.Unsafe.set obj (Js.string "_type") (Js.string "dict");
|
||||
Hashtbl.iter (fun k v ->
|
||||
Js.Unsafe.set obj (Js.string k) (value_to_js v)) d;
|
||||
Js.Unsafe.inject obj)
|
||||
(* Callable values: wrap as JS functions with __sx_handle *)
|
||||
| Lambda _ | NativeFn _ | Continuation _ | CallccContinuation _ | VmClosure _ ->
|
||||
let handle = alloc_handle v in
|
||||
let inner = Js.wrap_callback (fun args_js ->
|
||||
try
|
||||
let arg = js_to_value args_js in
|
||||
let args = match arg with Nil -> [] | _ -> [arg] in
|
||||
let result = call_sx_fn v args in
|
||||
value_to_js result
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
|
||||
ignore (Js.Unsafe.meth_call
|
||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] " ^ msg ^ fn_info)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
| exn ->
|
||||
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
|
||||
ignore (Js.Unsafe.meth_call
|
||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] UNCAUGHT: " ^ Printexc.to_string exn ^ fn_info)) |]);
|
||||
Js.Unsafe.inject Js.null) in
|
||||
Js.Unsafe.fun_call _tag_fn [|
|
||||
Js.Unsafe.inject inner;
|
||||
Js.Unsafe.inject handle;
|
||||
Js.Unsafe.inject (Js.string (type_of v)) |]
|
||||
(* Non-callable compound: tagged object with handle *)
|
||||
| _ ->
|
||||
let handle = alloc_handle v in
|
||||
Js.Unsafe.inject (Js.Unsafe.obj [|
|
||||
("_type", Js.Unsafe.inject (Js.string (type_of v)));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |])
|
||||
|
||||
and js_to_value (js : Js.Unsafe.any) : value =
|
||||
if Js.Unsafe.equals js Js.null || Js.Unsafe.equals js Js.undefined then Nil
|
||||
else
|
||||
let ty = Js.to_string (Js.typeof js) in
|
||||
match ty with
|
||||
| "number" -> Number (Js.float_of_number (Js.Unsafe.coerce js))
|
||||
| "boolean" -> Bool (Js.to_bool (Js.Unsafe.coerce js))
|
||||
| "string" -> String (Js.to_string (Js.Unsafe.coerce js))
|
||||
| "function" ->
|
||||
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals h Js.undefined) then
|
||||
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
|
||||
else
|
||||
(* Plain JS function — wrap as NativeFn *)
|
||||
NativeFn ("js-callback", fun args ->
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
js_to_value (Js.Unsafe.fun_call js (Array.map Fun.id js_args)))
|
||||
| "object" ->
|
||||
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals h Js.undefined) then
|
||||
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
|
||||
else
|
||||
let type_field = Js.Unsafe.get js (Js.string "_type") in
|
||||
if Js.Unsafe.equals type_field Js.undefined then begin
|
||||
if Js.to_bool (Js.Unsafe.global##._Array##isArray js) then begin
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce (Js.Unsafe.get js (Js.string "length"))) |> int_of_float in
|
||||
List (List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce js) i |> Js.Optdef.to_option |> Option.get)))
|
||||
end else begin
|
||||
(* Opaque host object — store in JS-side table, return Dict with __host_handle *)
|
||||
let id = host_put js in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "__host_handle" (Number (float_of_int id));
|
||||
Dict d
|
||||
end
|
||||
end else begin
|
||||
let tag = Js.to_string (Js.Unsafe.coerce type_field) in
|
||||
match tag with
|
||||
| "symbol" -> Symbol (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "keyword" -> Keyword (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "list" ->
|
||||
let items_js = Js.Unsafe.get js (Js.string "items") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce (Js.Unsafe.get items_js (Js.string "length"))) |> int_of_float in
|
||||
List (List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce items_js) i |> Js.Optdef.to_option |> Option.get)))
|
||||
| "dict" ->
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
if k <> "_type" then
|
||||
Hashtbl.replace d k (js_to_value (Js.Unsafe.get js (Js.string k)))
|
||||
done;
|
||||
Dict d
|
||||
| _ -> Nil
|
||||
end
|
||||
| _ -> Nil
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Side-channel return (bypasses js_of_ocaml stripping properties) *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v; v
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Persistent VM globals — synced with global_env *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* String-keyed mirror of global_env.bindings for VmClosures.
|
||||
VmClosures from bytecode modules hold vm_env_ref pointing here.
|
||||
Must stay in sync so VmClosures see post-boot definitions. *)
|
||||
let _vm_globals : (string, value) Hashtbl.t = Hashtbl.create 512
|
||||
let _in_batch = ref false
|
||||
|
||||
(* Sync env→VM: copy all bindings from global_env.bindings to _vm_globals.
|
||||
Called after CEK eval/load so VmClosures can see new definitions. *)
|
||||
let sync_env_to_vm () =
|
||||
Hashtbl.iter (fun id v ->
|
||||
Hashtbl.replace _vm_globals (unintern id) v
|
||||
) global_env.bindings
|
||||
|
||||
(* Hook: intercept env_bind on global_env to also update _vm_globals.
|
||||
Only sync bindings on the global env — let bindings in child envs
|
||||
must NOT leak into _vm_globals (they'd overwrite real definitions). *)
|
||||
let () =
|
||||
Sx_types._env_bind_hook := Some (fun env name v ->
|
||||
if env == global_env then
|
||||
Hashtbl.replace _vm_globals name v)
|
||||
|
||||
(* Reverse hook: sync VM GLOBAL_SET mutations back to global_env.
|
||||
Without this, set! inside JIT-compiled functions writes to _vm_globals
|
||||
but leaves global_env stale — CEK reads then see the old value. *)
|
||||
let () =
|
||||
Sx_types._vm_global_set_hook := Some (fun name v ->
|
||||
Hashtbl.replace global_env.bindings (Sx_types.intern name) v)
|
||||
|
||||
(* Symbol resolve hook: transparent lazy module loading.
|
||||
When GLOBAL_GET can't find a symbol, this calls the JS __resolve-symbol
|
||||
native which checks the manifest's symbol→library index and loads the
|
||||
library that exports it. After loading, the symbol is in _vm_globals. *)
|
||||
let () =
|
||||
Sx_types._symbol_resolve_hook := Some (fun name ->
|
||||
match Hashtbl.find_opt Sx_primitives.primitives "__resolve-symbol" with
|
||||
| None -> None
|
||||
| Some resolve_fn ->
|
||||
(try ignore (resolve_fn [String name]) with _ -> ());
|
||||
(* Check if the symbol appeared in globals after the load *)
|
||||
match Hashtbl.find_opt _vm_globals name with
|
||||
| Some v -> Some v
|
||||
| None -> None)
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Core API *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let api_parse src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let values = Sx_parser.parse_all src in
|
||||
Js.Unsafe.inject (Js.array (values |> List.map value_to_js |> Array.of_list))
|
||||
with Parse_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Build a JS suspension marker for the platform to handle.
|
||||
Returns {suspended: true, op: string, request: obj, resume: fn(result)} *)
|
||||
let _make_js_suspension request resume_fn =
|
||||
let obj = Js.Unsafe.obj [||] in
|
||||
Js.Unsafe.set obj (Js.string "suspended") (Js.Unsafe.inject (Js.bool true));
|
||||
let op = match request with
|
||||
| Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "unknown")
|
||||
| _ -> "unknown" in
|
||||
Js.Unsafe.set obj (Js.string "op") (Js.Unsafe.inject (Js.string op));
|
||||
Js.Unsafe.set obj (Js.string "request") (value_to_js request);
|
||||
Js.Unsafe.set obj (Js.string "resume") (Js.wrap_callback (fun result_js ->
|
||||
let result = js_to_value result_js in
|
||||
resume_fn result));
|
||||
obj
|
||||
|
||||
(** Handle an import suspension: load the library from the library registry
|
||||
or return a suspension marker to JS for async loading. *)
|
||||
let handle_import_suspension request =
|
||||
let lib_spec = match request with
|
||||
| Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil)
|
||||
| _ -> Nil in
|
||||
let key = Sx_ref.library_name_key lib_spec in
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
|
||||
Some Nil (* Already loaded — resume immediately *)
|
||||
else
|
||||
None (* Not loaded — JS platform must fetch it *)
|
||||
|
||||
let api_eval src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let result = List.fold_left (fun _acc expr -> Sx_ref.eval_expr expr env) Nil exprs in
|
||||
sync_env_to_vm ();
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** evalVM: compile SX source to bytecode and run through the VM.
|
||||
Globals defined with `define` are visible to subsequent evalVM/eval calls.
|
||||
This tests the exact same code path as island hydration and click handlers. *)
|
||||
let api_eval_vm src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let compile_fn = match Hashtbl.find_opt _vm_globals "compile-module" with
|
||||
| Some v -> v
|
||||
| None -> env_get global_env "compile-module" in
|
||||
let code_val = Sx_ref.trampoline (Sx_runtime.sx_call compile_fn [List exprs]) in
|
||||
let code = Sx_vm.code_from_value code_val in
|
||||
let result = Sx_vm_ref.execute_module code _vm_globals in
|
||||
(* Sync VM globals → CEK env so subsequent eval() calls see defines *)
|
||||
Hashtbl.iter (fun name v ->
|
||||
let id = intern name in
|
||||
if not (Hashtbl.mem global_env.bindings id) then
|
||||
Hashtbl.replace global_env.bindings id v
|
||||
else (match Hashtbl.find global_env.bindings id, v with
|
||||
| VmClosure _, VmClosure _ | _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
|
||||
| _ -> ())
|
||||
) _vm_globals;
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
| Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded")
|
||||
|
||||
let api_eval_expr expr_js _env_js =
|
||||
let expr = js_to_value expr_js in
|
||||
try
|
||||
let result = Sx_ref.eval_expr expr (Env global_env) in
|
||||
sync_env_to_vm ();
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
let api_load src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
(* Use IO-aware eval for each expression to handle import suspensions *)
|
||||
let state = Sx_ref.make_cek_state expr env (List []) in
|
||||
let final = ref (Sx_ref.cek_step_loop state) in
|
||||
while Sx_types.sx_truthy (Sx_ref.cek_suspended_p !final) do
|
||||
let request = Sx_ref.cek_io_request !final in
|
||||
let op = match request with
|
||||
| Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "")
|
||||
| _ -> "" in
|
||||
let response = if op = "import" then begin
|
||||
match handle_import_suspension request with
|
||||
| Some v -> v
|
||||
| None -> Nil (* Library not found — resume with nil, import will use what's in env *)
|
||||
end else Nil in
|
||||
final := Sx_ref.cek_resume !final response
|
||||
done;
|
||||
ignore (Sx_ref.cek_value !final);
|
||||
incr count
|
||||
) exprs;
|
||||
sync_env_to_vm ();
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
let api_begin_module_load () =
|
||||
(* Snapshot current env into the persistent VM globals table *)
|
||||
Hashtbl.clear _vm_globals;
|
||||
Hashtbl.iter (fun id v -> Hashtbl.replace _vm_globals (unintern id) v) global_env.bindings;
|
||||
_in_batch := true;
|
||||
Js.Unsafe.inject true
|
||||
|
||||
let api_end_module_load () =
|
||||
if !_in_batch then begin
|
||||
(* Copy VM globals back to env (bytecode modules defined new symbols) *)
|
||||
Hashtbl.iter (fun k v ->
|
||||
Hashtbl.replace global_env.bindings (intern k) v
|
||||
) _vm_globals;
|
||||
_in_batch := false
|
||||
end;
|
||||
Js.Unsafe.inject true
|
||||
|
||||
let sync_vm_to_env () =
|
||||
Hashtbl.iter (fun name v ->
|
||||
let id = intern name in
|
||||
if not (Hashtbl.mem global_env.bindings id) then
|
||||
Hashtbl.replace global_env.bindings id v
|
||||
else begin
|
||||
(* Update existing binding if the VM has a newer value *)
|
||||
let existing = Hashtbl.find global_env.bindings id in
|
||||
match existing, v with
|
||||
| VmClosure _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
|
||||
| _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
|
||||
| _ -> ()
|
||||
end
|
||||
) _vm_globals
|
||||
|
||||
(** Convert a VM suspension dict to a JS suspension object for the platform. *)
|
||||
let rec make_js_import_suspension (d : (string, value) Hashtbl.t) =
|
||||
let obj = Js.Unsafe.obj [||] in
|
||||
Js.Unsafe.set obj (Js.string "suspended") (Js.Unsafe.inject Js._true);
|
||||
Js.Unsafe.set obj (Js.string "op") (Js.Unsafe.inject (Js.string "import"));
|
||||
let request = match Hashtbl.find_opt d "request" with Some v -> v | None -> Nil in
|
||||
Js.Unsafe.set obj (Js.string "request") (value_to_js request);
|
||||
(* resume callback: clears __io_request, pushes nil, re-runs VM *)
|
||||
Js.Unsafe.set obj (Js.string "resume") (Js.wrap_callback (fun _result_js ->
|
||||
let resumed = Sx_vm_ref.resume_module (Dict d) in
|
||||
sync_vm_to_env ();
|
||||
match resumed with
|
||||
| Dict d2 when (match Hashtbl.find_opt d2 "suspended" with Some (Bool true) -> true | _ -> false) ->
|
||||
Js.Unsafe.inject (make_js_import_suspension d2)
|
||||
| result -> value_to_js result));
|
||||
obj
|
||||
|
||||
let api_load_module module_js =
|
||||
try
|
||||
let code_val = js_to_value module_js in
|
||||
let code = Sx_vm.code_from_value code_val in
|
||||
let result = Sx_vm_ref.execute_module code _vm_globals in
|
||||
match result with
|
||||
| Dict d when (match Hashtbl.find_opt d "suspended" with Some (Bool true) -> true | _ -> false) ->
|
||||
(* VM suspended on OP_PERFORM (import) — return JS suspension object *)
|
||||
Js.Unsafe.inject (make_js_import_suspension d)
|
||||
| _ ->
|
||||
sync_vm_to_env ();
|
||||
Js.Unsafe.inject (Hashtbl.length _vm_globals)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
|
||||
|
||||
let api_debug_env name_js =
|
||||
let name = Js.to_string name_js in
|
||||
let id = intern name in
|
||||
let found_env = Hashtbl.find_opt global_env.bindings id in
|
||||
let found_vm = Hashtbl.find_opt _vm_globals name in
|
||||
let total_env = Hashtbl.length global_env.bindings in
|
||||
let total_vm = Hashtbl.length _vm_globals in
|
||||
let env_s = match found_env with Some v -> "env:" ^ type_of v | None -> "env:MISSING" in
|
||||
let vm_s = match found_vm with Some v -> "vm:" ^ type_of v | None -> "vm:MISSING" in
|
||||
Js.Unsafe.inject (Js.string (Printf.sprintf "%s %s (env=%d vm=%d)" env_s vm_s total_env total_vm))
|
||||
|
||||
let api_compile_module src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let compile_fn = env_get global_env "compile-module" in
|
||||
let code = Sx_ref.eval_expr (List [compile_fn; List exprs]) (Env global_env) in
|
||||
return_via_side_channel (value_to_js code)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
| Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded")
|
||||
|
||||
let api_render_to_html expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let prev = !_sx_render_mode in
|
||||
_sx_render_mode := true;
|
||||
(try
|
||||
let html = Sx_render.sx_render_to_html global_env expr global_env in
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string html)
|
||||
with Eval_error msg ->
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg)))
|
||||
|
||||
let api_stringify v_js =
|
||||
Js.Unsafe.inject (Js.string (inspect (js_to_value v_js)))
|
||||
|
||||
let api_type_of v_js =
|
||||
Js.Unsafe.inject (Js.string (type_of (js_to_value v_js)))
|
||||
|
||||
let api_inspect v_js =
|
||||
Js.Unsafe.inject (Js.string (inspect (js_to_value v_js)))
|
||||
|
||||
let api_engine () =
|
||||
Js.Unsafe.inject (Js.string "ocaml-vm-wasm")
|
||||
|
||||
let api_register_native name_js callback_js =
|
||||
let name = Js.to_string name_js in
|
||||
let native_fn args =
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
js_to_value (Js.Unsafe.fun_call callback_js [| Js.Unsafe.inject (Js.array js_args) |])
|
||||
in
|
||||
let v = NativeFn (name, native_fn) in
|
||||
Sx_primitives.register name native_fn;
|
||||
ignore (env_bind global_env name v);
|
||||
Hashtbl.replace _vm_globals name v;
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
let api_call_fn fn_js args_js =
|
||||
try
|
||||
let fn = js_to_value fn_js in
|
||||
let args = Array.to_list (Array.map js_to_value (Js.to_array (Js.Unsafe.coerce args_js))) in
|
||||
return_via_side_channel (value_to_js (call_sx_fn fn args))
|
||||
with
|
||||
| Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call
|
||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] callFn: " ^ msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
| exn ->
|
||||
ignore (Js.Unsafe.meth_call
|
||||
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string ("[sx] callFn: " ^ Printexc.to_string exn)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
let api_is_callable fn_js =
|
||||
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
else
|
||||
let h = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if Js.Unsafe.equals h Js.undefined then Js.Unsafe.inject (Js.bool false)
|
||||
else Js.Unsafe.inject (Js.bool (is_callable (get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float))))
|
||||
|
||||
let api_fn_arity fn_js =
|
||||
let h = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if Js.Unsafe.equals h Js.undefined then Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
else
|
||||
let v = get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float) in
|
||||
match v with
|
||||
| Lambda l -> Js.Unsafe.inject (Js.number_of_float (float_of_int (List.length l.l_params)))
|
||||
| _ -> Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Platform bindings (registered in global env) *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let () =
|
||||
let bind name fn = ignore (env_bind global_env name (NativeFn (name, fn))) in
|
||||
|
||||
(* client? returns true in browser — set the ref so the primitive returns true *)
|
||||
Sx_primitives._is_client := true;
|
||||
|
||||
(* --- Evaluation --- *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [String s] -> let e = Sx_parser.parse_all s in (match e with h :: _ -> Sx_ref.eval_expr h (Env global_env) | [] -> Nil)
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [f; a] when is_callable f ->
|
||||
let arg_list = match a with List l -> l | Nil -> [] | v -> [v] in
|
||||
Sx_ref.trampoline (Sx_runtime.sx_call f arg_list)
|
||||
| [f; _] -> raise (Eval_error ("cek-call: not callable: " ^ type_of f))
|
||||
| _ -> raise (Eval_error "cek-call: expected (fn args)"));
|
||||
|
||||
bind "sx-parse" (fun args ->
|
||||
match args with
|
||||
| [String src] -> List (Sx_parser.parse_all src)
|
||||
| _ -> raise (Eval_error "sx-parse: expected string"));
|
||||
|
||||
(* parse: same as server — unwraps single results, returns list for multiple.
|
||||
Used by boot.sx (page scripts, suspense) and engine.sx (marsh update). *)
|
||||
bind "parse" (fun args ->
|
||||
match args with
|
||||
| [String src] | [SxExpr src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
(match exprs with [e] -> e | _ -> List exprs)
|
||||
| [v] -> v
|
||||
| _ -> raise (Eval_error "parse: expected string"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
(* --- Assertions & equality --- *)
|
||||
let rec deep_equal a b =
|
||||
match a, b with
|
||||
| Nil, Nil -> true | Bool a, Bool b -> a = b
|
||||
| Number a, Number b -> a = b | String a, String b -> a = b
|
||||
| Symbol a, Symbol b -> a = b | Keyword a, Keyword b -> a = b
|
||||
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
|
||||
List.length a = List.length b && List.for_all2 deep_equal a b
|
||||
| Dict a, Dict b ->
|
||||
let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in
|
||||
let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in
|
||||
List.length ka = List.length kb &&
|
||||
List.for_all (fun k -> Hashtbl.mem b k &&
|
||||
deep_equal (Hashtbl.find a k) (Hashtbl.find b k)) ka
|
||||
| _ -> false
|
||||
in
|
||||
bind "equal?" (fun args -> match args with [a; b] -> Bool (deep_equal a b) | _ -> raise (Eval_error "equal?: 2 args"));
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] -> if not (sx_truthy cond) then raise (Eval_error "Assertion failed"); Bool true
|
||||
| [cond; msg] -> if not (sx_truthy cond) then raise (Eval_error ("Assertion: " ^ value_to_string msg)); Bool true
|
||||
| _ -> raise (Eval_error "assert: 1-2 args"));
|
||||
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try ignore (Sx_ref.eval_expr (List [thunk]) (Env global_env));
|
||||
let d = Hashtbl.create 2 in Hashtbl.replace d "ok" (Bool true); Dict d
|
||||
with Eval_error msg ->
|
||||
let d = Hashtbl.create 2 in Hashtbl.replace d "ok" (Bool false); Hashtbl.replace d "error" (String msg); Dict d)
|
||||
| _ -> raise (Eval_error "try-call: 1 arg"));
|
||||
|
||||
(* --- Bytecode loading from s-expression format ---
|
||||
(sxbc version hash (code :arity N :upvalue-count N :bytecode (...) :constants (...)))
|
||||
Recursively converts the SX tree into the dict format that loadModule expects. *)
|
||||
bind "load-sxbc" (fun args ->
|
||||
match args with
|
||||
| [List (_ :: _ :: _ :: code_form :: _)] | [List (_ :: _ :: code_form :: _)] ->
|
||||
let rec convert_code form =
|
||||
match form with
|
||||
| List (Symbol "code" :: rest) ->
|
||||
let d = Hashtbl.create 8 in
|
||||
let rec parse_kv = function
|
||||
| Keyword "arity" :: Number n :: rest -> Hashtbl.replace d "arity" (Number n); parse_kv rest
|
||||
| Keyword "upvalue-count" :: Number n :: rest -> Hashtbl.replace d "upvalue-count" (Number n); parse_kv rest
|
||||
| Keyword "bytecode" :: List nums :: rest ->
|
||||
Hashtbl.replace d "bytecode" (List nums); parse_kv rest
|
||||
| Keyword "constants" :: List consts :: rest ->
|
||||
Hashtbl.replace d "constants" (List (List.map convert_const consts)); parse_kv rest
|
||||
| _ :: rest -> parse_kv rest (* skip unknown keywords *)
|
||||
| [] -> ()
|
||||
in
|
||||
parse_kv rest;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error ("load-sxbc: expected (code ...), got " ^ type_of form))
|
||||
and convert_const = function
|
||||
| List (Symbol "code" :: _) as form -> convert_code form
|
||||
| List (Symbol "list" :: items) -> List (List.map convert_const items)
|
||||
| v -> v (* strings, numbers, booleans, nil, symbols, keywords pass through *)
|
||||
in
|
||||
let module_val = convert_code code_form in
|
||||
let code = Sx_vm.code_from_value module_val in
|
||||
let _result = Sx_vm.execute_module code _vm_globals in
|
||||
sync_vm_to_env ();
|
||||
Number (float_of_int (Hashtbl.length _vm_globals))
|
||||
| _ -> raise (Eval_error "load-sxbc: expected (sxbc version hash (code ...))"));
|
||||
|
||||
(* --- List mutation --- *)
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* remove! — mutate ListRef in-place, removing by identity (==) *)
|
||||
bind "remove!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; target] ->
|
||||
r := List.filter (fun x -> x != target) !r; ListRef r
|
||||
| [List items; target] ->
|
||||
List (List.filter (fun x -> x != target) items)
|
||||
| _ -> raise (Eval_error "append!: list and value"));
|
||||
|
||||
(* --- Environment ops --- *)
|
||||
(* Use unwrap_env for nil/dict tolerance, matching the server kernel *)
|
||||
let uw = Sx_runtime.unwrap_env in
|
||||
bind "make-env" (fun _ -> Env (make_env ()));
|
||||
bind "global-env" (fun _ -> Env global_env);
|
||||
bind "env-has?" (fun args -> match args with [e; String k] | [e; Keyword k] -> Bool (env_has (uw e) k) | _ -> raise (Eval_error "env-has?"));
|
||||
bind "env-get" (fun args -> match args with [e; String k] | [e; Keyword k] -> env_get (uw e) k | _ -> raise (Eval_error "env-get"));
|
||||
bind "env-bind!" (fun args -> match args with [e; String k; v] | [e; Keyword k; v] -> env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!"));
|
||||
bind "env-set!" (fun args -> match args with [e; String k; v] | [e; Keyword k; v] -> env_set (uw e) k v | _ -> raise (Eval_error "env-set!"));
|
||||
bind "env-extend" (fun args -> match args with [e] -> Env (env_extend (uw e)) | _ -> raise (Eval_error "env-extend"));
|
||||
bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge"));
|
||||
|
||||
(* --- Type constructors --- *)
|
||||
bind "make-symbol" (fun args -> match args with [String s] -> Symbol s | [v] -> Symbol (value_to_string v) | _ -> raise (Eval_error "make-symbol"));
|
||||
bind "make-keyword" (fun args -> match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword"));
|
||||
bind "keyword-name" (fun args -> match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name"));
|
||||
bind "symbol-name" (fun args -> match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name"));
|
||||
|
||||
(* --- Component/Island accessors (must handle both types) --- *)
|
||||
bind "component-name" (fun args ->
|
||||
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
|
||||
bind "component-closure" (fun args ->
|
||||
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> Nil);
|
||||
bind "component-body" (fun args ->
|
||||
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
|
||||
let has_children_impl = 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) in
|
||||
ignore (env_bind global_env "component-has-children" has_children_impl);
|
||||
ignore (env_bind global_env "component-has-children?" has_children_impl);
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with [Component c] -> String c.c_affinity | [Island _] -> String "client" | _ -> String "auto");
|
||||
bind "component-param-types" (fun _ -> Nil);
|
||||
bind "component-set-param-types!" (fun _ -> Nil);
|
||||
|
||||
(* --- CEK stepping --- *)
|
||||
bind "make-cek-state" (fun args -> match args with [c; e; k] -> Sx_ref.make_cek_state c e k | _ -> raise (Eval_error "make-cek-state"));
|
||||
bind "cek-step" (fun args -> match args with [s] -> Sx_ref.cek_step s | _ -> raise (Eval_error "cek-step"));
|
||||
bind "cek-phase" (fun args -> match args with [s] -> Sx_ref.cek_phase s | _ -> raise (Eval_error "cek-phase"));
|
||||
bind "cek-value" (fun args -> match args with [s] -> Sx_ref.cek_value s | _ -> raise (Eval_error "cek-value"));
|
||||
bind "cek-terminal?" (fun args -> match args with [s] -> Sx_ref.cek_terminal_p s | _ -> raise (Eval_error "cek-terminal?"));
|
||||
bind "cek-kont" (fun args -> match args with [s] -> Sx_ref.cek_kont s | _ -> raise (Eval_error "cek-kont"));
|
||||
bind "frame-type" (fun args -> match args with [f] -> Sx_ref.frame_type f | _ -> raise (Eval_error "frame-type"));
|
||||
|
||||
(* --- Strict mode --- *)
|
||||
ignore (env_bind global_env "*strict*" (Bool false));
|
||||
ignore (env_bind global_env "*prim-param-types*" Nil);
|
||||
bind "set-strict!" (fun args -> match args with [v] -> Sx_ref._strict_ref := v; ignore (env_set global_env "*strict*" v); Nil | _ -> Nil);
|
||||
bind "set-prim-param-types!" (fun args -> match args with [v] -> Sx_ref._prim_param_types_ref := v; ignore (env_set global_env "*prim-param-types*" v); Nil | _ -> Nil);
|
||||
bind "value-matches-type?" (fun args -> match args with [v; t] -> Sx_ref.value_matches_type_p v t | _ -> Nil);
|
||||
|
||||
(* --- Apply --- *)
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with List last :: prefix -> List.rev prefix @ last | _ -> rest in
|
||||
Sx_runtime.sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply"));
|
||||
|
||||
(* --- Scope stack --- *)
|
||||
(* Scope primitives (scope-push!, scope-pop!, context, collect!, collected,
|
||||
emit!, emitted, scope-emit!, scope-emitted, etc.) are registered by
|
||||
Sx_primitives module initialization in the primitives table.
|
||||
The CEK evaluator falls through to the primitives table when a symbol
|
||||
isn't in the env, so these work automatically.
|
||||
Only provide-push!/provide-pop! need explicit env bindings as aliases. *)
|
||||
bind "provide-push!" (fun args -> match args with [n; v] -> Sx_runtime.provide_push n v | _ -> raise (Eval_error "provide-push!"));
|
||||
bind "provide-pop!" (fun args -> match args with [n] -> Sx_runtime.provide_pop n | _ -> raise (Eval_error "provide-pop!"));
|
||||
|
||||
(* Runtime helpers for bytecoded defcomp/defisland/defmacro forms.
|
||||
The compiler emits GLOBAL_GET "eval-defcomp" + CALL — these must
|
||||
exist as callable values for bytecoded .sx files that contain
|
||||
component definitions (e.g. cssx.sx). *)
|
||||
bind "eval-defcomp" (fun args ->
|
||||
match args with [List (_ :: rest)] -> Sx_ref.sf_defcomp (List rest) (Env global_env) | _ -> Nil);
|
||||
bind "eval-defisland" (fun args ->
|
||||
match args with [List (_ :: rest)] -> Sx_ref.sf_defisland (List rest) (Env global_env) | _ -> Nil);
|
||||
bind "eval-defmacro" (fun args ->
|
||||
match args with [List (_ :: rest)] -> Sx_ref.sf_defmacro (List rest) (Env global_env) | _ -> Nil);
|
||||
|
||||
(* --- Fragment / raw HTML --- *)
|
||||
bind "<>" (fun args ->
|
||||
RawHTML (String.concat "" (List.map (fun a ->
|
||||
match a with String s | RawHTML s -> s | Nil -> ""
|
||||
| List _ -> Sx_render.sx_render_to_html global_env a global_env
|
||||
| _ -> value_to_string a) args)));
|
||||
bind "raw!" (fun args ->
|
||||
RawHTML (String.concat "" (List.map (fun a ->
|
||||
match a with String s | RawHTML s -> s | _ -> value_to_string a) args)));
|
||||
|
||||
bind "define-page-helper" (fun _ -> Nil);
|
||||
|
||||
(* IO registry — spec-level defio populates *io-registry* in evaluator.
|
||||
Alias as __io-registry for backward compat. *)
|
||||
ignore (env_bind global_env "__io-registry" Sx_ref._io_registry_);
|
||||
|
||||
(* --- Render --- *)
|
||||
Sx_render.setup_render_env global_env;
|
||||
bind "set-render-active!" (fun _ -> Nil);
|
||||
bind "render-active?" (fun _ -> Bool true);
|
||||
bind "is-html-tag?" (fun args -> match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
||||
|
||||
(* --- Render constants needed by web adapters --- *)
|
||||
let html_tags = List (List.map (fun s -> String s) Sx_render.html_tags) in
|
||||
let void_elements = List (List.map (fun s -> String s) Sx_render.void_elements) in
|
||||
let boolean_attrs = List (List.map (fun s -> String s) Sx_render.boolean_attrs) in
|
||||
ignore (env_bind global_env "HTML_TAGS" html_tags);
|
||||
ignore (env_bind global_env "VOID_ELEMENTS" void_elements);
|
||||
ignore (env_bind global_env "BOOLEAN_ATTRS" boolean_attrs);
|
||||
|
||||
(* --- HTML tag special forms (div, span, h1, ...) --- *)
|
||||
(* Registered as custom special forms so keywords are preserved.
|
||||
Handler receives (raw-args env), evaluates non-keyword args
|
||||
while keeping keyword names intact. *)
|
||||
let eval_tag_args raw_args env =
|
||||
let args = Sx_runtime.sx_to_list raw_args in
|
||||
let rec process = function
|
||||
| [] -> []
|
||||
| (Keyword _ as kw) :: value :: rest ->
|
||||
(* keyword + its value: keep keyword, evaluate value *)
|
||||
kw :: Sx_ref.eval_expr value env :: process rest
|
||||
| (Keyword _ as kw) :: [] ->
|
||||
(* trailing keyword with no value — boolean attr *)
|
||||
[kw]
|
||||
| expr :: rest ->
|
||||
(* non-keyword: evaluate *)
|
||||
Sx_ref.eval_expr expr env :: process rest
|
||||
in
|
||||
process args
|
||||
in
|
||||
List.iter (fun tag ->
|
||||
ignore (Sx_ref.register_special_form (String tag)
|
||||
(NativeFn ("sf:" ^ tag, fun handler_args ->
|
||||
match handler_args with
|
||||
| [raw_args; env] -> List (Symbol tag :: eval_tag_args raw_args env)
|
||||
| _ -> Nil)))
|
||||
) Sx_render.html_tags;
|
||||
|
||||
(* --- Error handling --- *)
|
||||
bind "cek-try" (fun args ->
|
||||
match args with
|
||||
| [thunk; handler] ->
|
||||
(try Sx_ref.cek_call thunk Nil
|
||||
with Eval_error msg -> Sx_ref.cek_call handler (List [String msg]))
|
||||
| [thunk] ->
|
||||
(try let r = Sx_ref.cek_call thunk Nil in
|
||||
List [Symbol "ok"; r]
|
||||
with Eval_error msg -> List [Symbol "error"; String msg])
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Evaluator bridge functions needed by spec .sx files --- *)
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with [expr; e] -> Sx_ref.eval_expr expr e | [expr] -> Sx_ref.eval_expr expr (Env global_env) | _ -> Nil);
|
||||
bind "trampoline" (fun args -> match args with [v] -> !Sx_primitives._sx_trampoline_fn v | _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with [mac; raw; Env e] -> Sx_ref.expand_macro mac raw (Env e) | [mac; raw] -> Sx_ref.expand_macro mac raw (Env global_env) | _ -> Nil);
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [f; a; _] | [f; a] when is_callable f ->
|
||||
(* Use cek_call instead of sx_call to avoid eval_expr copying
|
||||
Dict values (signals). sx_call returns a Thunk resolved via
|
||||
eval_expr which deep-copies dicts, breaking signal mutation. *)
|
||||
Sx_ref.cek_call f a
|
||||
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [f; a] when is_callable f ->
|
||||
let arg_list = match a with List l -> l | Nil -> [] | v -> [v] in
|
||||
Sx_ref.trampoline (Sx_runtime.sx_call f arg_list)
|
||||
| [f; _] -> raise (Eval_error ("cek-call: not callable: " ^ type_of f))
|
||||
| _ -> raise (Eval_error "cek-call: expected (fn args)"));
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with [expr] -> Sx_ref.eval_expr expr (Env global_env) | [expr; e] -> Sx_ref.eval_expr expr e | _ -> Nil);
|
||||
bind "qq-expand-runtime" (fun args ->
|
||||
match args with [template] -> Sx_ref.qq_expand template (Env global_env) | [template; Env e] -> Sx_ref.qq_expand template (Env e) | _ -> Nil);
|
||||
|
||||
(* --- Type predicates needed by adapters --- *)
|
||||
bind "thunk?" (fun args -> match args with [Thunk _] -> Bool true | _ -> Bool false);
|
||||
bind "thunk-expr" (fun args -> match args with [v] -> thunk_expr v | _ -> Nil);
|
||||
bind "thunk-env" (fun args -> match args with [v] -> thunk_env v | _ -> Nil);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args -> match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "callable?" (fun args -> match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "continuation?" (fun args -> match args with [Continuation _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda-params" (fun args -> match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args -> match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
|
||||
|
||||
(* --- Core operations needed by adapters --- *)
|
||||
bind "spread-attrs" (fun args ->
|
||||
match args with [Spread pairs] -> let d = Hashtbl.create 4 in List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d | _ -> Dict (Hashtbl.create 0));
|
||||
bind "make-spread" (fun args ->
|
||||
match args with [Dict d] -> Spread (Hashtbl.fold (fun k v acc -> (k, v) :: acc) d []) | _ -> Nil);
|
||||
bind "make-raw-html" (fun args -> match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
|
||||
bind "raw-html-content" (fun args -> match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
|
||||
bind "empty-dict?" (fun args -> match args with [Dict d] -> Bool (Hashtbl.length d = 0) | _ -> Bool true);
|
||||
bind "identical?" (fun args -> match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?"));
|
||||
bind "for-each-indexed" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List items] | [fn_val; ListRef { contents = items }] ->
|
||||
List.iteri (fun i item ->
|
||||
ignore (Sx_ref.eval_expr (List [fn_val; Number (float_of_int i); item]) (Env global_env))
|
||||
) items; Nil
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- String/number helpers used by orchestration/browser --- *)
|
||||
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr"));
|
||||
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source"));
|
||||
bind "parse-int" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (try Number (float_of_int (int_of_string s)) with _ -> Nil)
|
||||
| [String s; default_val] -> (try Number (float_of_int (int_of_string s)) with _ -> default_val)
|
||||
| [Number n] | [Number n; _] -> Number (Float.round n)
|
||||
| [_; default_val] -> default_val | _ -> Nil);
|
||||
bind "parse-number" (fun args -> match args with [String s] -> (try Number (float_of_string s) with _ -> Nil) | _ -> Nil);
|
||||
|
||||
(* --- Server-only stubs (no-ops in browser) --- *)
|
||||
bind "query" (fun _ -> Nil);
|
||||
bind "action" (fun _ -> Nil);
|
||||
bind "request-arg" (fun args -> match args with [_; d] -> d | _ -> Nil);
|
||||
bind "request-method" (fun _ -> String "GET");
|
||||
bind "ctx" (fun _ -> Nil);
|
||||
bind "helper" (fun _ -> Nil);
|
||||
()
|
||||
|
||||
(* ================================================================== *)
|
||||
(* JIT compilation hook *)
|
||||
(* *)
|
||||
(* On first call to a named lambda, try to compile it to bytecode via *)
|
||||
(* compiler.sx (loaded as an .sx platform file). Compiled closures run *)
|
||||
(* on the bytecode VM; failures fall back to the CEK interpreter. *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let _jit_compiling = ref false
|
||||
let _jit_enabled = ref false
|
||||
|
||||
let () =
|
||||
Sx_runtime._jit_try_call_fn := Some (fun f args ->
|
||||
match f with
|
||||
| Lambda l when !_jit_enabled ->
|
||||
(match l.l_compiled with
|
||||
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
||||
(try Some (Sx_vm.call_closure cl args _vm_globals)
|
||||
with Eval_error msg ->
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
||||
Printf.eprintf "[jit] FAIL %s: %s (bc=%d consts=%d upv=%d)\n%!"
|
||||
fn_name msg
|
||||
(Array.length cl.vm_code.vc_bytecode)
|
||||
(Array.length cl.vm_code.vc_constants)
|
||||
(Array.length cl.vm_upvalues);
|
||||
(* Mark as failed to stop retrying *)
|
||||
l.l_compiled <- Some (Sx_vm.jit_failed_sentinel);
|
||||
None)
|
||||
| Some _ -> None
|
||||
| None ->
|
||||
if !_jit_compiling then None
|
||||
else begin
|
||||
_jit_compiling := true;
|
||||
let compiled = Sx_vm.jit_compile_lambda l _vm_globals in
|
||||
_jit_compiling := false;
|
||||
(match compiled with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
(try Some (Sx_vm.call_closure cl args _vm_globals)
|
||||
with Eval_error msg ->
|
||||
let fn_name2 = match l.l_name with Some n -> n | None -> "?" in
|
||||
Printf.eprintf "[jit] FAIL %s: %s (bc=%d consts=%d upv=%d)\n%!"
|
||||
fn_name2 msg
|
||||
(Array.length cl.vm_code.vc_bytecode)
|
||||
(Array.length cl.vm_code.vc_constants)
|
||||
(Array.length cl.vm_upvalues);
|
||||
l.l_compiled <- Some (Sx_vm.jit_failed_sentinel);
|
||||
None)
|
||||
| None -> None)
|
||||
end)
|
||||
| _ -> None)
|
||||
|
||||
let () = ignore (env_bind global_env "enable-jit!" (NativeFn ("enable-jit!", fun _ -> _jit_enabled := true; Nil)))
|
||||
|
||||
(* Seed BOTH _vm_globals AND global_env with ALL primitives as NativeFn values.
|
||||
Unconditional — native primitives are authoritative for CALL_PRIM dispatch.
|
||||
Must be in both because sync_env_to_vm() copies global_env → _vm_globals. *)
|
||||
let () =
|
||||
Hashtbl.iter (fun name fn ->
|
||||
let v = NativeFn (name, fn) in
|
||||
Hashtbl.replace _vm_globals name v;
|
||||
Hashtbl.replace global_env.bindings (intern name) v
|
||||
) Sx_primitives.primitives
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Register global SxKernel object *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let () =
|
||||
let sx = Js.Unsafe.obj [||] in
|
||||
let wrap fn = Js.Unsafe.fun_call
|
||||
(Js.Unsafe.pure_js_expr "(function(fn) { return function() { globalThis.__sxR = undefined; var r = fn.apply(null, arguments); return globalThis.__sxR !== undefined ? globalThis.__sxR : r; }; })")
|
||||
[| Js.Unsafe.inject (Js.wrap_callback fn) |] in
|
||||
|
||||
Js.Unsafe.set sx (Js.string "parse") (Js.wrap_callback api_parse);
|
||||
Js.Unsafe.set sx (Js.string "stringify") (Js.wrap_callback api_stringify);
|
||||
Js.Unsafe.set sx (Js.string "eval") (wrap api_eval);
|
||||
Js.Unsafe.set sx (Js.string "evalVM") (wrap api_eval_vm);
|
||||
Js.Unsafe.set sx (Js.string "evalExpr") (wrap api_eval_expr);
|
||||
Js.Unsafe.set sx (Js.string "renderToHtml") (Js.wrap_callback api_render_to_html);
|
||||
Js.Unsafe.set sx (Js.string "load") (Js.wrap_callback api_load);
|
||||
Js.Unsafe.set sx (Js.string "loadModule") (Js.wrap_callback api_load_module);
|
||||
Js.Unsafe.set sx (Js.string "beginModuleLoad") (Js.wrap_callback (fun () -> api_begin_module_load ()));
|
||||
Js.Unsafe.set sx (Js.string "endModuleLoad") (Js.wrap_callback (fun () -> api_end_module_load ()));
|
||||
Js.Unsafe.set sx (Js.string "compileModule") (wrap api_compile_module);
|
||||
Js.Unsafe.set sx (Js.string "typeOf") (Js.wrap_callback api_type_of);
|
||||
Js.Unsafe.set sx (Js.string "inspect") (Js.wrap_callback api_inspect);
|
||||
Js.Unsafe.set sx (Js.string "engine") (Js.wrap_callback api_engine);
|
||||
Js.Unsafe.set sx (Js.string "registerNative") (Js.wrap_callback api_register_native);
|
||||
Js.Unsafe.set sx (Js.string "loadSource") (Js.wrap_callback api_load);
|
||||
Js.Unsafe.set sx (Js.string "callFn") (wrap api_call_fn);
|
||||
Js.Unsafe.set sx (Js.string "isCallable") (Js.wrap_callback api_is_callable);
|
||||
Js.Unsafe.set sx (Js.string "fnArity") (Js.wrap_callback api_fn_arity);
|
||||
Js.Unsafe.set sx (Js.string "debugEnv") (Js.wrap_callback api_debug_env);
|
||||
|
||||
(* Scope tracing API *)
|
||||
Js.Unsafe.set sx (Js.string "scopeTraceOn") (Js.wrap_callback (fun () ->
|
||||
Sx_primitives.scope_trace_enable (); Js.Unsafe.inject Js.null));
|
||||
Js.Unsafe.set sx (Js.string "scopeTraceOff") (Js.wrap_callback (fun () ->
|
||||
Sx_primitives.scope_trace_disable (); Js.Unsafe.inject Js.null));
|
||||
Js.Unsafe.set sx (Js.string "scopeTraceDrain") (Js.wrap_callback (fun () ->
|
||||
let log = Sx_primitives.scope_trace_drain () in
|
||||
Js.Unsafe.inject (Js.array (Array.of_list (List.map (fun s -> Js.Unsafe.inject (Js.string s)) log)))));
|
||||
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
||||
226
hosts/ocaml/browser/test-spa.js
Normal file
226
hosts/ocaml/browser/test-spa.js
Normal file
@@ -0,0 +1,226 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* test-spa.js — Deep browser diagnostic for SPA navigation.
|
||||
*
|
||||
* Uses Chrome DevTools Protocol to inspect event listeners,
|
||||
* trace click handling, and detect SPA vs full reload.
|
||||
*
|
||||
* Usage:
|
||||
* node test-spa.js # bytecode mode
|
||||
* node test-spa.js --source # source mode (nosxbc)
|
||||
* node test-spa.js --headed # visible browser
|
||||
*/
|
||||
|
||||
const { chromium } = require('playwright');
|
||||
|
||||
const args = process.argv.slice(2);
|
||||
const sourceMode = args.includes('--source');
|
||||
const headed = args.includes('--headed');
|
||||
const baseUrl = 'http://localhost:8013/sx/';
|
||||
const url = sourceMode ? baseUrl + '?nosxbc' : baseUrl;
|
||||
const label = sourceMode ? 'SOURCE' : 'BYTECODE';
|
||||
|
||||
(async () => {
|
||||
const browser = await chromium.launch({ headless: !headed });
|
||||
const page = await browser.newPage();
|
||||
|
||||
// Capture console
|
||||
page.on('console', msg => {
|
||||
const t = msg.text();
|
||||
if (t.startsWith('[spa-diag]') || t.includes('Not callable') || t.includes('Error:'))
|
||||
console.log(` [browser] ${t}`);
|
||||
});
|
||||
|
||||
console.log(`\n=== SPA Diagnostic: ${label} mode ===\n`);
|
||||
await page.goto(url);
|
||||
await page.waitForTimeout(5000);
|
||||
|
||||
// ----------------------------------------------------------------
|
||||
// 1. Use CDP to get event listeners on a link
|
||||
// ----------------------------------------------------------------
|
||||
console.log('--- 1. Event listeners on Geography link ---');
|
||||
|
||||
const cdp = await page.context().newCDPSession(page);
|
||||
|
||||
const listeners = await page.evaluate(async () => {
|
||||
const link = document.querySelector('a[href="/sx/(geography)"]');
|
||||
if (!link) return { error: 'link not found' };
|
||||
|
||||
// We can't use getEventListeners from page context (it's a DevTools API)
|
||||
// But we can check _sxBound* properties and enumerate own properties
|
||||
const ownProps = {};
|
||||
for (const k of Object.getOwnPropertyNames(link)) {
|
||||
if (k.startsWith('_') || k.startsWith('on'))
|
||||
ownProps[k] = typeof link[k];
|
||||
}
|
||||
|
||||
// Check for jQuery-style event data
|
||||
const jqData = link.__events || link._events || null;
|
||||
|
||||
return {
|
||||
href: link.getAttribute('href'),
|
||||
ownProps,
|
||||
jqData: jqData ? 'present' : 'none',
|
||||
onclick: link.onclick ? 'set' : 'null',
|
||||
parentTag: link.parentElement?.tagName,
|
||||
};
|
||||
});
|
||||
console.log(' Link props:', JSON.stringify(listeners, null, 2));
|
||||
|
||||
// Check should-boost-link? and why it returns false
|
||||
const boostCheck = await page.evaluate(() => {
|
||||
const K = window.SxKernel;
|
||||
const link = document.querySelectorAll('a[href]')[1]; // geography link
|
||||
if (!link) return 'no link';
|
||||
try {
|
||||
// Check the conditions should-boost-link? checks
|
||||
const href = link.getAttribute('href');
|
||||
const checks = {
|
||||
href,
|
||||
hasBoostAttr: link.closest('[data-sx-boost]') ? 'yes' : 'no',
|
||||
hasNoBoost: link.hasAttribute('data-sx-no-boost') ? 'yes' : 'no',
|
||||
isExternal: href.startsWith('http') ? 'yes' : 'no',
|
||||
isHash: href.startsWith('#') ? 'yes' : 'no',
|
||||
};
|
||||
// Try calling should-boost-link?
|
||||
try { checks.shouldBoost = K.eval('(should-boost-link? (nth (dom-query-all (dom-body) "a[href]") 1))'); }
|
||||
catch(e) { checks.shouldBoost = 'err: ' + e.message.slice(0, 80); }
|
||||
return checks;
|
||||
} catch(e) { return 'err: ' + e.message; }
|
||||
});
|
||||
console.log(' Boost check:', JSON.stringify(boostCheck, null, 2));
|
||||
|
||||
// Use CDP to get actual event listeners
|
||||
const linkNode = await page.$('a[href="/sx/(geography)"]');
|
||||
if (linkNode) {
|
||||
const { object } = await cdp.send('Runtime.evaluate', {
|
||||
expression: 'document.querySelector(\'a[href="/sx/(geography)"]\')',
|
||||
});
|
||||
if (object?.objectId) {
|
||||
const { listeners: cdpListeners } = await cdp.send('DOMDebugger.getEventListeners', {
|
||||
objectId: object.objectId,
|
||||
depth: 0,
|
||||
});
|
||||
console.log(' CDP event listeners on link:', cdpListeners.length);
|
||||
for (const l of cdpListeners) {
|
||||
console.log(` ${l.type}: ${l.handler?.description?.slice(0, 100) || 'native'} (useCapture=${l.useCapture})`);
|
||||
}
|
||||
}
|
||||
|
||||
// Also check document-level click listeners
|
||||
const { object: docObj } = await cdp.send('Runtime.evaluate', {
|
||||
expression: 'document',
|
||||
});
|
||||
if (docObj?.objectId) {
|
||||
const { listeners: docListeners } = await cdp.send('DOMDebugger.getEventListeners', {
|
||||
objectId: docObj.objectId,
|
||||
depth: 0,
|
||||
});
|
||||
const clickListeners = docListeners.filter(l => l.type === 'click');
|
||||
console.log(' CDP document click listeners:', clickListeners.length);
|
||||
for (const l of clickListeners) {
|
||||
console.log(` ${l.type}: ${l.handler?.description?.slice(0, 120) || 'native'} (capture=${l.useCapture})`);
|
||||
}
|
||||
}
|
||||
|
||||
// Check window-level listeners too
|
||||
const { object: winObj } = await cdp.send('Runtime.evaluate', {
|
||||
expression: 'window',
|
||||
});
|
||||
if (winObj?.objectId) {
|
||||
const { listeners: winListeners } = await cdp.send('DOMDebugger.getEventListeners', {
|
||||
objectId: winObj.objectId,
|
||||
depth: 0,
|
||||
});
|
||||
const winClick = winListeners.filter(l => l.type === 'click');
|
||||
const winPop = winListeners.filter(l => l.type === 'popstate');
|
||||
console.log(' CDP window click listeners:', winClick.length);
|
||||
console.log(' CDP window popstate listeners:', winPop.length);
|
||||
for (const l of winPop) {
|
||||
console.log(` popstate: ${l.handler?.description?.slice(0, 120) || 'native'}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// ----------------------------------------------------------------
|
||||
// 2. Trace what happens when we click
|
||||
// ----------------------------------------------------------------
|
||||
console.log('\n--- 2. Click trace ---');
|
||||
|
||||
// Inject click tracing
|
||||
await page.evaluate(() => {
|
||||
// Trace click event propagation
|
||||
const phases = ['NONE', 'CAPTURE', 'AT_TARGET', 'BUBBLE'];
|
||||
document.addEventListener('click', function(e) {
|
||||
console.log('[spa-diag] click CAPTURE on document: target=' + e.target.tagName +
|
||||
' href=' + (e.target.getAttribute?.('href') || 'none') +
|
||||
' defaultPrevented=' + e.defaultPrevented);
|
||||
}, true);
|
||||
|
||||
document.addEventListener('click', function(e) {
|
||||
console.log('[spa-diag] click BUBBLE on document: defaultPrevented=' + e.defaultPrevented +
|
||||
' propagation=' + (e.cancelBubble ? 'stopped' : 'running'));
|
||||
}, false);
|
||||
|
||||
// Monitor pushState
|
||||
const origPush = history.pushState;
|
||||
history.pushState = function() {
|
||||
console.log('[spa-diag] pushState called: ' + JSON.stringify(arguments[2]));
|
||||
return origPush.apply(this, arguments);
|
||||
};
|
||||
|
||||
// Monitor replaceState
|
||||
const origReplace = history.replaceState;
|
||||
history.replaceState = function() {
|
||||
console.log('[spa-diag] replaceState called: ' + JSON.stringify(arguments[2]));
|
||||
return origReplace.apply(this, arguments);
|
||||
};
|
||||
});
|
||||
|
||||
// Detect full reload vs SPA by checking if a new page load happens
|
||||
let fullReload = false;
|
||||
let networkNav = false;
|
||||
page.on('load', () => { fullReload = true; });
|
||||
page.on('request', req => {
|
||||
if (req.isNavigationRequest()) {
|
||||
networkNav = true;
|
||||
console.log(' [network] Navigation request:', req.url());
|
||||
}
|
||||
});
|
||||
|
||||
// Click the link
|
||||
console.log(' Clicking /sx/(geography)...');
|
||||
const urlBefore = page.url();
|
||||
await page.click('a[href="/sx/(geography)"]');
|
||||
await page.waitForTimeout(3000);
|
||||
const urlAfter = page.url();
|
||||
|
||||
console.log(` URL: ${urlBefore.split('8013')[1]} → ${urlAfter.split('8013')[1]}`);
|
||||
console.log(` Full reload: ${fullReload}`);
|
||||
console.log(` Network navigation: ${networkNav}`);
|
||||
|
||||
// Check page content
|
||||
const content = await page.evaluate(() => ({
|
||||
title: document.title,
|
||||
h1: document.querySelector('h1')?.textContent?.slice(0, 50) || 'none',
|
||||
bodyLen: document.body.innerHTML.length,
|
||||
}));
|
||||
console.log(' Content:', JSON.stringify(content));
|
||||
|
||||
// ----------------------------------------------------------------
|
||||
// 3. Check SX router state
|
||||
// ----------------------------------------------------------------
|
||||
console.log('\n--- 3. SX router state ---');
|
||||
const routerState = await page.evaluate(() => {
|
||||
const K = window.SxKernel;
|
||||
if (!K) return { error: 'no kernel' };
|
||||
const checks = {};
|
||||
try { checks['_page-routes count'] = K.eval('(len _page-routes)'); } catch(e) { checks['_page-routes'] = e.message; }
|
||||
try { checks['current-route'] = K.eval('(browser-location-pathname)'); } catch(e) { checks['current-route'] = e.message; }
|
||||
return checks;
|
||||
});
|
||||
console.log(' Router:', JSON.stringify(routerState));
|
||||
|
||||
console.log('\n=== Done ===\n');
|
||||
await browser.close();
|
||||
})();
|
||||
30
hosts/ocaml/browser/test_boot.sh
Executable file
30
hosts/ocaml/browser/test_boot.sh
Executable file
@@ -0,0 +1,30 @@
|
||||
#!/bin/bash
|
||||
# Test WASM boot in Node.js — verifies the compiled sx_browser.bc.js loads
|
||||
# without errors by providing minimal DOM/browser API stubs.
|
||||
set -euo pipefail
|
||||
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
node -e "
|
||||
global.window = global;
|
||||
global.document = { createElement: () => ({style:{},setAttribute:()=>{},appendChild:()=>{},children:[]}), createDocumentFragment: () => ({appendChild:()=>{},children:[],childNodes:[]}), head:{appendChild:()=>{}}, body:{appendChild:()=>{}}, querySelector:()=>null, querySelectorAll:()=>[], createTextNode:(s)=>({textContent:s}), addEventListener:()=>{}, createComment:(s)=>({textContent:s||''}) };
|
||||
global.localStorage = {getItem:()=>null,setItem:()=>{},removeItem:()=>{}};
|
||||
global.CustomEvent = class { constructor(n,o){this.type=n;this.detail=(o||{}).detail||{}} };
|
||||
global.MutationObserver = class { observe(){} disconnect(){} };
|
||||
global.requestIdleCallback = (fn) => setTimeout(fn,0);
|
||||
global.matchMedia = () => ({matches:false});
|
||||
global.navigator = {serviceWorker:{register:()=>Promise.resolve()}};
|
||||
global.location = {href:'',pathname:'/',hostname:'localhost'};
|
||||
global.history = {pushState:()=>{},replaceState:()=>{}};
|
||||
global.fetch = () => Promise.resolve({ok:true,text:()=>Promise.resolve('')});
|
||||
global.setTimeout = setTimeout;
|
||||
global.clearTimeout = clearTimeout;
|
||||
try {
|
||||
require('./shared/static/wasm/sx_browser.bc.js');
|
||||
console.log('WASM boot: OK');
|
||||
} catch(e) {
|
||||
console.error('WASM boot: FAILED');
|
||||
console.error(e.message);
|
||||
process.exit(1);
|
||||
}
|
||||
"
|
||||
62
hosts/ocaml/browser/test_js.js
Normal file
62
hosts/ocaml/browser/test_js.js
Normal file
@@ -0,0 +1,62 @@
|
||||
#!/usr/bin/env node
|
||||
// Test js_of_ocaml build of SX kernel
|
||||
const path = require('path');
|
||||
require(path.join(__dirname, '../_build/default/browser/sx_browser.bc.js'));
|
||||
|
||||
const sx = globalThis.SxKernel;
|
||||
console.log('Engine:', sx.engine());
|
||||
|
||||
const tests = [
|
||||
['(+ 1 2)', 3],
|
||||
['(- 10 3)', 7],
|
||||
['(* 6 7)', 42],
|
||||
['(/ 10 2)', 5],
|
||||
['(= 5 5)', true],
|
||||
['(< 3 5)', true],
|
||||
['(> 5 3)', true],
|
||||
['(not false)', true],
|
||||
['(inc 5)', 6],
|
||||
['(dec 5)', 4],
|
||||
['(len (list 1 2 3))', 3],
|
||||
['(len "hello")', 5],
|
||||
['(first (list 10 20))', 10],
|
||||
['(nth "hello" 0)', 'h'],
|
||||
['(nth "hello" 4)', 'o'],
|
||||
['(str "a" "b")', 'ab'],
|
||||
['(join ", " (list "a" "b" "c"))', 'a, b, c'],
|
||||
['(let ((x 10) (y 20)) (+ x y))', 30],
|
||||
['(if true "yes" "no")', 'yes'],
|
||||
['(cond (= 1 2) "one" :else "other")', 'other'],
|
||||
['(case 2 1 "one" 2 "two" :else "other")', 'two'],
|
||||
['(render-to-html (list (quote div) "hello"))', '<div>hello</div>'],
|
||||
['(render-to-html (list (quote span) (list (quote b) "bold")))', '<span><b>bold</b></span>'],
|
||||
// Lambda + closure
|
||||
['(let ((add (fn (a b) (+ a b)))) (add 3 4))', 7],
|
||||
['(let ((x 10)) (let ((f (fn () x))) (f)))', 10],
|
||||
// Higher-order
|
||||
['(len (filter (fn (x) (> x 2)) (list 1 2 3 4 5)))', 3],
|
||||
// Recursion
|
||||
['(let ((fact (fn (n) (if (<= n 1) 1 (* n (fact (- n 1))))))) (fact 5))', 120],
|
||||
];
|
||||
|
||||
let passed = 0, failed = 0;
|
||||
for (const [expr, expected] of tests) {
|
||||
try {
|
||||
const result = sx.eval(expr);
|
||||
const ok = typeof expected === 'object'
|
||||
? result && result._type === expected._type
|
||||
: result === expected;
|
||||
if (ok) {
|
||||
passed++;
|
||||
} else {
|
||||
console.log(` FAIL: ${expr} = ${JSON.stringify(result)} (expected ${JSON.stringify(expected)})`);
|
||||
failed++;
|
||||
}
|
||||
} catch (e) {
|
||||
console.log(` ERROR: ${expr}: ${e.message || e}`);
|
||||
failed++;
|
||||
}
|
||||
}
|
||||
|
||||
console.log(`${passed} passed, ${failed} failed`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
244
hosts/ocaml/browser/test_kernel.js
Normal file
244
hosts/ocaml/browser/test_kernel.js
Normal file
@@ -0,0 +1,244 @@
|
||||
#!/usr/bin/env node
|
||||
// WASM kernel integration tests: env sync, globals, pages parsing, preventDefault
|
||||
const path = require('path');
|
||||
const fs = require('fs');
|
||||
require(path.join(__dirname, '../_build/default/browser/sx_browser.bc.js'));
|
||||
|
||||
const K = globalThis.SxKernel;
|
||||
|
||||
// Load compiler for evalVM support
|
||||
const compilerFiles = ['lib/bytecode.sx', 'lib/compiler.sx', 'lib/vm.sx'];
|
||||
for (const f of compilerFiles) {
|
||||
K.load(fs.readFileSync(path.join(__dirname, '../../..', f), 'utf8'));
|
||||
}
|
||||
|
||||
let passed = 0, failed = 0;
|
||||
function test(name, fn) {
|
||||
try {
|
||||
const result = fn();
|
||||
if (result === true) {
|
||||
passed++;
|
||||
} else {
|
||||
console.log(` FAIL: ${name} — got ${JSON.stringify(result)}`);
|
||||
failed++;
|
||||
}
|
||||
} catch (e) {
|
||||
console.log(` FAIL: ${name} — ${e.message || e}`);
|
||||
failed++;
|
||||
}
|
||||
}
|
||||
|
||||
// ================================================================
|
||||
// 1. Env binding / globals sync
|
||||
// ================================================================
|
||||
|
||||
test('define at top level visible to VM', () => {
|
||||
K.eval('(define _test-toplevel-1 42)');
|
||||
return K.evalVM('_test-toplevel-1') === 42;
|
||||
});
|
||||
|
||||
test('define in begin visible to VM', () => {
|
||||
K.eval('(begin (define _test-begin-1 99))');
|
||||
return K.evalVM('_test-begin-1') === 99;
|
||||
});
|
||||
|
||||
test('set! on global syncs to VM', () => {
|
||||
K.eval('(define _test-set-g 1)');
|
||||
K.eval('(set! _test-set-g 55)');
|
||||
return K.evalVM('_test-set-g') === 55;
|
||||
});
|
||||
|
||||
test('VM define syncs back to CEK', () => {
|
||||
K.evalVM('(define _test-vm-def 777)');
|
||||
return K.eval('_test-vm-def') === 777;
|
||||
});
|
||||
|
||||
test('CEK and VM see same value after multiple updates', () => {
|
||||
K.eval('(define _test-ping 0)');
|
||||
K.eval('(set! _test-ping 1)');
|
||||
K.evalVM('(set! _test-ping 2)');
|
||||
const cek = K.eval('_test-ping');
|
||||
const vm = K.evalVM('_test-ping');
|
||||
return cek === 2 && vm === 2;
|
||||
});
|
||||
|
||||
test('lambda defined at top level callable from VM', () => {
|
||||
K.eval('(define _test-top-fn (fn (x) (* x 10)))');
|
||||
return K.evalVM('(_test-top-fn 3)') === 30;
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// 2. Parse function (pages-sx format)
|
||||
// ================================================================
|
||||
|
||||
test('parse single dict', () => {
|
||||
const r = K.eval('(get (parse "{:name \\"home\\" :path \\"/\\"}") "name")');
|
||||
return r === 'home';
|
||||
});
|
||||
|
||||
test('parse multiple dicts returns list', () => {
|
||||
const r = K.eval('(len (parse "{:a 1}\\n{:b 2}\\n{:c 3}"))');
|
||||
return r === 3;
|
||||
});
|
||||
|
||||
test('parse single expr unwraps', () => {
|
||||
return K.eval('(type-of (parse "42"))') === 'number';
|
||||
});
|
||||
|
||||
test('parse multiple exprs returns list', () => {
|
||||
return K.eval('(type-of (parse "1 2 3"))') === 'list';
|
||||
});
|
||||
|
||||
test('parse dict with content string', () => {
|
||||
const r = K.eval('(get (parse "{:name \\"test\\" :content \\"(div \\\\\\\"hello\\\\\\\")\\" :has-data false}") "content")');
|
||||
return typeof r === 'string' && r.includes('div');
|
||||
});
|
||||
|
||||
test('parse dict with path param pattern', () => {
|
||||
const r = K.eval('(get (parse "{:path \\"/docs/<slug>\\"}") "path")');
|
||||
return r === '/docs/<slug>';
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// 3. Route pattern parsing (requires router.sx loaded)
|
||||
// ================================================================
|
||||
|
||||
// Load router module
|
||||
const routerSrc = fs.readFileSync(path.join(__dirname, '../../../web/router.sx'), 'utf8');
|
||||
K.load(routerSrc);
|
||||
|
||||
test('parse-route-pattern splits static path', () => {
|
||||
const r = K.eval('(len (parse-route-pattern "/docs/intro"))');
|
||||
return r === 2;
|
||||
});
|
||||
|
||||
test('parse-route-pattern detects param segments', () => {
|
||||
const r = K.eval('(get (nth (parse-route-pattern "/docs/<slug>") 1) "type")');
|
||||
return r === 'param';
|
||||
});
|
||||
|
||||
test('parse-route-pattern detects literal segments', () => {
|
||||
const r = K.eval('(get (first (parse-route-pattern "/docs/<slug>")) "type")');
|
||||
return r === 'literal';
|
||||
});
|
||||
|
||||
test('find-matching-route matches static path', () => {
|
||||
K.eval('(define _test-routes (list (merge {:name "home" :path "/"} {:parsed (parse-route-pattern "/")})))');
|
||||
const r = K.eval('(get (find-matching-route "/" _test-routes) "name")');
|
||||
return r === 'home';
|
||||
});
|
||||
|
||||
test('find-matching-route matches param path', () => {
|
||||
K.eval('(define _test-routes2 (list (merge {:name "doc" :path "/docs/<slug>"} {:parsed (parse-route-pattern "/docs/<slug>")})))');
|
||||
const r = K.eval('(get (find-matching-route "/docs/intro" _test-routes2) "name")');
|
||||
return r === 'doc';
|
||||
});
|
||||
|
||||
test('find-matching-route returns nil for no match', () => {
|
||||
return K.eval('(nil? (find-matching-route "/unknown" _test-routes))') === true;
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// 4. Click handler preventDefault pattern
|
||||
// ================================================================
|
||||
|
||||
// Register host FFI primitives (normally done by sx-platform.js)
|
||||
K.registerNative("host-global", function(args) {
|
||||
var name = args[0];
|
||||
return (typeof name === 'string') ? globalThis[name] : undefined;
|
||||
});
|
||||
K.registerNative("host-get", function(args) {
|
||||
var obj = args[0], key = args[1];
|
||||
if (obj == null) return null;
|
||||
var v = obj[key];
|
||||
return v === undefined ? null : v;
|
||||
});
|
||||
K.registerNative("host-call", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = args.slice(2);
|
||||
if (obj == null || typeof obj[method] !== 'function') return null;
|
||||
try { return obj[method].apply(obj, callArgs); } catch(e) { return null; }
|
||||
});
|
||||
K.registerNative("host-set!", function(args) {
|
||||
var obj = args[0], key = args[1], val = args[2];
|
||||
if (obj != null) obj[key] = val;
|
||||
return null;
|
||||
});
|
||||
|
||||
test('host-call preventDefault on mock event', () => {
|
||||
let prevented = false;
|
||||
globalThis._testMockEvent = {
|
||||
preventDefault: () => { prevented = true; },
|
||||
type: 'click',
|
||||
target: { tagName: 'A', getAttribute: () => '/test' }
|
||||
};
|
||||
K.eval('(host-call (host-global "_testMockEvent") "preventDefault")');
|
||||
delete globalThis._testMockEvent;
|
||||
return prevented === true;
|
||||
});
|
||||
|
||||
test('host-get reads property from JS object', () => {
|
||||
globalThis._testObj = { foo: 42 };
|
||||
const r = K.eval('(host-get (host-global "_testObj") "foo")');
|
||||
delete globalThis._testObj;
|
||||
return r === 42;
|
||||
});
|
||||
|
||||
test('host-set! writes property on JS object', () => {
|
||||
globalThis._testObj2 = { val: 0 };
|
||||
K.eval('(host-set! (host-global "_testObj2") "val" 99)');
|
||||
const r = globalThis._testObj2.val;
|
||||
delete globalThis._testObj2;
|
||||
return r === 99;
|
||||
});
|
||||
|
||||
test('click handler pattern: check target, prevent, navigate', () => {
|
||||
let prevented = false;
|
||||
let navigated = null;
|
||||
globalThis._testClickEvent = {
|
||||
preventDefault: () => { prevented = true; },
|
||||
type: 'click',
|
||||
target: { tagName: 'A', href: '/about' }
|
||||
};
|
||||
globalThis._testNavigate = (url) => { navigated = url; };
|
||||
|
||||
K.eval(`
|
||||
(let ((e (host-global "_testClickEvent")))
|
||||
(let ((tag (host-get (host-get e "target") "tagName")))
|
||||
(when (= tag "A")
|
||||
(host-call e "preventDefault")
|
||||
(host-call (host-global "_testNavigate") "call" nil
|
||||
(host-get (host-get e "target") "href")))))
|
||||
`);
|
||||
|
||||
delete globalThis._testClickEvent;
|
||||
delete globalThis._testNavigate;
|
||||
return prevented === true && navigated === '/about';
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// 5. Iterative cek_run — deep evaluation without stack overflow
|
||||
// ================================================================
|
||||
|
||||
test('deep recursion via foldl (100 iterations)', () => {
|
||||
const r = K.eval('(reduce + 0 (map (fn (x) x) (list ' +
|
||||
Array.from({length: 100}, (_, i) => i + 1).join(' ') + ')))');
|
||||
return r === 5050;
|
||||
});
|
||||
|
||||
test('deeply nested let bindings', () => {
|
||||
// Build (let ((x0 0)) (let ((x1 (+ x0 1))) ... (let ((xN (+ xN-1 1))) xN)))
|
||||
let expr = 'x49';
|
||||
for (let i = 49; i >= 0; i--) {
|
||||
const prev = i === 0 ? '0' : `(+ x${i-1} 1)`;
|
||||
expr = `(let ((x${i} ${prev})) ${expr})`;
|
||||
}
|
||||
return K.eval(expr) === 49;
|
||||
});
|
||||
|
||||
// ================================================================
|
||||
// Results
|
||||
// ================================================================
|
||||
|
||||
console.log(`\n${passed} passed, ${failed} failed`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
18
hosts/ocaml/browser/test_page_render.js
Normal file
18
hosts/ocaml/browser/test_page_render.js
Normal file
@@ -0,0 +1,18 @@
|
||||
const path = require("path");
|
||||
const fs = require("fs");
|
||||
require(path.join(__dirname, "../_build/default/browser/sx_browser.bc.js"));
|
||||
require(path.join(__dirname, "sx-platform.js"));
|
||||
const K = globalThis.SxKernel;
|
||||
for (const n of ["signals","deps","page-helpers","router","adapter-html"])
|
||||
K.loadSource(fs.readFileSync(path.join(__dirname,`../../../web/${n}.sx`),"utf8"));
|
||||
K.loadSource(fs.readFileSync("/tmp/comp_defs.txt","utf8"));
|
||||
|
||||
const pageSx = fs.readFileSync("/tmp/page_sx.txt","utf8");
|
||||
const parsed = K.parse(pageSx);
|
||||
const html = K.renderToHtml(parsed[0]);
|
||||
if (typeof html === "string" && !html.startsWith("Error:")) {
|
||||
console.log("SUCCESS! Rendered", html.length, "chars of HTML");
|
||||
console.log("Preview:", html.substring(0, 200));
|
||||
} else {
|
||||
console.log("Error:", html);
|
||||
}
|
||||
134
hosts/ocaml/browser/test_platform.js
Normal file
134
hosts/ocaml/browser/test_platform.js
Normal file
@@ -0,0 +1,134 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test the full WASM + platform stack in Node.
|
||||
* Loads the kernel, registers FFI stubs, loads .sx web files.
|
||||
*/
|
||||
const path = require('path');
|
||||
const fs = require('fs');
|
||||
|
||||
// Load js_of_ocaml kernel (WASM needs browser; JS works in Node)
|
||||
require(path.join(__dirname, '../_build/default/browser/sx_browser.bc.js'));
|
||||
|
||||
const K = globalThis.SxKernel;
|
||||
console.log('Engine:', K.engine());
|
||||
|
||||
// Register FFI stubs (no real DOM in Node, but the primitives must exist)
|
||||
K.registerNative("host-global", (args) => {
|
||||
const name = args[0];
|
||||
return globalThis[name] || null;
|
||||
});
|
||||
K.registerNative("host-get", (args) => {
|
||||
const [obj, prop] = args;
|
||||
if (obj == null) return null;
|
||||
const v = obj[prop];
|
||||
return v === undefined ? null : v;
|
||||
});
|
||||
K.registerNative("host-set!", (args) => {
|
||||
const [obj, prop, val] = args;
|
||||
if (obj != null) obj[prop] = val;
|
||||
});
|
||||
K.registerNative("host-call", (args) => {
|
||||
const [obj, method, ...rest] = args;
|
||||
if (obj == null) return null;
|
||||
if (typeof obj[method] === 'function') {
|
||||
try { return obj[method].apply(obj, rest); } catch(e) { return null; }
|
||||
}
|
||||
return null;
|
||||
});
|
||||
K.registerNative("host-new", (args) => null);
|
||||
K.registerNative("host-callback", (args) => {
|
||||
const fn = args[0];
|
||||
if (typeof fn === 'function') return fn;
|
||||
if (fn && fn.__sx_handle !== undefined)
|
||||
return (...a) => K.callFn(fn, a);
|
||||
return () => {};
|
||||
});
|
||||
K.registerNative("host-typeof", (args) => {
|
||||
const obj = args[0];
|
||||
if (obj == null) return "nil";
|
||||
return typeof obj;
|
||||
});
|
||||
K.registerNative("host-await", (args) => {
|
||||
const [promise, callback] = args;
|
||||
if (promise && typeof promise.then === 'function') {
|
||||
const cb = typeof callback === 'function' ? callback :
|
||||
(callback && callback.__sx_handle !== undefined) ?
|
||||
(v) => K.callFn(callback, [v]) : () => {};
|
||||
promise.then(cb);
|
||||
}
|
||||
});
|
||||
|
||||
// Load .sx web files in order
|
||||
const root = path.join(__dirname, '../../..');
|
||||
const sxFiles = [
|
||||
'spec/render.sx', // HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS, parse-element-args
|
||||
'web/signals.sx',
|
||||
'web/deps.sx',
|
||||
'web/router.sx',
|
||||
'web/page-helpers.sx',
|
||||
'lib/bytecode.sx',
|
||||
'lib/compiler.sx',
|
||||
'lib/vm.sx',
|
||||
'web/lib/dom.sx',
|
||||
'web/lib/browser.sx',
|
||||
'web/adapter-html.sx',
|
||||
'web/adapter-sx.sx',
|
||||
// Skip adapter-dom.sx, engine.sx, orchestration.sx, boot.sx — need real DOM
|
||||
];
|
||||
|
||||
let totalExprs = 0;
|
||||
for (const f of sxFiles) {
|
||||
const src = fs.readFileSync(path.join(root, f), 'utf8');
|
||||
const result = K.load(src);
|
||||
if (typeof result === 'string' && result.startsWith('Error')) {
|
||||
console.error(` FAIL loading ${f}: ${result}`);
|
||||
process.exit(1);
|
||||
}
|
||||
totalExprs += (typeof result === 'number' ? result : 0);
|
||||
}
|
||||
console.log(`Loaded ${totalExprs} expressions from ${sxFiles.length} .sx files`);
|
||||
|
||||
// Test the loaded stack
|
||||
const tests = [
|
||||
// Signals
|
||||
['(let ((s (signal 0))) (reset! s 42) (deref s))', 42],
|
||||
['(let ((s (signal 10))) (swap! s inc) (deref s))', 11],
|
||||
// Computed
|
||||
['(let ((a (signal 2)) (b (computed (fn () (* (deref a) 3))))) (deref b))', 6],
|
||||
// Render (OCaml renderer uses XHTML-style void tags)
|
||||
['(render-to-html (quote (div :class "foo" "bar")))', '<div class="foo">bar</div>'],
|
||||
['(render-to-html (quote (br)))', '<br />'],
|
||||
// Compiler + VM
|
||||
['(let ((c (compile (quote (+ 1 2))))) (get c "bytecode"))', { check: v => v && v._type === 'list' }],
|
||||
// dom.sx loaded (functions exist even without real DOM)
|
||||
['(type-of dom-create-element)', 'lambda'],
|
||||
['(type-of dom-listen)', 'lambda'],
|
||||
// browser.sx loaded
|
||||
['(type-of console-log)', 'lambda'],
|
||||
];
|
||||
|
||||
let passed = 0, failed = 0;
|
||||
for (const [expr, expected] of tests) {
|
||||
try {
|
||||
const result = K.eval(expr);
|
||||
let ok;
|
||||
if (expected && typeof expected === 'object' && expected.check) {
|
||||
ok = expected.check(result);
|
||||
} else {
|
||||
ok = result === expected;
|
||||
}
|
||||
if (ok) {
|
||||
passed++;
|
||||
} else {
|
||||
console.log(` FAIL: ${expr}`);
|
||||
console.log(` got: ${JSON.stringify(result)}, expected: ${JSON.stringify(expected)}`);
|
||||
failed++;
|
||||
}
|
||||
} catch(e) {
|
||||
console.log(` ERROR: ${expr}: ${e.message || e}`);
|
||||
failed++;
|
||||
}
|
||||
}
|
||||
|
||||
console.log(`\n${passed} passed, ${failed} failed`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
25
hosts/ocaml/browser/test_signals.js
Normal file
25
hosts/ocaml/browser/test_signals.js
Normal file
@@ -0,0 +1,25 @@
|
||||
const path = require("path");
|
||||
const fs = require("fs");
|
||||
require(path.join(__dirname, "../_build/default/browser/sx_browser.bc.js"));
|
||||
require(path.join(__dirname, "sx-platform.js"));
|
||||
const K = globalThis.SxKernel;
|
||||
for (const n of ["signals","deps","page-helpers","router","adapter-html"])
|
||||
K.loadSource(fs.readFileSync(path.join(__dirname,`../../../web/${n}.sx`),"utf8"));
|
||||
|
||||
// Test signal basics
|
||||
const tests = [
|
||||
'(signal 42)',
|
||||
'(let ((s (signal 42))) (deref s))',
|
||||
'(let ((s (signal 42))) (reset! s 100) (deref s))',
|
||||
'(let ((s (signal 10))) (swap! s (fn (v) (* v 2))) (deref s))',
|
||||
'(let ((s (signal 0))) (computed (fn () (+ (deref s) 1))))',
|
||||
'(let ((idx (signal 0))) (let ((c (computed (fn () (+ (deref idx) 10))))) (deref c)))',
|
||||
];
|
||||
|
||||
for (const t of tests) {
|
||||
const r = K.eval(t);
|
||||
const s = JSON.stringify(r);
|
||||
console.log(`${t.substring(0,60)}`);
|
||||
console.log(` => ${s && s.length > 100 ? s.substring(0,100) + '...' : s}`);
|
||||
console.log();
|
||||
}
|
||||
73
hosts/ocaml/browser/test_wasm.js
Normal file
73
hosts/ocaml/browser/test_wasm.js
Normal file
@@ -0,0 +1,73 @@
|
||||
#!/usr/bin/env node
|
||||
// Test WASM build of SX kernel
|
||||
const path = require('path');
|
||||
const build_dir = path.join(__dirname, '../_build/default/browser');
|
||||
|
||||
async function main() {
|
||||
// Load WASM module — require.main.filename must point to build dir
|
||||
// so the WASM loader finds .wasm assets via path.dirname(require.main.filename)
|
||||
require.main.filename = path.join(build_dir, 'test_wasm.js');
|
||||
require(path.join(build_dir, 'sx_browser.bc.wasm.js'));
|
||||
|
||||
// Wait for WASM init
|
||||
await new Promise(r => setTimeout(r, 2000));
|
||||
|
||||
const sx = globalThis.SxKernel;
|
||||
if (!sx) {
|
||||
console.error('FAIL: SxKernel not available');
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
console.log('Engine:', sx.engine());
|
||||
|
||||
// Basic tests
|
||||
const tests = [
|
||||
['(+ 1 2)', 3],
|
||||
['(- 10 3)', 7],
|
||||
['(* 6 7)', 42],
|
||||
['(/ 10 2)', 5],
|
||||
['(= 5 5)', true],
|
||||
['(< 3 5)', true],
|
||||
['(> 5 3)', true],
|
||||
['(not false)', true],
|
||||
['(inc 5)', 6],
|
||||
['(dec 5)', 4],
|
||||
['(len (list 1 2 3))', 3],
|
||||
['(len "hello")', 5],
|
||||
['(first (list 10 20))', 10],
|
||||
['(nth "hello" 0)', 'h'],
|
||||
['(nth "hello" 4)', 'o'],
|
||||
['(str "a" "b")', 'ab'],
|
||||
['(join ", " (list "a" "b" "c"))', 'a, b, c'],
|
||||
['(let ((x 10) (y 20)) (+ x y))', 30],
|
||||
['(if true "yes" "no")', 'yes'],
|
||||
['(cond (= 1 2) "one" :else "other")', 'other'],
|
||||
['(case 2 1 "one" 2 "two" :else "other")', 'two'],
|
||||
['(render-to-html (list (quote div) "hello"))', '<div>hello</div>'],
|
||||
['(render-to-html (list (quote span) (list (quote b) "bold")))', '<span><b>bold</b></span>'],
|
||||
['(let ((add (fn (a b) (+ a b)))) (add 3 4))', 7],
|
||||
['(let ((x 10)) (let ((f (fn () x))) (f)))', 10],
|
||||
['(len (filter (fn (x) (> x 2)) (list 1 2 3 4 5)))', 3],
|
||||
['(let ((fact (fn (n) (if (<= n 1) 1 (* n (fact (- n 1))))))) (fact 5))', 120],
|
||||
];
|
||||
|
||||
let passed = 0, failed = 0;
|
||||
for (const [expr, expected] of tests) {
|
||||
const result = sx.eval(expr);
|
||||
const ok = typeof expected === 'object'
|
||||
? result && result._type === expected._type
|
||||
: result === expected;
|
||||
if (ok) {
|
||||
console.log(` PASS: ${expr} = ${JSON.stringify(result)}`);
|
||||
passed++;
|
||||
} else {
|
||||
console.log(` FAIL: ${expr} = ${JSON.stringify(result)} (expected ${JSON.stringify(expected)})`);
|
||||
failed++;
|
||||
}
|
||||
}
|
||||
|
||||
console.log(`\n${passed} passed, ${failed} failed`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
}
|
||||
|
||||
main().catch(e => { console.error(e); process.exit(1); });
|
||||
307
hosts/ocaml/browser/test_wasm.sh
Executable file
307
hosts/ocaml/browser/test_wasm.sh
Executable file
@@ -0,0 +1,307 @@
|
||||
#!/bin/bash
|
||||
# WASM kernel tests in Node.js — verifies the compiled sx_browser.bc.js
|
||||
# handles HTML tags, rendering, signals, and components correctly.
|
||||
# Does NOT require a running server or browser.
|
||||
set -euo pipefail
|
||||
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
node -e '
|
||||
// --- DOM stubs that track state ---
|
||||
function makeElement(tag) {
|
||||
var el = {
|
||||
tagName: tag,
|
||||
_attrs: {},
|
||||
_children: [],
|
||||
style: {},
|
||||
childNodes: [],
|
||||
children: [],
|
||||
textContent: "",
|
||||
setAttribute: function(k, v) { el._attrs[k] = v; },
|
||||
getAttribute: function(k) { return el._attrs[k] || null; },
|
||||
removeAttribute: function(k) { delete el._attrs[k]; },
|
||||
appendChild: function(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||
insertBefore: function(c, ref) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||
removeChild: function(c) { return c; },
|
||||
replaceChild: function(n, o) { return n; },
|
||||
cloneNode: function() { return makeElement(tag); },
|
||||
addEventListener: function() {},
|
||||
removeEventListener: function() {},
|
||||
dispatchEvent: function() {},
|
||||
get innerHTML() {
|
||||
// Reconstruct from children for simple cases
|
||||
return el._children.map(function(c) {
|
||||
if (c._isText) return c.textContent || "";
|
||||
if (c._isComment) return "<!--" + (c.textContent || "") + "-->";
|
||||
return c.outerHTML || "";
|
||||
}).join("");
|
||||
},
|
||||
set innerHTML(v) { el._children = []; el.childNodes = []; el.children = []; el.textContent = v; },
|
||||
get outerHTML() {
|
||||
var s = "<" + tag;
|
||||
var keys = Object.keys(el._attrs).sort();
|
||||
for (var i = 0; i < keys.length; i++) {
|
||||
s += " " + keys[i] + "=\"" + el._attrs[keys[i]] + "\"";
|
||||
}
|
||||
s += ">";
|
||||
var voids = ["br","hr","img","input","meta","link"];
|
||||
if (voids.indexOf(tag) >= 0) return s;
|
||||
s += el.innerHTML;
|
||||
s += "</" + tag + ">";
|
||||
return s;
|
||||
},
|
||||
dataset: new Proxy({}, {
|
||||
get: function(t, k) { return el._attrs["data-" + k.replace(/[A-Z]/g, function(c) { return "-" + c.toLowerCase(); })]; },
|
||||
set: function(t, k, v) { el._attrs["data-" + k.replace(/[A-Z]/g, function(c) { return "-" + c.toLowerCase(); })] = v; return true; }
|
||||
}),
|
||||
querySelectorAll: function() { return []; },
|
||||
querySelector: function() { return null; },
|
||||
};
|
||||
return el;
|
||||
}
|
||||
|
||||
global.window = global;
|
||||
global.document = {
|
||||
createElement: makeElement,
|
||||
createDocumentFragment: function() {
|
||||
var f = makeElement("fragment");
|
||||
f.tagName = undefined;
|
||||
return f;
|
||||
},
|
||||
head: makeElement("head"),
|
||||
body: makeElement("body"),
|
||||
querySelector: function() { return null; },
|
||||
querySelectorAll: function() { return []; },
|
||||
createTextNode: function(s) { return {_isText:true, textContent:String(s), nodeType:3}; },
|
||||
addEventListener: function() {},
|
||||
createComment: function(s) { return {_isComment:true, textContent:s||"", nodeType:8}; },
|
||||
getElementsByTagName: function() { return []; },
|
||||
};
|
||||
global.localStorage = {getItem:function(){return null},setItem:function(){},removeItem:function(){}};
|
||||
global.CustomEvent = class { constructor(n,o){this.type=n;this.detail=(o||{}).detail||{}} };
|
||||
global.MutationObserver = class { observe(){} disconnect(){} };
|
||||
global.requestIdleCallback = function(fn) { return setTimeout(fn,0); };
|
||||
global.matchMedia = function() { return {matches:false}; };
|
||||
global.navigator = {serviceWorker:{register:function(){return Promise.resolve()}}};
|
||||
global.location = {href:"",pathname:"/",hostname:"localhost"};
|
||||
global.history = {pushState:function(){},replaceState:function(){}};
|
||||
global.fetch = function() { return Promise.resolve({ok:true,text:function(){return Promise.resolve("")}}); };
|
||||
global.setTimeout = setTimeout;
|
||||
global.clearTimeout = clearTimeout;
|
||||
global.XMLHttpRequest = class { open(){} send(){} };
|
||||
|
||||
// --- Load kernel ---
|
||||
require("./shared/static/wasm/sx_browser.bc.js");
|
||||
var K = globalThis.SxKernel;
|
||||
if (!K) { console.error("FAIL: SxKernel not found"); process.exit(1); }
|
||||
|
||||
// --- Register 8 FFI host primitives (normally done by sx-platform.js) ---
|
||||
K.registerNative("host-global", function(args) {
|
||||
var name = args[0];
|
||||
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
|
||||
return null;
|
||||
});
|
||||
K.registerNative("host-get", function(args) {
|
||||
var obj = args[0], prop = args[1];
|
||||
if (obj == null) return null;
|
||||
var v = obj[prop];
|
||||
return v === undefined ? null : v;
|
||||
});
|
||||
K.registerNative("host-set!", function(args) {
|
||||
var obj = args[0], prop = args[1], val = args[2];
|
||||
if (obj != null) obj[prop] = val;
|
||||
return val;
|
||||
});
|
||||
K.registerNative("host-call", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = args.slice(2);
|
||||
if (obj == null || typeof obj[method] !== "function") return null;
|
||||
var r = obj[method].apply(obj, callArgs);
|
||||
return r === undefined ? null : r;
|
||||
});
|
||||
K.registerNative("host-new", function(args) {
|
||||
var ctor = args[0];
|
||||
var ctorArgs = args.slice(1);
|
||||
return new (Function.prototype.bind.apply(ctor, [null].concat(ctorArgs)));
|
||||
});
|
||||
K.registerNative("host-callback", function(args) {
|
||||
var fn = args[0];
|
||||
return function() { return K.callFn(fn, Array.from(arguments)); };
|
||||
});
|
||||
K.registerNative("host-typeof", function(args) {
|
||||
return typeof args[0];
|
||||
});
|
||||
K.registerNative("host-await", function(args) { return args[0]; });
|
||||
|
||||
// Platform constants
|
||||
K.eval("(define SX_VERSION \"test-1.0\")");
|
||||
K.eval("(define SX_ENGINE \"ocaml-vm-test\")");
|
||||
K.eval("(define parse sx-parse)");
|
||||
K.eval("(define serialize sx-serialize)");
|
||||
|
||||
var pass = 0, fail = 0;
|
||||
function assert(name, got, expected) {
|
||||
if (got === expected) { pass++; }
|
||||
else { fail++; console.error("FAIL: " + name + "\n got: " + JSON.stringify(got) + "\n expected: " + JSON.stringify(expected)); }
|
||||
}
|
||||
function assertIncludes(name, got, substr) {
|
||||
if (typeof got === "string" && got.includes(substr)) { pass++; }
|
||||
else { fail++; console.error("FAIL: " + name + "\n got: " + JSON.stringify(got) + "\n expected to include: " + JSON.stringify(substr)); }
|
||||
}
|
||||
function assertNotError(name, got) {
|
||||
if (typeof got === "string" && got.startsWith("Error:")) { fail++; console.error("FAIL: " + name + ": " + got); }
|
||||
else { pass++; }
|
||||
}
|
||||
|
||||
// =====================================================================
|
||||
// Section 1: HTML tags and rendering
|
||||
// =====================================================================
|
||||
|
||||
assert("arithmetic", K.eval("(+ 1 2)"), 3);
|
||||
assert("string", K.eval("(str \"hello\" \" world\")"), "hello world");
|
||||
|
||||
// Tags as special forms — keywords preserved
|
||||
assert("div preserves keywords",
|
||||
K.eval("(inspect (div :class \"test\" \"hello\"))"),
|
||||
"(div :class \"test\" \"hello\")");
|
||||
|
||||
assert("span preserves keywords",
|
||||
K.eval("(inspect (span :id \"x\" \"content\"))"),
|
||||
"(span :id \"x\" \"content\")");
|
||||
|
||||
// render-to-html
|
||||
assert("render div+class", K.eval("(render-to-html (div :class \"card\" \"content\"))"), "<div class=\"card\">content</div>");
|
||||
assert("render h1+class", K.eval("(render-to-html (h1 :class \"title\" \"Hello\"))"), "<h1 class=\"title\">Hello</h1>");
|
||||
assert("render a+href", K.eval("(render-to-html (a :href \"/about\" \"About\"))"), "<a href=\"/about\">About</a>");
|
||||
assert("render nested", K.eval("(render-to-html (div :class \"outer\" (span :class \"inner\" \"text\")))"), "<div class=\"outer\"><span class=\"inner\">text</span></div>");
|
||||
assertIncludes("void element br", K.eval("(render-to-html (br))"), "br");
|
||||
|
||||
// Component rendering
|
||||
K.eval("(defcomp ~test-card (&key title) (div :class \"card\" (h2 title)))");
|
||||
assert("component render", K.eval("(render-to-html (~test-card :title \"Hello\"))"), "<div class=\"card\"><h2>Hello</h2></div>");
|
||||
|
||||
K.eval("(defcomp ~test-wrap (&key label) (div :class \"wrap\" (span label)))");
|
||||
assert("component nested", K.eval("(render-to-html (~test-wrap :label \"hi\"))"), "<div class=\"wrap\"><span>hi</span></div>");
|
||||
|
||||
// Core primitives
|
||||
assert("list length", K.eval("(list 1 2 3)").items.length, 3);
|
||||
assert("first", K.eval("(first (list 1 2 3))"), 1);
|
||||
assert("len", K.eval("(len (list 1 2 3))"), 3);
|
||||
assert("map", K.eval("(len (map (fn (x) (+ x 1)) (list 1 2 3)))"), 3);
|
||||
|
||||
// HTML tag registry
|
||||
assertNotError("HTML_TAGS defined", K.eval("(type-of HTML_TAGS)"));
|
||||
assert("is-html-tag? div", K.eval("(is-html-tag? \"div\")"), true);
|
||||
assert("is-html-tag? fake", K.eval("(is-html-tag? \"fake\")"), false);
|
||||
|
||||
// =====================================================================
|
||||
// Load web stack modules (same as sx-platform.js loadWebStack)
|
||||
// =====================================================================
|
||||
var fs = require("fs");
|
||||
var webStackFiles = [
|
||||
"shared/static/wasm/sx/render.sx",
|
||||
"shared/static/wasm/sx/core-signals.sx",
|
||||
"shared/static/wasm/sx/signals.sx",
|
||||
"shared/static/wasm/sx/deps.sx",
|
||||
"shared/static/wasm/sx/router.sx",
|
||||
"shared/static/wasm/sx/page-helpers.sx",
|
||||
"shared/static/wasm/sx/freeze.sx",
|
||||
"shared/static/wasm/sx/dom.sx",
|
||||
"shared/static/wasm/sx/browser.sx",
|
||||
"shared/static/wasm/sx/adapter-html.sx",
|
||||
"shared/static/wasm/sx/adapter-sx.sx",
|
||||
"shared/static/wasm/sx/adapter-dom.sx",
|
||||
"shared/static/wasm/sx/boot-helpers.sx",
|
||||
"shared/static/wasm/sx/hypersx.sx",
|
||||
"shared/static/wasm/sx/engine.sx",
|
||||
"shared/static/wasm/sx/orchestration.sx",
|
||||
"shared/static/wasm/sx/boot.sx",
|
||||
];
|
||||
var loadFails = [];
|
||||
var useBytecode = process.env.SX_TEST_BYTECODE === "1";
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
for (var i = 0; i < webStackFiles.length; i++) {
|
||||
var loaded = false;
|
||||
if (useBytecode) {
|
||||
var bcPath = webStackFiles[i].replace(/\.sx$/, ".sxbc");
|
||||
try {
|
||||
var bcSrc = fs.readFileSync(bcPath, "utf8");
|
||||
global.__sxbcText = bcSrc;
|
||||
var bcResult = K.eval("(load-sxbc (first (parse (host-global \"__sxbcText\"))))");
|
||||
delete global.__sxbcText;
|
||||
if (typeof bcResult !== "string" || !bcResult.startsWith("Error")) {
|
||||
loaded = true;
|
||||
} else {
|
||||
loadFails.push(bcPath + " (sxbc): " + bcResult);
|
||||
}
|
||||
} catch(e) { delete global.__sxbcText; }
|
||||
}
|
||||
if (!loaded) {
|
||||
var src = fs.readFileSync(webStackFiles[i], "utf8");
|
||||
var r = K.load(src);
|
||||
if (typeof r === "string" && r.startsWith("Error")) {
|
||||
loadFails.push(webStackFiles[i] + ": " + r);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
if (loadFails.length > 0) {
|
||||
console.error("Module load failures:");
|
||||
loadFails.forEach(function(f) { console.error(" " + f); });
|
||||
}
|
||||
|
||||
// =====================================================================
|
||||
// Section 2: render-to-dom (requires working DOM stubs)
|
||||
// All DOM results are host objects — use host-get/dom-get-attr from SX
|
||||
// =====================================================================
|
||||
|
||||
// Basic DOM rendering
|
||||
assert("dom tagName",
|
||||
K.eval("(host-get (render-to-dom (div :class \"test\" \"hello\") (global-env) nil) \"tagName\")"),
|
||||
"div");
|
||||
assert("dom class attr",
|
||||
K.eval("(dom-get-attr (render-to-dom (div :class \"test\" \"hello\") (global-env) nil) \"class\")"),
|
||||
"test");
|
||||
assertIncludes("dom outerHTML",
|
||||
K.eval("(host-get (render-to-dom (div :class \"test\" \"hello\") (global-env) nil) \"outerHTML\")"),
|
||||
"hello");
|
||||
|
||||
// Nested DOM rendering
|
||||
assertIncludes("nested dom outerHTML",
|
||||
K.eval("(host-get (render-to-dom (div :class \"outer\" (span :id \"inner\" \"text\")) (global-env) nil) \"outerHTML\")"),
|
||||
"class=\"outer\"");
|
||||
|
||||
// =====================================================================
|
||||
// Section 3: Reactive rendering — with-island-scope + deref
|
||||
// This is the critical test for the hydration bug.
|
||||
// with-island-scope should NOT strip attributes.
|
||||
// =====================================================================
|
||||
|
||||
// 3a. with-island-scope should preserve static attributes
|
||||
assert("scoped static class",
|
||||
K.eval("(dom-get-attr (let ((d (list))) (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (div :class \"scoped\" \"text\") (global-env) nil)))) \"class\")"),
|
||||
"scoped");
|
||||
|
||||
// 3b. Signal deref in text position should render initial value
|
||||
assertIncludes("signal text initial value",
|
||||
K.eval("(host-get (let ((s (signal 42)) (d (list))) (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (div (deref s)) (global-env) nil)))) \"outerHTML\")"),
|
||||
"42");
|
||||
|
||||
// 3c. Signal deref in attribute position should set initial value
|
||||
assert("signal attr initial value",
|
||||
K.eval("(dom-get-attr (let ((s (signal \"active\")) (d (list))) (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (div :class (deref s) \"content\") (global-env) nil)))) \"class\")"),
|
||||
"active");
|
||||
|
||||
// 3d. After signal update, reactive DOM should update
|
||||
// render-to-dom needs unevaluated expr (as in real browser boot from parsed source)
|
||||
K.eval("(define test-reactive-sig (signal \"before\"))");
|
||||
assert("reactive attr update",
|
||||
K.eval("(let ((d (list))) (let ((el (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (quote (div :class (deref test-reactive-sig) \"content\")) (global-env) nil))))) (reset! test-reactive-sig \"after\") (dom-get-attr el \"class\")))"),
|
||||
"after");
|
||||
|
||||
// =====================================================================
|
||||
// Summary
|
||||
// =====================================================================
|
||||
console.log("WASM kernel tests: " + pass + " passed, " + fail + " failed");
|
||||
if (fail > 0) process.exit(1);
|
||||
'
|
||||
187
hosts/ocaml/browser/test_wasm_native.js
Normal file
187
hosts/ocaml/browser/test_wasm_native.js
Normal file
@@ -0,0 +1,187 @@
|
||||
#!/usr/bin/env node
|
||||
// test_wasm_native.js — Run WASM kernel tests in Node.js using the actual
|
||||
// WASM binary (not js_of_ocaml JS fallback). Tests are SX deftest forms
|
||||
// in web/tests/test-wasm-browser.sx.
|
||||
//
|
||||
// Usage: node hosts/ocaml/browser/test_wasm_native.js
|
||||
// SX_TEST_BYTECODE=1 node hosts/ocaml/browser/test_wasm_native.js
|
||||
|
||||
const fs = require('fs');
|
||||
const path = require('path');
|
||||
|
||||
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
|
||||
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
|
||||
|
||||
// --- DOM stubs ---
|
||||
function makeElement(tag) {
|
||||
const el = {
|
||||
tagName: tag, _attrs: {}, _children: [], style: {},
|
||||
childNodes: [], children: [], textContent: '',
|
||||
nodeType: 1,
|
||||
setAttribute(k, v) { el._attrs[k] = String(v); },
|
||||
getAttribute(k) { return el._attrs[k] || null; },
|
||||
removeAttribute(k) { delete el._attrs[k]; },
|
||||
appendChild(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||
insertBefore(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
|
||||
removeChild(c) { return c; },
|
||||
replaceChild(n) { return n; },
|
||||
cloneNode() { return makeElement(tag); },
|
||||
addEventListener() {}, removeEventListener() {}, dispatchEvent() {},
|
||||
get innerHTML() {
|
||||
return el._children.map(c => {
|
||||
if (c._isText) return c.textContent || '';
|
||||
if (c._isComment) return '<!--' + (c.textContent || '') + '-->';
|
||||
return c.outerHTML || '';
|
||||
}).join('');
|
||||
},
|
||||
set innerHTML(v) { el._children = []; el.childNodes = []; el.children = []; },
|
||||
get outerHTML() {
|
||||
let s = '<' + tag;
|
||||
for (const k of Object.keys(el._attrs).sort()) s += ` ${k}="${el._attrs[k]}"`;
|
||||
s += '>';
|
||||
if (['br','hr','img','input','meta','link'].includes(tag)) return s;
|
||||
return s + el.innerHTML + '</' + tag + '>';
|
||||
},
|
||||
dataset: new Proxy({}, {
|
||||
get(_, k) { return el._attrs['data-' + k.replace(/[A-Z]/g, c => '-' + c.toLowerCase())]; },
|
||||
set(_, k, v) { el._attrs['data-' + k.replace(/[A-Z]/g, c => '-' + c.toLowerCase())] = v; return true; }
|
||||
}),
|
||||
querySelectorAll() { return []; },
|
||||
querySelector() { return null; },
|
||||
};
|
||||
return el;
|
||||
}
|
||||
|
||||
global.window = global;
|
||||
global.document = {
|
||||
createElement: makeElement,
|
||||
createDocumentFragment() { return makeElement('fragment'); },
|
||||
head: makeElement('head'), body: makeElement('body'),
|
||||
querySelector() { return null; }, querySelectorAll() { return []; },
|
||||
createTextNode(s) { return { _isText: true, textContent: String(s), nodeType: 3 }; },
|
||||
addEventListener() {},
|
||||
createComment(s) { return { _isComment: true, textContent: s || '', nodeType: 8 }; },
|
||||
getElementsByTagName() { return []; },
|
||||
};
|
||||
global.localStorage = { getItem() { return null; }, setItem() {}, removeItem() {} };
|
||||
global.CustomEvent = class { constructor(n, o) { this.type = n; this.detail = (o || {}).detail || {}; } };
|
||||
global.MutationObserver = class { observe() {} disconnect() {} };
|
||||
global.requestIdleCallback = fn => setTimeout(fn, 0);
|
||||
global.matchMedia = () => ({ matches: false });
|
||||
global.navigator = { serviceWorker: { register() { return Promise.resolve(); } } };
|
||||
global.location = { href: '', pathname: '/', hostname: 'localhost' };
|
||||
global.history = { pushState() {}, replaceState() {} };
|
||||
global.fetch = () => Promise.resolve({ ok: true, text() { return Promise.resolve(''); } });
|
||||
global.XMLHttpRequest = class { open() {} send() {} };
|
||||
|
||||
// --- Load WASM kernel ---
|
||||
async function main() {
|
||||
// The WASM loader sets globalThis.SxKernel after async init
|
||||
require(path.join(WASM_DIR, 'sx_browser.bc.wasm.js'));
|
||||
|
||||
// Poll for SxKernel (WASM init is async)
|
||||
const K = await new Promise((resolve, reject) => {
|
||||
let tries = 0;
|
||||
const poll = setInterval(() => {
|
||||
if (globalThis.SxKernel) { clearInterval(poll); resolve(globalThis.SxKernel); }
|
||||
else if (++tries > 200) { clearInterval(poll); reject(new Error('SxKernel not found after 10s')); }
|
||||
}, 50);
|
||||
});
|
||||
|
||||
console.log('WASM kernel loaded (native WASM, not JS fallback)');
|
||||
|
||||
// --- Register 8 FFI host primitives ---
|
||||
K.registerNative('host-global', args => {
|
||||
const name = args[0];
|
||||
return (name in globalThis) ? globalThis[name] : null;
|
||||
});
|
||||
K.registerNative('host-get', args => {
|
||||
const [obj, prop] = args;
|
||||
if (obj == null) return null;
|
||||
const v = obj[prop];
|
||||
return v === undefined ? null : v;
|
||||
});
|
||||
K.registerNative('host-set!', args => { if (args[0] != null) args[0][args[1]] = args[2]; return args[2]; });
|
||||
K.registerNative('host-call', args => {
|
||||
const [obj, method, ...rest] = args;
|
||||
if (obj == null || typeof obj[method] !== 'function') return null;
|
||||
const r = obj[method].apply(obj, rest);
|
||||
return r === undefined ? null : r;
|
||||
});
|
||||
K.registerNative('host-new', args => new (Function.prototype.bind.apply(args[0], [null, ...args.slice(1)])));
|
||||
K.registerNative('host-callback', args => function() { return K.callFn(args[0], Array.from(arguments)); });
|
||||
K.registerNative('host-typeof', args => typeof args[0]);
|
||||
K.registerNative('host-await', args => args[0]);
|
||||
|
||||
K.eval('(define SX_VERSION "test-wasm-1.0")');
|
||||
K.eval('(define SX_ENGINE "ocaml-vm-wasm-test")');
|
||||
K.eval('(define parse sx-parse)');
|
||||
K.eval('(define serialize sx-serialize)');
|
||||
|
||||
// --- Load web stack modules ---
|
||||
const useBytecode = process.env.SX_TEST_BYTECODE === '1';
|
||||
const sxDir = path.join(WASM_DIR, 'sx');
|
||||
const modules = [
|
||||
'render', 'core-signals', 'signals', 'deps', 'router', 'page-helpers', 'freeze',
|
||||
'bytecode', 'compiler', 'vm', 'dom', 'browser',
|
||||
'adapter-html', 'adapter-sx', 'adapter-dom',
|
||||
'boot-helpers', 'hypersx',
|
||||
'harness', 'harness-reactive', 'harness-web',
|
||||
'engine', 'orchestration', 'boot',
|
||||
];
|
||||
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
for (const mod of modules) {
|
||||
let loaded = false;
|
||||
if (useBytecode) {
|
||||
try {
|
||||
const bcSrc = fs.readFileSync(path.join(sxDir, mod + '.sxbc'), 'utf8');
|
||||
global.__sxbcText = bcSrc;
|
||||
const r = K.eval('(load-sxbc (first (parse (host-global "__sxbcText"))))');
|
||||
delete global.__sxbcText;
|
||||
if (typeof r !== 'string' || !r.startsWith('Error')) { loaded = true; }
|
||||
} catch (e) { delete global.__sxbcText; }
|
||||
}
|
||||
if (!loaded) {
|
||||
const src = fs.readFileSync(path.join(sxDir, mod + '.sx'), 'utf8');
|
||||
K.load(src);
|
||||
}
|
||||
}
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
|
||||
// --- Register test framework hooks ---
|
||||
let pass = 0, fail = 0;
|
||||
const suiteStack = [];
|
||||
|
||||
K.registerNative('report-pass', args => {
|
||||
pass++;
|
||||
return null;
|
||||
});
|
||||
K.registerNative('report-fail', args => {
|
||||
fail++;
|
||||
const suitePath = suiteStack.join(' > ');
|
||||
console.error(`FAIL: ${suitePath ? suitePath + ' > ' : ''}${args[0]}\n ${args[1]}`);
|
||||
return null;
|
||||
});
|
||||
K.registerNative('push-suite', args => {
|
||||
suiteStack.push(args[0]);
|
||||
return null;
|
||||
});
|
||||
K.registerNative('pop-suite', args => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
// try-call must return {"ok": bool, "error": string|nil} for the test framework
|
||||
K.eval('(define try-call (fn (thunk) (let ((result (cek-try thunk (fn (err) err)))) (if (and (= (type-of result) "string") (starts-with? result "Error")) {"ok" false "error" result} {"ok" true "error" nil}))))');
|
||||
|
||||
|
||||
// --- Load test framework + SX test file ---
|
||||
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'spec/tests/test-framework.sx'), 'utf8'));
|
||||
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'web/tests/test-wasm-browser.sx'), 'utf8'));
|
||||
|
||||
// --- Summary ---
|
||||
console.log(`WASM native tests: ${pass} passed, ${fail} failed`);
|
||||
process.exit(fail > 0 ? 1 : 0);
|
||||
}
|
||||
|
||||
main().catch(e => { console.error('FATAL:', e.message); process.exit(1); });
|
||||
200
hosts/ocaml/browser/wrap-modules.js
Normal file
200
hosts/ocaml/browser/wrap-modules.js
Normal file
@@ -0,0 +1,200 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* wrap-modules.js — Add define-library wrappers and import declarations
|
||||
* to browser .sx SOURCE files for lazy loading support.
|
||||
*
|
||||
* Targets the real source locations (spec/, web/, lib/), NOT dist/.
|
||||
* Run bundle.sh after to copy to dist/, then compile-modules.js.
|
||||
*
|
||||
* - 8 unwrapped files get define-library + export + begin wrappers
|
||||
* - 4 already-wrapped files get dependency import declarations
|
||||
* - boot.sx gets imports (stays unwrapped — entry point)
|
||||
*/
|
||||
|
||||
const fs = require('fs');
|
||||
const path = require('path');
|
||||
|
||||
const ROOT = path.resolve(__dirname, '..', '..', '..');
|
||||
|
||||
// Source file → library name (null = entry point)
|
||||
const MODULES = {
|
||||
// Spec modules
|
||||
'spec/render.sx': { lib: '(sx render)', deps: [] },
|
||||
'spec/signals.sx': { lib: '(sx signals)', deps: [] },
|
||||
'web/web-signals.sx': { lib: '(sx signals-web)', deps: ['(sx dom)', '(sx browser)'] },
|
||||
'web/deps.sx': { lib: '(web deps)', deps: [] },
|
||||
'web/router.sx': { lib: '(web router)', deps: [] },
|
||||
'web/page-helpers.sx': { lib: '(web page-helpers)', deps: [] },
|
||||
// Lib modules
|
||||
'lib/freeze.sx': { lib: '(sx freeze)', deps: [] },
|
||||
'lib/highlight.sx': { lib: '(sx highlight)', deps: [] },
|
||||
'lib/bytecode.sx': { lib: '(sx bytecode)', deps: [] },
|
||||
'lib/compiler.sx': { lib: '(sx compiler)', deps: [] },
|
||||
'lib/vm.sx': { lib: '(sx vm)', deps: [] },
|
||||
// Web FFI
|
||||
'web/lib/dom.sx': { lib: '(sx dom)', deps: [] },
|
||||
'web/lib/browser.sx': { lib: '(sx browser)', deps: [] },
|
||||
// Web adapters
|
||||
'web/adapter-html.sx': { lib: '(web adapter-html)', deps: ['(sx render)'] },
|
||||
'web/adapter-sx.sx': { lib: '(web adapter-sx)', deps: ['(web boot-helpers)'] },
|
||||
'web/adapter-dom.sx': { lib: '(web adapter-dom)', deps: ['(sx dom)', '(sx render)'] },
|
||||
// Web framework
|
||||
'web/lib/boot-helpers.sx': { lib: '(web boot-helpers)', deps: ['(sx dom)', '(sx browser)', '(web adapter-dom)'] },
|
||||
'web/lib/hypersx.sx': { lib: '(sx hypersx)', deps: [] },
|
||||
'web/engine.sx': { lib: '(web engine)', deps: ['(web boot-helpers)', '(sx dom)', '(sx browser)'] },
|
||||
'web/orchestration.sx': { lib: '(web orchestration)', deps: ['(web boot-helpers)', '(sx dom)', '(sx browser)', '(web adapter-dom)', '(web engine)'] },
|
||||
'web/boot.sx': { lib: null, deps: ['(sx dom)', '(sx browser)', '(web boot-helpers)', '(web adapter-dom)',
|
||||
'(sx signals)', '(sx signals-web)', '(web router)', '(web page-helpers)',
|
||||
'(web orchestration)', '(sx render)',
|
||||
'(sx bytecode)', '(sx compiler)', '(sx vm)'] },
|
||||
// Test harness
|
||||
'spec/harness.sx': { lib: '(sx harness)', deps: [] },
|
||||
'web/harness-reactive.sx': { lib: '(sx harness-reactive)', deps: [] },
|
||||
'web/harness-web.sx': { lib: '(sx harness-web)', deps: [] },
|
||||
};
|
||||
|
||||
// Extract top-level define names from source.
|
||||
// Handles both `(define name ...)` and `(define\n name ...)` formats.
|
||||
function extractDefineNames(source) {
|
||||
const names = [];
|
||||
const lines = source.split('\n');
|
||||
let depth = 0;
|
||||
let expectName = false;
|
||||
for (const line of lines) {
|
||||
if (depth === 0) {
|
||||
const m = line.match(/^\(define\s+\(?(\S+)/);
|
||||
if (m) {
|
||||
names.push(m[1]);
|
||||
expectName = false;
|
||||
} else if (line.match(/^\(define\s*$/)) {
|
||||
expectName = true;
|
||||
}
|
||||
} else if (depth === 1 && expectName) {
|
||||
const m = line.match(/^\s+(\S+)/);
|
||||
if (m) {
|
||||
names.push(m[1]);
|
||||
expectName = false;
|
||||
}
|
||||
}
|
||||
for (const ch of line) {
|
||||
if (ch === '(') depth++;
|
||||
else if (ch === ')') depth--;
|
||||
}
|
||||
}
|
||||
return names;
|
||||
}
|
||||
|
||||
function processFile(relPath, info) {
|
||||
const filePath = path.join(ROOT, relPath);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(' SKIP', relPath, '(not found)');
|
||||
return;
|
||||
}
|
||||
|
||||
let source = fs.readFileSync(filePath, 'utf8');
|
||||
const { lib, deps } = info;
|
||||
const hasWrapper = source.includes('(define-library');
|
||||
const hasDepImports = deps.length > 0 && source.match(/^\(import\s+\(/m) &&
|
||||
!source.match(/^\(import\s+\(\w+ \w+\)\)\s*$/m); // more than just self-import
|
||||
|
||||
// Skip files with no deps and already wrapped (or no wrapper needed)
|
||||
if (deps.length === 0 && (hasWrapper || !lib)) {
|
||||
console.log(' ok', relPath, '(no changes needed)');
|
||||
return;
|
||||
}
|
||||
|
||||
// Build import lines for deps
|
||||
const importLines = deps.map(d => `(import ${d})`).join('\n');
|
||||
|
||||
// CASE 1: Entry point (boot.sx) — just add imports at top
|
||||
if (!lib) {
|
||||
if (deps.length > 0 && !source.startsWith('(import')) {
|
||||
source = importLines + '\n\n' + source;
|
||||
fs.writeFileSync(filePath, source);
|
||||
console.log(' +imports', relPath, `(${deps.length} deps, entry point)`);
|
||||
} else {
|
||||
console.log(' ok', relPath, '(entry point, already has imports)');
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
// CASE 2: Already wrapped — add imports before define-library
|
||||
if (hasWrapper) {
|
||||
if (deps.length > 0) {
|
||||
// Check if imports already present
|
||||
const firstImportCheck = deps[0].replace(/[()]/g, '\\$&');
|
||||
if (source.match(new RegExp('\\(import ' + firstImportCheck))) {
|
||||
console.log(' ok', relPath, '(already has dep imports)');
|
||||
return;
|
||||
}
|
||||
const dlIdx = source.indexOf('(define-library');
|
||||
source = source.slice(0, dlIdx) + importLines + '\n\n' + source.slice(dlIdx);
|
||||
fs.writeFileSync(filePath, source);
|
||||
console.log(' +imports', relPath, `(${deps.length} deps)`);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
// CASE 3: Needs full wrapping
|
||||
if (deps.length === 0 && !hasWrapper) {
|
||||
// Wrap with no deps
|
||||
const names = extractDefineNames(source);
|
||||
if (names.length === 0) {
|
||||
console.log(' WARN', relPath, '— no defines found, skipping');
|
||||
return;
|
||||
}
|
||||
const wrapped = buildWrapped(lib, names, source, '');
|
||||
fs.writeFileSync(filePath, wrapped);
|
||||
console.log(' wrapped', relPath, `as ${lib} (${names.length} exports)`);
|
||||
return;
|
||||
}
|
||||
|
||||
// Wrap with deps
|
||||
const names = extractDefineNames(source);
|
||||
if (names.length === 0) {
|
||||
console.log(' WARN', relPath, '— no defines found, skipping');
|
||||
return;
|
||||
}
|
||||
const wrapped = buildWrapped(lib, names, source, importLines);
|
||||
fs.writeFileSync(filePath, wrapped);
|
||||
console.log(' wrapped', relPath, `as ${lib} (${names.length} exports, ${deps.length} deps)`);
|
||||
}
|
||||
|
||||
function buildWrapped(libName, exportNames, bodySource, importSection) {
|
||||
const parts = [];
|
||||
|
||||
// Dependency imports (top-level, before define-library)
|
||||
if (importSection) {
|
||||
parts.push(importSection);
|
||||
parts.push('');
|
||||
}
|
||||
|
||||
// define-library header
|
||||
parts.push(`(define-library ${libName}`);
|
||||
parts.push(` (export ${exportNames.join(' ')})`);
|
||||
parts.push(' (begin');
|
||||
parts.push('');
|
||||
|
||||
// Body (original source, indented)
|
||||
parts.push(bodySource);
|
||||
parts.push('');
|
||||
|
||||
// Close begin + define-library
|
||||
parts.push('))');
|
||||
parts.push('');
|
||||
|
||||
// Self-import for backward compat
|
||||
parts.push(`;; Re-export to global env`);
|
||||
parts.push(`(import ${libName})`);
|
||||
parts.push('');
|
||||
|
||||
return parts.join('\n');
|
||||
}
|
||||
|
||||
console.log('Processing source .sx files...\n');
|
||||
for (const [relPath, info] of Object.entries(MODULES)) {
|
||||
processFile(relPath, info);
|
||||
}
|
||||
console.log('\nDone! Now run:');
|
||||
console.log(' bash hosts/ocaml/browser/bundle.sh');
|
||||
console.log(' node hosts/ocaml/browser/compile-modules.js');
|
||||
2
hosts/ocaml/dune-project
Normal file
2
hosts/ocaml/dune-project
Normal file
@@ -0,0 +1,2 @@
|
||||
(lang dune 3.19)
|
||||
(name sx)
|
||||
4
hosts/ocaml/lib/dune
Normal file
4
hosts/ocaml/lib/dune
Normal file
@@ -0,0 +1,4 @@
|
||||
(library
|
||||
(name sx)
|
||||
(wrapped false)
|
||||
(libraries re re.pcre))
|
||||
212
hosts/ocaml/lib/sx_compiler.ml
Normal file
212
hosts/ocaml/lib/sx_compiler.ml
Normal file
@@ -0,0 +1,212 @@
|
||||
(* sx_compiler.ml — Auto-generated from lib/compiler.sx *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_compiler.py *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* The compiler uses cek_call from the evaluator for runtime dispatch *)
|
||||
let cek_call = Sx_ref.cek_call
|
||||
let eval_expr = Sx_ref.eval_expr
|
||||
let trampoline v = match v with
|
||||
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
|
||||
| other -> other
|
||||
|
||||
(* Bindings for external functions the compiler calls.
|
||||
Some shadow OCaml stdlib names — the SX versions operate on values. *)
|
||||
let serialize v = String (Sx_types.inspect v)
|
||||
let sx_parse v = match v with
|
||||
| String s -> (match Sx_parser.parse_all s with [e] -> e | es -> List es)
|
||||
| v -> v
|
||||
let floor v = prim_call "floor" [v]
|
||||
let abs v = prim_call "abs" [v]
|
||||
let min a b = prim_call "min" [a; b]
|
||||
let max a b = prim_call "max" [a; b]
|
||||
let set_nth_b lst idx v = prim_call "set-nth!" [lst; idx; v]
|
||||
let init lst = prim_call "init" [lst]
|
||||
|
||||
(* skip_annotations: strips :keyword value pairs from a list (type annotations) *)
|
||||
let rec skip_annotations items =
|
||||
match items with
|
||||
| List [] | Nil -> Nil
|
||||
| List (Keyword _ :: _ :: rest) -> skip_annotations (List rest)
|
||||
| ListRef { contents = [] } -> Nil
|
||||
| ListRef { contents = Keyword _ :: _ :: rest } -> skip_annotations (List rest)
|
||||
| List (first :: _) -> first
|
||||
| ListRef { contents = first :: _ } -> first
|
||||
| _ -> Nil
|
||||
|
||||
(* compile_match: uses local recursion (letrec) that the transpiler can't handle.
|
||||
Falls back to CEK evaluation at runtime. *)
|
||||
let compile_match em args scope tail_p =
|
||||
let fn = Sx_ref.eval_expr (Symbol "compile-match") (Env (Sx_types.make_env ())) in
|
||||
ignore (Sx_ref.cek_call fn (List [em; args; scope; tail_p]));
|
||||
Nil
|
||||
|
||||
|
||||
(* === Transpiled from bytecode compiler === *)
|
||||
(* make-pool *)
|
||||
let rec make_pool () =
|
||||
(let _d = Hashtbl.create 2 in Hashtbl.replace _d "entries" (if sx_truthy ((is_primitive ((String "mutable-list")))) then (mutable_list ()) else (List [])); Hashtbl.replace _d "index" (let _d = Hashtbl.create 1 in Hashtbl.replace _d "_count" (Number 0.0); Dict _d); Dict _d)
|
||||
|
||||
(* pool-add *)
|
||||
and pool_add pool value =
|
||||
(let () = ignore ((String "Add a value to the constant pool, return its index. Deduplicates.")) in (let key = (serialize (value)) in let idx_map = (get (pool) ((String "index"))) in (if sx_truthy ((prim_call "has-key?" [idx_map; key])) then (get (idx_map) (key)) else (let idx = (get (idx_map) ((String "_count"))) in (let () = ignore ((sx_dict_set_b idx_map key idx)) in (let () = ignore ((sx_dict_set_b idx_map (String "_count") (prim_call "+" [idx; (Number 1.0)]))) in (let () = ignore ((sx_append_b (get (pool) ((String "entries"))) value)) in idx)))))))
|
||||
|
||||
(* make-scope *)
|
||||
and make_scope parent =
|
||||
(let _d = Hashtbl.create 5 in Hashtbl.replace _d "next-slot" (Number 0.0); Hashtbl.replace _d "upvalues" (List []); Hashtbl.replace _d "locals" (List []); Hashtbl.replace _d "parent" parent; Hashtbl.replace _d "is-function" (Bool false); Dict _d)
|
||||
|
||||
(* scope-define-local *)
|
||||
and scope_define_local scope name =
|
||||
(let () = ignore ((String "Add a local variable, return its slot index.\n Idempotent: if name already has a slot, return it.")) in (let existing = (first ((List (List.filter (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list (get (scope) ((String "locals")))))))) in (if sx_truthy (existing) then (get (existing) ((String "slot"))) else (let slot = (get (scope) ((String "next-slot"))) in (let () = ignore ((sx_append_b (get (scope) ((String "locals"))) (let _d = Hashtbl.create 3 in Hashtbl.replace _d "mutable" (Bool false); Hashtbl.replace _d "slot" slot; Hashtbl.replace _d "name" name; Dict _d))) in (let () = ignore ((sx_dict_set_b scope (String "next-slot") (prim_call "+" [slot; (Number 1.0)]))) in slot))))))
|
||||
|
||||
(* scope-resolve *)
|
||||
and scope_resolve scope name =
|
||||
(let () = ignore ((String "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.\n Upvalue captures only happen at function boundaries (is-function=true).\n Let scopes share the enclosing function's frame — their locals are\n accessed directly without upvalue indirection.")) in (if sx_truthy ((is_nil (scope))) then (CekFrame { cf_type = "global"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) else (let locals = (get (scope) ((String "locals"))) in let found = (Bool (List.exists (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list locals))) in (if sx_truthy (found) then (let local = (first ((List (List.filter (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list locals))))) in (CekFrame { cf_type = "local"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })) else (let upvals = (get (scope) ((String "upvalues"))) in let uv_found = (Bool (List.exists (fun u -> sx_truthy ((prim_call "=" [(get (u) ((String "name"))); name]))) (sx_to_list upvals))) in (if sx_truthy (uv_found) then (let uv = (first ((List (List.filter (fun u -> sx_truthy ((prim_call "=" [(get (u) ((String "name"))); name]))) (sx_to_list upvals))))) in (CekFrame { cf_type = "upvalue"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })) else (let parent = (get (scope) ((String "parent"))) in (if sx_truthy ((is_nil (parent))) then (CekFrame { cf_type = "global"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) else (let parent_result = (scope_resolve (parent) (name)) in (if sx_truthy ((prim_call "=" [(get (parent_result) ((String "type"))); (String "global")])) then parent_result else (if sx_truthy ((get (scope) ((String "is-function")))) then (let uv_idx = (len ((get (scope) ((String "upvalues"))))) in (let () = ignore ((sx_append_b (get (scope) ((String "upvalues"))) (let _d = Hashtbl.create 4 in Hashtbl.replace _d "index" (get (parent_result) ((String "index"))); Hashtbl.replace _d "is-local" (prim_call "=" [(get (parent_result) ((String "type"))); (String "local")]); Hashtbl.replace _d "uv-index" uv_idx; Hashtbl.replace _d "name" name; Dict _d))) in (CekFrame { cf_type = "upvalue"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }))) else parent_result)))))))))))
|
||||
|
||||
(* make-emitter *)
|
||||
and make_emitter () =
|
||||
(let _d = Hashtbl.create 2 in Hashtbl.replace _d "pool" (make_pool ()); Hashtbl.replace _d "bytecode" (if sx_truthy ((is_primitive ((String "mutable-list")))) then (mutable_list ()) else (List [])); Dict _d)
|
||||
|
||||
(* emit-byte *)
|
||||
and emit_byte em byte =
|
||||
(sx_append_b (get (em) ((String "bytecode"))) byte)
|
||||
|
||||
(* emit-u16 *)
|
||||
and emit_u16 em value =
|
||||
(let () = ignore ((emit_byte (em) ((prim_call "mod" [value; (Number 256.0)])))) in (emit_byte (em) ((prim_call "mod" [(floor ((prim_call "/" [value; (Number 256.0)]))); (Number 256.0)]))))
|
||||
|
||||
(* emit-i16 *)
|
||||
and emit_i16 em value =
|
||||
(let v = (if sx_truthy ((prim_call "<" [value; (Number 0.0)])) then (prim_call "+" [value; (Number 65536.0)]) else value) in (emit_u16 (em) (v)))
|
||||
|
||||
(* emit-op *)
|
||||
and emit_op em opcode =
|
||||
(emit_byte (em) (opcode))
|
||||
|
||||
(* emit-const *)
|
||||
and emit_const em value =
|
||||
(let idx = (pool_add ((get (em) ((String "pool")))) (value)) in (let () = ignore ((emit_op (em) ((Number 1.0)))) in (emit_u16 (em) (idx))))
|
||||
|
||||
(* current-offset *)
|
||||
and current_offset em =
|
||||
(len ((get (em) ((String "bytecode")))))
|
||||
|
||||
(* patch-i16 *)
|
||||
and patch_i16 em offset value =
|
||||
(let () = ignore ((String "Patch a previously emitted i16 at the given bytecode offset.")) in (let v = (if sx_truthy ((prim_call "<" [value; (Number 0.0)])) then (prim_call "+" [value; (Number 65536.0)]) else value) in let bc = (get (em) ((String "bytecode"))) in (let () = ignore ((set_nth_b (bc) (offset) ((prim_call "mod" [v; (Number 256.0)])))) in (set_nth_b (bc) ((prim_call "+" [offset; (Number 1.0)])) ((prim_call "mod" [(floor ((prim_call "/" [v; (Number 256.0)]))); (Number 256.0)]))))))
|
||||
|
||||
(* compile-expr *)
|
||||
and compile_expr em expr scope tail_p =
|
||||
(let () = ignore ((String "Compile an expression. tail? indicates tail position for TCO.")) in (if sx_truthy ((is_nil (expr))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "number")])) then (emit_const (em) (expr)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "string")])) then (emit_const (em) (expr)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "boolean")])) then (emit_op (em) ((if sx_truthy (expr) then (Number 3.0) else (Number 4.0)))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "keyword")])) then (emit_const (em) ((keyword_name (expr)))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "symbol")])) then (compile_symbol (em) ((symbol_name (expr))) (scope)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")])) then (if sx_truthy ((empty_p (expr))) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((Number 0.0)))) else (compile_list (em) (expr) (scope) (tail_p))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "dict")])) then (compile_dict (em) (expr) (scope)) else (emit_const (em) (expr)))))))))))
|
||||
|
||||
(* compile-symbol *)
|
||||
and compile_symbol em name scope =
|
||||
(let resolved = (scope_resolve (scope) (name)) in (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "local")])) then (let () = ignore ((emit_op (em) ((Number 16.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "upvalue")])) then (let () = ignore ((emit_op (em) ((Number 18.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (let idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (idx)))))))
|
||||
|
||||
(* compile-dict *)
|
||||
and compile_dict em expr scope =
|
||||
(let ks = (prim_call "keys" [expr]) in let count = (len (ks)) in (let () = ignore ((List.iter (fun k -> ignore ((let () = ignore ((emit_const (em) (k))) in (compile_expr (em) ((get (expr) (k))) (scope) ((Bool false)))))) (sx_to_list ks); Nil)) in (let () = ignore ((emit_op (em) ((Number 65.0)))) in (emit_u16 (em) (count)))))
|
||||
|
||||
(* compile-list *)
|
||||
and compile_list em expr scope tail_p =
|
||||
(let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])))))) then (compile_call (em) (head) (args) (scope) (tail_p)) else (let name = (symbol_name (head)) in (if sx_truthy ((prim_call "=" [name; (String "if")])) then (compile_if (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (compile_when (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "and")])) then (compile_and (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "or")])) then (compile_or (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "let")])) then (compile_let (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "let*")])) then (compile_let (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (compile_begin (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (compile_begin (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "lambda")])) then (compile_lambda (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "fn")])) then (compile_lambda (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "define")])) then (compile_define (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (compile_set (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "quote")])) then (compile_quote (em) (args)) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (compile_cond (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (compile_case (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (compile_thread (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (compile_defmacro (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defstyle")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defhandler")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defpage")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defquery")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defaction")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defrelation")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "deftype")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defeffect")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "quasiquote")])) then (compile_quasiquote (em) ((first (args))) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (compile_letrec (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "match")])) then (compile_match (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "perform")])) then ( (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 112.0)))) in Nil))) else (compile_call (em) (head) (args) (scope) (tail_p)))))))))))))))))))))))))))))))))))))
|
||||
|
||||
(* compile-if *)
|
||||
and compile_if em args scope tail_p =
|
||||
(let test = (first (args)) in let then_expr = (nth (args) ((Number 1.0))) in let else_expr = (if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (nth (args) ((Number 2.0))) else Nil) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let else_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_expr (em) (then_expr) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (else_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [else_jump; (Number 2.0)])])))) in (let () = ignore ((if sx_truthy ((is_nil (else_expr))) then (emit_op (em) ((Number 2.0))) else (compile_expr (em) (else_expr) (scope) (tail_p)))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])]))))))))))))))
|
||||
|
||||
(* compile-when *)
|
||||
and compile_when em args scope tail_p =
|
||||
(let test = (first (args)) in let body = (rest (args)) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_begin (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip_jump; (Number 2.0)])])))) in (let () = ignore ((emit_op (em) ((Number 2.0)))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])]))))))))))))))
|
||||
|
||||
(* compile-and *)
|
||||
and compile_and em args scope tail_p =
|
||||
(if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 3.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_and (em) ((rest (args))) (scope) (tail_p))) in (patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])]))))))))))))
|
||||
|
||||
(* compile-or *)
|
||||
and compile_or em args scope tail_p =
|
||||
(if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 4.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((emit_op (em) ((Number 34.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_or (em) ((rest (args))) (scope) (tail_p))) in (patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])]))))))))))))
|
||||
|
||||
(* compile-begin *)
|
||||
and compile_begin em exprs scope tail_p =
|
||||
(let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (exprs)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil ((get (scope) ((String "parent"))))))))))) then (List.iter (fun expr -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (expr)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (expr)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (expr)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (expr)))); (String "define")]))))) then (let name_expr = (nth (expr) ((Number 1.0))) in let name = (if sx_truthy ((prim_call "=" [(type_of (name_expr)); (String "symbol")])) then (symbol_name (name_expr)) else name_expr) in (scope_define_local (scope) (name))) else Nil))) (sx_to_list exprs); Nil) else Nil)) in (if sx_truthy ((empty_p (exprs))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(len (exprs)); (Number 1.0)])) then (compile_expr (em) ((first (exprs))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (exprs))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (compile_begin (em) ((rest (exprs))) (scope) (tail_p)))))))
|
||||
|
||||
(* compile-let *)
|
||||
and compile_let em args scope tail_p =
|
||||
(if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (first (binding)) else (make_symbol ((first (binding))))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil)) in (let lambda_expr = (prim_call "concat" [(List [(make_symbol ((String "fn"))); !params]); body]) in let letrec_bindings = (List [(List [(make_symbol (loop_name)); lambda_expr])]) in let call_expr = (cons ((make_symbol (loop_name))) (!inits)) in (compile_letrec (em) ((List [letrec_bindings; call_expr])) (scope) (tail_p))))) else (let bindings = (first (args)) in let body = (rest (args)) in let let_scope = (make_scope (scope)) in (let () = ignore ((sx_dict_set_b let_scope (String "next-slot") (get (scope) ((String "next-slot"))))) in (let () = ignore ((List.iter (fun binding -> ignore ((let name = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in let value = (nth (binding) ((Number 1.0))) in let slot = (scope_define_local (let_scope) (name)) in (let () = ignore ((compile_expr (em) (value) (let_scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))))) (sx_to_list bindings); Nil)) in (compile_begin (em) (body) (let_scope) (tail_p))))))
|
||||
|
||||
(* compile-letrec *)
|
||||
and compile_letrec em args scope tail_p =
|
||||
(let () = ignore ((String "Compile letrec: all names visible during value compilation.\n 1. Define all local slots (initialized to nil).\n 2. Compile each value and assign — names are already in scope\n so mutually recursive functions can reference each other.")) in (let bindings = (first (args)) in let body = (rest (args)) in let let_scope = (make_scope (scope)) in (let () = ignore ((sx_dict_set_b let_scope (String "next-slot") (get (scope) ((String "next-slot"))))) in (let () = ignore ((let slots = (List (List.map (fun binding -> (let name = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let slot = (scope_define_local (let_scope) (name)) in (let () = ignore ((emit_op (em) ((Number 2.0)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (let () = ignore ((emit_byte (em) (slot))) in slot)))))) (sx_to_list bindings))) in (List.iter (fun pair -> ignore ((let binding = (first (pair)) in let slot = (nth (pair) ((Number 1.0))) in (let () = ignore ((compile_expr (em) ((nth (binding) ((Number 1.0)))) (let_scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))))) (sx_to_list (List (List.map (fun i -> (List [(nth (bindings) (i)); (nth (slots) (i))])) (sx_to_list (prim_call "range" [(Number 0.0); (len (bindings))]))))); Nil))) in (compile_begin (em) (body) (let_scope) (tail_p))))))
|
||||
|
||||
(* compile-lambda *)
|
||||
and compile_lambda em args scope =
|
||||
(let params = (first (args)) in let body = (rest (args)) in let fn_scope = (make_scope (scope)) in let fn_em = (make_emitter ()) in (let () = ignore ((sx_dict_set_b fn_scope (String "is-function") (Bool true))) in (let () = ignore ((List.iter (fun p -> ignore ((let name = (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else (if sx_truthy ((let _and = (list_p (p)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (p)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((first (p)))); (String "symbol")])))) then (symbol_name ((first (p)))) else p)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((prim_call "=" [name; (String "&key")]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [name; (String "&rest")]))))))) then (scope_define_local (fn_scope) (name)) else Nil)))) (sx_to_list params); Nil)) in (let () = ignore ((compile_begin (fn_em) (body) (fn_scope) ((Bool true)))) in (let () = ignore ((emit_op (fn_em) ((Number 50.0)))) in (let upvals = (get (fn_scope) ((String "upvalues"))) in let code = (let _d = Hashtbl.create 4 in Hashtbl.replace _d "upvalue-count" (len (upvals)); Hashtbl.replace _d "arity" (len ((get (fn_scope) ((String "locals"))))); Hashtbl.replace _d "constants" (get ((get (fn_em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (fn_em) ((String "bytecode"))); Dict _d) in let code_idx = (pool_add ((get (em) ((String "pool")))) (code)) in (let () = ignore ((emit_op (em) ((Number 51.0)))) in (let () = ignore ((emit_u16 (em) (code_idx))) in (List.iter (fun uv -> ignore ((let () = ignore ((emit_byte (em) ((if sx_truthy ((get (uv) ((String "is-local")))) then (Number 1.0) else (Number 0.0))))) in (emit_byte (em) ((get (uv) ((String "index")))))))) (sx_to_list upvals); Nil)))))))))
|
||||
|
||||
(* compile-define *)
|
||||
and compile_define em args scope =
|
||||
(let name_expr = (first (args)) in let name = (if sx_truthy ((prim_call "=" [(type_of (name_expr)); (String "symbol")])) then (symbol_name (name_expr)) else name_expr) in let value = (let rest_args = (rest (args)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (rest_args)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((first (rest_args)))); (String "keyword")]))) then (skip_annotations (rest_args)) else (first (rest_args)))) in (if sx_truthy ((Bool (not (sx_truthy ((is_nil ((get (scope) ((String "parent")))))))))) then (let slot = (scope_define_local (scope) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))) else (let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 128.0)))) in (emit_u16 (em) (name_idx)))))))
|
||||
|
||||
(* compile-set *)
|
||||
and compile_set em args scope =
|
||||
(let name = (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (symbol_name ((first (args)))) else (first (args))) in let value = (nth (args) ((Number 1.0))) in let resolved = (scope_resolve (scope) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "local")])) then (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "upvalue")])) then (let () = ignore ((emit_op (em) ((Number 19.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (let idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((emit_op (em) ((Number 21.0)))) in (emit_u16 (em) (idx))))))))
|
||||
|
||||
(* compile-quote *)
|
||||
and compile_quote em args =
|
||||
(if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 2.0))) else (emit_const (em) ((first (args)))))
|
||||
|
||||
(* compile-cond *)
|
||||
and compile_cond em args scope tail_p =
|
||||
(let () = ignore ((String "Compile (cond test1 body1 test2 body2 ... :else fallback).")) in (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (emit_op (em) ((Number 2.0))) else (let test = (first (args)) in let body = (nth (args) ((Number 1.0))) in let rest_clauses = (if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (prim_call "slice" [args; (Number 2.0)]) else (List [])) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (prim_call "=" [test; (Bool true)]))) then (compile_expr (em) (body) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_expr (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))) in (let () = ignore ((compile_cond (em) (rest_clauses) (scope) (tail_p))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])])))))))))))))))))
|
||||
|
||||
(* compile-case *)
|
||||
and compile_case em args scope tail_p =
|
||||
(let () = ignore ((String "Compile (case expr val1 body1 val2 body2 ... :else fallback).")) in (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let clauses = (rest (args)) in (compile_case_clauses (em) (clauses) (scope) (tail_p)))))
|
||||
|
||||
(* compile-case-clauses *)
|
||||
and compile_case_clauses em clauses scope tail_p =
|
||||
(if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (let () = ignore ((emit_op (em) ((Number 5.0)))) in (emit_op (em) ((Number 2.0)))) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in let rest_clauses = (if sx_truthy ((prim_call ">" [(len (clauses)); (Number 2.0)])) then (prim_call "slice" [clauses; (Number 2.0)]) else (List [])) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (prim_call "=" [test; (Bool true)]))) then (let () = ignore ((emit_op (em) ((Number 5.0)))) in (compile_expr (em) (body) (scope) (tail_p))) else (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "="))) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) ((Number 2.0))))))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_expr (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))) in (let () = ignore ((compile_case_clauses (em) (rest_clauses) (scope) (tail_p))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])])))))))))))))))))))
|
||||
|
||||
(* compile-thread *)
|
||||
and compile_thread em args scope tail_p =
|
||||
(let () = ignore ((String "Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls.")) in (if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let val_expr = (first (args)) in let forms = (rest (args)) in (compile_thread_step (em) (val_expr) (forms) (scope) (tail_p))))))
|
||||
|
||||
(* compile-thread-step *)
|
||||
and compile_thread_step em val_expr forms scope tail_p =
|
||||
(if sx_truthy ((empty_p (forms))) then (compile_expr (em) (val_expr) (scope) (tail_p)) else (let form = (first (forms)) in let rest_forms = (rest (forms)) in let is_tail = (let _and = tail_p in if not (sx_truthy _and) then _and else (empty_p (rest_forms))) in (let call_expr = (if sx_truthy ((list_p (form))) then (prim_call "concat" [(List [(first (form)); val_expr]); (rest (form))]) else (List [form; val_expr])) in (if sx_truthy ((empty_p (rest_forms))) then (compile_expr (em) (call_expr) (scope) (is_tail)) else (let () = ignore ((compile_expr (em) (call_expr) (scope) ((Bool false)))) in (compile_thread_step (em) (call_expr) (rest_forms) (scope) (tail_p)))))))
|
||||
|
||||
(* compile-defcomp *)
|
||||
and compile_defcomp em args scope =
|
||||
(let () = ignore ((String "Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL.")) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "eval-defcomp"))) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (name_idx))))) in (let () = ignore ((emit_const (em) ((prim_call "concat" [(List [(make_symbol ((String "defcomp")))]); args])))) in (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((Number 1.0)))))))
|
||||
|
||||
(* compile-defmacro *)
|
||||
and compile_defmacro em args scope =
|
||||
(let () = ignore ((String "Compile defmacro — delegates to runtime via GLOBAL_GET + CALL.")) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "eval-defmacro"))) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (name_idx))))) in (let () = ignore ((emit_const (em) ((prim_call "concat" [(List [(make_symbol ((String "defmacro")))]); args])))) in (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((Number 1.0)))))))
|
||||
|
||||
(* compile-quasiquote *)
|
||||
and compile_quasiquote em expr scope =
|
||||
(let () = ignore ((String "Compile quasiquote inline — walks the template at compile time,\n emitting code that builds the structure at runtime. Unquoted\n expressions are compiled normally (resolving locals/upvalues),\n avoiding the qq-expand-runtime env-lookup limitation.")) in (compile_qq_expr (em) (expr) (scope)))
|
||||
|
||||
(* compile-qq-expr *)
|
||||
and compile_qq_expr em expr scope =
|
||||
(let () = ignore ((String "Compile a quasiquote sub-expression.")) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")])))))) then (emit_const (em) (expr)) else (if sx_truthy ((empty_p (expr))) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((Number 0.0)))) else (let head = (first (expr)) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (head)); (String "unquote")]))) then (compile_expr (em) ((nth (expr) ((Number 1.0)))) (scope) ((Bool false))) else (compile_qq_list (em) (expr) (scope)))))))
|
||||
|
||||
(* compile-qq-list *)
|
||||
and compile_qq_list em items scope =
|
||||
(let () = ignore ((String "Compile a quasiquote list. Handles splice-unquote by building\n segments and concatenating them.")) in (let has_splice = (Bool (List.exists (fun item -> sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")])))))) (sx_to_list items))) in (if sx_truthy ((Bool (not (sx_truthy (has_splice))))) then (let () = ignore ((List.iter (fun item -> ignore ((compile_qq_expr (em) (item) (scope)))) (sx_to_list items); Nil)) in (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((len (items)))))) else (let segment_count = ref ((Number 0.0)) in let pending = ref ((Number 0.0)) in (let () = ignore ((List.iter (fun item -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")]))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [!pending; (Number 0.0)])) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (let () = ignore ((emit_u16 (em) (!pending))) in (let () = ignore ((segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil)) in (pending := (Number 0.0); Nil)))) else Nil)) in (let () = ignore ((compile_expr (em) ((nth (item) ((Number 1.0)))) (scope) ((Bool false)))) in (segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil))) else (let () = ignore ((compile_qq_expr (em) (item) (scope))) in (pending := (prim_call "+" [!pending; (Number 1.0)]); Nil))))) (sx_to_list items); Nil)) in (let () = ignore ((if sx_truthy ((prim_call ">" [!pending; (Number 0.0)])) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (let () = ignore ((emit_u16 (em) (!pending))) in (segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil))) else Nil)) in (if sx_truthy ((prim_call ">" [!segment_count; (Number 1.0)])) then (let concat_idx = (pool_add ((get (em) ((String "pool")))) ((String "concat"))) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (concat_idx))) in (emit_byte (em) (!segment_count))))) else Nil)))))))
|
||||
|
||||
(* compile-call *)
|
||||
and compile_call em head args scope tail_p =
|
||||
(let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) (argc)))))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args))))))))))
|
||||
|
||||
(* compile *)
|
||||
and compile expr =
|
||||
(let () = ignore ((String "Compile a single SX expression to a bytecode module.")) in (let em = (make_emitter ()) in let scope = (make_scope (Nil)) in (let () = ignore ((compile_expr (em) (expr) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 50.0)))) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "constants" (get ((get (em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (em) ((String "bytecode"))); Dict _d)))))
|
||||
|
||||
(* compile-module *)
|
||||
and compile_module exprs =
|
||||
(let () = ignore ((String "Compile a list of top-level expressions to a bytecode module.")) in (let em = (make_emitter ()) in let scope = (make_scope (Nil)) in (let () = ignore ((List.iter (fun expr -> ignore ((let () = ignore ((compile_expr (em) (expr) (scope) ((Bool false)))) in (emit_op (em) ((Number 5.0)))))) (sx_to_list (init (exprs))); Nil)) in (let () = ignore ((compile_expr (em) ((last (exprs))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 50.0)))) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "constants" (get ((get (em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (em) ((String "bytecode"))); Dict _d))))))
|
||||
|
||||
146
hosts/ocaml/lib/sx_cst.ml
Normal file
146
hosts/ocaml/lib/sx_cst.ml
Normal file
@@ -0,0 +1,146 @@
|
||||
(** Concrete Syntax Tree for SX — lossless source representation.
|
||||
|
||||
Every piece of source text is preserved: whitespace, comments,
|
||||
delimiters, raw token text. The CST supports two projections:
|
||||
- [cst_to_source]: reconstruct the exact original source
|
||||
- [cst_to_ast]: strip trivia, produce [Sx_types.value] for evaluation
|
||||
|
||||
Trivia attaches to nodes (leading on every node, trailing on
|
||||
containers before the close delimiter). No separate comment map. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** {1 Types} *)
|
||||
|
||||
type trivia =
|
||||
| Whitespace of string (** Runs of spaces, tabs, newlines *)
|
||||
| LineComment of string (** ";;" through end of line, including the ";" chars *)
|
||||
|
||||
type span = {
|
||||
start_offset : int;
|
||||
end_offset : int;
|
||||
}
|
||||
|
||||
type cst_node =
|
||||
| CstAtom of {
|
||||
leading_trivia : trivia list;
|
||||
token : string; (** Raw source text of the token *)
|
||||
value : value; (** Parsed semantic value *)
|
||||
span : span;
|
||||
}
|
||||
| CstList of {
|
||||
leading_trivia : trivia list;
|
||||
open_delim : char; (** '(' or '[' *)
|
||||
children : cst_node list;
|
||||
close_delim : char; (** ')' or ']' *)
|
||||
trailing_trivia : trivia list; (** Trivia between last child and close delim *)
|
||||
span : span;
|
||||
}
|
||||
| CstDict of {
|
||||
leading_trivia : trivia list;
|
||||
children : cst_node list; (** Alternating key/value atoms *)
|
||||
trailing_trivia : trivia list;
|
||||
span : span;
|
||||
}
|
||||
|
||||
|
||||
(** {1 CST → Source (lossless reconstruction)} *)
|
||||
|
||||
let trivia_to_string ts =
|
||||
let buf = Buffer.create 64 in
|
||||
List.iter (function
|
||||
| Whitespace s -> Buffer.add_string buf s
|
||||
| LineComment s -> Buffer.add_string buf s
|
||||
) ts;
|
||||
Buffer.contents buf
|
||||
|
||||
let rec cst_to_source node =
|
||||
match node with
|
||||
| CstAtom { leading_trivia; token; _ } ->
|
||||
trivia_to_string leading_trivia ^ token
|
||||
| CstList { leading_trivia; open_delim; children; close_delim; trailing_trivia; _ } ->
|
||||
let buf = Buffer.create 256 in
|
||||
Buffer.add_string buf (trivia_to_string leading_trivia);
|
||||
Buffer.add_char buf open_delim;
|
||||
List.iter (fun c -> Buffer.add_string buf (cst_to_source c)) children;
|
||||
Buffer.add_string buf (trivia_to_string trailing_trivia);
|
||||
Buffer.add_char buf close_delim;
|
||||
Buffer.contents buf
|
||||
| CstDict { leading_trivia; children; trailing_trivia; _ } ->
|
||||
let buf = Buffer.create 256 in
|
||||
Buffer.add_string buf (trivia_to_string leading_trivia);
|
||||
Buffer.add_char buf '{';
|
||||
List.iter (fun c -> Buffer.add_string buf (cst_to_source c)) children;
|
||||
Buffer.add_string buf (trivia_to_string trailing_trivia);
|
||||
Buffer.add_char buf '}';
|
||||
Buffer.contents buf
|
||||
|
||||
let cst_to_source_file nodes =
|
||||
String.concat "" (List.map cst_to_source nodes)
|
||||
|
||||
(** Reconstruct source from a parsed file (nodes + trailing trivia). *)
|
||||
let cst_file_to_source nodes trailing =
|
||||
cst_to_source_file nodes ^ trivia_to_string trailing
|
||||
|
||||
|
||||
(** {1 CST → AST (strip trivia for evaluation)} *)
|
||||
|
||||
let rec cst_to_ast = function
|
||||
| CstAtom { value; _ } -> value
|
||||
| CstList { children; _ } ->
|
||||
List (List.map cst_to_ast children)
|
||||
| CstDict { children; _ } ->
|
||||
let d = make_dict () in
|
||||
let rec pairs = function
|
||||
| k :: v :: rest ->
|
||||
let key_str = match cst_to_ast k with
|
||||
| Keyword k -> k | String k -> k | Symbol k -> k | _ -> ""
|
||||
in
|
||||
dict_set d key_str (cst_to_ast v);
|
||||
pairs rest
|
||||
| _ -> ()
|
||||
in
|
||||
pairs children;
|
||||
Dict d
|
||||
|
||||
|
||||
(** {1 CST editing — apply AST-level edits back to the CST} *)
|
||||
|
||||
(** Replace the CST node at [path] with [new_source], preserving the
|
||||
original node's leading trivia. [new_source] is parsed as CST so
|
||||
any comments in it are preserved. *)
|
||||
let apply_edit path new_cst_nodes original_cst_nodes =
|
||||
let rec go nodes idx_path =
|
||||
match idx_path with
|
||||
| [] -> nodes (* shouldn't happen *)
|
||||
| [target] ->
|
||||
List.mapi (fun i node ->
|
||||
if i = target then
|
||||
match new_cst_nodes with
|
||||
| [replacement] ->
|
||||
(* Preserve original leading trivia *)
|
||||
let orig_trivia = match node with
|
||||
| CstAtom { leading_trivia; _ } -> leading_trivia
|
||||
| CstList { leading_trivia; _ } -> leading_trivia
|
||||
| CstDict { leading_trivia; _ } -> leading_trivia
|
||||
in
|
||||
(match replacement with
|
||||
| CstAtom r -> CstAtom { r with leading_trivia = orig_trivia }
|
||||
| CstList r -> CstList { r with leading_trivia = orig_trivia }
|
||||
| CstDict r -> CstDict { r with leading_trivia = orig_trivia })
|
||||
| _ -> node (* multi-node replacement: use as-is *)
|
||||
else node
|
||||
) nodes
|
||||
| target :: rest ->
|
||||
List.mapi (fun i node ->
|
||||
if i = target then
|
||||
match node with
|
||||
| CstList r ->
|
||||
CstList { r with children = go r.children rest }
|
||||
| CstDict r ->
|
||||
CstDict { r with children = go r.children rest }
|
||||
| _ -> node
|
||||
else node
|
||||
) nodes
|
||||
in
|
||||
go original_cst_nodes path
|
||||
453
hosts/ocaml/lib/sx_parser.ml
Normal file
453
hosts/ocaml/lib/sx_parser.ml
Normal file
@@ -0,0 +1,453 @@
|
||||
(** S-expression parser.
|
||||
|
||||
Recursive descent over a string, producing [Sx_types.value list].
|
||||
Supports: lists, dicts, symbols, keywords, strings (with escapes),
|
||||
numbers, booleans, nil, comments, quote/quasiquote/unquote sugar. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
type state = {
|
||||
src : string;
|
||||
len : int;
|
||||
mutable pos : int;
|
||||
}
|
||||
|
||||
let make_state src = { src; len = String.length src; pos = 0 }
|
||||
|
||||
let peek s = if s.pos < s.len then Some s.src.[s.pos] else None
|
||||
let advance s = s.pos <- s.pos + 1
|
||||
let at_end s = s.pos >= s.len
|
||||
|
||||
let skip_whitespace_and_comments s =
|
||||
let rec go () =
|
||||
if at_end s then ()
|
||||
else match s.src.[s.pos] with
|
||||
| ' ' | '\t' | '\n' | '\r' -> advance s; go ()
|
||||
| ';' ->
|
||||
while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done;
|
||||
if s.pos < s.len then advance s;
|
||||
go ()
|
||||
| _ -> ()
|
||||
in go ()
|
||||
|
||||
(* Character classification — matches spec/parser.sx ident-start/ident-char.
|
||||
ident-start: a-z A-Z _ ~ * + - > < = / ! ? &
|
||||
ident-char: ident-start plus 0-9 . : / # , *)
|
||||
let is_ident_start = function
|
||||
| 'a'..'z' | 'A'..'Z' | '_' | '~' | '*' | '+' | '-'
|
||||
| '>' | '<' | '=' | '/' | '!' | '?' | '&' -> true
|
||||
| _ -> false
|
||||
|
||||
let is_ident_char = function
|
||||
| c when is_ident_start c -> true
|
||||
| '0'..'9' | '.' | ':' | '#' | ',' -> true
|
||||
| _ -> false
|
||||
|
||||
(* Symbol reading uses ident_char; first char must be ident_start or digit/colon *)
|
||||
let is_symbol_char = is_ident_char
|
||||
|
||||
let read_string s =
|
||||
(* s.pos is on the opening quote *)
|
||||
advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '"' then Buffer.contents buf
|
||||
else if c = '\\' then begin
|
||||
if at_end s then raise (Parse_error "Unterminated string escape");
|
||||
let esc = s.src.[s.pos] in
|
||||
advance s;
|
||||
(match esc with
|
||||
| 'n' -> Buffer.add_char buf '\n'
|
||||
| 't' -> Buffer.add_char buf '\t'
|
||||
| 'r' -> Buffer.add_char buf '\r'
|
||||
| '"' -> Buffer.add_char buf '"'
|
||||
| '\\' -> Buffer.add_char buf '\\'
|
||||
| 'u' ->
|
||||
(* \uXXXX — read 4 hex digits, encode as UTF-8 *)
|
||||
if s.pos + 4 > s.len then raise (Parse_error "Incomplete \\u escape");
|
||||
let hex = String.sub s.src s.pos 4 in
|
||||
s.pos <- s.pos + 4;
|
||||
let code = int_of_string ("0x" ^ hex) in
|
||||
let ubuf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar ubuf (Uchar.of_int code);
|
||||
Buffer.add_string buf (Buffer.contents ubuf)
|
||||
| '`' -> Buffer.add_char buf '`'
|
||||
| _ -> Buffer.add_char buf '\\'; Buffer.add_char buf esc);
|
||||
go ()
|
||||
end else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
let read_symbol s =
|
||||
let start = s.pos in
|
||||
while s.pos < s.len && is_symbol_char s.src.[s.pos] do advance s done;
|
||||
String.sub s.src start (s.pos - start)
|
||||
|
||||
let try_number str =
|
||||
match float_of_string_opt str with
|
||||
| Some n -> Some (Number n)
|
||||
| None -> None
|
||||
|
||||
let rec read_value s : value =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then begin
|
||||
let line = ref 1 in
|
||||
String.iter (fun c -> if c = '\n' then incr line) s.src;
|
||||
raise (Parse_error (Printf.sprintf "Unexpected end of input at line %d (pos %d)" !line s.pos))
|
||||
end;
|
||||
match s.src.[s.pos] with
|
||||
| '(' -> read_list s ')'
|
||||
| '[' -> read_list s ']'
|
||||
| '{' -> read_dict s
|
||||
| '"' -> String (read_string s)
|
||||
| '\'' -> advance s; List [Symbol "quote"; read_value s]
|
||||
| '`' -> advance s; List [Symbol "quasiquote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
|
||||
(* Datum comment: #; discards next expression *)
|
||||
advance s; advance s;
|
||||
ignore (read_value s);
|
||||
read_value s
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' ->
|
||||
(* Quote shorthand: #'expr -> (quote expr) *)
|
||||
advance s; advance s;
|
||||
List [Symbol "quote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' ->
|
||||
(* Raw string: #|...| — ends at next | *)
|
||||
advance s; advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated raw string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '|' then
|
||||
String (Buffer.contents buf)
|
||||
else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
| ',' ->
|
||||
(* Unquote / splice-unquote — matches spec: , always triggers unquote *)
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
| _ ->
|
||||
begin
|
||||
(* Symbol, keyword, number, or boolean *)
|
||||
let token = read_symbol s in
|
||||
if token = "" then begin
|
||||
let line = ref 1 and col = ref 1 in
|
||||
for i = 0 to s.pos - 1 do
|
||||
if s.src.[i] = '\n' then (incr line; col := 1) else incr col
|
||||
done;
|
||||
raise (Parse_error (Printf.sprintf "Unexpected char: %c at line %d col %d (pos %d)"
|
||||
s.src.[s.pos] !line !col s.pos))
|
||||
end;
|
||||
match token with
|
||||
| "true" -> Bool true
|
||||
| "false" -> Bool false
|
||||
| "nil" -> Nil
|
||||
| _ when token.[0] = ':' ->
|
||||
Keyword (String.sub token 1 (String.length token - 1))
|
||||
| _ ->
|
||||
match try_number token with
|
||||
| Some n -> n
|
||||
| None -> Symbol token
|
||||
end
|
||||
|
||||
and read_list s close_char =
|
||||
advance s; (* skip opening paren/bracket *)
|
||||
let items = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated list");
|
||||
if s.src.[s.pos] = close_char then begin
|
||||
advance s;
|
||||
List (List.rev !items)
|
||||
end else begin
|
||||
items := read_value s :: !items;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
and read_dict s =
|
||||
advance s; (* skip { *)
|
||||
let d = make_dict () in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated dict");
|
||||
if s.src.[s.pos] = '}' then begin
|
||||
advance s;
|
||||
Dict d
|
||||
end else begin
|
||||
let key = read_value s in
|
||||
let key_str = match key with
|
||||
| Keyword k -> k
|
||||
| String k -> k
|
||||
| Symbol k -> k
|
||||
| _ -> raise (Parse_error "Dict key must be keyword, string, or symbol")
|
||||
in
|
||||
let v = read_value s in
|
||||
dict_set d key_str v;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
|
||||
(** Parse a string into a list of SX values (AST — comments stripped). *)
|
||||
let parse_all src =
|
||||
let s = make_state src in
|
||||
let results = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then List.rev !results
|
||||
else begin
|
||||
results := read_value s :: !results;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
(** Parse a file into a list of SX values (AST — comments stripped). *)
|
||||
let parse_file path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let src = really_input_string ic n in
|
||||
close_in ic;
|
||||
parse_all src
|
||||
|
||||
|
||||
(* ================================================================== *)
|
||||
(* CST parser — lossless concrete syntax tree *)
|
||||
(* ================================================================== *)
|
||||
|
||||
open Sx_cst
|
||||
|
||||
(** Collect leading trivia (whitespace + comments) from current position. *)
|
||||
let collect_trivia s =
|
||||
let items = ref [] in
|
||||
let rec go () =
|
||||
if at_end s then ()
|
||||
else match s.src.[s.pos] with
|
||||
| ' ' | '\t' | '\n' | '\r' ->
|
||||
let start = s.pos in
|
||||
while s.pos < s.len && (let c = s.src.[s.pos] in c = ' ' || c = '\t' || c = '\n' || c = '\r') do
|
||||
advance s
|
||||
done;
|
||||
items := Whitespace (String.sub s.src start (s.pos - start)) :: !items;
|
||||
go ()
|
||||
| ';' ->
|
||||
let start = s.pos in
|
||||
while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done;
|
||||
let text = String.sub s.src start (s.pos - start) in
|
||||
if s.pos < s.len then advance s;
|
||||
(* Include the newline in the comment trivia *)
|
||||
let text = if s.pos > 0 && s.pos <= s.len && s.src.[s.pos - 1] = '\n'
|
||||
then text ^ "\n" else text in
|
||||
items := LineComment text :: !items;
|
||||
go ()
|
||||
| _ -> ()
|
||||
in
|
||||
go ();
|
||||
List.rev !items
|
||||
|
||||
(** Read a single CST value — dispatches on first non-trivia char. *)
|
||||
let rec read_cst s : cst_node =
|
||||
let trivia = collect_trivia s in
|
||||
if at_end s then
|
||||
raise (Parse_error "Unexpected end of input");
|
||||
let start = s.pos in
|
||||
match s.src.[s.pos] with
|
||||
| '(' -> read_cst_list s trivia start '(' ')'
|
||||
| '[' -> read_cst_list s trivia start '[' ']'
|
||||
| '{' -> read_cst_dict s trivia start
|
||||
| '\'' ->
|
||||
(* Quote sugar: 'x → (quote x) — emit as raw token *)
|
||||
advance s;
|
||||
let inner = read_cst s in
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
let value = List [Symbol "quote"; cst_to_ast inner] in
|
||||
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
|
||||
| '`' ->
|
||||
advance s;
|
||||
let inner = read_cst s in
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
let value = List [Symbol "quasiquote"; cst_to_ast inner] in
|
||||
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
|
||||
| ',' ->
|
||||
advance s;
|
||||
let splice = s.pos < s.len && s.src.[s.pos] = '@' in
|
||||
if splice then advance s;
|
||||
let inner = read_cst s in
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
let sym = if splice then "splice-unquote" else "unquote" in
|
||||
let value = List [Symbol sym; cst_to_ast inner] in
|
||||
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
|
||||
(* Datum comment: #; discards next expression *)
|
||||
advance s; advance s;
|
||||
let _discarded = read_cst s in
|
||||
(* Read the real value after the datum comment — attach trivia from #; *)
|
||||
let next = read_cst s in
|
||||
let combined_trivia = trivia @ (match next with
|
||||
| CstAtom r -> r.leading_trivia
|
||||
| CstList r -> r.leading_trivia
|
||||
| CstDict r -> r.leading_trivia) in
|
||||
(match next with
|
||||
| CstAtom r -> CstAtom { r with leading_trivia = combined_trivia }
|
||||
| CstList r -> CstList { r with leading_trivia = combined_trivia }
|
||||
| CstDict r -> CstDict { r with leading_trivia = combined_trivia })
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' ->
|
||||
advance s; advance s;
|
||||
let inner = read_cst s in
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
let value = List [Symbol "quote"; cst_to_ast inner] in
|
||||
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' ->
|
||||
(* Raw string: #|...| *)
|
||||
advance s; advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated raw string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '|' then ()
|
||||
else begin Buffer.add_char buf c; go () end
|
||||
in
|
||||
go ();
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
CstAtom { leading_trivia = trivia; token; value = String (Buffer.contents buf);
|
||||
span = { start_offset = start; end_offset = end_pos } }
|
||||
| '"' ->
|
||||
let value = String (read_string s) in
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
CstAtom { leading_trivia = trivia; token; value;
|
||||
span = { start_offset = start; end_offset = end_pos } }
|
||||
| _ ->
|
||||
let sym = read_symbol s in
|
||||
if sym = "" then begin
|
||||
let line = ref 1 and col = ref 1 in
|
||||
for i = 0 to s.pos - 1 do
|
||||
if s.src.[i] = '\n' then (incr line; col := 1) else incr col
|
||||
done;
|
||||
raise (Parse_error (Printf.sprintf "Unexpected char: %c at line %d col %d (pos %d)"
|
||||
s.src.[s.pos] !line !col s.pos))
|
||||
end;
|
||||
let end_pos = s.pos in
|
||||
let token = String.sub s.src start (end_pos - start) in
|
||||
let value = match sym with
|
||||
| "true" -> Bool true
|
||||
| "false" -> Bool false
|
||||
| "nil" -> Nil
|
||||
| _ when sym.[0] = ':' -> Keyword (String.sub sym 1 (String.length sym - 1))
|
||||
| _ -> match try_number sym with Some n -> n | None -> Symbol sym
|
||||
in
|
||||
CstAtom { leading_trivia = trivia; token; value;
|
||||
span = { start_offset = start; end_offset = end_pos } }
|
||||
|
||||
and read_cst_list s trivia start open_c close_c =
|
||||
advance s; (* skip open delim *)
|
||||
let children = ref [] in
|
||||
let rec go () =
|
||||
let child_trivia = collect_trivia s in
|
||||
if at_end s then raise (Parse_error "Unterminated list");
|
||||
if s.src.[s.pos] = close_c then begin
|
||||
advance s;
|
||||
let end_pos = s.pos in
|
||||
CstList { leading_trivia = trivia; open_delim = open_c;
|
||||
children = List.rev !children; close_delim = close_c;
|
||||
trailing_trivia = child_trivia;
|
||||
span = { start_offset = start; end_offset = end_pos } }
|
||||
end else begin
|
||||
(* Push collected trivia onto the next child *)
|
||||
let child_start = s.pos in
|
||||
let child = read_cst_inner s in
|
||||
let child_with_trivia = match child with
|
||||
| CstAtom r -> CstAtom { r with leading_trivia = child_trivia @ r.leading_trivia }
|
||||
| CstList r -> CstList { r with leading_trivia = child_trivia @ r.leading_trivia }
|
||||
| CstDict r -> CstDict { r with leading_trivia = child_trivia @ r.leading_trivia }
|
||||
in
|
||||
ignore child_start;
|
||||
children := child_with_trivia :: !children;
|
||||
go ()
|
||||
end
|
||||
in
|
||||
go ()
|
||||
|
||||
and read_cst_dict s trivia start =
|
||||
advance s; (* skip { *)
|
||||
let children = ref [] in
|
||||
let rec go () =
|
||||
let child_trivia = collect_trivia s in
|
||||
if at_end s then raise (Parse_error "Unterminated dict");
|
||||
if s.src.[s.pos] = '}' then begin
|
||||
advance s;
|
||||
let end_pos = s.pos in
|
||||
CstDict { leading_trivia = trivia; children = List.rev !children;
|
||||
trailing_trivia = child_trivia;
|
||||
span = { start_offset = start; end_offset = end_pos } }
|
||||
end else begin
|
||||
let child = read_cst_inner s in
|
||||
let child_with_trivia = match child with
|
||||
| CstAtom r -> CstAtom { r with leading_trivia = child_trivia @ r.leading_trivia }
|
||||
| CstList r -> CstList { r with leading_trivia = child_trivia @ r.leading_trivia }
|
||||
| CstDict r -> CstDict { r with leading_trivia = child_trivia @ r.leading_trivia }
|
||||
in
|
||||
children := child_with_trivia :: !children;
|
||||
go ()
|
||||
end
|
||||
in
|
||||
go ()
|
||||
|
||||
(** Inner read — no trivia collection (caller handles it). *)
|
||||
and read_cst_inner s : cst_node =
|
||||
read_cst s
|
||||
|
||||
(** Parse result: list of CST nodes + any trailing trivia after the last node. *)
|
||||
type cst_file = {
|
||||
nodes : cst_node list;
|
||||
trailing_trivia : trivia list;
|
||||
}
|
||||
|
||||
(** Parse a string into a list of CST nodes. *)
|
||||
let parse_all_cst src =
|
||||
let s = make_state src in
|
||||
let results = ref [] in
|
||||
let rec go () =
|
||||
let trivia = collect_trivia s in
|
||||
if at_end s then
|
||||
{ nodes = List.rev !results; trailing_trivia = trivia }
|
||||
else begin
|
||||
let node = read_cst_inner s in
|
||||
(* Prepend collected trivia to this node *)
|
||||
let node_with_trivia = match node with
|
||||
| CstAtom r -> CstAtom { r with leading_trivia = trivia @ r.leading_trivia }
|
||||
| CstList r -> CstList { r with leading_trivia = trivia @ r.leading_trivia }
|
||||
| CstDict r -> CstDict { r with leading_trivia = trivia @ r.leading_trivia }
|
||||
in
|
||||
results := node_with_trivia :: !results;
|
||||
go ()
|
||||
end
|
||||
in
|
||||
go ()
|
||||
|
||||
(** Parse a file into a list of CST nodes. *)
|
||||
let parse_file_cst path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let src = really_input_string ic n in
|
||||
close_in ic;
|
||||
parse_all_cst src
|
||||
1594
hosts/ocaml/lib/sx_primitives.ml
Normal file
1594
hosts/ocaml/lib/sx_primitives.ml
Normal file
File diff suppressed because it is too large
Load Diff
985
hosts/ocaml/lib/sx_ref.ml
Normal file
985
hosts/ocaml/lib/sx_ref.ml
Normal file
File diff suppressed because one or more lines are too long
380
hosts/ocaml/lib/sx_render.ml
Normal file
380
hosts/ocaml/lib/sx_render.ml
Normal file
File diff suppressed because one or more lines are too long
508
hosts/ocaml/lib/sx_runtime.ml
Normal file
508
hosts/ocaml/lib/sx_runtime.ml
Normal file
@@ -0,0 +1,508 @@
|
||||
(** Runtime helpers for transpiled code.
|
||||
|
||||
These bridge the gap between the transpiler's output and the
|
||||
foundation types/primitives. The transpiled evaluator calls these
|
||||
functions directly. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** Call a registered primitive by name. *)
|
||||
let prim_call name args =
|
||||
match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f args
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(** Convert any SX value to an OCaml string (internal). *)
|
||||
let value_to_str = function
|
||||
| String s -> s
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> k
|
||||
| v -> inspect v
|
||||
|
||||
(** sx_to_string returns a value (String) for transpiled code. *)
|
||||
let sx_to_string v = String (value_to_str v)
|
||||
|
||||
(** String concatenation helper — [sx_str] takes a list of values. *)
|
||||
let sx_str args =
|
||||
String.concat "" (List.map value_to_str args)
|
||||
|
||||
(** Convert a value to a list. *)
|
||||
let sx_to_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
(** Call an SX callable (lambda, native fn, continuation). *)
|
||||
let sx_call f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| VmClosure cl -> !Sx_types._vm_call_closure_ref cl args
|
||||
| Lambda l ->
|
||||
let local = Sx_types.env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
||||
Thunk (l.l_body, local)
|
||||
| Continuation (k, _) ->
|
||||
k (match args with x :: _ -> x | [] -> Nil)
|
||||
| CallccContinuation _ ->
|
||||
raise (Eval_error "callcc continuations must be invoked through the CEK machine")
|
||||
| _ ->
|
||||
let nargs = List.length args in
|
||||
let args_preview = if nargs = 0 then "" else
|
||||
let s = String.concat ", " (List.map (fun a -> let s = inspect a in if String.length s > 40 then String.sub s 0 40 ^ ".." else s) args) in
|
||||
" with args=[" ^ s ^ "]" in
|
||||
raise (Eval_error ("Not callable: " ^ inspect f ^ args_preview))
|
||||
|
||||
(* Initialize forward ref so primitives can call SX functions *)
|
||||
let () = Sx_primitives._sx_call_fn := sx_call
|
||||
(* Trampoline ref is set by sx_ref.ml after it's loaded *)
|
||||
|
||||
(** Apply a function to a list of args. *)
|
||||
let sx_apply f args_list =
|
||||
sx_call f (sx_to_list args_list)
|
||||
|
||||
(** CEK-safe apply — catches Eval_error from native fns and returns an error
|
||||
marker dict instead of raising. The CEK evaluator checks for this and
|
||||
converts to a raise-eval state so guard/handler-bind can intercept it.
|
||||
Non-native calls (lambda, continuation) delegate to sx_apply unchanged. *)
|
||||
let sx_apply_cek f args_list =
|
||||
match f with
|
||||
| NativeFn _ | VmClosure _ ->
|
||||
(try sx_apply f args_list
|
||||
with Eval_error msg ->
|
||||
let d = Hashtbl.create 3 in
|
||||
Hashtbl.replace d "__eval_error__" (Bool true);
|
||||
Hashtbl.replace d "message" (String msg);
|
||||
Dict d)
|
||||
| _ -> sx_apply f args_list
|
||||
|
||||
(** Check if a value is an eval-error marker from sx_apply_cek. *)
|
||||
let is_eval_error v =
|
||||
match v with
|
||||
| Dict d -> (match Hashtbl.find_opt d "__eval_error__" with
|
||||
| Some (Bool true) -> true | _ -> false)
|
||||
| _ -> false
|
||||
|
||||
(** Mutable append — add item to a list ref or accumulator.
|
||||
In transpiled code, lists that get appended to are mutable refs. *)
|
||||
let sx_append_b lst item =
|
||||
match lst with
|
||||
| List items -> List (items @ [item])
|
||||
| ListRef r -> r := !r @ [item]; lst (* mutate in place, return same ref *)
|
||||
| _ -> raise (Eval_error ("append!: expected list, got " ^ type_of lst))
|
||||
|
||||
(** Mutable dict-set — set key in dict, return value. *)
|
||||
let sx_dict_set_b d k v =
|
||||
match d, k with
|
||||
| Dict tbl, String key -> Hashtbl.replace tbl key v; v
|
||||
| Dict tbl, Keyword key -> Hashtbl.replace tbl key v; v
|
||||
| CekFrame f, String key ->
|
||||
(match key with
|
||||
| "value" | "extra" | "ho-type" | "scheme" | "indexed"
|
||||
| "phase" | "has-effects" | "match-val" | "current-item"
|
||||
| "update-fn" | "head-name" -> f.cf_extra <- v; v
|
||||
| "remaining" -> f.cf_remaining <- v; v
|
||||
| "subscribers" | "results" | "raw-args" -> f.cf_results <- v; v
|
||||
| "emitted" | "effect-list" | "first-render" | "extra2" -> f.cf_extra2 <- v; v
|
||||
| _ -> raise (Eval_error ("dict-set! cek-frame: unknown field " ^ key)))
|
||||
| VmFrame f, String key ->
|
||||
(match key with
|
||||
| "ip" -> f.vf_ip <- val_to_int v; v
|
||||
| _ -> raise (Eval_error ("dict-set! vm-frame: unknown field " ^ key)))
|
||||
| VmMachine m, String key ->
|
||||
(match key with
|
||||
| "sp" -> m.vm_sp <- val_to_int v; v
|
||||
| "frames" -> m.vm_frames <- (match v with List l -> List.map (fun x -> match x with VmFrame f -> f | _ -> raise (Eval_error "vm: frames must be vm-frame list")) l | _ -> []); v
|
||||
| "stack" -> (match v with List _ -> v | _ -> raise (Eval_error "vm: stack must be array"))
|
||||
| _ -> raise (Eval_error ("dict-set! vm-machine: unknown field " ^ key)))
|
||||
| _ -> raise (Eval_error "dict-set!: expected dict and string key")
|
||||
|
||||
(** Get from dict or list. *)
|
||||
let get_val container key =
|
||||
match container, key with
|
||||
| CekState s, String k ->
|
||||
(match k with
|
||||
| "control" -> s.cs_control | "env" -> s.cs_env
|
||||
| "kont" -> s.cs_kont | "phase" -> String s.cs_phase
|
||||
| "value" -> s.cs_value | _ -> Nil)
|
||||
| CekFrame f, String k ->
|
||||
(match k with
|
||||
| "type" -> String f.cf_type | "env" -> f.cf_env
|
||||
| "name" -> f.cf_name | "body" -> f.cf_body
|
||||
| "remaining" -> f.cf_remaining | "f" -> f.cf_f
|
||||
| "args" -> f.cf_args | "evaled" -> f.cf_args
|
||||
| "results" -> f.cf_results | "raw-args" -> f.cf_results
|
||||
| "then" -> f.cf_body | "else" -> f.cf_name
|
||||
| "ho-type" -> f.cf_extra | "scheme" -> f.cf_extra
|
||||
| "indexed" -> f.cf_extra | "value" -> f.cf_extra
|
||||
| "phase" -> f.cf_extra | "has-effects" -> f.cf_extra
|
||||
| "match-val" -> f.cf_extra | "current-item" -> f.cf_extra
|
||||
| "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra
|
||||
| "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
|
||||
| "first-render" -> f.cf_extra2 | "file" -> f.cf_env
|
||||
| "extra" -> f.cf_extra | "extra2" -> f.cf_extra2
|
||||
| "subscribers" -> f.cf_results
|
||||
| "prev-tracking" -> f.cf_extra
|
||||
| _ -> Nil)
|
||||
| VmFrame f, String k ->
|
||||
(match k with
|
||||
| "ip" -> Number (float_of_int f.vf_ip)
|
||||
| "closure" -> VmClosure f.vf_closure
|
||||
| "base" -> Number (float_of_int f.vf_base)
|
||||
| "local-cells" -> Nil (* opaque — accessed via frame-local-get/set *)
|
||||
| _ -> Nil)
|
||||
| VmMachine m, String k ->
|
||||
(match k with
|
||||
| "sp" -> Number (float_of_int m.vm_sp)
|
||||
| "stack" -> Nil (* opaque — accessed via vm-push/pop *)
|
||||
| "frames" -> List (List.map (fun f -> VmFrame f) m.vm_frames)
|
||||
| "globals" -> Dict m.vm_globals
|
||||
| _ -> Nil)
|
||||
| VmClosure cl, String k ->
|
||||
(match k with
|
||||
| "vm-code" ->
|
||||
(* Return vm_code fields as a Dict. The bytecode and constants arrays
|
||||
are lazily converted to Lists and cached on the vm_code record so
|
||||
the transpiled VM loop (which re-derives bc/consts each iteration)
|
||||
doesn't allocate on every step. *)
|
||||
let c = cl.vm_code in
|
||||
let bc = match c.vc_bytecode_list with
|
||||
| Some l -> l
|
||||
| None ->
|
||||
let l = Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vc_bytecode) in
|
||||
c.vc_bytecode_list <- Some l; l in
|
||||
let consts = match c.vc_constants_list with
|
||||
| Some l -> l
|
||||
| None ->
|
||||
let l = Array.to_list c.vc_constants in
|
||||
c.vc_constants_list <- Some l; l in
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "vc-bytecode" (List bc);
|
||||
Hashtbl.replace d "vc-constants" (List consts);
|
||||
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity));
|
||||
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals));
|
||||
Dict d
|
||||
| "vm-upvalues" ->
|
||||
List (Array.to_list (Array.map (fun uv -> uv.uv_value) cl.vm_upvalues))
|
||||
| "vm-name" ->
|
||||
(match cl.vm_name with Some n -> String n | None -> Nil)
|
||||
| "vm-globals" -> Dict cl.vm_env_ref
|
||||
| "vm-closure-env" ->
|
||||
(match cl.vm_closure_env with Some e -> Env e | None -> Nil)
|
||||
| _ -> Nil)
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
| (List l | ListRef { contents = l }), Number n ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| Nil, _ -> Nil (* nil.anything → nil *)
|
||||
| _, _ -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
|
||||
|
||||
(** Register get as a primitive override — transpiled code calls (get d k). *)
|
||||
let () =
|
||||
Sx_primitives.register "get" (fun args ->
|
||||
match args with
|
||||
| [c; k] -> get_val c k
|
||||
| [c; k; default] ->
|
||||
(try
|
||||
let v = get_val c k in
|
||||
if v = Nil then default else v
|
||||
with _ -> default)
|
||||
| _ -> raise (Eval_error "get: 2-3 args"))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Primitive aliases — top-level functions called by transpiled code *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** The transpiled evaluator calls primitives directly by their mangled
|
||||
OCaml name. These aliases delegate to the primitives table so the
|
||||
transpiled code compiles without needing [prim_call] everywhere. *)
|
||||
|
||||
let _prim name = match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f | None -> (fun _ -> raise (Eval_error ("Missing prim: " ^ name)))
|
||||
|
||||
(* Collection ops *)
|
||||
let first args = _prim "first" [args]
|
||||
let rest args = _prim "rest" [args]
|
||||
let last args = _prim "last" [args]
|
||||
let nth coll i = _prim "nth" [coll; i]
|
||||
let cons x l = _prim "cons" [x; l]
|
||||
let append a b = _prim "append" [a; b]
|
||||
let reverse l = _prim "reverse" [l]
|
||||
let flatten l = _prim "flatten" [l]
|
||||
let concat a b = _prim "concat" [a; b]
|
||||
let slice a b = _prim "slice" [a; b]
|
||||
let len a = _prim "len" [a]
|
||||
let get a b = get_val a b
|
||||
let sort' a = _prim "sort" [a]
|
||||
let range' a = _prim "range" [a]
|
||||
let unique a = _prim "unique" [a]
|
||||
let zip a b = _prim "zip" [a; b]
|
||||
let take a b = _prim "take" [a; b]
|
||||
let drop a b = _prim "drop" [a; b]
|
||||
|
||||
(* Predicates *)
|
||||
let keyword_p a = _prim "keyword?" [a]
|
||||
let empty_p a = _prim "empty?" [a]
|
||||
let number_p a = _prim "number?" [a]
|
||||
let string_p a = _prim "string?" [a]
|
||||
let boolean_p a = _prim "boolean?" [a]
|
||||
let list_p a = _prim "list?" [a]
|
||||
let dict_p a = _prim "dict?" [a]
|
||||
let symbol_p a = _prim "symbol?" [a]
|
||||
|
||||
(* String ops *)
|
||||
let str' args = String (sx_str args)
|
||||
let upper a = _prim "upper" [a]
|
||||
let upcase a = _prim "upcase" [a]
|
||||
let lower a = _prim "lower" [a]
|
||||
let downcase a = _prim "downcase" [a]
|
||||
let trim a = _prim "trim" [a]
|
||||
let split a b = _prim "split" [a; b]
|
||||
let join a b = _prim "join" [a; b]
|
||||
let replace a b c = _prim "replace" [a; b; c]
|
||||
let substring a b c = _prim "substring" [a; b; c]
|
||||
|
||||
(* Dict ops *)
|
||||
let assoc d k v = _prim "assoc" [d; k; v]
|
||||
let dissoc d k = _prim "dissoc" [d; k]
|
||||
let merge' a b = _prim "merge" [a; b]
|
||||
let keys a = _prim "keys" [a]
|
||||
let vals a = _prim "vals" [a]
|
||||
let dict_set a b c = _prim "dict-set!" [a; b; c]
|
||||
let dict_get a b = _prim "dict-get" [a; b]
|
||||
let dict_delete a b = _prim "dict-delete!" [a; b]
|
||||
|
||||
(* Math *)
|
||||
let abs' a = _prim "abs" [a]
|
||||
let sqrt' a = _prim "sqrt" [a]
|
||||
let pow' a b = _prim "pow" [a; b]
|
||||
let floor' a = _prim "floor" [a]
|
||||
let ceil' a = _prim "ceil" [a]
|
||||
let round' a = _prim "round" [a]
|
||||
let min' a b = _prim "min" [a; b]
|
||||
let max' a b = _prim "max" [a; b]
|
||||
let clamp a b c = _prim "clamp" [a; b; c]
|
||||
|
||||
(* Misc *)
|
||||
let error msg = raise (Eval_error (value_to_str msg))
|
||||
|
||||
(* inspect wrapper — returns String value instead of OCaml string *)
|
||||
let inspect v = String (Sx_types.inspect v)
|
||||
let apply' f args = sx_apply f args
|
||||
let spread_attrs a = _prim "spread-attrs" [a]
|
||||
|
||||
let sx_context a b = prim_call "context" [a; b]
|
||||
|
||||
(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
|
||||
(* This is a stub; the real trampoline is wired up in sx_ref.ml after eval_expr is defined *)
|
||||
let trampoline v = v
|
||||
|
||||
(* Value-returning type predicates — the transpiled code passes these through
|
||||
sx_truthy, so they need to return Bool, not OCaml bool. *)
|
||||
(* type_of returns value, not string *)
|
||||
let type_of v = String (Sx_types.type_of v)
|
||||
|
||||
(* Env operations — accept Env-wrapped values and value keys.
|
||||
The transpiled CEK machine stores envs in dicts as Env values. *)
|
||||
let unwrap_env = function
|
||||
| Env e -> e
|
||||
| Dict d ->
|
||||
(* Dict used as env — wrap it. Needed by adapter-html.sx which
|
||||
passes dicts as env args (e.g. empty {} as caller env). *)
|
||||
let e = Sx_types.make_env () in
|
||||
Hashtbl.iter (fun k v -> ignore (Sx_types.env_bind e k v)) d;
|
||||
e
|
||||
| Nil ->
|
||||
Sx_types.make_env ()
|
||||
| v -> raise (Eval_error ("Expected env, got " ^ Sx_types.type_of v))
|
||||
|
||||
let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
|
||||
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)
|
||||
let env_bind e name v = Sx_types.env_bind (unwrap_env e) (value_to_str name) v
|
||||
let env_set e name v = Sx_types.env_set (unwrap_env e) (value_to_str name) v
|
||||
|
||||
let make_env () = Env (Sx_types.make_env ())
|
||||
let env_extend e = Env (Sx_types.env_extend (unwrap_env e))
|
||||
let env_merge a b = Env (Sx_types.env_merge (unwrap_env a) (unwrap_env b))
|
||||
|
||||
(* set_lambda_name wrapper — accepts value, extracts string *)
|
||||
let set_lambda_name l n = Sx_types.set_lambda_name l (value_to_str n)
|
||||
|
||||
let is_nil v = Bool (Sx_types.is_nil v)
|
||||
let is_thunk v = Bool (Sx_types.is_thunk v)
|
||||
let is_lambda v = Bool (Sx_types.is_lambda v)
|
||||
let is_component v = Bool (Sx_types.is_component v)
|
||||
let is_island v = Bool (Sx_types.is_island v)
|
||||
let is_macro v = Bool (Sx_types.is_macro v)
|
||||
let is_signal v = Bool (Sx_types.is_signal v)
|
||||
let is_callable v = Bool (Sx_types.is_callable v)
|
||||
let is_primitive name = Bool (Sx_primitives.is_primitive (value_to_str name))
|
||||
let get_primitive name = Sx_primitives.get_primitive (value_to_str name)
|
||||
|
||||
(* Stubs for functions defined in sx_ref.ml — resolved at link time *)
|
||||
(* These are forward-declared here; sx_ref.ml defines the actual implementations *)
|
||||
|
||||
(* strip-prefix *)
|
||||
(* Stubs for evaluator functions — defined in sx_ref.ml but
|
||||
sometimes referenced before their definition via forward calls.
|
||||
These get overridden by the actual transpiled definitions. *)
|
||||
|
||||
let for_each_indexed fn coll =
|
||||
List.iteri (fun i x -> ignore (sx_call fn [Number (float_of_int i); x])) (sx_to_list coll);
|
||||
Nil
|
||||
|
||||
(* Continuation support *)
|
||||
let continuation_p v = match v with Continuation (_, _) -> Bool true | _ -> Bool false
|
||||
|
||||
let make_cek_continuation captured rest_kont =
|
||||
let data = Hashtbl.create 2 in
|
||||
Hashtbl.replace data "captured" captured;
|
||||
Hashtbl.replace data "rest-kont" rest_kont;
|
||||
Continuation ((fun v -> v), Some data)
|
||||
|
||||
let continuation_data v = match v with
|
||||
| Continuation (_, Some d) -> Dict d
|
||||
| Continuation (_, None) -> Dict (Hashtbl.create 0)
|
||||
| _ -> raise (Eval_error "not a continuation")
|
||||
|
||||
(* Callcc (undelimited) continuation support *)
|
||||
let callcc_continuation_p v = match v with CallccContinuation _ -> Bool true | _ -> Bool false
|
||||
|
||||
let make_callcc_continuation captured =
|
||||
CallccContinuation (sx_to_list captured)
|
||||
|
||||
let callcc_continuation_data v = match v with
|
||||
| CallccContinuation frames -> List frames
|
||||
| _ -> raise (Eval_error "not a callcc continuation")
|
||||
|
||||
(* Dynamic wind — simplified for OCaml (no async) *)
|
||||
let host_error msg =
|
||||
raise (Eval_error (value_to_str msg))
|
||||
|
||||
let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call before []);
|
||||
let result = sx_call body [] in
|
||||
ignore (sx_call after []);
|
||||
result
|
||||
|
||||
(* Scope stack — all delegated to primitives registered in sx_server.ml *)
|
||||
let scope_push name value = prim_call "scope-push!" [name; value]
|
||||
let scope_pop name = prim_call "scope-pop!" [name]
|
||||
let scope_peek name = prim_call "scope-peek" [name]
|
||||
let scope_emit name value = prim_call "scope-emit!" [name; value]
|
||||
let provide_push name value = prim_call "scope-push!" [name; value]
|
||||
let provide_pop name = prim_call "scope-pop!" [name]
|
||||
|
||||
(* Custom special forms registry — mutable dict *)
|
||||
let custom_special_forms = Dict (Hashtbl.create 4)
|
||||
|
||||
(* register-special-form! — add a handler to the custom registry *)
|
||||
let register_special_form name handler =
|
||||
(match custom_special_forms with
|
||||
| Dict tbl -> Hashtbl.replace tbl (value_to_str name) handler; handler
|
||||
| _ -> raise (Eval_error "custom_special_forms not a dict"))
|
||||
|
||||
(* Render check/fn hooks — nil by default, set by platform if needed *)
|
||||
let render_check = Nil
|
||||
let render_fn = Nil
|
||||
|
||||
(* is-else-clause? — check if a cond/case test is an else marker *)
|
||||
let is_else_clause v =
|
||||
match v with
|
||||
| Keyword k -> Bool (k = "else" || k = "default")
|
||||
| Symbol s -> Bool (s = "else" || s = "default")
|
||||
| Bool true -> Bool true
|
||||
| _ -> Bool false
|
||||
|
||||
(* Signal accessors *)
|
||||
let signal_value s = match s with
|
||||
| Signal sig' -> sig'.s_value
|
||||
| Dict d -> (match Hashtbl.find_opt d "value" with Some v -> v | None -> Nil)
|
||||
| _ -> raise (Eval_error "not a signal")
|
||||
let signal_add_sub_b s f =
|
||||
match s with
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "subscribers" with
|
||||
| Some (ListRef r) -> r := !r @ [f]; Nil
|
||||
| Some (List items) -> Hashtbl.replace d "subscribers" (ListRef (ref (items @ [f]))); Nil
|
||||
| _ -> Hashtbl.replace d "subscribers" (ListRef (ref [f])); Nil)
|
||||
| _ -> Nil
|
||||
|
||||
let signal_remove_sub_b s f =
|
||||
match s with
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "subscribers" with
|
||||
| Some (ListRef r) -> r := List.filter (fun x -> x != f) !r; Nil
|
||||
| Some (List items) -> Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f) items)); Nil
|
||||
| _ -> Nil)
|
||||
| _ -> Nil
|
||||
|
||||
(* Island scope stubs — accept both bare OCaml fns and NativeFn values
|
||||
from transpiled code (NativeFn wrapping for value-storable lambdas). *)
|
||||
let with_island_scope _register_fn body_fn =
|
||||
match body_fn with
|
||||
| NativeFn (_, f) -> f []
|
||||
| _ -> Nil
|
||||
let register_in_scope _dispose_fn = Nil
|
||||
|
||||
(* Component type annotation stub *)
|
||||
let component_set_param_types_b _comp _types = Nil
|
||||
|
||||
(* Parse keyword args from a call — this is defined in evaluator.sx,
|
||||
the transpiled version will override this stub. *)
|
||||
(* Forward-reference stubs for evaluator functions used before definition *)
|
||||
let parse_comp_params _params = List [List []; Nil; Bool false]
|
||||
let parse_macro_params _params = List [List []; Nil]
|
||||
|
||||
let parse_keyword_args _raw_args _env =
|
||||
(* Stub — the real implementation is transpiled from evaluator.sx *)
|
||||
List [Dict (Hashtbl.create 0); List []]
|
||||
|
||||
(* Make handler def — used by custom_special_forms *)
|
||||
let make_handler_def name params body _env = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "handler"); Hashtbl.replace d "name" name; Hashtbl.replace d "params" params; Hashtbl.replace d "body" body; d)
|
||||
let make_page_def name _opts = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "page"); Hashtbl.replace d "name" name; d)
|
||||
|
||||
(* sf_defhandler — used by custom_special_forms *)
|
||||
let sf_defhandler args env =
|
||||
let name = first args in let rest_args = rest args in
|
||||
make_handler_def name (first rest_args) (nth rest_args (Number 1.0)) env
|
||||
|
||||
let strip_prefix s prefix =
|
||||
match s, prefix with
|
||||
| String s, String p ->
|
||||
let pl = String.length p in
|
||||
if String.length s >= pl && String.sub s 0 pl = p
|
||||
then String (String.sub s pl (String.length s - pl))
|
||||
else String s
|
||||
| _ -> s
|
||||
|
||||
(* debug_log — no-op in production, used by CEK evaluator for component warnings *)
|
||||
let debug_log _ _ = Nil
|
||||
|
||||
(* mutable_list — mutable list for bytecode compiler pool entries *)
|
||||
let mutable_list () = ListRef (ref [])
|
||||
|
||||
(* JIT try-call — ref set by sx_server.ml after compiler loads.
|
||||
Returns Nil (no JIT) or the result value. Spec calls this. *)
|
||||
let _jit_try_call_fn : (value -> value list -> value option) option ref = ref None
|
||||
let _jit_hit = ref 0
|
||||
let _jit_miss = ref 0
|
||||
let _jit_skip = ref 0
|
||||
let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0
|
||||
let jit_try_call f args =
|
||||
match !_jit_try_call_fn with
|
||||
| None -> incr _jit_skip; Nil
|
||||
| Some hook ->
|
||||
match f with
|
||||
| Lambda l when l.l_name <> None ->
|
||||
let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
|
||||
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; Nil)
|
||||
| _ -> incr _jit_skip; Nil
|
||||
|
||||
784
hosts/ocaml/lib/sx_types.ml
Normal file
784
hosts/ocaml/lib/sx_types.ml
Normal file
@@ -0,0 +1,784 @@
|
||||
(** Core types for the SX language.
|
||||
|
||||
The [value] sum type represents every possible SX runtime value.
|
||||
OCaml's algebraic types make the CEK machine's frame dispatch a
|
||||
pattern match — exactly what the spec describes. *)
|
||||
|
||||
(** {1 Symbol interning} *)
|
||||
|
||||
(** Map symbol names to small integers for O(1) env lookups.
|
||||
The intern table is populated once per unique symbol name;
|
||||
all subsequent env operations use the integer key. *)
|
||||
|
||||
let sym_to_id : (string, int) Hashtbl.t = Hashtbl.create 512
|
||||
let id_to_sym : (int, string) Hashtbl.t = Hashtbl.create 512
|
||||
let sym_next = ref 0
|
||||
|
||||
let intern s =
|
||||
match Hashtbl.find_opt sym_to_id s with
|
||||
| Some id -> id
|
||||
| None ->
|
||||
let id = !sym_next in
|
||||
incr sym_next;
|
||||
Hashtbl.replace sym_to_id s id;
|
||||
Hashtbl.replace id_to_sym id s;
|
||||
id
|
||||
|
||||
let unintern id =
|
||||
match Hashtbl.find_opt id_to_sym id with
|
||||
| Some s -> s
|
||||
| None -> "<sym:" ^ string_of_int id ^ ">"
|
||||
|
||||
|
||||
(** {1 Environment} *)
|
||||
|
||||
(** Lexical scope chain. Each frame holds a mutable binding table
|
||||
keyed by interned symbol IDs for fast lookup. *)
|
||||
type env = {
|
||||
bindings : (int, value) Hashtbl.t;
|
||||
parent : env option;
|
||||
}
|
||||
|
||||
(** {1 Values} *)
|
||||
|
||||
and value =
|
||||
| Nil
|
||||
| Bool of bool
|
||||
| Number of float
|
||||
| String of string
|
||||
| Symbol of string
|
||||
| Keyword of string
|
||||
| List of value list
|
||||
| Dict of dict
|
||||
| Lambda of lambda
|
||||
| Component of component
|
||||
| Island of island
|
||||
| Macro of macro
|
||||
| Thunk of value * env
|
||||
| Continuation of (value -> value) * dict option
|
||||
| CallccContinuation of value list (** Undelimited continuation — captured kont frames *)
|
||||
| NativeFn of string * (value list -> value)
|
||||
| Signal of signal
|
||||
| RawHTML of string
|
||||
| Spread of (string * value) list
|
||||
| SxExpr of string (** Opaque SX wire-format string — aser output. *)
|
||||
| Env of env (** First-class environment — used by CEK machine state dicts. *)
|
||||
| ListRef of value list ref (** Mutable list — JS-style array for append! *)
|
||||
| CekState of cek_state (** Optimized CEK machine state — avoids Dict allocation. *)
|
||||
| CekFrame of cek_frame (** Optimized CEK continuation frame. *)
|
||||
| VmClosure of vm_closure (** VM-compiled closure — callable within the VM without allocating a new VM. *)
|
||||
| VmFrame of vm_frame (** VM call frame — one per function invocation. *)
|
||||
| VmMachine of vm_machine (** VM state — stack, frames, globals. *)
|
||||
| Record of record (** R7RS record — opaque, generative, field-indexed. *)
|
||||
| Parameter of parameter (** R7RS parameter — dynamic binding via kont-stack provide frames. *)
|
||||
| Vector of value array (** R7RS vector — mutable fixed-size array. *)
|
||||
|
||||
(** CEK machine state — record instead of Dict for performance.
|
||||
5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *)
|
||||
and cek_state = {
|
||||
cs_control : value;
|
||||
cs_env : value;
|
||||
cs_kont : value;
|
||||
cs_phase : string;
|
||||
cs_value : value;
|
||||
}
|
||||
|
||||
(** CEK continuation frame — tagged record covering all 29 frame types.
|
||||
Fields are named generically; not all are used by every frame type.
|
||||
Eliminates ~100K Hashtbl allocations per page render. *)
|
||||
and cek_frame = {
|
||||
cf_type : string; (* frame type tag: "if", "let", "call", etc. *)
|
||||
cf_env : value; (* environment — every frame has this *)
|
||||
cf_name : value; (* let/define/set/scope: binding name *)
|
||||
cf_body : value; (* when/let: body expr *)
|
||||
mutable cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
|
||||
cf_f : value; (* call/map/filter/etc: function *)
|
||||
cf_args : value; (* call: raw args; arg: evaled args *)
|
||||
mutable cf_results : value; (* map/filter/dict: accumulated results; provide: subscribers *)
|
||||
mutable cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
|
||||
mutable cf_extra2 : value; (* second extra: emitted, etc. *)
|
||||
}
|
||||
|
||||
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
|
||||
and dict = (string, value) Hashtbl.t
|
||||
|
||||
and lambda = {
|
||||
l_params : string list;
|
||||
l_body : value;
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and component = {
|
||||
c_name : string;
|
||||
c_params : string list;
|
||||
c_has_children : bool;
|
||||
c_body : value;
|
||||
c_closure : env;
|
||||
c_affinity : string; (** "auto" | "client" | "server" *)
|
||||
mutable c_file : string option; (** Source file path *)
|
||||
mutable c_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and island = {
|
||||
i_name : string;
|
||||
i_params : string list;
|
||||
i_has_children : bool;
|
||||
i_body : value;
|
||||
i_closure : env;
|
||||
mutable i_file : string option; (** Source file path *)
|
||||
mutable i_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and macro = {
|
||||
m_params : string list;
|
||||
m_rest_param : string option;
|
||||
m_body : value;
|
||||
m_closure : env;
|
||||
m_name : string option;
|
||||
}
|
||||
|
||||
and signal = {
|
||||
mutable s_value : value;
|
||||
mutable s_subscribers : (unit -> unit) list;
|
||||
mutable s_deps : signal list;
|
||||
}
|
||||
|
||||
(** R7RS record type descriptor — one per [define-record-type] call.
|
||||
Stored in [rtd_table]; closures capture only the integer uid. *)
|
||||
and record_type = {
|
||||
rt_name : string; (** e.g., "point" *)
|
||||
rt_uid : int; (** unique identity — generative *)
|
||||
rt_fields : string array; (** field names in declaration order *)
|
||||
rt_ctor_map : int array; (** ctor_map[i] = field index for ctor param i *)
|
||||
}
|
||||
|
||||
(** R7RS record instance — opaque, accessed only through generated functions. *)
|
||||
and record = {
|
||||
r_type : record_type;
|
||||
r_fields : value array; (** mutable via Array.set for record-set! *)
|
||||
}
|
||||
|
||||
(** R7RS parameter — dynamic binding via provide frames on the kont stack.
|
||||
Calling [(param)] searches kont for the nearest provide frame keyed
|
||||
by [pm_uid]; if not found returns [pm_default]. *)
|
||||
and parameter = {
|
||||
pm_uid : string; (** unique ID — used as provide frame key *)
|
||||
pm_default : value; (** initial/default value *)
|
||||
pm_converter : value option; (** optional converter function *)
|
||||
}
|
||||
|
||||
(** {1 Bytecode VM types}
|
||||
|
||||
Defined here (not in sx_vm.ml) because [vm_code.constants] references
|
||||
[value] and [lambda.l_compiled] references [vm_closure] — mutual
|
||||
recursion requires all types in one [and] chain. *)
|
||||
|
||||
(** Compiled function body — bytecode + constant pool. *)
|
||||
and vm_code = {
|
||||
vc_arity : int;
|
||||
vc_locals : int;
|
||||
vc_bytecode : int array;
|
||||
vc_constants : value array;
|
||||
mutable vc_bytecode_list : value list option; (** Lazy cache for transpiled VM *)
|
||||
mutable vc_constants_list : value list option; (** Lazy cache for transpiled VM *)
|
||||
}
|
||||
|
||||
(** Upvalue cell — shared mutable reference to a captured variable. *)
|
||||
and vm_upvalue_cell = {
|
||||
mutable uv_value : value;
|
||||
}
|
||||
|
||||
(** Closure — compiled code + captured upvalues + live env reference. *)
|
||||
and vm_closure = {
|
||||
vm_code : vm_code;
|
||||
vm_upvalues : vm_upvalue_cell array;
|
||||
vm_name : string option;
|
||||
vm_env_ref : (string, value) Hashtbl.t;
|
||||
vm_closure_env : env option; (** Original closure env for inner functions *)
|
||||
}
|
||||
|
||||
(** VM call frame — one per function invocation.
|
||||
Defined here (not in sx_vm.ml) so it can be a [value] variant. *)
|
||||
and vm_frame = {
|
||||
vf_closure : vm_closure;
|
||||
mutable vf_ip : int;
|
||||
vf_base : int;
|
||||
vf_local_cells : (int, vm_upvalue_cell) Hashtbl.t;
|
||||
}
|
||||
|
||||
(** VM state — stack machine with frame list.
|
||||
Defined here for the same mutual-recursion reason. *)
|
||||
and vm_machine = {
|
||||
mutable vm_stack : value array;
|
||||
mutable vm_sp : int;
|
||||
mutable vm_frames : vm_frame list;
|
||||
vm_globals : (string, value) Hashtbl.t;
|
||||
mutable vm_pending_cek : value option;
|
||||
}
|
||||
|
||||
|
||||
(** {1 Forward ref for calling VM closures from outside the VM} *)
|
||||
|
||||
let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Failure "VM call_closure not initialized"))
|
||||
|
||||
(** Forward ref for calling CEK evaluator from primitives (avoids dependency cycle). *)
|
||||
let _cek_call_ref : (value -> value -> value) ref =
|
||||
ref (fun _ _ -> raise (Failure "CEK call not initialized"))
|
||||
|
||||
|
||||
(** {1 Errors} *)
|
||||
|
||||
exception Eval_error of string
|
||||
exception Parse_error of string
|
||||
|
||||
|
||||
(** {1 Record type descriptor table} *)
|
||||
|
||||
let rtd_table : (int, record_type) Hashtbl.t = Hashtbl.create 16
|
||||
let rtd_counter = ref 0
|
||||
|
||||
(** {1 Parameter UID counter} *)
|
||||
|
||||
let param_counter = ref 0
|
||||
|
||||
|
||||
(** {1 Environment operations} *)
|
||||
|
||||
let make_env () =
|
||||
{ bindings = Hashtbl.create 16; parent = None }
|
||||
|
||||
let env_extend parent =
|
||||
{ bindings = Hashtbl.create 16; parent = Some parent }
|
||||
|
||||
(* Optional hook: called after every env_bind with (env, name, value).
|
||||
Used by browser kernel to sync VM globals table. *)
|
||||
let _env_bind_hook : (env -> string -> value -> unit) option ref = ref None
|
||||
|
||||
(* Optional hook: called after VM GLOBAL_SET writes to vm.globals.
|
||||
Used by browser kernel to sync mutations back to global_env. *)
|
||||
let _vm_global_set_hook : (string -> value -> unit) option ref = ref None
|
||||
|
||||
(* Optional hook: called by cek_run on import suspension.
|
||||
If set, the hook loads the library and returns true; cek_run then resumes. *)
|
||||
let _import_hook : (value -> bool) option ref = ref None
|
||||
|
||||
(* Optional hook: called by vm_global_get when a symbol isn't found.
|
||||
Receives the symbol name. If the hook can resolve it (e.g. by loading a
|
||||
library that exports it), it returns Some value. Otherwise None.
|
||||
This enables transparent lazy module loading — just use a symbol and
|
||||
the VM loads whatever module provides it. *)
|
||||
let _symbol_resolve_hook : (string -> value option) option ref = ref None
|
||||
|
||||
let env_bind env name v =
|
||||
Hashtbl.replace env.bindings (intern name) v;
|
||||
(match !_env_bind_hook with Some f -> f env name v | None -> ());
|
||||
Nil
|
||||
|
||||
(* Internal: scope-chain lookup with pre-interned ID *)
|
||||
let rec env_has_id env id =
|
||||
Hashtbl.mem env.bindings id ||
|
||||
match env.parent with Some p -> env_has_id p id | None -> false
|
||||
|
||||
let env_has env name = env_has_id env (intern name)
|
||||
|
||||
let rec env_get_id env id name =
|
||||
match Hashtbl.find_opt env.bindings id with
|
||||
| Some v -> v
|
||||
| None ->
|
||||
match env.parent with
|
||||
| Some p -> env_get_id p id name
|
||||
| None ->
|
||||
(* Symbol not in any scope — try the resolve hook (transparent lazy loading).
|
||||
The hook loads the module that exports this symbol, making it available. *)
|
||||
match !_symbol_resolve_hook with
|
||||
| Some hook ->
|
||||
(match hook name with
|
||||
| Some v ->
|
||||
(* Cache in the root env so subsequent lookups are instant *)
|
||||
Hashtbl.replace env.bindings id v; v
|
||||
| None -> raise (Eval_error ("Undefined symbol: " ^ name)))
|
||||
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
|
||||
|
||||
let env_get env name = env_get_id env (intern name) name
|
||||
|
||||
let rec env_set_id env id v =
|
||||
if Hashtbl.mem env.bindings id then begin
|
||||
Hashtbl.replace env.bindings id v;
|
||||
(match !_env_bind_hook with Some f -> f env (unintern id) v | None -> ());
|
||||
Nil
|
||||
end else
|
||||
match env.parent with
|
||||
| Some p -> env_set_id p id v
|
||||
| None -> Hashtbl.replace env.bindings id v; Nil
|
||||
|
||||
let env_set env name v = env_set_id env (intern name) v
|
||||
|
||||
let env_merge base overlay =
|
||||
if base == overlay then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
let rec is_descendant e depth =
|
||||
if depth > 100 then false
|
||||
else if e == base then true
|
||||
else match e.parent with Some p -> is_descendant p (depth + 1) | None -> false
|
||||
in
|
||||
if is_descendant overlay 0 then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
let e = { bindings = Hashtbl.create 16; parent = Some base } in
|
||||
Hashtbl.iter (fun id v ->
|
||||
if not (env_has_id base id) then Hashtbl.replace e.bindings id v
|
||||
) overlay.bindings;
|
||||
e
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
(** {1 Value extraction helpers} *)
|
||||
|
||||
let value_to_string = function
|
||||
| String s -> s | Symbol s -> s | Keyword k -> k
|
||||
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
||||
| Bool true -> "true" | Bool false -> "false"
|
||||
| Nil -> "" | _ -> "<value>"
|
||||
|
||||
let value_to_string_list = function
|
||||
| List items | ListRef { contents = items } -> List.map value_to_string items
|
||||
| _ -> []
|
||||
|
||||
let value_to_bool = function
|
||||
| Bool b -> b | Nil -> false | _ -> true
|
||||
|
||||
let value_to_string_opt = function
|
||||
| String s -> Some s | Symbol s -> Some s | Nil -> None | _ -> None
|
||||
|
||||
|
||||
(** {1 Constructors — accept [value] args from transpiled code} *)
|
||||
|
||||
let unwrap_env_val = function
|
||||
| Env e -> e
|
||||
| _ -> raise (Eval_error "make_lambda: expected env for closure")
|
||||
|
||||
let make_lambda params body closure =
|
||||
let ps = match params with
|
||||
| List items -> List.map value_to_string items
|
||||
| _ -> value_to_string_list params
|
||||
in
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
let ps = value_to_string_list params in
|
||||
let hc = value_to_bool has_children in
|
||||
let aff = match affinity with String s -> s | _ -> "auto" in
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
c_file = None; c_compiled = None;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
let n = value_to_string name in
|
||||
let ps = value_to_string_list params in
|
||||
let hc = value_to_bool has_children in
|
||||
Island {
|
||||
i_name = n; i_params = ps; i_has_children = hc;
|
||||
i_body = body; i_closure = unwrap_env_val closure;
|
||||
i_file = None; i_compiled = None;
|
||||
}
|
||||
|
||||
let make_macro params rest_param body closure name =
|
||||
let ps = value_to_string_list params in
|
||||
let rp = value_to_string_opt rest_param in
|
||||
let n = value_to_string_opt name in
|
||||
Macro {
|
||||
m_params = ps; m_rest_param = rp;
|
||||
m_body = body; m_closure = unwrap_env_val closure; m_name = n;
|
||||
}
|
||||
|
||||
let make_thunk expr env = Thunk (expr, unwrap_env_val env)
|
||||
|
||||
let make_symbol name = Symbol (value_to_string name)
|
||||
let make_keyword name = Keyword (value_to_string name)
|
||||
|
||||
|
||||
(** {1 Type inspection} *)
|
||||
|
||||
let type_of = function
|
||||
| Nil -> "nil"
|
||||
| Bool _ -> "boolean"
|
||||
| Number _ -> "number"
|
||||
| String _ -> "string"
|
||||
| Symbol _ -> "symbol"
|
||||
| Keyword _ -> "keyword"
|
||||
| List _ | ListRef _ -> "list"
|
||||
| Dict _ -> "dict"
|
||||
| Lambda _ -> "lambda"
|
||||
| Component _ -> "component"
|
||||
| Island _ -> "island"
|
||||
| Macro _ -> "macro"
|
||||
| Thunk _ -> "thunk"
|
||||
| Continuation (_, _) -> "continuation"
|
||||
| CallccContinuation _ -> "continuation"
|
||||
| NativeFn _ -> "function"
|
||||
| Signal _ -> "signal"
|
||||
| RawHTML _ -> "raw-html"
|
||||
| Spread _ -> "spread"
|
||||
| SxExpr _ -> "sx-expr"
|
||||
| Env _ -> "env"
|
||||
| CekState _ -> "dict" (* CEK state behaves as a dict for type checks *)
|
||||
| CekFrame _ -> "dict"
|
||||
| VmClosure _ -> "function"
|
||||
| VmFrame _ -> "vm-frame"
|
||||
| VmMachine _ -> "vm-machine"
|
||||
| Record r -> r.r_type.rt_name
|
||||
| Parameter _ -> "parameter"
|
||||
| Vector _ -> "vector"
|
||||
|
||||
let is_nil = function Nil -> true | _ -> false
|
||||
let is_lambda = function Lambda _ -> true | _ -> false
|
||||
let is_component = function Component _ -> true | _ -> false
|
||||
let is_island = function Island _ -> true | _ -> false
|
||||
let is_macro = function Macro _ -> true | _ -> false
|
||||
let is_thunk = function Thunk _ -> true | _ -> false
|
||||
let is_signal = function
|
||||
| Signal _ -> true
|
||||
| Dict d -> Hashtbl.mem d "__signal"
|
||||
| _ -> false
|
||||
|
||||
let is_record = function Record _ -> true | _ -> false
|
||||
|
||||
let is_callable = function
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation _ | VmClosure _ -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
(** {1 Truthiness} *)
|
||||
|
||||
(** SX truthiness: everything is truthy except [Nil] and [Bool false]. *)
|
||||
let sx_truthy = function
|
||||
| Nil | Bool false -> false
|
||||
| _ -> true
|
||||
|
||||
|
||||
(** {1 Accessors} *)
|
||||
|
||||
let symbol_name = function
|
||||
| Symbol s -> String s
|
||||
| v -> raise (Eval_error ("Expected symbol, got " ^ type_of v))
|
||||
|
||||
let keyword_name = function
|
||||
| Keyword k -> String k
|
||||
| v -> raise (Eval_error ("Expected keyword, got " ^ type_of v))
|
||||
|
||||
let lambda_params = function
|
||||
| Lambda l -> List (List.map (fun s -> String s) l.l_params)
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_body = function
|
||||
| Lambda l -> l.l_body
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_closure = function
|
||||
| Lambda l -> Env l.l_closure
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_name = function
|
||||
| Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let set_lambda_name l n = match l with
|
||||
| Lambda l -> l.l_name <- Some n; Nil
|
||||
| _ -> raise (Eval_error "set-lambda-name!: not a lambda")
|
||||
|
||||
let component_name = function
|
||||
| Component c -> String c.c_name
|
||||
| Island i -> String i.i_name
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_file = function
|
||||
| Component c -> (match c.c_file with Some f -> String f | None -> Nil)
|
||||
| Island i -> (match i.i_file with Some f -> String f | None -> Nil)
|
||||
| _ -> Nil
|
||||
|
||||
let component_set_file v f =
|
||||
(match v, f with
|
||||
| Component c, String s -> c.c_file <- Some s
|
||||
| Island i, String s -> i.i_file <- Some s
|
||||
| _ -> ()); Nil
|
||||
|
||||
let component_set_file_b = component_set_file
|
||||
|
||||
let component_params = function
|
||||
| Component c -> List (List.map (fun s -> String s) c.c_params)
|
||||
| Island i -> List (List.map (fun s -> String s) i.i_params)
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_body = function
|
||||
| Component c -> c.c_body
|
||||
| Island i -> i.i_body
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_closure = function
|
||||
| Component c -> Env c.c_closure
|
||||
| Island i -> Env i.i_closure
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_has_children = function
|
||||
| Component c -> Bool c.c_has_children
|
||||
| Island i -> Bool i.i_has_children
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_affinity = function
|
||||
| Component c -> String c.c_affinity
|
||||
| Island _ -> String "client"
|
||||
| _ -> String "auto"
|
||||
|
||||
let macro_params = function
|
||||
| Macro m -> List (List.map (fun s -> String s) m.m_params)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_rest_param = function
|
||||
| Macro m -> (match m.m_rest_param with Some s -> String s | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_body = function
|
||||
| Macro m -> m.m_body
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_closure = function
|
||||
| Macro m -> Env m.m_closure
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let thunk_expr = function
|
||||
| Thunk (e, _) -> e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
let thunk_env = function
|
||||
| Thunk (_, e) -> Env e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
|
||||
(** {1 Record operations} *)
|
||||
|
||||
let val_to_int = function
|
||||
| Number n -> int_of_float n
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
|
||||
|
||||
(** [make_rtd name fields ctor_params] — create a record type descriptor.
|
||||
Called as [make-rtd] from transpiled evaluator. Takes 3 separate args. *)
|
||||
let make_rtd name fields ctor_params =
|
||||
let uid = !rtd_counter in
|
||||
incr rtd_counter;
|
||||
let field_names = List.map value_to_string (match fields with List l -> l | _ -> []) in
|
||||
let ctor_names = List.map value_to_string (match ctor_params with List l -> l | _ -> []) in
|
||||
let field_arr = Array.of_list field_names in
|
||||
let ctor_map = Array.of_list (List.map (fun cp ->
|
||||
let rec find j = function
|
||||
| [] -> raise (Eval_error (Printf.sprintf "make-rtd: ctor param %s not in fields" cp))
|
||||
| f :: _ when f = cp -> j
|
||||
| _ :: rest -> find (j + 1) rest
|
||||
in find 0 field_names
|
||||
) ctor_names) in
|
||||
let rt = { rt_name = value_to_string name; rt_uid = uid; rt_fields = field_arr; rt_ctor_map = ctor_map } in
|
||||
Hashtbl.add rtd_table uid rt;
|
||||
Number (float_of_int uid)
|
||||
|
||||
(** [make_record uid_val args_list] — create a record from uid + args list.
|
||||
2-arg direct call: (make-record rtd-uid ctor-args-list). *)
|
||||
let make_record uid_val args_list =
|
||||
let uid = val_to_int uid_val in
|
||||
let ctor_args = match args_list with List l -> l | _ -> [] in
|
||||
match Hashtbl.find_opt rtd_table uid with
|
||||
| None -> raise (Eval_error "make-record: unknown rtd")
|
||||
| Some rt ->
|
||||
let n_ctor = Array.length rt.rt_ctor_map in
|
||||
let n_args = List.length ctor_args in
|
||||
if n_args <> n_ctor then
|
||||
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
|
||||
rt.rt_name n_ctor n_args));
|
||||
let fields = Array.make (Array.length rt.rt_fields) Nil in
|
||||
List.iteri (fun i arg ->
|
||||
fields.(rt.rt_ctor_map.(i)) <- arg
|
||||
) ctor_args;
|
||||
Record { r_type = rt; r_fields = fields }
|
||||
|
||||
(** [record_ref v idx] — access field by index. 2-arg direct call. *)
|
||||
let record_ref v idx =
|
||||
match v with
|
||||
| Record r ->
|
||||
let i = val_to_int idx in
|
||||
if i < 0 || i >= Array.length r.r_fields then
|
||||
raise (Eval_error (Printf.sprintf "record-ref: index %d out of bounds for %s" i r.r_type.rt_name));
|
||||
r.r_fields.(i)
|
||||
| _ -> raise (Eval_error ("record-ref: not a record, got " ^ type_of v))
|
||||
|
||||
(** [record_set_b v idx new_val] — mutate field by index. 3-arg direct call.
|
||||
Named record_set_b because transpiler mangles record-set! to record_set_b. *)
|
||||
let record_set_b v idx new_val =
|
||||
match v with
|
||||
| Record r ->
|
||||
let i = val_to_int idx in
|
||||
if i < 0 || i >= Array.length r.r_fields then
|
||||
raise (Eval_error (Printf.sprintf "record-set!: index %d out of bounds for %s" i r.r_type.rt_name));
|
||||
r.r_fields.(i) <- new_val; Nil
|
||||
| _ -> raise (Eval_error ("record-set!: not a record, got " ^ type_of v))
|
||||
|
||||
(** [record_type_p v uid_val] — type predicate. 2-arg direct call.
|
||||
Named record_type_p because transpiler mangles record-type? to record_type_p. *)
|
||||
let record_type_p v uid_val =
|
||||
match v with
|
||||
| Record r -> Bool (r.r_type.rt_uid = val_to_int uid_val)
|
||||
| _ -> Bool false
|
||||
|
||||
(** [record_p v] — generic record predicate.
|
||||
Named record_p because transpiler mangles record? to record_p. *)
|
||||
let record_p v = Bool (is_record v)
|
||||
|
||||
(** [make_record_constructor rtd_uid] — returns a NativeFn that constructs records.
|
||||
Called from transpiled sf-define-record-type. *)
|
||||
let make_record_constructor uid_val =
|
||||
let uid = val_to_int uid_val in
|
||||
let rt = match Hashtbl.find_opt rtd_table uid with
|
||||
| Some rt -> rt | None -> raise (Eval_error "make-record-constructor: unknown rtd") in
|
||||
NativeFn (rt.rt_name, fun args ->
|
||||
let n_ctor = Array.length rt.rt_ctor_map in
|
||||
let n_args = List.length args in
|
||||
if n_args <> n_ctor then
|
||||
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" rt.rt_name n_ctor n_args));
|
||||
let fields = Array.make (Array.length rt.rt_fields) Nil in
|
||||
List.iteri (fun i arg -> fields.(rt.rt_ctor_map.(i)) <- arg) args;
|
||||
Record { r_type = rt; r_fields = fields })
|
||||
|
||||
(** [make_record_predicate rtd_uid] — returns a NativeFn that tests record type. *)
|
||||
let make_record_predicate uid_val =
|
||||
let uid = val_to_int uid_val in
|
||||
NativeFn ("?", fun args ->
|
||||
match args with
|
||||
| [Record r] -> Bool (r.r_type.rt_uid = uid)
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "record predicate: expected 1 arg"))
|
||||
|
||||
(** [make_record_accessor field_idx] — returns a NativeFn that reads a field. *)
|
||||
let make_record_accessor idx_val =
|
||||
let idx = val_to_int idx_val in
|
||||
NativeFn ("ref", fun args ->
|
||||
match args with
|
||||
| [Record r] ->
|
||||
if idx < 0 || idx >= Array.length r.r_fields then
|
||||
raise (Eval_error (Printf.sprintf "record accessor: index %d out of bounds" idx));
|
||||
r.r_fields.(idx)
|
||||
| [v] -> raise (Eval_error ("record accessor: not a record, got " ^ type_of v))
|
||||
| _ -> raise (Eval_error "record accessor: expected 1 arg"))
|
||||
|
||||
(** [make_record_mutator field_idx] — returns a NativeFn that sets a field. *)
|
||||
let make_record_mutator idx_val =
|
||||
let idx = val_to_int idx_val in
|
||||
NativeFn ("set!", fun args ->
|
||||
match args with
|
||||
| [Record r; new_val] ->
|
||||
if idx < 0 || idx >= Array.length r.r_fields then
|
||||
raise (Eval_error (Printf.sprintf "record mutator: index %d out of bounds" idx));
|
||||
r.r_fields.(idx) <- new_val; Nil
|
||||
| _ -> raise (Eval_error "record mutator: expected (record value)"))
|
||||
|
||||
|
||||
(** {1 R7RS parameter accessors — called from transpiled evaluator} *)
|
||||
|
||||
let parameter_p v = match v with Parameter _ -> Bool true | _ -> Bool false
|
||||
let parameter_uid v = match v with
|
||||
| Parameter p -> String p.pm_uid
|
||||
| _ -> raise (Eval_error "parameter-uid: not a parameter")
|
||||
let parameter_default v = match v with
|
||||
| Parameter p -> p.pm_default
|
||||
| _ -> raise (Eval_error "parameter-default: not a parameter")
|
||||
let parameter_converter v = match v with
|
||||
| Parameter p -> (match p.pm_converter with Some c -> c | None -> Nil)
|
||||
| _ -> raise (Eval_error "parameter-converter: not a parameter")
|
||||
|
||||
|
||||
(** {1 Dict operations} *)
|
||||
|
||||
let make_dict () : dict = Hashtbl.create 8
|
||||
|
||||
let dict_get (d : dict) key =
|
||||
match Hashtbl.find_opt d key with Some v -> v | None -> Nil
|
||||
|
||||
let dict_has (d : dict) key = Hashtbl.mem d key
|
||||
|
||||
let dict_set (d : dict) key v = Hashtbl.replace d key v
|
||||
|
||||
let dict_delete (d : dict) key = Hashtbl.remove d key
|
||||
|
||||
let dict_keys (d : dict) =
|
||||
Hashtbl.fold (fun k _ acc -> String k :: acc) d []
|
||||
|
||||
let dict_vals (d : dict) =
|
||||
Hashtbl.fold (fun _ v acc -> v :: acc) d []
|
||||
|
||||
|
||||
(** {1 Value display} *)
|
||||
|
||||
let rec inspect = function
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Number n ->
|
||||
if Float.is_integer n then Printf.sprintf "%d" (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s ->
|
||||
let buf = Buffer.create (String.length s + 2) in
|
||||
Buffer.add_char buf '"';
|
||||
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.add_char buf '"';
|
||||
Buffer.contents buf
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(" ^ String.concat " " (List.map inspect items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| Lambda l ->
|
||||
let tag = match l.l_name with Some n -> n | None -> "lambda" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
|
||||
| Component c ->
|
||||
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
|
||||
| Island i ->
|
||||
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
|
||||
| Macro m ->
|
||||
let tag = match m.m_name with Some n -> n | None -> "macro" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
|
||||
| Thunk _ -> "<thunk>"
|
||||
| Continuation (_, _) -> "<continuation>"
|
||||
| CallccContinuation _ -> "<callcc-continuation>"
|
||||
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
|
||||
| Signal _ -> "<signal>"
|
||||
| RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "\"<sx-expr:%d>\"" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
| CekState _ -> "<cek-state>"
|
||||
| CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
|
||||
| VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
|
||||
| Record r ->
|
||||
let fields = Array.to_list (Array.mapi (fun i v ->
|
||||
Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v)
|
||||
) r.r_fields) in
|
||||
Printf.sprintf "<record:%s %s>" r.r_type.rt_name (String.concat " " fields)
|
||||
| Parameter p -> Printf.sprintf "<parameter:%s>" p.pm_uid
|
||||
| Vector arr ->
|
||||
let elts = Array.to_list (Array.map inspect arr) in
|
||||
Printf.sprintf "#(%s)" (String.concat " " elts)
|
||||
| VmFrame f -> Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base
|
||||
| VmMachine m -> Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames)
|
||||
1169
hosts/ocaml/lib/sx_vm.ml
Normal file
1169
hosts/ocaml/lib/sx_vm.ml
Normal file
File diff suppressed because it is too large
Load Diff
521
hosts/ocaml/lib/sx_vm_ref.ml
Normal file
521
hosts/ocaml/lib/sx_vm_ref.ml
Normal file
File diff suppressed because one or more lines are too long
516
hosts/ocaml/sx_vm_ref.ml
Normal file
516
hosts/ocaml/sx_vm_ref.ml
Normal file
File diff suppressed because one or more lines are too long
1992
hosts/ocaml/transpiler.sx
Normal file
1992
hosts/ocaml/transpiler.sx
Normal file
File diff suppressed because it is too large
Load Diff
@@ -179,6 +179,11 @@ class PyEmitter:
|
||||
"*batch-depth*": "_batch_depth",
|
||||
"*batch-queue*": "_batch_queue",
|
||||
"*store-registry*": "_store_registry",
|
||||
"*custom-special-forms*": "_custom_special_forms",
|
||||
"*render-check*": "_render_check",
|
||||
"*render-fn*": "_render_fn",
|
||||
"register-special-form!": "register_special_form_b",
|
||||
"is-else-clause?": "is_else_clause_p",
|
||||
"def-store": "def_store",
|
||||
"use-store": "use_store",
|
||||
"clear-stores": "clear_stores",
|
||||
@@ -1443,6 +1448,7 @@ def compile_ref_to_py(
|
||||
_project = os.path.abspath(os.path.join(ref_dir, "..", "..", ".."))
|
||||
_source_dirs = [
|
||||
os.path.join(_project, "spec"),
|
||||
os.path.join(_project, "lib"),
|
||||
os.path.join(_project, "web"),
|
||||
ref_dir,
|
||||
]
|
||||
@@ -1484,16 +1490,16 @@ def compile_ref_to_py(
|
||||
spec_mod_set.add("page-helpers")
|
||||
if "router" in SPEC_MODULES:
|
||||
spec_mod_set.add("router")
|
||||
# CEK is the canonical evaluator — always include
|
||||
spec_mod_set.add("cek")
|
||||
spec_mod_set.add("frames")
|
||||
# CEK is always included (part of evaluator.sx core file)
|
||||
has_cek = True
|
||||
has_deps = "deps" in spec_mod_set
|
||||
has_cek = "cek" in spec_mod_set
|
||||
|
||||
# Core files always included, then selected adapters, then spec modules
|
||||
# evaluator.sx = merged frames + eval utilities + CEK machine
|
||||
sx_files = [
|
||||
("eval.sx", "eval"),
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
("forms.sx", "forms (server definition forms)"),
|
||||
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
|
||||
("render.sx", "render (core)"),
|
||||
]
|
||||
# Parser before html/sx — provides serialize used by adapters
|
||||
|
||||
@@ -525,13 +525,24 @@ def env_merge(base, overlay):
|
||||
if base is overlay:
|
||||
# Same env — just extend with empty local scope for params
|
||||
return base.extend()
|
||||
# Check if base is an ancestor of overlay — if so, no need to merge
|
||||
# (common for self-recursive calls where closure == caller's ancestor)
|
||||
# Check if base is an ancestor of overlay — if so, overlay contains
|
||||
# everything in base. But overlay scopes between overlay and base may
|
||||
# have extra local bindings (e.g. page helpers injected at request time).
|
||||
# Only take the shortcut if no intermediate scope has local bindings.
|
||||
p = overlay
|
||||
depth = 0
|
||||
while p is not None and depth < 100:
|
||||
if p is base:
|
||||
return base.extend()
|
||||
q = overlay
|
||||
has_extra = False
|
||||
while q is not base:
|
||||
if hasattr(q, '_bindings') and q._bindings:
|
||||
has_extra = True
|
||||
break
|
||||
q = getattr(q, '_parent', None)
|
||||
if not has_extra:
|
||||
return base.extend()
|
||||
break
|
||||
p = getattr(p, '_parent', None)
|
||||
depth += 1
|
||||
# MergedEnv: reads walk base then overlay; set! walks base only
|
||||
@@ -601,13 +612,7 @@ def inspect(x):
|
||||
return repr(x)
|
||||
|
||||
|
||||
def escape_html(s):
|
||||
s = str(s)
|
||||
return s.replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """)
|
||||
|
||||
|
||||
def escape_attr(s):
|
||||
return escape_html(s)
|
||||
# escape_html and escape_attr are now library functions defined in render.sx
|
||||
|
||||
|
||||
def raw_html_content(x):
|
||||
@@ -831,7 +836,7 @@ def _sx_parse_int(v, default=0):
|
||||
"stdlib.text": '''
|
||||
# stdlib.text
|
||||
PRIMITIVES["pluralize"] = lambda n, s="", p="s": s if n == 1 else p
|
||||
PRIMITIVES["escape"] = escape_html
|
||||
PRIMITIVES["escape"] = lambda s: str(s).replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """)
|
||||
PRIMITIVES["strip-tags"] = lambda s: _strip_tags(str(s))
|
||||
|
||||
import re as _re
|
||||
@@ -1635,15 +1640,18 @@ SPEC_MODULES = {
|
||||
"engine": ("engine.sx", "engine (fetch/swap/trigger pure logic)"),
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"stdlib": ("stdlib.sx", "stdlib (library functions from former primitives)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"frames": ("frames.sx", "frames (CEK continuation frames)"),
|
||||
"cek": ("cek.sx", "cek (explicit CEK machine evaluator)"),
|
||||
"freeze": ("freeze.sx", "freeze (serializable state boundaries)"),
|
||||
"content": ("content.sx", "content (content-addressed computation)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
# Modules listed here are emitted in this order; any not listed use alphabetical.
|
||||
# stdlib must come first — other modules use its functions.
|
||||
# freeze depends on signals; content depends on freeze.
|
||||
SPEC_MODULE_ORDER = [
|
||||
"deps", "engine", "frames", "page-helpers", "router", "cek", "signals", "types",
|
||||
"stdlib", "deps", "engine", "page-helpers", "router", "signals", "types", "freeze", "content",
|
||||
]
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
|
||||
@@ -1,251 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-cek-reactive.sx — tests for deref-as-shift reactive rendering."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
sys.setrecursionlimit(20000)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set,
|
||||
env_extend, env_merge,
|
||||
)
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# The CEK override (eval_expr = cek_run) would cause the interpreted cek.sx
|
||||
# to delegate to the transpiled CEK, not the interpreted one being tested.
|
||||
# Override both the local names AND the module-level names so that transpiled
|
||||
# functions (ho_map, call_lambda, etc.) also use tree-walk internally.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Continuation, Macro,
|
||||
_ShiftSignal,
|
||||
)
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
def _sx_parse_one(source):
|
||||
"""Parse a single expression."""
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
def _make_continuation(fn):
|
||||
return Continuation(fn)
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-extend"] = env_extend
|
||||
env["make-continuation"] = _make_continuation
|
||||
env["continuation?"] = lambda x: isinstance(x, Continuation)
|
||||
env["continuation-fn"] = lambda c: c.fn
|
||||
|
||||
def _make_cek_continuation_with_data(captured, rest_kont):
|
||||
c = Continuation(lambda v=NIL: v)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
env["make-cek-continuation"] = _make_cek_continuation_with_data
|
||||
env["continuation-data"] = lambda c: getattr(c, '_cek_data', {})
|
||||
|
||||
# Type predicates and constructors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island, Continuation))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-island"] = sx_ref.make_island
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["make-symbol"] = lambda n: Symbol(n)
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, 'name', n) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, 'affinity', 'auto')
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, 'param_types', t) or NIL
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["env-merge"] = env_merge
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["type-of"] = sx_ref.type_of
|
||||
env["primitive?"] = sx_ref.is_primitive
|
||||
env["get-primitive"] = sx_ref.get_primitive
|
||||
env["strip-prefix"] = lambda s, p: s[len(p):] if s.startswith(p) else s
|
||||
env["inspect"] = repr
|
||||
env["debug-log"] = lambda *args: None
|
||||
env["error"] = sx_ref.error
|
||||
env["apply"] = lambda f, args: f(*args)
|
||||
|
||||
# Functions from eval.sx that cek.sx references
|
||||
env["trampoline"] = trampoline
|
||||
env["eval-expr"] = eval_expr
|
||||
env["eval-list"] = sx_ref.eval_list
|
||||
env["eval-call"] = sx_ref.eval_call
|
||||
env["call-lambda"] = sx_ref.call_lambda
|
||||
env["call-component"] = sx_ref.call_component
|
||||
env["parse-keyword-args"] = sx_ref.parse_keyword_args
|
||||
env["sf-lambda"] = sx_ref.sf_lambda
|
||||
env["sf-defcomp"] = sx_ref.sf_defcomp
|
||||
env["sf-defisland"] = sx_ref.sf_defisland
|
||||
env["sf-defmacro"] = sx_ref.sf_defmacro
|
||||
env["sf-defstyle"] = sx_ref.sf_defstyle
|
||||
env["sf-deftype"] = sx_ref.sf_deftype
|
||||
env["sf-defeffect"] = sx_ref.sf_defeffect
|
||||
env["sf-letrec"] = sx_ref.sf_letrec
|
||||
env["sf-named-let"] = sx_ref.sf_named_let
|
||||
env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind
|
||||
env["sf-scope"] = sx_ref.sf_scope
|
||||
env["sf-provide"] = sx_ref.sf_provide
|
||||
env["qq-expand"] = sx_ref.qq_expand
|
||||
env["expand-macro"] = sx_ref.expand_macro
|
||||
env["cond-scheme?"] = sx_ref.cond_scheme_p
|
||||
|
||||
# Higher-order form handlers
|
||||
env["ho-map"] = sx_ref.ho_map
|
||||
env["ho-map-indexed"] = sx_ref.ho_map_indexed
|
||||
env["ho-filter"] = sx_ref.ho_filter
|
||||
env["ho-reduce"] = sx_ref.ho_reduce
|
||||
env["ho-some"] = sx_ref.ho_some
|
||||
env["ho-every"] = sx_ref.ho_every
|
||||
env["ho-for-each"] = sx_ref.ho_for_each
|
||||
env["call-fn"] = sx_ref.call_fn
|
||||
|
||||
# Render-related (stub for testing — no active rendering)
|
||||
env["render-active?"] = lambda: False
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Scope primitives (needed for reactive-shift-deref island cleanup)
|
||||
env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL)
|
||||
env["scope-pop!"] = sx_ref.PRIMITIVES.get("scope-pop!", lambda *a: NIL)
|
||||
env["context"] = sx_ref.PRIMITIVES.get("context", lambda *a: NIL)
|
||||
env["emit!"] = sx_ref.PRIMITIVES.get("emit!", lambda *a: NIL)
|
||||
env["emitted"] = sx_ref.PRIMITIVES.get("emitted", lambda *a: [])
|
||||
|
||||
# Dynamic wind
|
||||
env["push-wind!"] = lambda before, after: NIL
|
||||
env["pop-wind!"] = lambda: NIL
|
||||
env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f], e))
|
||||
|
||||
# Mutation helpers
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
env["identical?"] = lambda a, b: a is b
|
||||
|
||||
# defhandler, defpage, defquery, defaction stubs
|
||||
for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
pyname = name.replace("-", "_")
|
||||
fn = getattr(sx_ref, pyname, None)
|
||||
if fn:
|
||||
env[name] = fn
|
||||
else:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load signals module
|
||||
print("Loading signals.sx ...")
|
||||
with open(os.path.join(_PROJECT, "web", "signals.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load frames module
|
||||
print("Loading frames.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "frames.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load CEK module
|
||||
print("Loading cek.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-cek-reactive.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_WEB_TESTS, "test-cek-reactive.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user