Compare commits
838 Commits
7ac026eccb
...
loops/hs
| Author | SHA1 | Date | |
|---|---|---|---|
| 84e7bc8a24 | |||
| 7735eb7512 | |||
| 4e2e2c781c | |||
| 30d76537d1 | |||
| d7070ee901 | |||
| e67852ca96 | |||
| 99753580b4 | |||
| e274878052 | |||
| a3d1c37c95 | |||
| 2b486976a6 | |||
| 6e92a5ad66 | |||
| 2cd8e57694 | |||
| 0f67021aa3 | |||
| 81022784bc | |||
| 4be90bf21f | |||
| b45a69b7a4 | |||
| 8f202e03c2 | |||
| d865c4d58d | |||
| 6c1da9212a | |||
| 30fca2dd19 | |||
| d7a88d85ae | |||
| 9db703324d | |||
| b2810db1a0 | |||
| 2af31248f2 | |||
| 81059861fd | |||
| 52fc87f222 | |||
| 2caf356fc4 | |||
| 67df95508d | |||
| 679d6bd590 | |||
| 6a4269d327 | |||
| ec0be48a00 | |||
| 83c9d60d72 | |||
| 00edae49e4 | |||
| bf09055c4e | |||
| f63934b15e | |||
| 05aef11bf5 | |||
| 7cffae2148 | |||
| dc97c17304 | |||
| 4a277941b6 | |||
| f14a257533 | |||
| 5875c97391 | |||
| c932ad59e1 | |||
| 4cc2e82091 | |||
| 0c31dd2735 | |||
| cee9ae7f22 | |||
| 1473e277fd | |||
| 304a52d2cf | |||
| 99c5911347 | |||
| 64bcefffdc | |||
| eb587bb3d0 | |||
| c3b0aef1f8 | |||
| 38e9376573 | |||
| 9da43877e8 | |||
| 3b5f16088b | |||
| cb37259d10 | |||
| 094945d86a | |||
| 1c0a71517c | |||
| ade87c0744 | |||
| 0d38a75b21 | |||
| 99706a91d1 | |||
| 3e1bca5435 | |||
| 9ea67b9422 | |||
| 85a329e8d6 | |||
| c22f553146 | |||
| edfbb75466 | |||
| 3aa8034a0b | |||
| 84b947024d | |||
| 60bb77d365 | |||
| 621a1ad947 | |||
| 88217ec612 | |||
| d294443627 | |||
| db7a3d10dd | |||
| fd73c43eba | |||
| 30ef085844 | |||
| d74344ffbd | |||
| d862efe811 | |||
| c4da069815 | |||
| 87cafaaa3f | |||
| 3587443742 | |||
| 6b7559fcaf | |||
| 67d4b9dae5 | |||
| df8913e9a1 | |||
| 4ee748bf42 | |||
| 320e948224 | |||
| 1b4b7effbd | |||
| f0c4127870 | |||
| a15c1d2cfb | |||
| 3c4d68575c | |||
| dda3becbab | |||
| baa5cd9341 | |||
| 00bb21ca13 | |||
| a82050e819 | |||
| c532dd57f1 | |||
| bb64e42570 | |||
| 3d35205533 | |||
| e155c21798 | |||
| e5346d5ea3 | |||
| 5f3a8e43c0 | |||
| 860549c1db | |||
| 0e22779fe0 | |||
| bd821c0445 | |||
| 16df723e08 | |||
| 9502d56a38 | |||
| 0474514e59 | |||
| 98c957b3bf | |||
| 92c1fc72a5 | |||
| 1774a900aa | |||
| dc1aaac35a | |||
| beb120baf7 | |||
| 65d4c70638 | |||
| 20a1a81d15 | |||
| ae999e3362 | |||
| 30f3334107 | |||
| bf78f2ecc8 | |||
| fda8846376 | |||
| f79f96c1c3 | |||
| e8a89a6ce2 | |||
| fe6cadd268 | |||
| c94b340943 | |||
| 64e53518ae | |||
| 6293a0fe70 | |||
| 27bd25843e | |||
| 0a3425ba18 | |||
| 9f9e4e1e9d | |||
| c5e2bc2fe1 | |||
| 835d42fd1a | |||
| d7ad7172aa | |||
| 1079004981 | |||
| c257971bb1 | |||
| 1459f7a637 | |||
| d6975d3c79 | |||
| 18ae63b0bd | |||
| 067c0ab34a | |||
| ed8d71c9b8 | |||
| 15c310cdc1 | |||
| dd6375af18 | |||
| 8268010a0a | |||
| ccf59a9882 | |||
| 5e682b01c6 | |||
| 41d0c65874 | |||
| 216c3c5e9d | |||
| f21eb00878 | |||
| 4800246b23 | |||
| b502b8f58e | |||
| 60bb7c4687 | |||
| 6fb65464ed | |||
| 5fe1c2c7d5 | |||
| 108e25d418 | |||
| babef2503f | |||
| 3efd527d4e | |||
| e7b8626498 | |||
| f113b45d48 | |||
| ee16e358f3 | |||
| 3279954234 | |||
| 4fe0b64965 | |||
| 9e92b9c9fc | |||
| b48dabf383 | |||
| e59c0b8e0a | |||
| 35c72e2a13 | |||
| 19e148d930 | |||
| 835025ec37 | |||
| e195b5bd72 | |||
| 94b47a4b2b | |||
| f3e1383466 | |||
| 39a597e9b6 | |||
| ebaec1659e | |||
| 6f0b4fb476 | |||
| 449b77cbb0 | |||
| 65dfd75865 | |||
| 2bd3a6b2ba | |||
| 9d3e54029a | |||
| 275d2ecbae | |||
| 6c4001a299 | |||
| e0531d730c | |||
| 608a5088a4 | |||
| ce46420c2e | |||
| 6b0334affe | |||
| 8984520f05 | |||
| 1613f551ef | |||
| 9e568ad886 | |||
| 14b6586e41 | |||
| 1cd81e5369 | |||
| 1213ee04c7 | |||
| a5f0325935 | |||
| 7ecdd59335 | |||
| d6137f0d6f | |||
| 5b31d935bd | |||
| e976d7c145 | |||
| f44a185230 | |||
| 601fdc1c34 | |||
| 3528cef35a | |||
| 5b100cac17 | |||
| b90aa54dd0 | |||
| 7330bc1a36 | |||
| adb06ed1fd | |||
| 19f5bf7d72 | |||
| e4773ec336 | |||
| 24dbc966e9 | |||
| dc194b05eb | |||
| 781e0d427a | |||
| 1bdd141178 | |||
| f8d30f50fb | |||
| a11d0941e9 | |||
| 0515295317 | |||
| b2ae80fb21 | |||
| 7329b1d242 | |||
| 7833fc2716 | |||
| fd1dfea9b3 | |||
| 802ccd23e8 | |||
| 5c66095b0f | |||
| 71cf5b8472 | |||
| 41cfa5621b | |||
| 5b0c8569a8 | |||
| ef5faa6b54 | |||
| ce7ad3eead | |||
| ebcb5348ba | |||
| 0a5066a75c | |||
| be3fbae584 | |||
| 7357988af6 | |||
| 5c42f4842b | |||
| 6528ce78b9 | |||
| bfe4727edf | |||
| a7da235459 | |||
| 1a9c8d61b5 | |||
| fc24cc704d | |||
| dd604f2bb1 | |||
| 9d246f5c96 | |||
| b23da3190e | |||
| 5a3bae5516 | |||
| 922e7a7892 | |||
| a876ac8a7f | |||
| 84f0af657a | |||
| c59070ad20 | |||
| c8aab54d52 | |||
| c25ab23709 | |||
| f200418d91 | |||
| 79b3fa3f26 | |||
| d0b3b86823 | |||
| dcbeb5cec5 | |||
| 7516d1e1f9 | |||
| 00bf13a230 | |||
| 06bed36272 | |||
| 5a0740d3ce | |||
| be84246961 | |||
| 3ba819d9ae | |||
| ac65666f6f | |||
| 9e0de8831f | |||
| d4f74b5b02 | |||
| f78a97960f | |||
| de90cd04f2 | |||
| 444cd1ea70 | |||
| b5387c069f | |||
| 673be85743 | |||
| f85004c8a2 | |||
| 84996d74e2 | |||
| db8e680caf | |||
| 0410812420 | |||
| ac193e8839 | |||
| 25db89a96c | |||
| 017451370f | |||
| cc9975aaf0 | |||
| b12ec746a2 | |||
| d8fec1305b | |||
| 112eed50d0 | |||
| b9c9216409 | |||
| f276c4a56a | |||
| aef92cc1f3 | |||
| 922c4de2d0 | |||
| c0b001d3c2 | |||
| bceccccedb | |||
| 0e152721cc | |||
| c641b445f8 | |||
| 0f9bb68ba2 | |||
| 15e593b725 | |||
| 8c85e892c2 | |||
| 76f7e3b68a | |||
| 97818c6de1 | |||
| 2285ea3e49 | |||
| ca9196a693 | |||
| d981e5f620 | |||
| 1bce1b701b | |||
| e12e84a4c7 | |||
| b86d0b7e15 | |||
| 133edd4c5e | |||
| 98fbd5cf40 | |||
| fec3194464 | |||
| 4981e9a32f | |||
| 6f374fabce | |||
| 87fdb1db71 | |||
| fc76a42403 | |||
| 6bd45daed6 | |||
| 8819d7cbd1 | |||
| faa65e15d8 | |||
| ca077b429b | |||
| c9634ba649 | |||
| 684a46297d | |||
| 1e42451252 | |||
| 4aa49e42e8 | |||
| 4f02f82f4e | |||
| a93e5924df | |||
| d6ae303db3 | |||
| 745e78ab05 | |||
| 8bf874c50c | |||
| e5e3e90ee7 | |||
| b1666a5fe2 | |||
| b81c26c45b | |||
| 23e8379622 | |||
| a6eb125dcc | |||
| e3eb46d0dc | |||
| 3d7fffe4eb | |||
| 1d83ccba3c | |||
| 2cba359fdf | |||
| d42717d4b9 | |||
| 75f1c04559 | |||
| fb93aaaa8c | |||
| 49afef6eef | |||
| eb060ef32c | |||
| d938682469 | |||
| 4cac08d56f | |||
| c05d8788c7 | |||
| eaf3c88a36 | |||
| e2fe070dd4 | |||
| e12ddefdff | |||
| da0da1472d | |||
| e5293e4e03 | |||
| 429c2b59f9 | |||
| 5948741fb6 | |||
| 564e344961 | |||
| 1884c28763 | |||
| 13f24e5f26 | |||
| e71e74941e | |||
| 7ec42386fb | |||
| 45209caf73 | |||
| 699dd5ad69 | |||
| 676ec6dd2b | |||
| 498f1a33b6 | |||
| 1eadefd0c1 | |||
| f60d22e86e | |||
| 1783f4805a | |||
| 7d798be14f | |||
| ae32254dfb | |||
| 854ed9c027 | |||
| 3dbbe7e1d1 | |||
| 56855eee7f | |||
| 6e27442d57 | |||
| 7aefe4da8f | |||
| d4c0be52b1 | |||
| 3cada3f8fe | |||
| c850737c60 | |||
| eaf5af4cd8 | |||
| ccd89dfa53 | |||
| 55a4fba58f | |||
| fc9c90b7b1 | |||
| ef8f8b7c03 | |||
| bca0d8e4e5 | |||
| 99c5c44cc1 | |||
| 36ae0384ae | |||
| 299f3e748d | |||
| 6e38a2e1e1 | |||
| 52e4d38852 | |||
| 5fe97d8481 | |||
| cfc7e74a56 | |||
| 08cd82ed65 | |||
| f97a1711c6 | |||
| e85de7d5cc | |||
| 1461919857 | |||
| ce4579badb | |||
| e98aedf803 | |||
| ab50c4516e | |||
| a2a4d17d53 | |||
| 89ffb02b20 | |||
| 0044f17e4c | |||
| 3d05efbb9b | |||
| 9c64d1d929 | |||
| 42198e4e22 | |||
| e6def8b6cd | |||
| 2805e0077b | |||
| 737964be89 | |||
| 23c88cd1e5 | |||
| 3329512bf8 | |||
| 79ba9c2d40 | |||
| 32fd3ef7d3 | |||
| 3b06299e4b | |||
| 42a7747d02 | |||
| 0a2d7768dd | |||
| fecfc71e5f | |||
| 0bed9e3664 | |||
| 9982cd5926 | |||
| cf10e9a2d6 | |||
| 0365ecb2b9 | |||
| de9ab4ca07 | |||
| c6df054957 | |||
| 7f273dc7c2 | |||
| 7492ceac4e | |||
| 908f4f80d4 | |||
| 981b6e7560 | |||
| 8e9dc4a623 | |||
| 5e708e1b20 | |||
| ddc48c6d48 | |||
| 52165f6a2a | |||
| 6456bd927a | |||
| 67d2f32512 | |||
| 7a1af7a80a | |||
| 4ca92960c4 | |||
| 34e7cb177c | |||
| 48c5ac6287 | |||
| 520424954b | |||
| c521ff8731 | |||
| aeaa8cb498 | |||
| a9066c0653 | |||
| 1f7f47b4c1 | |||
| 2278443182 | |||
| 71d1ac9ce4 | |||
| 33e8788781 | |||
| 23749773f2 | |||
| 783ffc2ddd | |||
| d715d8c4ac | |||
| 3155ba47f9 | |||
| 387a6cb49e | |||
| 4d1079aa5e | |||
| 03278c640d | |||
| 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 | |||
| 858275dff9 |
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
|
||||
@@ -43,8 +43,9 @@ 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, web, shared (needed by bootstrappers + tests)
|
||||
# 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
|
||||
|
||||
18
.gitignore
vendored
18
.gitignore
vendored
@@ -15,3 +15,21 @@ 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-results/
|
||||
test-case-define.sx
|
||||
test-case-define.txt
|
||||
test_all.js
|
||||
test_final.js
|
||||
test_interactive.js
|
||||
|
||||
# Loop lock/log state
|
||||
.loop-locks/
|
||||
.loop-logs/
|
||||
|
||||
18
.mcp.json
Normal file
18
.mcp.json
Normal file
@@ -0,0 +1,18 @@
|
||||
{
|
||||
"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"]
|
||||
},
|
||||
"hs-test": {
|
||||
"type": "stdio",
|
||||
"command": "python3",
|
||||
"args": ["tools/mcp_hs_test.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"})
|
||||
64
applications/graphql/spec.sx
Normal file
64
applications/graphql/spec.sx
Normal file
@@ -0,0 +1,64 @@
|
||||
|
||||
;; GraphQL — SX language assimilation
|
||||
;;
|
||||
;; Pure SX implementation of the GraphQL query language.
|
||||
;; Parser, executor, and serializer — all s-expressions,
|
||||
;; compiled to bytecode by the same kernel.
|
||||
;;
|
||||
;; Files:
|
||||
;; lib/graphql.sx — Tokenizer + recursive descent parser
|
||||
;; lib/graphql-exec.sx — Executor (projection, fragments, variables)
|
||||
;; spec/tests/test-graphql.sx — 66 tests across 15 suites
|
||||
;;
|
||||
;; Hyperscript integration:
|
||||
;; fetch gql { query { ... } } — shorthand query
|
||||
;; fetch gql mutation { ... } — mutation
|
||||
;; fetch gql { ... } from "/endpoint" — custom endpoint
|
||||
;;
|
||||
;; Maps to existing SX infrastructure:
|
||||
;; Query → defquery (IO suspension)
|
||||
;; Mutation → defaction (IO suspension)
|
||||
;; Subscription → SSE + signals (reactive islands)
|
||||
;; Fragment → defcomp (component composition)
|
||||
;; Schema → spec/types.sx (gradual type system)
|
||||
;; Resolver → perform (CEK IO suspension)
|
||||
|
||||
(define graphql-version "0.1.0")
|
||||
|
||||
(define
|
||||
graphql-features
|
||||
(quote
|
||||
(queries
|
||||
mutations
|
||||
subscriptions
|
||||
fragments
|
||||
inline-fragments
|
||||
fragment-spreads
|
||||
variables
|
||||
variable-defaults
|
||||
directives
|
||||
directive-arguments
|
||||
aliases
|
||||
field-arguments
|
||||
object-values
|
||||
list-values
|
||||
enum-values
|
||||
block-strings
|
||||
comments
|
||||
field-projection
|
||||
nested-projection
|
||||
list-projection
|
||||
variable-substitution
|
||||
fragment-resolution
|
||||
custom-resolvers
|
||||
default-io-resolver
|
||||
aliased-execution
|
||||
multi-root-fields
|
||||
named-operations
|
||||
operation-introspection
|
||||
ast-to-source
|
||||
round-trip
|
||||
fetch-gql
|
||||
fetch-gql-from
|
||||
fetch-gql-mutation
|
||||
fetch-gql-query)))
|
||||
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)}))))
|
||||
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"})
|
||||
12
deploy.sh
12
deploy.sh
@@ -53,8 +53,8 @@ fi
|
||||
echo "Building: ${BUILD[*]}"
|
||||
echo ""
|
||||
|
||||
# --- Run all tests before deploying ---
|
||||
if ! ./run-tests.sh; then
|
||||
# --- Run unit tests before deploying (skip Playwright — needs running server) ---
|
||||
if ! QUICK=true ./run-tests.sh; then
|
||||
exit 1
|
||||
fi
|
||||
|
||||
@@ -63,8 +63,12 @@ for app in "${BUILD[@]}"; do
|
||||
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,71 +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_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
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
|
||||
# Spec + lib + web SX files (loaded by OCaml kernel)
|
||||
# SX source files (hot-reload on restart)
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
# OCaml SX kernel binary (built with: cd hosts/ocaml && eval $(opam env) && dune build)
|
||||
- ./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
|
||||
- ./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
|
||||
networks:
|
||||
- externalnet
|
||||
- default
|
||||
restart: unless-stopped
|
||||
|
||||
redis:
|
||||
image: redis:7-alpine
|
||||
restart: unless-stopped
|
||||
|
||||
networks:
|
||||
externalnet:
|
||||
external: true
|
||||
|
||||
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
|
||||
|
||||
@@ -99,6 +99,8 @@ 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")
|
||||
@@ -130,7 +132,7 @@ def compile_ref_to_js(
|
||||
("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)
|
||||
|
||||
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()
|
||||
@@ -61,6 +61,7 @@ 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)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"vm": ("vm.sx", "vm (bytecode virtual machine)"),
|
||||
@@ -68,7 +69,7 @@ SPEC_MODULES = {
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types", "vm"]
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "signals-web", "types", "vm"]
|
||||
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
@@ -834,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
|
||||
// =========================================================================
|
||||
@@ -943,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; };
|
||||
@@ -1026,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]); };
|
||||
@@ -1067,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;
|
||||
@@ -1305,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; }
|
||||
@@ -1700,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);
|
||||
};
|
||||
|
||||
@@ -2665,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);
|
||||
}
|
||||
@@ -3077,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) {
|
||||
@@ -3211,7 +3237,15 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
// 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_;
|
||||
@@ -3287,7 +3321,34 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
if (typeof sxParse === "function") PRIMITIVES["sx-parse"] = sxParse;''']
|
||||
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('''
|
||||
// Platform deps functions (native JS, not transpiled — need explicit registration)
|
||||
|
||||
@@ -82,6 +82,18 @@ 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); };
|
||||
@@ -232,6 +244,20 @@ env["render-sx"] = function(source) {
|
||||
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 {
|
||||
@@ -279,10 +305,61 @@ 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"]) {
|
||||
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");
|
||||
@@ -294,6 +371,31 @@ if (fullBuild) {
|
||||
}
|
||||
}
|
||||
}
|
||||
// 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
|
||||
|
||||
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"
|
||||
@@ -1,6 +1,6 @@
|
||||
module T = Sx.Sx_types
|
||||
module P = Sx.Sx_parser
|
||||
module R = Sx.Sx_ref
|
||||
module T = Sx_types
|
||||
module P = Sx_parser
|
||||
module R = Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
|
||||
@@ -1,3 +1,11 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server integration_tests)
|
||||
(libraries sx unix))
|
||||
(libraries sx unix threads.posix otfm yojson))
|
||||
|
||||
(executable
|
||||
(name mcp_tree)
|
||||
(libraries sx unix yojson str))
|
||||
|
||||
(executable
|
||||
(name test_cst)
|
||||
(libraries sx))
|
||||
|
||||
@@ -7,12 +7,7 @@
|
||||
Usage:
|
||||
dune exec bin/integration_tests.exe *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
(* Modules accessed directly — library is unwrapped *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
@@ -320,7 +315,7 @@ let make_integration_env () =
|
||||
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 p v
|
||||
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)"));
|
||||
@@ -412,7 +407,7 @@ let () =
|
||||
let render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
Sx_render.render_to_html expr env
|
||||
Sx_render.sx_render_to_html env expr env
|
||||
in
|
||||
|
||||
(* Helper: call SX render-to-html via the adapter *)
|
||||
@@ -513,6 +508,141 @@ let () =
|
||||
(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";
|
||||
|
||||
3125
hosts/ocaml/bin/mcp_tree.ml
Normal file
3125
hosts/ocaml/bin/mcp_tree.ml
Normal file
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
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
|
||||
@@ -49,16 +49,11 @@ let trampoline v = !trampoline_fn v
|
||||
|
||||
|
||||
|
||||
(* === Mutable state for strict mode === *)
|
||||
(* These are defined as top-level refs because the transpiler cannot handle
|
||||
global set! mutation (it creates local refs that shadow the global). *)
|
||||
(* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *)
|
||||
let _strict_ref = ref (Bool false)
|
||||
let _prim_param_types_ref = ref Nil
|
||||
|
||||
(* JIT call hook — cek_call checks this before CEK dispatch for named
|
||||
lambdas. Registered by sx_server.ml after compiler loads. Tests
|
||||
run with hook = None (pure CEK, no compilation dependency). *)
|
||||
let jit_call_hook : (value -> value list -> value option) option ref = ref None
|
||||
let _last_error_kont_ref = ref Nil
|
||||
let _protocol_registry_ = Dict (Hashtbl.create 0)
|
||||
|
||||
"""
|
||||
|
||||
@@ -75,13 +70,61 @@ let () = trampoline_fn := (fun 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 *)
|
||||
(* 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
|
||||
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
|
||||
s := cek_step !s
|
||||
(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;
|
||||
cek_value !s
|
||||
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)
|
||||
|
||||
|
||||
|
||||
@@ -163,90 +206,18 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
parts.append(FIXUPS)
|
||||
output = "\n".join(parts)
|
||||
|
||||
# Post-process: fix mutable globals that the transpiler can't handle.
|
||||
# The transpiler emits local refs for set! targets within functions,
|
||||
# but top-level globals (*strict*, *prim-param-types*) need to use
|
||||
# the pre-declared refs from the preamble.
|
||||
# Mutable globals (*strict*, *prim-param-types*) are now handled by
|
||||
# the transpiler directly — it emits !_ref for reads, _ref := for writes.
|
||||
import re
|
||||
|
||||
# Fix *strict*: use _strict_ref instead of immutable let rec binding
|
||||
# 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'and _strict_ =\n \(Bool false\)',
|
||||
'and _strict_ = !_strict_ref',
|
||||
output,
|
||||
r'\n\(\* \*protocol-registry\*.*?\nand _protocol_registry_ =\n \(Dict \(Hashtbl\.create 0\)\)\n',
|
||||
'\n',
|
||||
output
|
||||
)
|
||||
# Fix set-strict!: use _strict_ref instead of local ref
|
||||
output = re.sub(
|
||||
r'and set_strict_b val\' =\n let _strict_ = ref Nil in \(_strict_ := val\'; Nil\)',
|
||||
"and set_strict_b val' =\n _strict_ref := val'; Nil",
|
||||
output,
|
||||
)
|
||||
# Fix *prim-param-types*: use _prim_param_types_ref
|
||||
output = re.sub(
|
||||
r'and _prim_param_types_ =\n Nil',
|
||||
'and _prim_param_types_ = !_prim_param_types_ref',
|
||||
output,
|
||||
)
|
||||
# Fix set-prim-param-types!: use _prim_param_types_ref
|
||||
output = re.sub(
|
||||
r'and set_prim_param_types_b types =\n let _prim_param_types_ = ref Nil in \(_prim_param_types_ := types; Nil\)',
|
||||
"and set_prim_param_types_b types =\n _prim_param_types_ref := types; Nil",
|
||||
output,
|
||||
)
|
||||
|
||||
# Fix all runtime reads of _strict_ and _prim_param_types_ to deref
|
||||
# the mutable refs instead of using the stale let-rec bindings.
|
||||
# This is needed because let-rec value bindings capture initial values.
|
||||
# Use regex with word boundary to avoid replacing _strict_ref with
|
||||
# !_strict_refref.
|
||||
def fix_mutable_reads(text):
|
||||
lines = text.split('\n')
|
||||
fixed = []
|
||||
for line in lines:
|
||||
# Skip the definition lines
|
||||
stripped = line.strip()
|
||||
if stripped.startswith('and _strict_ =') or stripped.startswith('and _prim_param_types_ ='):
|
||||
fixed.append(line)
|
||||
continue
|
||||
# Replace _strict_ as a standalone identifier only (not inside
|
||||
# other names like set_strict_b). Match when preceded by space,
|
||||
# paren, or start-of-line, and followed by space, paren, or ;.
|
||||
line = re.sub(r'(?<=[ (])_strict_(?=[ );])', '!_strict_ref', line)
|
||||
line = re.sub(r'(?<=[ (])_prim_param_types_(?=[ );])', '!_prim_param_types_ref', line)
|
||||
fixed.append(line)
|
||||
return '\n'.join(fixed)
|
||||
output = fix_mutable_reads(output)
|
||||
|
||||
# Fix cek_call: the spec passes (make-env) as the env arg to
|
||||
# continue_with_call, but the transpiler evaluates make-env at
|
||||
# transpile time (it's a primitive), producing Dict instead of Env.
|
||||
output = output.replace(
|
||||
"((Dict (Hashtbl.create 0))) (a) ((List []))",
|
||||
"(Env (Sx_types.make_env ())) (a) ((List []))",
|
||||
)
|
||||
|
||||
# Inject JIT dispatch into continue_with_call's lambda branch.
|
||||
# After params are bound, check jit_call_hook before creating CEK state.
|
||||
lambda_body_pattern = (
|
||||
'(prim_call "slice" [params; (len (args))])); Nil)) in '
|
||||
'(make_cek_state ((lambda_body (f))) (local) (kont))'
|
||||
)
|
||||
lambda_body_jit = (
|
||||
'(prim_call "slice" [params; (len (args))])); Nil)) in '
|
||||
'(match !jit_call_hook, f with '
|
||||
'| Some hook, Lambda l when l.l_name <> None -> '
|
||||
'let args_list = match args with '
|
||||
'List a | ListRef { contents = a } -> a | _ -> [] in '
|
||||
'(match hook f args_list with '
|
||||
'Some result -> make_cek_value result local kont '
|
||||
'| None -> make_cek_state (lambda_body f) local kont) '
|
||||
'| _ -> make_cek_state ((lambda_body (f))) (local) (kont))'
|
||||
)
|
||||
if lambda_body_pattern in output:
|
||||
output = output.replace(lambda_body_pattern, lambda_body_jit, 1)
|
||||
else:
|
||||
import sys
|
||||
print("WARNING: Could not find lambda body pattern for JIT injection", file=sys.stderr)
|
||||
|
||||
return output
|
||||
|
||||
|
||||
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()
|
||||
649
hosts/ocaml/bootstrap_vm.py
Normal file
649
hosts/ocaml/bootstrap_vm.py
Normal file
@@ -0,0 +1,649 @@
|
||||
#!/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-rest-arity" (Number (float_of_int c.vm_code.vc_rest_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_rest_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
|
||||
41
hosts/ocaml/browser/build-all.sh
Executable file
41
hosts/ocaml/browser/build-all.sh
Executable file
@@ -0,0 +1,41 @@
|
||||
#!/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 "=== 6. Run bytecode regression tests ==="
|
||||
node test_bytecode_repeat.js
|
||||
|
||||
echo "=== Done ==="
|
||||
92
hosts/ocaml/browser/bundle.sh
Executable file
92
hosts/ocaml/browser/bundle.sh
Executable file
@@ -0,0 +1,92 @@
|
||||
#!/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/"
|
||||
|
||||
# 10. Hyperscript
|
||||
for f in tokenizer parser compiler runtime integration htmx; do
|
||||
cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx"
|
||||
done
|
||||
|
||||
# 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>'
|
||||
510
hosts/ocaml/browser/compile-modules.js
Normal file
510
hosts/ocaml/browser/compile-modules.js
Normal file
@@ -0,0 +1,510 @@
|
||||
#!/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',
|
||||
'text-layout.sx': 'lib/text-layout.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',
|
||||
'text-layout.sx',
|
||||
'boot-helpers.sx', 'hypersx.sx', 'harness.sx', 'harness-reactive.sx',
|
||||
'harness-web.sx', 'engine.sx', 'orchestration.sx',
|
||||
// Hyperscript modules — loaded on demand via transparent lazy loader
|
||||
'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx',
|
||||
'hs-integration.sx', 'hs-htmx.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) {
|
||||
// Paren-aware stripping: find (begin ...) inside (define-library ...), extract body.
|
||||
// Keep top-level (import ...) forms outside the define-library.
|
||||
|
||||
// Find (define-library at the start
|
||||
const dlMatch = source.match(/^[\s\S]*?\(define-library\b/);
|
||||
if (!dlMatch) return source; // no define-library, return as-is
|
||||
|
||||
// Find the (begin that opens the body — skip past (export ...) using paren counting
|
||||
const afterDL = dlMatch[0].length;
|
||||
let pos = afterDL;
|
||||
let foundBegin = -1;
|
||||
|
||||
while (pos < source.length) {
|
||||
// Skip whitespace and comments
|
||||
while (pos < source.length && /[\s]/.test(source[pos])) pos++;
|
||||
if (pos >= source.length) break;
|
||||
if (source[pos] === ';') { // skip comment line
|
||||
while (pos < source.length && source[pos] !== '\n') pos++;
|
||||
continue;
|
||||
}
|
||||
|
||||
// Check for (begin
|
||||
if (source.startsWith('(begin', pos)) {
|
||||
foundBegin = pos;
|
||||
break;
|
||||
}
|
||||
|
||||
// Skip balanced sexp (the library name and export list)
|
||||
if (source[pos] === '(') {
|
||||
let depth = 1;
|
||||
pos++;
|
||||
while (pos < source.length && depth > 0) {
|
||||
if (source[pos] === '(') depth++;
|
||||
else if (source[pos] === ')') depth--;
|
||||
else if (source[pos] === '"') { // skip strings
|
||||
pos++;
|
||||
while (pos < source.length && source[pos] !== '"') {
|
||||
if (source[pos] === '\\') pos++;
|
||||
pos++;
|
||||
}
|
||||
} else if (source[pos] === ';') { // skip comments
|
||||
while (pos < source.length && source[pos] !== '\n') pos++;
|
||||
continue;
|
||||
}
|
||||
pos++;
|
||||
}
|
||||
} else {
|
||||
// Skip atom
|
||||
while (pos < source.length && !/[\s()]/.test(source[pos])) pos++;
|
||||
}
|
||||
}
|
||||
|
||||
if (foundBegin === -1) return source; // no (begin found
|
||||
|
||||
// Find the body inside (begin ...) — skip "(begin" + optional whitespace
|
||||
let bodyStart = foundBegin + 6; // len("(begin") = 6
|
||||
// Skip optional newline/whitespace after (begin
|
||||
while (bodyStart < source.length && /[\s]/.test(source[bodyStart])) bodyStart++;
|
||||
|
||||
// Find matching close of (begin ...) using paren counting from foundBegin
|
||||
pos = foundBegin + 1; // after opening (
|
||||
let depth = 1;
|
||||
while (pos < source.length && depth > 0) {
|
||||
if (source[pos] === '(') depth++;
|
||||
else if (source[pos] === ')') depth--;
|
||||
else if (source[pos] === '"') {
|
||||
pos++;
|
||||
while (pos < source.length && source[pos] !== '"') {
|
||||
if (source[pos] === '\\') pos++;
|
||||
pos++;
|
||||
}
|
||||
} else if (source[pos] === ';') {
|
||||
while (pos < source.length && source[pos] !== '\n') pos++;
|
||||
continue;
|
||||
}
|
||||
if (depth > 0) pos++;
|
||||
}
|
||||
const beginClose = pos; // position of closing ) for (begin ...)
|
||||
|
||||
// Extract body (everything between (begin and its closing paren)
|
||||
const body = source.slice(bodyStart, beginClose);
|
||||
|
||||
// Find any (import ...) forms AFTER the define-library
|
||||
// The define-library's closing paren is right after begin's
|
||||
let dlClose = beginClose + 1;
|
||||
while (dlClose < source.length && source[dlClose] !== ')') {
|
||||
if (source[dlClose] === ';') {
|
||||
while (dlClose < source.length && source[dlClose] !== '\n') dlClose++;
|
||||
}
|
||||
dlClose++;
|
||||
}
|
||||
dlClose++; // past the closing )
|
||||
|
||||
const afterDLForm = source.slice(dlClose);
|
||||
|
||||
return body + '\n' + afterDLForm;
|
||||
}
|
||||
|
||||
// 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(/\)$/, '');
|
||||
}
|
||||
|
||||
// Extract top-level (define name ...) symbols from a non-library file
|
||||
function extractDefines(source) {
|
||||
const names = [];
|
||||
const re = /^\(define\s+(\S+)/gm;
|
||||
let m;
|
||||
while ((m = re.exec(source)) !== null) {
|
||||
const name = m[1];
|
||||
if (name && !name.startsWith('(') && !name.startsWith(':')) names.push(name);
|
||||
}
|
||||
return names;
|
||||
}
|
||||
|
||||
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) };
|
||||
} else {
|
||||
// Non-library file (e.g. hyperscript modules) — extract top-level defines
|
||||
// as exports so the transparent lazy loader can resolve symbols to files.
|
||||
const defines = extractDefines(src);
|
||||
if (defines.length > 0) {
|
||||
const key = file.replace(/\.sx$/, '');
|
||||
// HS modules form a dependency chain — loading one loads all predecessors.
|
||||
const HS_DEPS = {
|
||||
'hs-parser': ['hs-tokenizer'],
|
||||
'hs-compiler': ['hs-tokenizer', 'hs-parser'],
|
||||
'hs-runtime': ['hs-tokenizer', 'hs-parser', 'hs-compiler'],
|
||||
'hs-integration': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'],
|
||||
'hs-htmx': ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration'],
|
||||
};
|
||||
manifest[key] = {
|
||||
file: sxbcFile,
|
||||
deps: HS_DEPS[key] || [],
|
||||
exports: defines,
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
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));
|
||||
// Hyperscript modules aren't define-library, so not auto-detected as deps.
|
||||
// Load them lazily after boot — eager loading breaks the boot sequence.
|
||||
const HS_LAZY = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime', 'hs-integration', 'hs-htmx'];
|
||||
for (const m of HS_LAZY) {
|
||||
if (manifest[m] && !lazyDeps.includes(m)) lazyDeps.push(m);
|
||||
}
|
||||
// Text layout library — loaded eagerly for Pretext island
|
||||
if (manifest['sx text-layout'] && !eagerDeps.includes('sx text-layout')) {
|
||||
eagerDeps.push('sx text-layout');
|
||||
}
|
||||
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)))
|
||||
1054
hosts/ocaml/browser/sx-platform.js
Normal file
1054
hosts/ocaml/browser/sx-platform.js
Normal file
File diff suppressed because it is too large
Load Diff
1102
hosts/ocaml/browser/sx_browser.ml
Normal file
1102
hosts/ocaml/browser/sx_browser.ml
Normal file
File diff suppressed because it is too large
Load Diff
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);
|
||||
}
|
||||
"
|
||||
230
hosts/ocaml/browser/test_bytecode_repeat.js
Normal file
230
hosts/ocaml/browser/test_bytecode_repeat.js
Normal file
@@ -0,0 +1,230 @@
|
||||
#!/usr/bin/env node
|
||||
// test_bytecode_repeat.js — Regression test for bytecode when/do/perform bug
|
||||
//
|
||||
// Tests that (when cond (do (perform ...) (recurse))) correctly resumes
|
||||
// the do continuation after perform/cek_resume in bytecode-compiled code.
|
||||
//
|
||||
// The bug: bytecode-compiled hs-repeat-times only iterates 2x instead of 3x
|
||||
// because the do continuation is lost after perform suspension.
|
||||
//
|
||||
// Source-loaded code works (CEK handles when/do/perform correctly).
|
||||
// Bytecode-compiled code fails (VM/CEK handoff loses the continuation).
|
||||
//
|
||||
// Usage: node hosts/ocaml/browser/test_bytecode_repeat.js
|
||||
//
|
||||
// Expected output when bug is fixed:
|
||||
// SOURCE: 6 suspensions (3 iterations × 2 waits) ✓
|
||||
// BYTECODE: 6 suspensions (3 iterations × 2 waits) ✓
|
||||
|
||||
const fs = require('fs');
|
||||
const path = require('path');
|
||||
|
||||
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
|
||||
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
|
||||
const SX_DIR = path.join(WASM_DIR, 'sx');
|
||||
|
||||
// --- Minimal DOM stubs ---
|
||||
function makeElement(tag) {
|
||||
const el = {
|
||||
tagName: tag, _attrs: {}, _classes: new Set(), style: {},
|
||||
childNodes: [], children: [], textContent: '', nodeType: 1,
|
||||
classList: {
|
||||
add(c) { el._classes.add(c); },
|
||||
remove(c) { el._classes.delete(c); },
|
||||
contains(c) { return el._classes.has(c); },
|
||||
},
|
||||
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); return c; },
|
||||
insertBefore(c) { el.children.push(c); el.childNodes.push(c); return c; },
|
||||
removeChild(c) { return c; }, replaceChild(n) { return n; },
|
||||
cloneNode() { return makeElement(tag); },
|
||||
addEventListener() {}, removeEventListener() {}, dispatchEvent() {},
|
||||
get className() { return [...el._classes].join(' '); },
|
||||
get innerHTML() { return ''; }, set innerHTML(v) {},
|
||||
get outerHTML() { return '<' + tag + '>'; },
|
||||
dataset: {}, 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() {} };
|
||||
|
||||
async function main() {
|
||||
// Load WASM kernel
|
||||
require(path.join(WASM_DIR, 'sx_browser.bc.js'));
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) { console.error('FATAL: SxKernel not found'); process.exit(1); }
|
||||
|
||||
// Register FFI
|
||||
K.registerNative('host-global', args => (args[0] in globalThis) ? globalThis[args[0]] : null);
|
||||
K.registerNative('host-get', args => { if (args[0] == null) return null; const v = args[0][args[1]]; 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;
|
||||
return obj[method].apply(obj, rest) ?? null;
|
||||
});
|
||||
K.registerNative('host-new', args => new (Function.prototype.bind.apply(args[0], [null, ...args.slice(1)])));
|
||||
K.registerNative('host-callback', args => {
|
||||
const fn = args[0];
|
||||
return function() { return K.callFn(fn, Array.from(arguments)); };
|
||||
});
|
||||
K.registerNative('host-typeof', args => typeof args[0]);
|
||||
K.registerNative('host-await', args => args[0]);
|
||||
|
||||
K.eval('(define SX_VERSION "test-bc-repeat")');
|
||||
K.eval('(define SX_ENGINE "ocaml-vm-test")');
|
||||
K.eval('(define parse sx-parse)');
|
||||
K.eval('(define serialize sx-serialize)');
|
||||
|
||||
// DOM stubs for HS runtime
|
||||
K.eval('(define dom-add-class (fn (el cls) (host-call (host-get el "classList") "add" cls)))');
|
||||
K.eval('(define dom-remove-class (fn (el cls) (host-call (host-get el "classList") "remove" cls)))');
|
||||
K.eval('(define dom-has-class? (fn (el cls) (host-call (host-get el "classList") "contains" cls)))');
|
||||
K.eval('(define dom-listen (fn (target event-name handler) (handler {:type event-name :target target})))');
|
||||
|
||||
// --- Test helper: count suspensions ---
|
||||
function countSuspensions(result) {
|
||||
return new Promise(resolve => {
|
||||
let count = 0;
|
||||
function drive(r) {
|
||||
if (!r || !r.suspended) { resolve(count); return; }
|
||||
count++;
|
||||
const req = r.request;
|
||||
const items = req && (req.items || req);
|
||||
const op = items && items[0];
|
||||
const opName = typeof op === 'string' ? op : (op && op.name) || String(op);
|
||||
if (opName === 'io-sleep' || opName === 'wait') {
|
||||
setTimeout(() => {
|
||||
try { drive(r.resume(null)); }
|
||||
catch(e) { console.error(' resume error:', e.message); resolve(count); }
|
||||
}, 1);
|
||||
} else { resolve(count); }
|
||||
}
|
||||
drive(result);
|
||||
});
|
||||
}
|
||||
|
||||
let pass = 0, fail = 0;
|
||||
function assert(name, got, expected) {
|
||||
if (got === expected) { pass++; console.log(` ✓ ${name}`); }
|
||||
else { fail++; console.error(` ✗ ${name}: got ${got}, expected ${expected}`); }
|
||||
}
|
||||
|
||||
// =====================================================================
|
||||
// Test 1: SOURCE — load hs-repeat-times from .sx, call with perform
|
||||
// =====================================================================
|
||||
console.log('\n=== Test: SOURCE-loaded hs-repeat-times ===');
|
||||
|
||||
// Load from source
|
||||
const hsFiles = ['tokenizer', 'parser', 'compiler', 'runtime'];
|
||||
for (const f of hsFiles) {
|
||||
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'lib/hyperscript', f + '.sx'), 'utf8'));
|
||||
}
|
||||
|
||||
// Build handler and call it
|
||||
K.eval(`(define _src-handler
|
||||
(eval-expr
|
||||
(list 'fn '(me)
|
||||
(list 'let '((it nil) (event {:type "click"}))
|
||||
(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 1ms then remove .active then wait 1ms end")))))`);
|
||||
|
||||
const srcMe = makeElement('button');
|
||||
K.eval('(define _src-me (host-global "_srcMe"))');
|
||||
global._srcMe = srcMe;
|
||||
K.eval('(define _src-me (host-global "_srcMe"))');
|
||||
|
||||
let srcResult;
|
||||
try { srcResult = K.callFn(K.eval('_src-handler'), [srcMe]); }
|
||||
catch(e) { console.error('Source call error:', e.message); }
|
||||
|
||||
const srcSuspensions = await countSuspensions(srcResult);
|
||||
assert('source: 6 suspensions (3 iters × 2 waits)', srcSuspensions, 6);
|
||||
|
||||
// =====================================================================
|
||||
// Test 2: BYTECODE — load hs-repeat-times from .sxbc, call with perform
|
||||
// =====================================================================
|
||||
console.log('\n=== Test: BYTECODE-loaded hs-repeat-times ===');
|
||||
|
||||
// Reload from bytecode — overwrite the source-defined versions
|
||||
if (K.beginModuleLoad) K.beginModuleLoad();
|
||||
for (const f of ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime']) {
|
||||
const bcPath = path.join(SX_DIR, f + '.sxbc');
|
||||
if (fs.existsSync(bcPath)) {
|
||||
const bcSrc = fs.readFileSync(bcPath, 'utf8');
|
||||
K.load('(load-sxbc (first (parse "' + bcSrc.replace(/\\/g, '\\\\').replace(/"/g, '\\"') + '")))');
|
||||
}
|
||||
}
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
|
||||
// Build handler with the bytecode-loaded hs-repeat-times
|
||||
K.eval(`(define _bc-handler
|
||||
(eval-expr
|
||||
(list 'fn '(me)
|
||||
(list 'let '((it nil) (event {:type "click"}))
|
||||
(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 1ms then remove .active then wait 1ms end")))))`);
|
||||
|
||||
const bcMe = makeElement('button');
|
||||
global._bcMe = bcMe;
|
||||
K.eval('(define _bc-me (host-global "_bcMe"))');
|
||||
|
||||
let bcResult;
|
||||
try { bcResult = K.callFn(K.eval('_bc-handler'), [bcMe]); }
|
||||
catch(e) { console.error('Bytecode call error:', e.message); }
|
||||
|
||||
const bcSuspensions = await countSuspensions(bcResult);
|
||||
assert('bytecode: 6 suspensions (3 iters × 2 waits)', bcSuspensions, 6);
|
||||
|
||||
// =====================================================================
|
||||
// Test 3: Minimal — just hs-repeat-times + perform, no hyperscript
|
||||
// =====================================================================
|
||||
console.log('\n=== Test: Minimal repeat + perform ===');
|
||||
|
||||
// Source version
|
||||
K.eval('(define _src-count 0)');
|
||||
K.eval(`(define _src-repeat-fn
|
||||
(fn (n thunk)
|
||||
(define do-repeat
|
||||
(fn (i) (when (< i n) (do (thunk) (do-repeat (+ i 1))))))
|
||||
(do-repeat 0)))`);
|
||||
K.eval(`(define _src-repeat-thunk
|
||||
(eval-expr '(fn () (_src-repeat-fn 3 (fn () (set! _src-count (+ _src-count 1)) (perform (list 'io-sleep 1)))))))`);
|
||||
|
||||
let minSrcResult;
|
||||
try { minSrcResult = K.callFn(K.eval('_src-repeat-thunk'), []); }
|
||||
catch(e) { console.error('Minimal source error:', e.message); }
|
||||
const minSrcSusp = await countSuspensions(minSrcResult);
|
||||
const minSrcCount = K.eval('_src-count');
|
||||
assert('minimal source: 3 suspensions', minSrcSusp, 3);
|
||||
assert('minimal source: count=3', minSrcCount, 3);
|
||||
|
||||
// =====================================================================
|
||||
// Summary
|
||||
// =====================================================================
|
||||
console.log(`\n${pass} passed, ${fail} failed`);
|
||||
process.exit(fail > 0 ? 1 : 0);
|
||||
}
|
||||
|
||||
main().catch(e => { console.error('FATAL:', e.message); process.exit(1); });
|
||||
294
hosts/ocaml/browser/test_driveAsync_order.js
Normal file
294
hosts/ocaml/browser/test_driveAsync_order.js
Normal file
@@ -0,0 +1,294 @@
|
||||
#!/usr/bin/env node
|
||||
// test_driveAsync_order.js — Verify DOM mutation order with real _driveAsync
|
||||
//
|
||||
// This test mimics the exact browser flow:
|
||||
// 1. host-callback wraps handler with K.callFn + _driveAsync
|
||||
// 2. dom-listen uses host-callback + host-call addEventListener
|
||||
// 3. Event fires → wrapper runs → _driveAsync drives suspension chain
|
||||
//
|
||||
// If there's a dual-path issue (_driveAsync + CEK chain both driving),
|
||||
// mutations will appear out of order.
|
||||
//
|
||||
// Expected: +active, -active, +active, -active, +active, -active (3 iterations)
|
||||
// Bug: +active, +active, -active, ... (overlapping iterations)
|
||||
|
||||
const fs = require('fs');
|
||||
const path = require('path');
|
||||
|
||||
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
|
||||
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
|
||||
|
||||
// --- Track ALL mutations in order ---
|
||||
const mutations = [];
|
||||
|
||||
function makeElement(tag) {
|
||||
const el = {
|
||||
tagName: tag, _attrs: {}, _children: [], _classes: new Set(),
|
||||
_listeners: {},
|
||||
style: {}, childNodes: [], children: [], textContent: '',
|
||||
nodeType: 1,
|
||||
classList: {
|
||||
add(c) {
|
||||
el._classes.add(c);
|
||||
mutations.push('+' + c);
|
||||
console.log(' [DOM] classList.add("' + c + '") → {' + [...el._classes] + '}');
|
||||
},
|
||||
remove(c) {
|
||||
el._classes.delete(c);
|
||||
mutations.push('-' + c);
|
||||
console.log(' [DOM] classList.remove("' + c + '") → {' + [...el._classes] + '}');
|
||||
},
|
||||
contains(c) { return el._classes.has(c); },
|
||||
toggle(c) { if (el._classes.has(c)) el._classes.delete(c); else el._classes.add(c); },
|
||||
},
|
||||
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(event, fn) {
|
||||
if (!el._listeners[event]) el._listeners[event] = [];
|
||||
el._listeners[event].push(fn);
|
||||
},
|
||||
removeEventListener(event, fn) {
|
||||
if (el._listeners[event]) {
|
||||
el._listeners[event] = el._listeners[event].filter(f => f !== fn);
|
||||
}
|
||||
},
|
||||
dispatchEvent(e) {
|
||||
const name = typeof e === 'string' ? e : e.type;
|
||||
(el._listeners[name] || []).forEach(fn => fn(e));
|
||||
},
|
||||
get innerHTML() { return ''; }, set innerHTML(v) {},
|
||||
get outerHTML() { return '<' + tag + '>'; },
|
||||
dataset: {}, 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() {} };
|
||||
|
||||
async function main() {
|
||||
// Load WASM kernel
|
||||
require(path.join(WASM_DIR, 'sx_browser.bc.js'));
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) { console.error('FATAL: SxKernel not found'); process.exit(1); }
|
||||
console.log('WASM kernel loaded');
|
||||
|
||||
// --- Register FFI with the REAL _driveAsync (same as sx-platform.js) ---
|
||||
K.registerNative('host-global', function(args) {
|
||||
var name = args[0];
|
||||
if (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) {
|
||||
if (args[0] != null) args[0][args[1]] = args[2];
|
||||
});
|
||||
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) 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) {
|
||||
return null;
|
||||
});
|
||||
K.registerNative('host-typeof', function(args) { return typeof args[0]; });
|
||||
K.registerNative('host-await', function(args) { return args[0]; });
|
||||
|
||||
// THE REAL host-callback (same as sx-platform.js lines 82-97)
|
||||
K.registerNative('host-callback', function(args) {
|
||||
var fn = args[0];
|
||||
if (typeof fn === 'function' && fn.__sx_handle === undefined) return fn;
|
||||
if (fn && fn.__sx_handle !== undefined) {
|
||||
return function() {
|
||||
var a = Array.prototype.slice.call(arguments);
|
||||
var result = K.callFn(fn, a);
|
||||
// This is the line under investigation:
|
||||
_driveAsync(result);
|
||||
return result;
|
||||
};
|
||||
}
|
||||
return function() {};
|
||||
});
|
||||
|
||||
// THE REAL _driveAsync (same as sx-platform.js lines 104-138)
|
||||
var _asyncPending = 0;
|
||||
function _driveAsync(result) {
|
||||
if (!result || !result.suspended) return;
|
||||
_asyncPending++;
|
||||
console.log('[driveAsync] suspension detected, pending=' + _asyncPending);
|
||||
var req = result.request;
|
||||
if (!req) { _asyncPending--; return; }
|
||||
var items = req.items || req;
|
||||
var op = (items && items[0]) || req;
|
||||
var opName = (typeof op === 'string') ? op : (op && op.name) || String(op);
|
||||
|
||||
if (opName === 'wait' || opName === 'io-sleep') {
|
||||
var ms = (items && items[1]) || 0;
|
||||
if (typeof ms !== 'number') ms = parseFloat(ms) || 0;
|
||||
// Use 1ms for test speed
|
||||
setTimeout(function() {
|
||||
try {
|
||||
var resumed = result.resume(null);
|
||||
_asyncPending--;
|
||||
console.log('[driveAsync] resumed, pending=' + _asyncPending +
|
||||
', suspended=' + (resumed && resumed.suspended));
|
||||
_driveAsync(resumed);
|
||||
} catch(e) {
|
||||
_asyncPending--;
|
||||
console.error('[driveAsync] resume error:', e);
|
||||
}
|
||||
}, 1);
|
||||
} else {
|
||||
_asyncPending--;
|
||||
console.warn('[driveAsync] unhandled IO:', opName);
|
||||
}
|
||||
}
|
||||
|
||||
K.eval('(define SX_VERSION "test-drive-async")');
|
||||
K.eval('(define SX_ENGINE "ocaml-vm-wasm-test")');
|
||||
K.eval('(define parse sx-parse)');
|
||||
K.eval('(define serialize sx-serialize)');
|
||||
|
||||
// Load the REAL dom-listen (uses host-callback + host-call addEventListener)
|
||||
K.eval(`(define dom-listen
|
||||
(fn (el event-name handler)
|
||||
(let ((cb (host-callback handler)))
|
||||
(host-call el "addEventListener" event-name cb)
|
||||
(fn () (host-call el "removeEventListener" event-name cb)))))`);
|
||||
|
||||
K.eval('(define dom-add-class (fn (el cls) (host-call (host-get el "classList") "add" cls)))');
|
||||
K.eval('(define dom-remove-class (fn (el cls) (host-call (host-get el "classList") "remove" cls)))');
|
||||
K.eval('(define dom-has-class? (fn (el cls) (host-call (host-get el "classList") "contains" cls)))');
|
||||
|
||||
// Load hyperscript modules — try bytecode first, fall back to source
|
||||
const SX_DIR = path.join(WASM_DIR, 'sx');
|
||||
const useBytecode = process.argv.includes('--bytecode');
|
||||
if (useBytecode) {
|
||||
console.log('Loading BYTECODE modules...');
|
||||
const bcNames = ['hs-tokenizer', 'hs-parser', 'hs-compiler', 'hs-runtime'];
|
||||
for (const f of bcNames) {
|
||||
const bcPath = path.join(SX_DIR, f + '.sxbc');
|
||||
if (fs.existsSync(bcPath)) {
|
||||
const bcSrc = fs.readFileSync(bcPath, 'utf8');
|
||||
K.load('(load-sxbc (first (parse "' + bcSrc.replace(/\\/g, '\\\\').replace(/"/g, '\\"') + '")))');
|
||||
console.log(' loaded ' + f + '.sxbc');
|
||||
} else {
|
||||
console.error(' MISSING ' + bcPath);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
console.log('Loading SOURCE modules...');
|
||||
const hsFiles = ['tokenizer', 'parser', 'compiler', 'runtime'];
|
||||
for (const f of hsFiles) {
|
||||
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'lib/hyperscript', f + '.sx'), 'utf8'));
|
||||
}
|
||||
}
|
||||
console.log('Hyperscript modules loaded');
|
||||
|
||||
// Create element
|
||||
const btn = makeElement('button');
|
||||
global._testBtn = btn;
|
||||
K.eval('(define _btn (host-global "_testBtn"))');
|
||||
|
||||
// Compile + register handler using hs-on (which uses dom-listen → host-callback → addEventListener)
|
||||
console.log('\n=== Setting up hs-on handler ===');
|
||||
K.eval(`(hs-on _btn "click"
|
||||
(fn (event)
|
||||
(hs-repeat-times 3
|
||||
(fn ()
|
||||
(do
|
||||
(dom-add-class _btn "active")
|
||||
(hs-wait 300)
|
||||
(dom-remove-class _btn "active")
|
||||
(hs-wait 300))))))`);
|
||||
|
||||
console.log('Handler registered, listeners:', Object.keys(btn._listeners));
|
||||
console.log('Click listeners count:', (btn._listeners.click || []).length);
|
||||
|
||||
// Simulate click — fires the event listener which goes through host-callback + _driveAsync
|
||||
console.log('\n=== Simulating click ===');
|
||||
mutations.length = 0;
|
||||
btn.dispatchEvent({ type: 'click', target: btn });
|
||||
|
||||
// Wait for all async resumes to complete
|
||||
await new Promise(resolve => {
|
||||
function check() {
|
||||
if (_asyncPending === 0 && mutations.length > 0) {
|
||||
// Give a tiny extra delay to make sure nothing else fires
|
||||
setTimeout(() => {
|
||||
if (_asyncPending === 0) resolve();
|
||||
else check();
|
||||
}, 10);
|
||||
} else {
|
||||
setTimeout(check, 5);
|
||||
}
|
||||
}
|
||||
setTimeout(check, 50);
|
||||
});
|
||||
|
||||
// Verify mutation order
|
||||
console.log('\n=== Results ===');
|
||||
console.log('Mutations:', mutations.join(', '));
|
||||
console.log('Count:', mutations.length, '(expected: 6)');
|
||||
|
||||
const expected = ['+active', '-active', '+active', '-active', '+active', '-active'];
|
||||
let pass = true;
|
||||
if (mutations.length !== expected.length) {
|
||||
console.error(`FAIL: expected ${expected.length} mutations, got ${mutations.length}`);
|
||||
pass = false;
|
||||
} else {
|
||||
for (let i = 0; i < expected.length; i++) {
|
||||
if (mutations[i] !== expected[i]) {
|
||||
console.error(`FAIL at index ${i}: expected ${expected[i]}, got ${mutations[i]}`);
|
||||
pass = false;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (pass) {
|
||||
console.log('PASS: mutation order is correct');
|
||||
} else {
|
||||
console.log('FAIL: mutation order is wrong');
|
||||
console.log('Expected:', expected.join(', '));
|
||||
console.log('Got: ', mutations.join(', '));
|
||||
}
|
||||
|
||||
process.exit(pass ? 0 : 1);
|
||||
}
|
||||
|
||||
main().catch(e => { console.error('FATAL:', e); process.exit(1); });
|
||||
229
hosts/ocaml/browser/test_hs_repeat.js
Normal file
229
hosts/ocaml/browser/test_hs_repeat.js
Normal file
@@ -0,0 +1,229 @@
|
||||
#!/usr/bin/env node
|
||||
// test_hs_repeat.js — Debug hyperscript repeat+wait continuation bug
|
||||
//
|
||||
// Runs the exact expression that fails in the browser:
|
||||
// on click repeat 3 times add .active to me then wait 300ms
|
||||
// then remove .active then wait 300ms end
|
||||
//
|
||||
// Uses the real WASM kernel with perform/resume_vm, NOT mock IO.
|
||||
// Waits are shortened to 1ms. All IO suspensions are logged.
|
||||
//
|
||||
// Usage: node hosts/ocaml/browser/test_hs_repeat.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 with class tracking ---
|
||||
function makeElement(tag) {
|
||||
const el = {
|
||||
tagName: tag, _attrs: {}, _children: [], _classes: new Set(),
|
||||
style: {}, childNodes: [], children: [], textContent: '',
|
||||
nodeType: 1,
|
||||
classList: {
|
||||
add(c) { el._classes.add(c); console.log(` [dom] classList.add("${c}") → {${[...el._classes]}}`); },
|
||||
remove(c) { el._classes.delete(c); console.log(` [dom] classList.remove("${c}") → {${[...el._classes]}}`); },
|
||||
contains(c) { return el._classes.has(c); },
|
||||
toggle(c) { if (el._classes.has(c)) el._classes.delete(c); else el._classes.add(c); },
|
||||
},
|
||||
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() {} };
|
||||
|
||||
async function main() {
|
||||
// Load WASM kernel
|
||||
require(path.join(WASM_DIR, 'sx_browser.bc.js'));
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) { console.error('FATAL: SxKernel not found'); process.exit(1); }
|
||||
console.log('WASM kernel loaded');
|
||||
|
||||
// Register FFI 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 => {
|
||||
const fn = args[0];
|
||||
return function() { return K.callFn(fn, Array.from(arguments)); };
|
||||
});
|
||||
K.registerNative('host-typeof', args => typeof args[0]);
|
||||
K.registerNative('host-await', args => args[0]);
|
||||
|
||||
K.eval('(define SX_VERSION "test-hs-1.0")');
|
||||
K.eval('(define SX_ENGINE "ocaml-vm-wasm-test")');
|
||||
K.eval('(define parse sx-parse)');
|
||||
K.eval('(define serialize sx-serialize)');
|
||||
|
||||
// Stub DOM primitives that HS runtime calls
|
||||
// dom-listen fires handler immediately (simulates the event)
|
||||
K.eval('(define dom-add-class (fn (el cls) (dict-set! (get el "classes") cls true) nil))');
|
||||
K.eval('(define dom-remove-class (fn (el cls) (dict-delete! (get el "classes") cls) nil))');
|
||||
K.eval('(define dom-has-class? (fn (el cls) (dict-has? (get el "classes") cls)))');
|
||||
K.eval('(define dom-listen (fn (target event-name handler) (handler {:type event-name :target target})))');
|
||||
|
||||
// Load hyperscript modules
|
||||
const hsFiles = [
|
||||
'lib/hyperscript/tokenizer.sx',
|
||||
'lib/hyperscript/parser.sx',
|
||||
'lib/hyperscript/compiler.sx',
|
||||
'lib/hyperscript/runtime.sx',
|
||||
];
|
||||
for (const f of hsFiles) {
|
||||
const src = fs.readFileSync(path.join(PROJECT_ROOT, f), 'utf8');
|
||||
const r = K.load(src);
|
||||
if (typeof r === 'string' && r.startsWith('Error')) {
|
||||
console.error(`Load failed: ${f}: ${r}`);
|
||||
process.exit(1);
|
||||
}
|
||||
}
|
||||
console.log('Hyperscript modules loaded');
|
||||
|
||||
// Compile the expression
|
||||
const compiled = K.eval('(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end")');
|
||||
console.log('Compiled:', K.eval(`(inspect '${typeof compiled === 'string' ? compiled : '?'})`));
|
||||
// Actually get it as a string
|
||||
const compiledStr = K.eval('(inspect (hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end"))');
|
||||
console.log('Compiled SX:', compiledStr);
|
||||
|
||||
// Create handler function (same as hs-handler does)
|
||||
K.eval('(define _test-me {:tag "button" :id "test" :classes {} :_hs-activated true})');
|
||||
|
||||
// Build the handler — wraps compiled SX in (fn (me) (let ((it nil) (event ...)) <sx>))
|
||||
const handlerSrc = K.eval('(inspect (hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end"))');
|
||||
K.eval(`(define _test-handler
|
||||
(eval-expr
|
||||
(list 'fn '(me)
|
||||
(list 'let '((it nil) (event {:type "click" :target _test-me}))
|
||||
(hs-to-sx-from-source "on click repeat 3 times add .active to me then wait 300ms then remove .active then wait 300ms end")))))`);
|
||||
|
||||
console.log('\n=== Invoking handler (simulates click event) ===');
|
||||
console.log('Expected: 3 iterations × (add .active, wait 300, remove .active, wait 300)');
|
||||
console.log('Expected: 6 IO suspensions total\n');
|
||||
|
||||
// Call the handler — this will suspend on the first hs-wait (perform)
|
||||
let suspensionCount = 0;
|
||||
let result;
|
||||
try {
|
||||
result = K.callFn(K.eval('_test-handler'), [K.eval('_test-me')]);
|
||||
} catch(e) {
|
||||
console.error('Initial call error:', e.message);
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Drive async suspension chain with real timeouts (1ms instead of 300ms)
|
||||
function driveAsync(res) {
|
||||
return new Promise((resolve) => {
|
||||
function step(r) {
|
||||
if (!r || !r.suspended) {
|
||||
console.log(`\n=== Done. Total suspensions: ${suspensionCount} (expected: 6) ===`);
|
||||
console.log(`Result: ${r === null ? 'null' : typeof r === 'object' ? JSON.stringify(r) : r}`);
|
||||
resolve();
|
||||
return;
|
||||
}
|
||||
|
||||
suspensionCount++;
|
||||
const req = r.request;
|
||||
const items = req && (req.items || req);
|
||||
const op = items && items[0];
|
||||
const opName = typeof op === 'string' ? op : (op && op.name) || String(op);
|
||||
const arg = items && items[1];
|
||||
|
||||
console.log(`Suspension #${suspensionCount}: op=${opName} arg=${arg}`);
|
||||
|
||||
if (opName === 'io-sleep' || opName === 'wait') {
|
||||
// Resume after 1ms (not real 300ms)
|
||||
setTimeout(() => {
|
||||
try {
|
||||
const resumed = r.resume(null);
|
||||
console.log(` Resumed: suspended=${resumed && resumed.suspended}, type=${typeof resumed}`);
|
||||
step(resumed);
|
||||
} catch(e) {
|
||||
console.error(` Resume error: ${e.message}`);
|
||||
resolve();
|
||||
}
|
||||
}, 1);
|
||||
} else {
|
||||
console.log(` Unhandled IO op: ${opName}`);
|
||||
resolve();
|
||||
}
|
||||
}
|
||||
step(res);
|
||||
});
|
||||
}
|
||||
|
||||
await driveAsync(result);
|
||||
|
||||
// Check final element state
|
||||
const classes = K.eval('(get _test-me "classes")');
|
||||
console.log('\nFinal element classes:', JSON.stringify(classes));
|
||||
}
|
||||
|
||||
main().catch(e => { console.error('FATAL:', 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);
|
||||
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);
|
||||
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); });
|
||||
349
hosts/ocaml/browser/test_wasm.sh
Executable file
349
hosts/ocaml/browser/test_wasm.sh
Executable file
@@ -0,0 +1,349 @@
|
||||
#!/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");
|
||||
|
||||
// =====================================================================
|
||||
// Section 4: Letrec + perform resume (async _driveAsync)
|
||||
// =====================================================================
|
||||
|
||||
// Define the letrec+perform pattern — this matches the test-runner island
|
||||
K.eval("(define __letrec-test-fn (letrec ((other (fn () \"from-other\")) (go (fn () (do (perform {:op \"io-sleep\" :args (list 50)}) (other))))) go))");
|
||||
|
||||
// Get the function as a JS-callable value
|
||||
var letrecFn = K.eval("__letrec-test-fn");
|
||||
if (typeof letrecFn !== "function") {
|
||||
fail++; console.error("FAIL: letrec-fn not callable, got: " + typeof letrecFn);
|
||||
} else {
|
||||
// Call via callFn — same path as island click handlers
|
||||
var letrecResult = K.callFn(letrecFn, []);
|
||||
// Resume through all suspensions — tests that resume() preserves letrec env
|
||||
try {
|
||||
while (letrecResult && letrecResult.suspended) { letrecResult = letrecResult.resume(null); }
|
||||
assert("letrec sibling after perform resume", letrecResult, "from-other");
|
||||
} catch(e) {
|
||||
fail++; console.error("FAIL: letrec perform resume: " + (e.message || e));
|
||||
}
|
||||
}
|
||||
|
||||
// Recursive letrec after perform — the wait-boot pattern
|
||||
K.eval("(define __wb-counter 0)");
|
||||
K.eval("(define __recur-test-fn (letrec ((recur (fn () (set! __wb-counter (+ __wb-counter 1)) (if (>= __wb-counter 3) \"done\" (do (perform {:op \"io-sleep\" :args (list 10)}) (recur)))))) (fn () (set! __wb-counter 0) (recur))))");
|
||||
|
||||
var recurFn = K.eval("__recur-test-fn");
|
||||
if (typeof recurFn !== "function") {
|
||||
fail++; console.error("FAIL: recur-fn not callable, got: " + typeof recurFn);
|
||||
} else {
|
||||
var recurResult = K.callFn(recurFn, []);
|
||||
try {
|
||||
// Resume through all suspensions synchronously
|
||||
while (recurResult && recurResult.suspended) { recurResult = recurResult.resume(null); }
|
||||
assert("recursive letrec after perform", recurResult, "done");
|
||||
assert("recursive letrec counter", K.eval("__wb-counter"), 3);
|
||||
} catch(e) {
|
||||
fail++; console.error("FAIL: recursive letrec perform: " + (e.message || e));
|
||||
}
|
||||
}
|
||||
|
||||
// =====================================================================
|
||||
// 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');
|
||||
@@ -1,2 +1,2 @@
|
||||
(lang dune 3.0)
|
||||
(lang dune 3.19)
|
||||
(name sx)
|
||||
|
||||
@@ -1,2 +1,4 @@
|
||||
(library
|
||||
(name sx))
|
||||
(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))))))
|
||||
|
||||
173
hosts/ocaml/lib/sx_cst.ml
Normal file
173
hosts/ocaml/lib/sx_cst.ml
Normal file
@@ -0,0 +1,173 @@
|
||||
(** 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
|
||||
|
||||
|
||||
(** Convert character offset to line/col (1-based lines, 0-based cols) *)
|
||||
let offset_to_loc src offset =
|
||||
let line = ref 1 and col = ref 0 in
|
||||
for i = 0 to min (offset - 1) (String.length src - 1) do
|
||||
if src.[i] = '\n' then (incr line; col := 0)
|
||||
else col := !col + 1
|
||||
done;
|
||||
(!line, !col)
|
||||
|
||||
(** CST → AST with source location dicts ({:form value :line N :col N}) *)
|
||||
let cst_to_ast_loc src nodes =
|
||||
List.map (fun node ->
|
||||
let span = match node with
|
||||
| CstAtom { span; _ } -> span
|
||||
| CstList { span; _ } -> span
|
||||
| CstDict { span; _ } -> span
|
||||
in
|
||||
let value = cst_to_ast node in
|
||||
let (line, col) = offset_to_loc src span.start_offset in
|
||||
let d = make_dict () in
|
||||
dict_set d "form" value;
|
||||
dict_set d "line" (Number (float_of_int line));
|
||||
dict_set d "col" (Number (float_of_int col));
|
||||
Dict d
|
||||
) nodes
|
||||
|
||||
|
||||
(** {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
|
||||
@@ -65,6 +65,7 @@ let read_string s =
|
||||
| 'r' -> Buffer.add_char buf '\r'
|
||||
| '"' -> Buffer.add_char buf '"'
|
||||
| '\\' -> 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");
|
||||
@@ -95,7 +96,11 @@ let try_number str =
|
||||
|
||||
let rec read_value s : value =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unexpected end of input");
|
||||
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 ']'
|
||||
@@ -139,7 +144,14 @@ let rec read_value s : value =
|
||||
begin
|
||||
(* Symbol, keyword, number, or boolean *)
|
||||
let token = read_symbol s in
|
||||
if token = "" then raise (Parse_error ("Unexpected char: " ^ String.make 1 s.src.[s.pos]));
|
||||
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
|
||||
@@ -191,7 +203,7 @@ and read_dict s =
|
||||
in go ()
|
||||
|
||||
|
||||
(** Parse a string into a list of SX values. *)
|
||||
(** 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
|
||||
@@ -204,10 +216,239 @@ let parse_all src =
|
||||
end
|
||||
in go ()
|
||||
|
||||
(** Parse a file into a list of SX values. *)
|
||||
(** 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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
@@ -15,9 +15,7 @@ let prim_call name args =
|
||||
(** 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
|
||||
| Number n -> Sx_types.format_number n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
@@ -44,13 +42,18 @@ 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)
|
||||
| Lambda _ ->
|
||||
!Sx_types._cek_eval_lambda_ref f args
|
||||
| Continuation (k, _) ->
|
||||
k (match args with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error ("Not callable: " ^ inspect f))
|
||||
| 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
|
||||
@@ -60,6 +63,39 @@ let () = Sx_primitives._sx_call_fn := sx_call
|
||||
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
|
||||
| CekPerformRequest _ as e -> raise e
|
||||
| exn ->
|
||||
(* Check if this is a VM suspension — return marker dict so
|
||||
continue_with_call can build a proper suspended CEK state
|
||||
with vm-resume-frame on the kont. *)
|
||||
(match !_vm_suspension_to_dict exn with
|
||||
| Some marker -> marker
|
||||
| None ->
|
||||
(match exn 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
|
||||
| _ -> raise exn)))
|
||||
| _ -> 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 =
|
||||
@@ -73,6 +109,25 @@ 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. *)
|
||||
@@ -97,7 +152,57 @@ let get_val container key =
|
||||
| "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
|
||||
| "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-rest-arity" (Number (float_of_int c.vc_rest_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
|
||||
@@ -147,29 +252,18 @@ 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 zip_pairs a = _prim "zip-pairs" [a]
|
||||
let take a b = _prim "take" [a; b]
|
||||
let drop a b = _prim "drop" [a; b]
|
||||
let chunk_every a b = _prim "chunk-every" [a; b]
|
||||
|
||||
(* Predicates *)
|
||||
let keyword_p a = _prim "keyword?" [a]
|
||||
let empty_p a = _prim "empty?" [a]
|
||||
let nil_p a = _prim "nil?" [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]
|
||||
let keyword_p a = _prim "keyword?" [a]
|
||||
let contains_p a b = _prim "contains?" [a; b]
|
||||
let has_key_p a b = _prim "has-key?" [a; b]
|
||||
let starts_with_p a b = _prim "starts-with?" [a; b]
|
||||
let ends_with_p a b = _prim "ends-with?" [a; b]
|
||||
let string_contains_p a b = _prim "string-contains?" [a; b]
|
||||
let odd_p a = _prim "odd?" [a]
|
||||
let even_p a = _prim "even?" [a]
|
||||
let zero_p a = _prim "zero?" [a]
|
||||
|
||||
(* String ops *)
|
||||
let str' args = String (sx_str args)
|
||||
@@ -181,10 +275,7 @@ 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 index_of a b = _prim "index-of" [a; b]
|
||||
let substring a b c = _prim "substring" [a; b; c]
|
||||
let string_length a = _prim "string-length" [a]
|
||||
let char_from_code a = _prim "char-from-code" [a]
|
||||
|
||||
(* Dict ops *)
|
||||
let assoc d k v = _prim "assoc" [d; k; v]
|
||||
@@ -194,7 +285,6 @@ 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_has_p a b = _prim "dict-has?" [a; b]
|
||||
let dict_delete a b = _prim "dict-delete!" [a; b]
|
||||
|
||||
(* Math *)
|
||||
@@ -207,8 +297,6 @@ 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]
|
||||
let parse_int a = _prim "parse-int" [a]
|
||||
let parse_float a = _prim "parse-float" [a]
|
||||
|
||||
(* Misc *)
|
||||
let error msg = raise (Eval_error (value_to_str msg))
|
||||
@@ -216,17 +304,8 @@ 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 identical_p a b = _prim "identical?" [a; b]
|
||||
let _is_spread_prim a = _prim "spread?" [a]
|
||||
let spread_attrs a = _prim "spread-attrs" [a]
|
||||
let make_spread a = _prim "make-spread" [a]
|
||||
|
||||
(* Scope primitives — delegate to sx_ref.py's shared scope stacks *)
|
||||
let sx_collect a b = prim_call "collect!" [a; b]
|
||||
let sx_collected a = prim_call "collected" [a]
|
||||
let sx_clear_collected a = prim_call "clear-collected!" [a]
|
||||
let sx_emit a b = prim_call "emit!" [a; b]
|
||||
let sx_emitted a = prim_call "emitted" [a]
|
||||
let sx_context a b = prim_call "context" [a; b]
|
||||
|
||||
(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
|
||||
@@ -272,10 +351,8 @@ 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_identical a b = Bool (a == b)
|
||||
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)
|
||||
let is_spread v = match v with Spread _ -> Bool true | _ -> Bool false
|
||||
|
||||
(* Stubs for functions defined in sx_ref.ml — resolved at link time *)
|
||||
(* These are forward-declared here; sx_ref.ml defines the actual implementations *)
|
||||
@@ -285,21 +362,6 @@ let is_spread v = match v with Spread _ -> Bool true | _ -> Bool false
|
||||
sometimes referenced before their definition via forward calls.
|
||||
These get overridden by the actual transpiled definitions. *)
|
||||
|
||||
let map_indexed fn coll =
|
||||
List (List.mapi (fun i x -> sx_call fn [Number (float_of_int i); x]) (sx_to_list coll))
|
||||
|
||||
let map_dict fn d =
|
||||
match d with
|
||||
| Dict tbl ->
|
||||
let result = Hashtbl.create (Hashtbl.length tbl) in
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace result k (sx_call fn [String k; v])) tbl;
|
||||
Dict result
|
||||
| _ -> raise (Eval_error "map-dict: expected dict")
|
||||
|
||||
let for_each fn coll =
|
||||
List.iter (fun x -> ignore (sx_call fn [x])) (sx_to_list coll);
|
||||
Nil
|
||||
|
||||
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
|
||||
@@ -318,7 +380,20 @@ let continuation_data v = match v with
|
||||
| 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
|
||||
@@ -359,15 +434,23 @@ 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_set_value s v = match s with Signal sig' -> sig'.s_value <- v; v | _ -> raise (Eval_error "not a signal")
|
||||
let signal_subscribers s = match s with Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers) | _ -> List []
|
||||
let signal_add_sub_b _s _f = Nil
|
||||
let signal_remove_sub_b _s _f = Nil
|
||||
let signal_deps _s = List []
|
||||
let signal_set_deps _s _d = Nil
|
||||
let notify_subscribers _s = Nil
|
||||
let flush_subscribers _s = Nil
|
||||
let dispose_computed _s = Nil
|
||||
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). *)
|
||||
@@ -390,20 +473,14 @@ let parse_keyword_args _raw_args _env =
|
||||
(* Stub — the real implementation is transpiled from evaluator.sx *)
|
||||
List [Dict (Hashtbl.create 0); List []]
|
||||
|
||||
(* Make handler/query/action/page def stubs *)
|
||||
(* 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_query_def name params body _env = make_handler_def name params body _env
|
||||
let make_action_def name params body _env = make_handler_def name params body _env
|
||||
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-def* stubs — platform-specific def-forms, not in the SX spec *)
|
||||
(* 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 sf_defquery args env = sf_defhandler args env
|
||||
let sf_defaction args env = sf_defhandler args env
|
||||
let sf_defpage args _env =
|
||||
let name = first args in make_page_def name (rest args)
|
||||
|
||||
let strip_prefix s prefix =
|
||||
match s, prefix with
|
||||
@@ -417,3 +494,38 @@ let strip_prefix s prefix =
|
||||
(* 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
|
||||
(* Sentinel value for "JIT skipped — fall back to CEK".
|
||||
Must be distinguishable from any legitimate return value including Nil.
|
||||
We use a unique tagged dict that is_jit_skip can identify. *)
|
||||
let _jit_skip_sentinel =
|
||||
let d = Hashtbl.create 1 in
|
||||
Hashtbl.replace d "__jit_skip" (Bool true);
|
||||
Dict d
|
||||
|
||||
let is_jit_skip v = match v with
|
||||
| Dict d -> Hashtbl.mem d "__jit_skip"
|
||||
| _ -> false
|
||||
|
||||
(* Platform function for the spec: (jit-skip? v) → transpiles to jit_skip_p *)
|
||||
let jit_skip_p v = Bool (is_jit_skip v)
|
||||
|
||||
let jit_try_call f args =
|
||||
match !_jit_try_call_fn with
|
||||
| None -> incr _jit_skip; _jit_skip_sentinel
|
||||
| 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; _jit_skip_sentinel)
|
||||
| _ -> incr _jit_skip; _jit_skip_sentinel
|
||||
|
||||
|
||||
@@ -1,154 +0,0 @@
|
||||
(** Scope stacks — dynamic scope for render-time effects.
|
||||
|
||||
Provides scope-push!/pop!/peek, collect!/collected/clear-collected!,
|
||||
scope-emit!/emitted/scope-emitted, context, and cookie access.
|
||||
|
||||
All functions are registered as primitives so both the CEK evaluator
|
||||
and the JIT VM can find them in the same place. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** The shared scope stacks hashtable. Each key maps to a stack of values.
|
||||
Used by aser for spread/provide/emit patterns, CSSX collect/flush, etc. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Request cookies — set by the Python bridge before each render.
|
||||
get-cookie reads from here; set-cookie is a no-op on the server. *)
|
||||
let request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Clear all scope stacks. Called between requests if needed. *)
|
||||
let clear_all () = Hashtbl.clear scope_stacks
|
||||
|
||||
let () =
|
||||
let register = Sx_primitives.register in
|
||||
|
||||
(* --- Cookies --- *)
|
||||
|
||||
register "get-cookie" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
(match Hashtbl.find_opt request_cookies name with
|
||||
| Some v -> String v
|
||||
| None -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
register "set-cookie" (fun _args -> Nil);
|
||||
|
||||
(* --- Core scope stack operations --- *)
|
||||
|
||||
register "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (value :: stack); Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "scope-peek" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with v :: _ -> v | [] -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Context (scope lookup with optional default) --- *)
|
||||
|
||||
register "context" (fun args ->
|
||||
match args with
|
||||
| [String name] | [String name; _] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack, args with
|
||||
| v :: _, _ -> v
|
||||
| [], [_; default_val] -> default_val
|
||||
| [], _ -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Collect / collected / clear-collected! --- *)
|
||||
|
||||
register "collect!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
if not (List.mem value items) then
|
||||
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace scope_stacks name [List [value]]
|
||||
| _ :: _ -> ());
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "collected" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
|
||||
register "clear-collected!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| _ :: rest -> Hashtbl.replace scope_stacks name (List [] :: rest)
|
||||
| [] -> Hashtbl.replace scope_stacks name [List []]);
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Emit / emitted (for spread attrs in adapter-html.sx) --- *)
|
||||
|
||||
register "scope-emit!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
|
||||
| Nil :: rest ->
|
||||
Hashtbl.replace scope_stacks name (List [value] :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace scope_stacks name [List [value]]
|
||||
| _ :: _ -> ());
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "emit!" (fun args ->
|
||||
(* Alias for scope-emit! *)
|
||||
match Sx_primitives.get_primitive "scope-emit!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
register "emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
|
||||
register "scope-emitted" (fun args ->
|
||||
match Sx_primitives.get_primitive "emitted" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> List []);
|
||||
|
||||
register "scope-collected" (fun args ->
|
||||
match Sx_primitives.get_primitive "collected" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> List []);
|
||||
|
||||
register "scope-clear-collected!" (fun args ->
|
||||
match Sx_primitives.get_primitive "clear-collected!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
(* --- Provide aliases --- *)
|
||||
|
||||
register "provide-push!" (fun args ->
|
||||
match Sx_primitives.get_primitive "scope-push!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
register "provide-pop!" (fun args ->
|
||||
match Sx_primitives.get_primitive "scope-pop!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil)
|
||||
@@ -4,12 +4,38 @@
|
||||
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 and
|
||||
an optional parent link for scope-chain lookup. *)
|
||||
(** Lexical scope chain. Each frame holds a mutable binding table
|
||||
keyed by interned symbol IDs for fast lookup. *)
|
||||
type env = {
|
||||
bindings : (string, value) Hashtbl.t;
|
||||
bindings : (int, value) Hashtbl.t;
|
||||
parent : env option;
|
||||
}
|
||||
|
||||
@@ -30,6 +56,7 @@ and value =
|
||||
| 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
|
||||
@@ -40,6 +67,11 @@ and value =
|
||||
| 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. *)
|
||||
@@ -59,12 +91,12 @@ and cek_frame = {
|
||||
cf_env : value; (* environment — every frame has this *)
|
||||
cf_name : value; (* let/define/set/scope: binding name *)
|
||||
cf_body : value; (* when/let: body expr *)
|
||||
cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
|
||||
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 *)
|
||||
cf_results : value; (* map/filter/dict: accumulated results *)
|
||||
cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
|
||||
cf_extra2 : value; (* second extra: emitted, etc. *)
|
||||
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!]). *)
|
||||
@@ -85,6 +117,7 @@ and component = {
|
||||
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 *)
|
||||
}
|
||||
|
||||
@@ -94,6 +127,8 @@ and island = {
|
||||
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 = {
|
||||
@@ -110,6 +145,30 @@ and signal = {
|
||||
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
|
||||
@@ -119,9 +178,12 @@ and signal = {
|
||||
(** Compiled function body — bytecode + constant pool. *)
|
||||
and vm_code = {
|
||||
vc_arity : int;
|
||||
vc_rest_arity : int; (** -1 = no &rest; >= 0 = number of positional params before &rest *)
|
||||
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. *)
|
||||
@@ -138,18 +200,89 @@ and vm_closure = {
|
||||
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"))
|
||||
|
||||
(** Forward ref: evaluate a Lambda via CEK (supports perform/suspension).
|
||||
Set by sx_vm.ml to break the sx_runtime → sx_ref dependency cycle. *)
|
||||
let _cek_eval_lambda_ref : (value -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Failure "CEK eval lambda not initialized"))
|
||||
|
||||
|
||||
(** {1 Errors} *)
|
||||
|
||||
exception Eval_error of string
|
||||
exception Parse_error of string
|
||||
|
||||
(** Raised when a VmClosure hits OP_PERFORM inside a CEK evaluation.
|
||||
The CEK step loop catches this and creates a proper io-suspended state
|
||||
with the continuation preserved for resume. Defined here (not in sx_vm)
|
||||
to avoid a dependency cycle between sx_runtime and sx_vm. *)
|
||||
exception CekPerformRequest of value
|
||||
|
||||
(** Hook: resolve IO suspension inline in cek_run.
|
||||
When set, cek_run calls this instead of raising "IO suspension in non-IO context".
|
||||
The function receives the suspended state and returns the resolved value.
|
||||
Used by the HTTP server to handle perform (text-measure) during aser. *)
|
||||
let _cek_io_resolver : (value -> value -> value) option ref = ref None
|
||||
|
||||
(** Hook: handle CEK IO suspension in eval_expr (cek_run_iterative).
|
||||
When set, called with the suspended CEK state instead of raising
|
||||
"IO suspension in non-IO context". Used by the browser WASM kernel
|
||||
to convert CEK suspensions to VmSuspended for _driveAsync handling. *)
|
||||
let _cek_io_suspend_hook : (value -> value) option ref = ref None
|
||||
|
||||
(** Default VM globals for stub VMs created during IO suspension.
|
||||
Set by sx_browser.ml to _vm_globals so CEK resume can access platform functions. *)
|
||||
let _default_vm_globals : (string, value) Hashtbl.t ref = ref (Hashtbl.create 0)
|
||||
|
||||
(** Hook: convert VM suspension exceptions to CekPerformRequest.
|
||||
Set by sx_vm after it defines VmSuspended. Called by sx_runtime.sx_apply_cek. *)
|
||||
let _convert_vm_suspension : (exn -> unit) ref = ref (fun _ -> ())
|
||||
|
||||
(** Hook: convert VM suspension to a __vm_suspended marker dict.
|
||||
Returns Some(dict) for VmSuspended, None otherwise.
|
||||
The dict has keys: __vm_suspended, request, resume.
|
||||
Used by sx_apply_cek so continue_with_call can build a proper
|
||||
suspended CEK state with vm-resume-frame on the kont. *)
|
||||
let _vm_suspension_to_dict : (exn -> value option) ref = ref (fun _ -> None)
|
||||
|
||||
|
||||
(** {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} *)
|
||||
|
||||
@@ -159,37 +292,73 @@ let make_env () =
|
||||
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 name v; Nil
|
||||
Hashtbl.replace env.bindings (intern name) v;
|
||||
(match !_env_bind_hook with Some f -> f env name v | None -> ());
|
||||
Nil
|
||||
|
||||
let rec env_has env name =
|
||||
Hashtbl.mem env.bindings name ||
|
||||
match env.parent with Some p -> env_has p name | None -> false
|
||||
(* 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 rec env_get env name =
|
||||
match Hashtbl.find_opt env.bindings name with
|
||||
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 p name
|
||||
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
|
||||
| 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 rec env_set env name v =
|
||||
if Hashtbl.mem env.bindings name then
|
||||
(Hashtbl.replace env.bindings name v; Nil)
|
||||
else
|
||||
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 p name v
|
||||
| None -> Hashtbl.replace env.bindings name v; Nil
|
||||
| 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 and overlay are the same env (physical equality) or overlay
|
||||
is a descendant of base, just extend base — no copying needed.
|
||||
This prevents set! inside lambdas from modifying shadow copies. *)
|
||||
if base == overlay then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
(* Check if overlay is a descendant of base *)
|
||||
let rec is_descendant e depth =
|
||||
if depth > 100 then false
|
||||
else if e == base then true
|
||||
@@ -198,11 +367,9 @@ let env_merge base overlay =
|
||||
if is_descendant overlay 0 then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
(* General case: extend base, copy ONLY overlay bindings that don't
|
||||
exist anywhere in the base chain (avoids shadowing closure bindings). *)
|
||||
let e = { bindings = Hashtbl.create 16; parent = Some base } in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if not (env_has base k) then Hashtbl.replace e.bindings k v
|
||||
Hashtbl.iter (fun id v ->
|
||||
if not (env_has_id base id) then Hashtbl.replace e.bindings id v
|
||||
) overlay.bindings;
|
||||
e
|
||||
end
|
||||
@@ -211,9 +378,21 @@ let env_merge base overlay =
|
||||
|
||||
(** {1 Value extraction helpers} *)
|
||||
|
||||
(** Format a float safely — defuse [int_of_float] overflow on huge
|
||||
integer-valued floats, keep [%g] for fractions (unchanged). *)
|
||||
let format_number n =
|
||||
if Float.is_nan n then "nan"
|
||||
else if n = Float.infinity then "inf"
|
||||
else if n = Float.neg_infinity then "-inf"
|
||||
else if Float.is_integer n && Float.abs n < 1e16 then
|
||||
string_of_int (int_of_float n)
|
||||
else if Float.is_integer n then
|
||||
Printf.sprintf "%.17g" n
|
||||
else Printf.sprintf "%g" n
|
||||
|
||||
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
|
||||
| Number n -> format_number n
|
||||
| Bool true -> "true" | Bool false -> "false"
|
||||
| Nil -> "" | _ -> "<value>"
|
||||
|
||||
@@ -249,7 +428,7 @@ let make_component name params has_children body closure affinity =
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
c_compiled = None;
|
||||
c_file = None; c_compiled = None;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
@@ -259,6 +438,7 @@ let make_island name params has_children body closure =
|
||||
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 =
|
||||
@@ -293,6 +473,7 @@ let type_of = function
|
||||
| Macro _ -> "macro"
|
||||
| Thunk _ -> "thunk"
|
||||
| Continuation (_, _) -> "continuation"
|
||||
| CallccContinuation _ -> "continuation"
|
||||
| NativeFn _ -> "function"
|
||||
| Signal _ -> "signal"
|
||||
| RawHTML _ -> "raw-html"
|
||||
@@ -302,6 +483,11 @@ let type_of = function
|
||||
| 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
|
||||
@@ -314,8 +500,10 @@ let is_signal = function
|
||||
| Dict d -> Hashtbl.mem d "__signal"
|
||||
| _ -> false
|
||||
|
||||
let is_record = function Record _ -> true | _ -> false
|
||||
|
||||
let is_callable = function
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) | VmClosure _ -> true
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation _ | VmClosure _ -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
@@ -362,6 +550,19 @@ let component_name = function
|
||||
| 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)
|
||||
@@ -412,6 +613,144 @@ let thunk_env = function
|
||||
| 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
|
||||
@@ -438,9 +777,7 @@ 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
|
||||
| Number n -> format_number n
|
||||
| String s ->
|
||||
let buf = Buffer.create (String.length s + 2) in
|
||||
Buffer.add_char buf '"';
|
||||
@@ -473,12 +810,24 @@ let rec inspect = function
|
||||
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 chars>" (String.length s)
|
||||
| RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
|
||||
| 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)
|
||||
|
||||
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
749
hosts/ocaml/shared/static/wasm/sx-platform.js
Normal file
749
hosts/ocaml/shared/static/wasm/sx-platform.js
Normal file
@@ -0,0 +1,749 @@
|
||||
/**
|
||||
* 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];
|
||||
if (v === undefined) return null;
|
||||
// Functions can't cross the WASM boundary — return true as a truthy
|
||||
// sentinel so (host-get el "getAttribute") works as a guard.
|
||||
// Use host-call to actually invoke the method.
|
||||
if (typeof v === "function") return true;
|
||||
return 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]);
|
||||
}
|
||||
});
|
||||
|
||||
// IO suspension driver — resumes suspended callFn results (wait, fetch, etc.)
|
||||
if (!window._driveAsync) {
|
||||
window._driveAsync = function driveAsync(result) {
|
||||
if (!result || !result.suspended) return;
|
||||
var req = result.request;
|
||||
var items = req && (req.items || req);
|
||||
var op = items && items[0];
|
||||
var opName = typeof op === "string" ? op : (op && op.name) || String(op);
|
||||
var arg = items && items[1];
|
||||
if (opName === "io-sleep" || opName === "wait") {
|
||||
setTimeout(function() {
|
||||
try { driveAsync(result.resume(null)); } catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||
}, typeof arg === "number" ? arg : 0);
|
||||
} else if (opName === "io-fetch") {
|
||||
fetch(typeof arg === "string" ? arg : "").then(function(r) { return r.text(); }).then(function(t) {
|
||||
try { driveAsync(result.resume({ok: true, text: t})); } catch(e) { console.error("[sx] driveAsync:", e.message); }
|
||||
});
|
||||
} else if (opName === "io-navigate") {
|
||||
// navigation — don't resume
|
||||
} else {
|
||||
console.warn("[sx] unhandled IO:", opName);
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
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);
|
||||
var r = K.callFn(fn, a);
|
||||
if (window._driveAsync) window._driveAsync(r);
|
||||
return r;
|
||||
};
|
||||
}
|
||||
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 (bytecode first, fallback to source)
|
||||
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 + ")");
|
||||
});
|
||||
// Define resolveSuspense now that boot is complete and web stack is loaded.
|
||||
// Must happen AFTER boot — resolve-suspense needs dom-query, render-to-dom etc.
|
||||
Sx.resolveSuspense = function(id, sx) {
|
||||
try {
|
||||
K.eval('(resolve-suspense ' + JSON.stringify(id) + ' ' + JSON.stringify(sx) + ')');
|
||||
} catch (e) {
|
||||
console.error("[sx] resolveSuspense error for id=" + id, e);
|
||||
}
|
||||
};
|
||||
// Process any streaming suspense resolutions that arrived before boot
|
||||
if (globalThis.__sxPending && globalThis.__sxPending.length > 0) {
|
||||
for (var pi = 0; pi < globalThis.__sxPending.length; pi++) {
|
||||
try {
|
||||
Sx.resolveSuspense(globalThis.__sxPending[pi].id, globalThis.__sxPending[pi].sx);
|
||||
} catch(e) { console.error("[sx] pending resolve error:", e); }
|
||||
}
|
||||
globalThis.__sxPending = null;
|
||||
}
|
||||
// Set up direct resolution for future streaming chunks
|
||||
globalThis.__sxResolve = function(id, sx) { Sx.resolveSuspense(id, sx); };
|
||||
// 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);
|
||||
})();
|
||||
60695
hosts/ocaml/shared/static/wasm/sx_browser.bc.js
Normal file
60695
hosts/ocaml/shared/static/wasm/sx_browser.bc.js
Normal file
File diff suppressed because one or more lines are too long
1821
hosts/ocaml/shared/static/wasm/sx_browser.bc.wasm.js
Normal file
1821
hosts/ocaml/shared/static/wasm/sx_browser.bc.wasm.js
Normal file
File diff suppressed because it is too large
Load Diff
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
File diff suppressed because it is too large
Load Diff
@@ -19,6 +19,94 @@
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Stack / Constants
|
||||
|
||||
(define-library (sx bytecode)
|
||||
(export
|
||||
OP_CONST
|
||||
OP_NIL
|
||||
OP_TRUE
|
||||
OP_FALSE
|
||||
OP_POP
|
||||
OP_DUP
|
||||
OP_LOCAL_GET
|
||||
OP_LOCAL_SET
|
||||
OP_UPVALUE_GET
|
||||
OP_UPVALUE_SET
|
||||
OP_GLOBAL_GET
|
||||
OP_GLOBAL_SET
|
||||
OP_JUMP
|
||||
OP_JUMP_IF_FALSE
|
||||
OP_JUMP_IF_TRUE
|
||||
OP_CALL
|
||||
OP_TAIL_CALL
|
||||
OP_RETURN
|
||||
OP_CLOSURE
|
||||
OP_CALL_PRIM
|
||||
OP_APPLY
|
||||
OP_LIST
|
||||
OP_DICT
|
||||
OP_APPEND_BANG
|
||||
OP_ITER_INIT
|
||||
OP_ITER_NEXT
|
||||
OP_MAP_OPEN
|
||||
OP_MAP_APPEND
|
||||
OP_MAP_CLOSE
|
||||
OP_FILTER_TEST
|
||||
OP_HO_MAP
|
||||
OP_HO_FILTER
|
||||
OP_HO_REDUCE
|
||||
OP_HO_FOR_EACH
|
||||
OP_HO_SOME
|
||||
OP_HO_EVERY
|
||||
OP_SCOPE_PUSH
|
||||
OP_SCOPE_POP
|
||||
OP_PROVIDE_PUSH
|
||||
OP_PROVIDE_POP
|
||||
OP_CONTEXT
|
||||
OP_EMIT
|
||||
OP_EMITTED
|
||||
OP_RESET
|
||||
OP_SHIFT
|
||||
OP_DEFINE
|
||||
OP_DEFCOMP
|
||||
OP_DEFISLAND
|
||||
OP_DEFMACRO
|
||||
OP_EXPAND_MACRO
|
||||
OP_STR_CONCAT
|
||||
OP_STR_JOIN
|
||||
OP_SERIALIZE
|
||||
OP_ADD
|
||||
OP_SUB
|
||||
OP_MUL
|
||||
OP_DIV
|
||||
OP_EQ
|
||||
OP_LT
|
||||
OP_GT
|
||||
OP_NOT
|
||||
OP_LEN
|
||||
OP_FIRST
|
||||
OP_REST
|
||||
OP_NTH
|
||||
OP_CONS
|
||||
OP_NEG
|
||||
OP_INC
|
||||
OP_DEC
|
||||
OP_ASER_TAG
|
||||
OP_ASER_FRAG
|
||||
BYTECODE_MAGIC
|
||||
BYTECODE_VERSION
|
||||
CONST_NUMBER
|
||||
CONST_STRING
|
||||
CONST_BOOL
|
||||
CONST_NIL
|
||||
CONST_SYMBOL
|
||||
CONST_KEYWORD
|
||||
CONST_LIST
|
||||
CONST_DICT
|
||||
CONST_CODE
|
||||
opcode-name)
|
||||
(begin
|
||||
|
||||
(define OP_CONST 1) ;; u16 pool_idx — push constant
|
||||
(define OP_NIL 2) ;; push nil
|
||||
(define OP_TRUE 3) ;; push true
|
||||
@@ -161,3 +249,9 @@
|
||||
(= op 50) "RETURN" (= op 52) "CALL_PRIM"
|
||||
(= op 128) "DEFINE" (= op 144) "STR_CONCAT"
|
||||
:else (str "OP_" op))))
|
||||
|
||||
|
||||
)) ;; end define-library
|
||||
|
||||
;; Re-export to global namespace for backward compatibility
|
||||
(import (sx bytecode))
|
||||
|
||||
@@ -77,6 +77,12 @@
|
||||
;; 2. call/cc — call with current continuation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
(define-library (sx callcc)
|
||||
(export
|
||||
sf-callcc)
|
||||
(begin
|
||||
|
||||
(define sf-callcc
|
||||
(fn (args env)
|
||||
;; Single argument: a function to call with the current continuation.
|
||||
@@ -243,3 +249,9 @@
|
||||
;; dispatch in eval-list (same path as lambda calls).
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
)) ;; end define-library
|
||||
|
||||
;; Re-export to global namespace for backward compatibility
|
||||
(import (sx callcc))
|
||||
|
||||
1982
lib/compiler.sx
1982
lib/compiler.sx
File diff suppressed because it is too large
Load Diff
@@ -11,6 +11,17 @@
|
||||
;; localStorage or IPFS by providing their own store backend.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
(define-library (sx content)
|
||||
(export
|
||||
content-store
|
||||
content-hash
|
||||
content-put
|
||||
content-get
|
||||
freeze-to-cid
|
||||
thaw-from-cid)
|
||||
(begin
|
||||
|
||||
(define content-store (dict))
|
||||
|
||||
(define content-hash :effects []
|
||||
@@ -46,3 +57,9 @@
|
||||
(when sx-text
|
||||
(thaw-from-sx sx-text)
|
||||
true))))
|
||||
|
||||
|
||||
)) ;; end define-library
|
||||
|
||||
;; Re-export to global namespace for backward compatibility
|
||||
(import (sx content))
|
||||
|
||||
49
lib/erlang/parser-core.sx
Normal file
49
lib/erlang/parser-core.sx
Normal file
@@ -0,0 +1,49 @@
|
||||
;; Core parser helpers — shared by er-parse-expr and er-parse-module.
|
||||
;; Everything reads/mutates a parser state dict:
|
||||
;; {:toks TOKS :idx INDEX}
|
||||
|
||||
(define er-state-make (fn (toks) {:idx 0 :toks toks}))
|
||||
|
||||
(define
|
||||
er-peek
|
||||
(fn
|
||||
(st offset)
|
||||
(let
|
||||
((toks (get st :toks)) (idx (+ (get st :idx) offset)))
|
||||
(if (< idx (len toks)) (nth toks idx) (nth toks (- (len toks) 1))))))
|
||||
|
||||
(define er-cur (fn (st) (er-peek st 0)))
|
||||
|
||||
(define er-cur-type (fn (st) (get (er-cur st) :type)))
|
||||
(define er-cur-value (fn (st) (get (er-cur st) :value)))
|
||||
|
||||
(define er-advance! (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
|
||||
|
||||
(define er-at-eof? (fn (st) (= (er-cur-type st) "eof")))
|
||||
|
||||
(define
|
||||
er-is?
|
||||
(fn
|
||||
(st type value)
|
||||
(and
|
||||
(= (er-cur-type st) type)
|
||||
(or (= value nil) (= (er-cur-value st) value)))))
|
||||
|
||||
(define
|
||||
er-expect!
|
||||
(fn
|
||||
(st type value)
|
||||
(if
|
||||
(er-is? st type value)
|
||||
(let ((t (er-cur st))) (er-advance! st) t)
|
||||
(error
|
||||
(str
|
||||
"Erlang parse: expected "
|
||||
type
|
||||
(if value (str " '" value "'") "")
|
||||
" but got "
|
||||
(er-cur-type st)
|
||||
" '"
|
||||
(er-cur-value st)
|
||||
"' at pos "
|
||||
(get (er-cur st) :pos))))))
|
||||
534
lib/erlang/parser-expr.sx
Normal file
534
lib/erlang/parser-expr.sx
Normal file
@@ -0,0 +1,534 @@
|
||||
;; Erlang expression parser — top-level fns operating on parser state.
|
||||
;; Depends on parser-core.sx (er-state-*, er-cur-*, er-is?, er-expect!)
|
||||
;; and parser.sx (er-is-binop?, er-any-binop?, er-build-cons, er-slice-list).
|
||||
|
||||
;; ── entry point ───────────────────────────────────────────────────
|
||||
(define
|
||||
er-parse-expr
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((st (er-state-make (er-tokenize src))))
|
||||
(er-parse-expr-prec st 0))))
|
||||
|
||||
;; Pratt-like operator-precedence parser.
|
||||
(define
|
||||
er-parse-expr-prec
|
||||
(fn
|
||||
(st min-prec)
|
||||
(let
|
||||
((left (er-parse-unary st)))
|
||||
(er-parse-expr-loop st min-prec left))))
|
||||
|
||||
(define
|
||||
er-parse-expr-loop
|
||||
(fn
|
||||
(st min-prec left)
|
||||
(if
|
||||
(er-any-binop? (er-cur st) min-prec)
|
||||
(let
|
||||
((tok (er-cur st)))
|
||||
(cond
|
||||
(er-is-binop? tok 0)
|
||||
(do (er-advance! st) (er-parse-expr-loop st min-prec {:rhs (er-parse-expr-prec st 0) :type "match" :lhs left}))
|
||||
(er-is-binop? tok 1)
|
||||
(do (er-advance! st) (er-parse-expr-loop st min-prec {:msg (er-parse-expr-prec st 1) :type "send" :to left}))
|
||||
(er-is-binop? tok 2)
|
||||
(let
|
||||
((op (get tok :value)))
|
||||
(er-advance! st)
|
||||
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 3)) :type "op" :op op}))
|
||||
(er-is-binop? tok 3)
|
||||
(let
|
||||
((op (get tok :value)))
|
||||
(er-advance! st)
|
||||
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 4)) :type "op" :op op}))
|
||||
(er-is-binop? tok 4)
|
||||
(let
|
||||
((op (get tok :value)))
|
||||
(er-advance! st)
|
||||
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 5)) :type "op" :op op}))
|
||||
(er-is-binop? tok 5)
|
||||
(let
|
||||
((op (get tok :value)))
|
||||
(er-advance! st)
|
||||
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 5)) :type "op" :op op}))
|
||||
(er-is-binop? tok 6)
|
||||
(let
|
||||
((op (get tok :value)))
|
||||
(er-advance! st)
|
||||
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 7)) :type "op" :op op}))
|
||||
(er-is-binop? tok 7)
|
||||
(let
|
||||
((op (get tok :value)))
|
||||
(er-advance! st)
|
||||
(er-parse-expr-loop st min-prec {:args (list left (er-parse-expr-prec st 8)) :type "op" :op op}))
|
||||
:else left))
|
||||
left)))
|
||||
|
||||
(define
|
||||
er-parse-unary
|
||||
(fn
|
||||
(st)
|
||||
(cond
|
||||
(er-is? st "op" "-")
|
||||
(do (er-advance! st) {:arg (er-parse-unary st) :type "unop" :op "-"})
|
||||
(er-is? st "op" "+")
|
||||
(do (er-advance! st) (er-parse-unary st))
|
||||
(er-is? st "keyword" "not")
|
||||
(do (er-advance! st) {:arg (er-parse-unary st) :type "unop" :op "not"})
|
||||
(er-is? st "keyword" "bnot")
|
||||
(do (er-advance! st) {:arg (er-parse-unary st) :type "unop" :op "bnot"})
|
||||
:else (er-parse-postfix st))))
|
||||
|
||||
(define
|
||||
er-parse-postfix
|
||||
(fn (st) (er-parse-postfix-loop st (er-parse-primary st))))
|
||||
|
||||
(define
|
||||
er-parse-postfix-loop
|
||||
(fn
|
||||
(st node)
|
||||
(cond
|
||||
(er-is? st "punct" ":")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(let
|
||||
((rhs (er-parse-primary st)))
|
||||
(er-parse-postfix-loop st {:fun rhs :mod node :type "remote"})))
|
||||
(er-is? st "punct" "(")
|
||||
(let
|
||||
((args (er-parse-call-args st)))
|
||||
(er-parse-postfix-loop st {:args args :fun node :type "call"}))
|
||||
:else node)))
|
||||
|
||||
(define
|
||||
er-parse-call-args
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "punct" "(")
|
||||
(if
|
||||
(er-is? st "punct" ")")
|
||||
(do (er-advance! st) (list))
|
||||
(let
|
||||
((args (list (er-parse-expr-prec st 0))))
|
||||
(er-parse-args-tail st args)))))
|
||||
|
||||
(define
|
||||
er-parse-args-tail
|
||||
(fn
|
||||
(st args)
|
||||
(cond
|
||||
(er-is? st "punct" ",")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! args (er-parse-expr-prec st 0))
|
||||
(er-parse-args-tail st args))
|
||||
(er-is? st "punct" ")")
|
||||
(do (er-advance! st) args)
|
||||
:else (error
|
||||
(str
|
||||
"Erlang parse: expected ',' or ')' in args, got '"
|
||||
(er-cur-value st)
|
||||
"'")))))
|
||||
|
||||
;; A body is: Expr {, Expr}
|
||||
(define
|
||||
er-parse-body
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((exprs (list (er-parse-expr-prec st 0))))
|
||||
(er-parse-body-tail st exprs))))
|
||||
|
||||
(define
|
||||
er-parse-body-tail
|
||||
(fn
|
||||
(st exprs)
|
||||
(if
|
||||
(er-is? st "punct" ",")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! exprs (er-parse-expr-prec st 0))
|
||||
(er-parse-body-tail st exprs))
|
||||
exprs)))
|
||||
|
||||
;; Guards: G1 ; G2 ; ... where each Gi is a guard-conj (T, T, ...)
|
||||
(define
|
||||
er-parse-guards
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((alts (list (er-parse-guard-conj st))))
|
||||
(er-parse-guards-tail st alts))))
|
||||
|
||||
(define
|
||||
er-parse-guards-tail
|
||||
(fn
|
||||
(st alts)
|
||||
(if
|
||||
(er-is? st "punct" ";")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! alts (er-parse-guard-conj st))
|
||||
(er-parse-guards-tail st alts))
|
||||
alts)))
|
||||
|
||||
(define
|
||||
er-parse-guard-conj
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((ts (list (er-parse-expr-prec st 0))))
|
||||
(er-parse-guard-conj-tail st ts))))
|
||||
|
||||
(define
|
||||
er-parse-guard-conj-tail
|
||||
(fn
|
||||
(st ts)
|
||||
(if
|
||||
(er-is? st "punct" ",")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! ts (er-parse-expr-prec st 0))
|
||||
(er-parse-guard-conj-tail st ts))
|
||||
ts)))
|
||||
|
||||
(define er-parse-pattern (fn (st) (er-parse-expr-prec st 0)))
|
||||
|
||||
;; ── primary expressions ──────────────────────────────────────────
|
||||
(define
|
||||
er-parse-primary
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((tok (er-cur st)))
|
||||
(cond
|
||||
(= (er-cur-type st) "integer")
|
||||
(do (er-advance! st) {:value (get tok :value) :type "integer"})
|
||||
(= (er-cur-type st) "float")
|
||||
(do (er-advance! st) {:value (get tok :value) :type "float"})
|
||||
(= (er-cur-type st) "string")
|
||||
(do (er-advance! st) {:value (get tok :value) :type "string"})
|
||||
(= (er-cur-type st) "atom")
|
||||
(do (er-advance! st) {:value (get tok :value) :type "atom"})
|
||||
(= (er-cur-type st) "var")
|
||||
(do (er-advance! st) {:type "var" :name (get tok :value)})
|
||||
(er-is? st "punct" "(")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(let
|
||||
((e (er-parse-expr-prec st 0)))
|
||||
(er-expect! st "punct" ")")
|
||||
e))
|
||||
(er-is? st "punct" "{")
|
||||
(er-parse-tuple st)
|
||||
(er-is? st "punct" "[")
|
||||
(er-parse-list st)
|
||||
(er-is? st "keyword" "if")
|
||||
(er-parse-if st)
|
||||
(er-is? st "keyword" "case")
|
||||
(er-parse-case st)
|
||||
(er-is? st "keyword" "receive")
|
||||
(er-parse-receive st)
|
||||
(er-is? st "keyword" "begin")
|
||||
(er-parse-begin st)
|
||||
(er-is? st "keyword" "fun")
|
||||
(er-parse-fun-expr st)
|
||||
(er-is? st "keyword" "try")
|
||||
(er-parse-try st)
|
||||
:else (error
|
||||
(str
|
||||
"Erlang parse: unexpected "
|
||||
(er-cur-type st)
|
||||
" '"
|
||||
(get tok :value)
|
||||
"' at pos "
|
||||
(get tok :pos)))))))
|
||||
|
||||
(define
|
||||
er-parse-tuple
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "punct" "{")
|
||||
(if
|
||||
(er-is? st "punct" "}")
|
||||
(do (er-advance! st) {:elements (list) :type "tuple"})
|
||||
(let
|
||||
((elems (list (er-parse-expr-prec st 0))))
|
||||
(er-parse-tuple-tail st elems)))))
|
||||
|
||||
(define
|
||||
er-parse-tuple-tail
|
||||
(fn
|
||||
(st elems)
|
||||
(cond
|
||||
(er-is? st "punct" ",")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! elems (er-parse-expr-prec st 0))
|
||||
(er-parse-tuple-tail st elems))
|
||||
(er-is? st "punct" "}")
|
||||
(do (er-advance! st) {:elements elems :type "tuple"})
|
||||
:else (error
|
||||
(str
|
||||
"Erlang parse: expected ',' or '}' in tuple, got '"
|
||||
(er-cur-value st)
|
||||
"'")))))
|
||||
|
||||
(define
|
||||
er-parse-list
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "punct" "[")
|
||||
(if
|
||||
(er-is? st "punct" "]")
|
||||
(do (er-advance! st) {:type "nil"})
|
||||
(let
|
||||
((elems (list (er-parse-expr-prec st 0))))
|
||||
(er-parse-list-tail st elems)))))
|
||||
|
||||
(define
|
||||
er-parse-list-tail
|
||||
(fn
|
||||
(st elems)
|
||||
(cond
|
||||
(er-is? st "punct" ",")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! elems (er-parse-expr-prec st 0))
|
||||
(er-parse-list-tail st elems))
|
||||
(er-is? st "punct" "|")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(let
|
||||
((tail (er-parse-expr-prec st 0)))
|
||||
(er-expect! st "punct" "]")
|
||||
(er-build-cons elems tail)))
|
||||
(er-is? st "punct" "]")
|
||||
(do (er-advance! st) (er-build-cons elems {:type "nil"}))
|
||||
:else (error
|
||||
(str
|
||||
"Erlang parse: expected ',' '|' or ']' in list, got '"
|
||||
(er-cur-value st)
|
||||
"'")))))
|
||||
|
||||
;; ── if ──────────────────────────────────────────────────────────
|
||||
(define
|
||||
er-parse-if
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "keyword" "if")
|
||||
(let
|
||||
((clauses (list (er-parse-if-clause st))))
|
||||
(er-parse-if-tail st clauses))))
|
||||
|
||||
(define
|
||||
er-parse-if-tail
|
||||
(fn
|
||||
(st clauses)
|
||||
(if
|
||||
(er-is? st "punct" ";")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! clauses (er-parse-if-clause st))
|
||||
(er-parse-if-tail st clauses))
|
||||
(do (er-expect! st "keyword" "end") {:clauses clauses :type "if"}))))
|
||||
|
||||
(define
|
||||
er-parse-if-clause
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((guards (er-parse-guards st)))
|
||||
(er-expect! st "punct" "->")
|
||||
(let ((body (er-parse-body st))) {:body body :guards guards}))))
|
||||
|
||||
;; ── case ────────────────────────────────────────────────────────
|
||||
(define
|
||||
er-parse-case
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "keyword" "case")
|
||||
(let
|
||||
((e (er-parse-expr-prec st 0)))
|
||||
(er-expect! st "keyword" "of")
|
||||
(let
|
||||
((clauses (list (er-parse-case-clause st))))
|
||||
(er-parse-case-tail st e clauses)))))
|
||||
|
||||
(define
|
||||
er-parse-case-tail
|
||||
(fn
|
||||
(st e clauses)
|
||||
(if
|
||||
(er-is? st "punct" ";")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! clauses (er-parse-case-clause st))
|
||||
(er-parse-case-tail st e clauses))
|
||||
(do (er-expect! st "keyword" "end") {:expr e :clauses clauses :type "case"}))))
|
||||
|
||||
(define
|
||||
er-parse-case-clause
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((pat (er-parse-pattern st)))
|
||||
(let
|
||||
((guards (if (er-is? st "keyword" "when") (do (er-advance! st) (er-parse-guards st)) (list))))
|
||||
(er-expect! st "punct" "->")
|
||||
(let ((body (er-parse-body st))) {:pattern pat :body body :guards guards})))))
|
||||
|
||||
;; ── receive ─────────────────────────────────────────────────────
|
||||
(define
|
||||
er-parse-receive
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "keyword" "receive")
|
||||
(let
|
||||
((clauses (if (er-is? st "keyword" "after") (list) (list (er-parse-case-clause st)))))
|
||||
(er-parse-receive-clauses st clauses))))
|
||||
|
||||
(define
|
||||
er-parse-receive-clauses
|
||||
(fn
|
||||
(st clauses)
|
||||
(cond
|
||||
(er-is? st "punct" ";")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! clauses (er-parse-case-clause st))
|
||||
(er-parse-receive-clauses st clauses))
|
||||
(er-is? st "keyword" "after")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(let
|
||||
((after-ms (er-parse-expr-prec st 0)))
|
||||
(er-expect! st "punct" "->")
|
||||
(let
|
||||
((after-body (er-parse-body st)))
|
||||
(er-expect! st "keyword" "end")
|
||||
{:clauses clauses :type "receive" :after-ms after-ms :after-body after-body})))
|
||||
:else (do (er-expect! st "keyword" "end") {:clauses clauses :type "receive" :after-ms nil :after-body (list)}))))
|
||||
|
||||
(define
|
||||
er-parse-begin
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "keyword" "begin")
|
||||
(let
|
||||
((exprs (er-parse-body st)))
|
||||
(er-expect! st "keyword" "end")
|
||||
{:exprs exprs :type "block"})))
|
||||
|
||||
(define
|
||||
er-parse-fun-expr
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "keyword" "fun")
|
||||
(cond
|
||||
(er-is? st "punct" "(")
|
||||
(let
|
||||
((clauses (list (er-parse-fun-clause st nil))))
|
||||
(er-parse-fun-expr-tail st clauses))
|
||||
:else (error "Erlang parse: fun-ref syntax not yet supported"))))
|
||||
|
||||
(define
|
||||
er-parse-fun-expr-tail
|
||||
(fn
|
||||
(st clauses)
|
||||
(if
|
||||
(er-is? st "punct" ";")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! clauses (er-parse-fun-clause st nil))
|
||||
(er-parse-fun-expr-tail st clauses))
|
||||
(do (er-expect! st "keyword" "end") {:clauses clauses :type "fun"}))))
|
||||
|
||||
(define
|
||||
er-parse-fun-clause
|
||||
(fn
|
||||
(st named-name)
|
||||
(er-expect! st "punct" "(")
|
||||
(let
|
||||
((patterns (if (er-is? st "punct" ")") (list) (er-parse-pattern-list st (list (er-parse-pattern st))))))
|
||||
(er-expect! st "punct" ")")
|
||||
(let
|
||||
((guards (if (er-is? st "keyword" "when") (do (er-advance! st) (er-parse-guards st)) (list))))
|
||||
(er-expect! st "punct" "->")
|
||||
(let ((body (er-parse-body st))) {:patterns patterns :body body :guards guards :name named-name})))))
|
||||
|
||||
(define
|
||||
er-parse-pattern-list
|
||||
(fn
|
||||
(st pats)
|
||||
(if
|
||||
(er-is? st "punct" ",")
|
||||
(do
|
||||
(er-advance! st)
|
||||
(append! pats (er-parse-pattern st))
|
||||
(er-parse-pattern-list st pats))
|
||||
pats)))
|
||||
|
||||
;; ── try ─────────────────────────────────────────────────────────
|
||||
(define
|
||||
er-parse-try
|
||||
(fn
|
||||
(st)
|
||||
(er-expect! st "keyword" "try")
|
||||
(let
|
||||
((exprs (er-parse-body st))
|
||||
(of-clauses (list))
|
||||
(catch-clauses (list))
|
||||
(after-body (list)))
|
||||
(when
|
||||
(er-is? st "keyword" "of")
|
||||
(er-advance! st)
|
||||
(append! of-clauses (er-parse-case-clause st))
|
||||
(er-parse-try-of-tail st of-clauses))
|
||||
(when
|
||||
(er-is? st "keyword" "catch")
|
||||
(er-advance! st)
|
||||
(append! catch-clauses (er-parse-catch-clause st))
|
||||
(er-parse-try-catch-tail st catch-clauses))
|
||||
(when
|
||||
(er-is? st "keyword" "after")
|
||||
(er-advance! st)
|
||||
(set! after-body (er-parse-body st)))
|
||||
(er-expect! st "keyword" "end")
|
||||
{:exprs exprs :catch-clauses catch-clauses :type "try" :of-clauses of-clauses :after after-body})))
|
||||
|
||||
(define
|
||||
er-parse-try-of-tail
|
||||
(fn
|
||||
(st clauses)
|
||||
(when
|
||||
(er-is? st "punct" ";")
|
||||
(er-advance! st)
|
||||
(append! clauses (er-parse-case-clause st))
|
||||
(er-parse-try-of-tail st clauses))))
|
||||
|
||||
(define
|
||||
er-parse-try-catch-tail
|
||||
(fn
|
||||
(st clauses)
|
||||
(when
|
||||
(er-is? st "punct" ";")
|
||||
(er-advance! st)
|
||||
(append! clauses (er-parse-catch-clause st))
|
||||
(er-parse-try-catch-tail st clauses))))
|
||||
|
||||
(define
|
||||
er-parse-catch-clause
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((p1 (er-parse-pattern st)))
|
||||
(let
|
||||
((klass (if (= (get p1 :type) "remote") (get p1 :mod) {:value "throw" :type "atom"}))
|
||||
(pat (if (= (get p1 :type) "remote") (get p1 :fun) p1)))
|
||||
(let
|
||||
((guards (if (er-is? st "keyword" "when") (do (er-advance! st) (er-parse-guards st)) (list))))
|
||||
(er-expect! st "punct" "->")
|
||||
(let ((body (er-parse-body st))) {:pattern pat :body body :class klass :guards guards}))))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user