[
{
"path": ".dockerignore",
"content": "**/_build\n**/_opam\n**/_opam_*\n_opam*\nnode_modules/\n**/node_modules/\ncompare/\n**/.merlin\n*.install\n.git/\n\nREADME.md\nCHANGELOG.md\nbenchmark/\narch/\n.github/\n"
},
{
"path": ".gitattributes",
"content": "*.re linguist-language=Reason\n*.rei linguist-language=Reason\n\n*.ml linguist-language=OCaml\n*.mli linguist-language=OCaml\n*.mll linguist-language=OCaml\n*.mly linguist-language=OCaml\n"
},
{
"path": ".githooks/pre-push",
"content": "#!/bin/bash\n\nif ! ( make format-check ); then\n echo \"some files are not properly formatted, refusing to push\"\n exit 1\nfi\n"
},
{
"path": ".github/FUNDING.yml",
"content": "# These are supported funding model platforms\n\ngithub: davesnx jchavarri\n"
},
{
"path": ".github/workflows/benchmark.yml",
"content": "name: Framework Comparison\n\non:\n push:\n tags:\n - 'v*'\n workflow_dispatch:\n inputs:\n frameworks:\n description: 'Frameworks to test (comma-separated, or \"all\")'\n required: false\n default: 'all'\n scenarios:\n description: 'Scenarios to run (comma-separated, or \"all\")'\n required: false\n default: 'trivial,table100,table500'\n\njobs:\n benchmark-frameworks:\n name: Compare Frameworks\n runs-on: ubuntu-latest\n\n steps:\n - uses: actions/checkout@v4\n\n - name: Setup OCaml\n uses: ocaml/setup-ocaml@v3\n with:\n ocaml-compiler: 5.2.x\n dune-cache: true\n\n - name: Setup Node.js\n uses: actions/setup-node@v4\n with:\n node-version: '20'\n\n - name: Setup Bun\n uses: oven-sh/setup-bun@v1\n\n - name: Install wrk\n run: |\n sudo apt-get update\n sudo apt-get install -y wrk\n\n - name: Install OCaml dependencies\n run: opam install . --deps-only -y\n\n - name: Build native server\n run: opam exec -- dune build benchmark/native/server.exe --profile=release\n\n - name: Install JS framework dependencies\n working-directory: benchmark/frameworks\n run: npm install\n\n - name: Install runner dependencies\n working-directory: benchmark/runner\n run: npm install\n\n - name: Start native server\n run: |\n opam exec -- _build/default/benchmark/native/server.exe &\n sleep 2\n\n - name: Run framework comparison\n working-directory: benchmark/runner\n run: |\n FRAMEWORKS=\"${{ github.event.inputs.frameworks || 'all' }}\"\n SCENARIOS=\"${{ github.event.inputs.scenarios || 'trivial,table100,table500' }}\"\n\n ARGS=\"\"\n if [ \"$FRAMEWORKS\" != \"all\" ]; then\n ARGS=\"$ARGS --frameworks $FRAMEWORKS\"\n fi\n if [ \"$SCENARIOS\" != \"all\" ]; then\n ARGS=\"$ARGS --scenarios $SCENARIOS\"\n fi\n\n node runner.mjs $ARGS\n\n - name: Upload results\n uses: actions/upload-artifact@v4\n with:\n name: framework-comparison-${{ github.sha }}\n path: benchmark/runner/results/\n retention-days: 90\n\n - name: Add results to summary\n run: |\n echo \"## Framework Comparison Results\" >> $GITHUB_STEP_SUMMARY\n echo \"\" >> $GITHUB_STEP_SUMMARY\n LATEST=$(ls -t benchmark/runner/results/*.md 2>/dev/null | head -1)\n if [ -n \"$LATEST\" ]; then\n cat \"$LATEST\" >> $GITHUB_STEP_SUMMARY\n else\n echo \"No results generated\" >> $GITHUB_STEP_SUMMARY\n fi\n\n"
},
{
"path": ".github/workflows/ci.yml",
"content": "name: CI\n\non:\n push:\n branches:\n - main\n tags:\n - '*'\n pull_request:\n branches:\n - main\n\nenv:\n DUNE_PROFILE: release\n OCAMLRUNPARAM: b\n\npermissions:\n contents: write\n\nconcurrency:\n group: ci-${{ github.ref }}\n cancel-in-progress: ${{ github.event_name == 'pull_request' }}\n\ndefaults:\n run:\n shell: bash -xeuo pipefail {0}\n\njobs:\n build:\n name: Build and test\n\n runs-on: ${{ matrix.os }}\n\n strategy:\n fail-fast: false\n matrix:\n os:\n - macos-latest\n - ubuntu-latest\n # - windows-latest\n ocaml-compiler:\n - 4.14.1\n - 5.4.0\n\n steps:\n - uses: actions/checkout@v4\n\n - name: Use OCaml ${{ matrix.ocaml-compiler }}\n uses: ocaml/setup-ocaml@v3.4.5\n with:\n ocaml-compiler: ${{ matrix.ocaml-compiler }}\n dune-cache: false\n opam-disable-sandboxing: true\n\n - name: Use Node.js\n uses: actions/setup-node@v4\n with:\n node-version: '20'\n\n - name: Install opam deps\n run: make install\n\n - name: Install npm deps\n run: make install-npm\n\n - name: Pin dependencies\n run: make pin\n\n - name: Build\n run: make build\n\n - name: Check formatting\n if: matrix.ocaml-compiler != '4.14.1'\n run: make format-check\n\n - name: Run tests\n run: make test\n\n - name: Generate docs\n if: github.ref == 'refs/heads/main' && matrix.os == 'ubuntu-latest' && matrix.ocaml-compiler == '5.4.0'\n run: |\n opam install -y odoc-driver\n make docs\n\n - name: Upload docs artifact\n if: github.ref == 'refs/heads/main' && matrix.os == 'ubuntu-latest' && matrix.ocaml-compiler == '5.4.0'\n uses: actions/upload-artifact@v4\n with:\n name: documentation\n path: _html\n retention-days: 1\n\n - name: Run benchmarks\n run: make bench\n\n - name: Run benchmarks as JSON\n if: matrix.os == 'ubuntu-latest' && matrix.ocaml-compiler == '5.4.0'\n run: make bench-json\n\n - name: Store benchmark result\n if: matrix.os == 'ubuntu-latest' && matrix.ocaml-compiler == '5.4.0'\n uses: benchmark-action/github-action-benchmark@v1\n with:\n name: server-reason-react Benchmarks\n tool: 'customBiggerIsBetter'\n output-file-path: bench_results.json\n github-token: ${{ secrets.GITHUB_TOKEN }}\n auto-push: ${{ github.ref == 'refs/heads/main' }}\n gh-pages-branch: gh-pages\n benchmark-data-dir-path: dev/bench\n comment-always: true\n fail-on-alert: true\n comment-on-alert: true\n alert-comment-cc-users: '@davesnx'\n\n - name: Install dune-release\n if: startsWith(github.ref, 'refs/tags/') && matrix.os == 'ubuntu-latest' && matrix.ocaml-compiler == '5.4.0'\n run: opam install dune-release -y\n\n - name: Release\n uses: davesnx/dune-release-action@v0.2.14\n if: startsWith(github.ref, 'refs/tags/') && matrix.os == 'ubuntu-latest' && matrix.ocaml-compiler == '5.4.0'\n with:\n packages: 'server-reason-react'\n changelog: './CHANGES.md'\n github-token: ${{ secrets.GH_TOKEN }}\n\n publish-docs:\n name: Publish documentation\n needs: build\n if: github.ref == 'refs/heads/main'\n runs-on: ubuntu-latest\n\n environment:\n name: github-pages\n url: https://ml-in-barcelona.github.io/server-reason-react\n\n permissions:\n contents: write\n pages: write\n id-token: write\n\n steps:\n - uses: actions/checkout@v4\n\n - name: Download docs artifact\n uses: actions/download-artifact@v4\n with:\n name: documentation\n path: _html\n\n - name: Publish to GitHub Pages\n uses: crazy-max/ghaction-github-pages@v1\n with:\n target_branch: gh-pages\n build_dir: _html\n env:\n GITHUB_TOKEN: ${{ github.token }}\n"
},
{
"path": ".github/workflows/docker.yml",
"content": "name: Docker\n\non:\n push:\n branches:\n - main\n pull_request:\n branches:\n - main\n\nconcurrency:\n group: docker-${{ github.ref }}\n cancel-in-progress: ${{ github.event_name == 'pull_request' }}\n\njobs:\n build:\n name: Build Docker image\n runs-on: ubuntu-latest\n\n steps:\n - uses: actions/checkout@v4\n\n - name: Set up Docker Buildx\n uses: docker/setup-buildx-action@v3\n\n - name: Build Docker image\n uses: docker/build-push-action@v6\n with:\n context: .\n push: false\n tags: server-reason-react:${{ github.sha }}\n cache-from: type=gha\n cache-to: type=gha,mode=max\n"
},
{
"path": ".gitignore",
"content": "### OS ###\n.DS_Store\n\n### Node ###\n# Logs\nlogs\n*.log\nnpm-debug.log*\nyarn-debug.log*\nyarn-error.log*\n\n# Runtime data\npids\n*.pid\n*.seed\n*.pid.lock\n\n# Dependency directories\nnode_modules/\n\n# Build\n**/dist/\n\n# Optional npm cache directory\n.npm\n\n# Output of 'npm pack'\n*.tgz\n\n# Yarn Integrity file\n.yarn-integrity\n\n# dotenv environment variables file\n.env\n\n*.annot\n*.cmo\n*.cma\n*.cmi\n*.a\n*.o\n*.cmx\n*.cmxs\n*.cmxa\n\n# dune working directory\n_build/\n\n# odoc (odoc-driver) html artifacts\n_html/\n\n# ocamlbuild targets\n*.byte\n*.native\n\n# Merlin configuring file for Vim and Emacs\n.merlin\n\n# Dune generated files\n*.install\n\n# Local OPAM switch\n_opam/\n\n# vscode\n.vscode\n\n*.dump\n_build\n_opam\n_esy\n.bsb.lock\n.merlin\n\n.direnv/\ndemo/.running/*\n"
},
{
"path": ".ocamlformat",
"content": "profile=default\nmargin=120\nversion=0.28.1\n"
},
{
"path": "CHANGES.md",
"content": "# Changes\n\n## 0.5.0\n\n* Support Promise caching in react.client.components by @davesnx\n* Reorder head content exactly like react-dom/server by @davesnx\n* Implement hydration-compatible `useId` using React's tree-position-based algorithm, matching React 19 output. Adds `?identifier_prefix` to `renderToString`, `renderToStaticMarkup`, `renderToStream` and `render_html`. Fixes https://github.com/ml-in-barcelona/server-reason-react/issues/93\n* Fix `renderToString` rendering Suspense children twice (once as trial, once with markers) due to side-effectful match expression. Children are now rendered into a separate buffer\n* Change shape for React.Event.* since Js.t is now supported. All methods fail at runtime with `Runtime.fail_impossible_action_in_ssr`\n* [server-reason-react.ppx] Strip units at any position (supporting mlx difference with [@JSX] transformations)\n* Add runtime error with clear message when `React.cloneElement` is used with uppercase components by @davesnx\n* Allow `[@platform js]` and `[@browser_only]` on externals to conditionally exclude them from native builds. Fixes https://github.com/ml-in-barcelona/server-reason-react/issues/170 by @davesnx\n* Generate `makeProps` in the PPX by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/364\n* Implement `Js.t` natively with `Js.Internal` and a type registry by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/363\n* Add `React.useActionState` by @davesnx\n* Add `key` into client components by @davesnx\n* Fix several functions in Belt to match specification (`Belt.Array.setExn`, `Belt.Array.concat`, `Belt.MutableMap.remove`, `Belt.HashMap.keepMapInPlace`, and avoid double callback evaluation) by @yasunariw in https://github.com/ml-in-barcelona/server-reason-react/pull/362\n* Implement `Belt.Array.getUndefined` and annotate `Belt.Array.push` as not implemented by @davesnx\n* Remove deprecated folder from Belt and reorganise Belt tests by @davesnx\n* Fix leaking `was_previous` when node was closing by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/361\n* Fix `React.cloneElement` on `Static {}` components by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/359\n* Require ppxlib >= 0.36 by @davesnx\n\n## 0.4.1\n\n* Use OCaml 5.4.0 by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/335\n* Use latest ppxlib by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/334\n* Update to latest quickjs by @davesnx\n* Update dependency and usage by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/333\n* Add filter to esbuild plugin to scope entrypoint by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/330\n* Add back and forward navigation to nested router by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/329\n* Implement memo and memoCustomCompareProps by @davesnx\n* Move Date, BigInt and modularise Js by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/327\n* Create complex navigation at RSC demo by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/307\n\n## 0.4.0\n\n* Add upper bound to quickjs 0.2.0\n* Bump lwt to 5.9.2\n* Expand styles prop into className and style props with optional handling by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/324\n* Lowercase components have ?key:string by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/323\n* Wrap client value on React.Upper_case_component by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/322\n* Fix remove last element on nested_modules by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/321\n* Add searchParams function to native URL by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/320\n* Add URL construct function and improve lib build by @EmileTrotignon in https://github.com/ml-in-barcelona/server-reason-react/pull/317\n* Specify model values at React by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/309\n* Allow async in client props by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/315\n* Improve the Fiber and Model stream context by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/312\n* Align Suspense with reason-react by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/311\n* Make client component to execute in runtime by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/306\n* Fix mismatch of the model and html on render_html by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/305\n* Fix createFromFetch interface and avoid transition on navigation by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/299\n* Change ppx execution order (styles expansion in server-reason-react) by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/297\n* Rename use function to usePromise in Experimental module by @pedrobslisboa in https://github.com/ml-in-barcelona/server-reason-react/pull/298\n* Add shared-folder-prefix arg to ppx by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/294\n\n## 0.3.1\n\n* Update quickjs dependency to 0.1.2 by @davesnx\n\n## 0.3.0\n\n* browser-ppx: process stritems by @jchavarri in https://github.com/ml-in-barcelona/server-reason-react/pull/127\n* Make React.Children.* APIs work as expected by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/130\n* Improve global crashes by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/132\n* Support assets in `mel.module` by @jchavarri in https://github.com/ml-in-barcelona/server-reason-react/pull/134\n* browser_only: don't convert to runtime errors on identifiers or function application by @jchavarri in https://github.com/ml-in-barcelona/server-reason-react/pull/138\n* Port `j` quoted strings interpolation from Melange by @jchavarri in https://github.com/ml-in-barcelona/server-reason-react/pull/139\n* mel.module: handle asset prefix by @jchavarri in https://github.com/ml-in-barcelona/server-reason-react/pull/140\n* Add browser_only transformation to useEffect automatically by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/145\n* Append doctype tag on html lowercase by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/136\n* Transform Pexp_function with browser_only by @davesnx in https://github.com/ml-in-barcelona/server-reason-react/pull/146\n\n## 0.2.0\n\n- Remove data-reactroot attr from ReactDOM.renderToString #129 by @pedrobslisboa\n- Make useUrl return the provided serverUrl #125 by @purefunctor\n- Replace Js.Re implemenation from `pcre` to quickjs b1a3e225cdad1298d705fbbd9618e15b0427ef0f by @davesnx\n- Remove Belt.Array.push #122 by @davesnx\n\n## 0.1.0\n\nInitial release of server-reason-react, includes:\n\n- Server-side rendering of ReasonReact components (renderToString, renderToStaticMarkup & renderToLwtStream)\n- `server-reason-react.browser_ppx` for skipping code from the server\n- `server-reason-react.melange_ppx` for enabling melange bindings and extensions which run on the server\n- `server-reason-react.belt` a native Belt implementation\n- `server-reason-react.js` a native Js implementation (unsafe and limited)\n- `server-reason-react.url` and `server-reason-react.url-native` a universal library with both implementations to work with URLs on the server and the client\n- `server-reason-react.promise` and `server-reason-react.promise-native` a universal library with both implementations to work with Promises on the server and the client. Based on https://github.com/aantron/promise\n- `server-reason-react.melange-fetch` a fork of melange-fetch which is a melange library to fetch data on the client via the Fetch API. This fork is to be able to compile it on the server (not running).\n- `server-reason-react.webapi` a fork of melange-webapi which is a melange library to work with the Web API on the client. This fork is to be able to compile it on the server (not running).\n"
},
{
"path": "Dockerfile",
"content": "FROM ocaml/opam:ubuntu-22.04-ocaml-5.4 AS builder\n\nRUN sudo apt-get update && sudo apt-get install -y --no-install-recommends curl git libev-dev libssl-dev && \\\n sudo apt-get remove -y nodejs npm && sudo apt-get autoremove -y\n\nRUN curl -fsSL https://deb.nodesource.com/setup_20.x | sudo -E bash - && \\\n sudo apt-get update && \\\n sudo apt-get install -y --no-install-recommends nodejs && \\\n sudo npm install -g npm@latest\n\nRUN sudo ln -sf /usr/bin/opam-2.5 /usr/bin/opam && opam init --reinit -n\n\nWORKDIR /app\n\nRUN opam remote set-url default https://opam.ocaml.org\nRUN cd ~/opam-repository && git fetch -q origin master && git reset --hard origin/master && opam update -y\n\nCOPY Makefile ./\nCOPY *.opam ./\nCOPY *.opam.template ./\nCOPY dune ./\nCOPY dune-project ./\n\nRUN make pin\nRUN opam update -y && opam install . --deps-only -y && opam install dream -y\n\nWORKDIR /app/demo\nCOPY demo/package.json ./package.json\nCOPY demo/package-lock.json ./package-lock.json\nRUN sudo npm ci --omit=dev\n\nWORKDIR /app/demo/client\nCOPY demo/client/package.json ./package.json\nCOPY demo/client/package-lock.json ./package-lock.json\nRUN sudo npm install\n\nWORKDIR /app\nCOPY . .\nRUN sudo chown -R opam:opam /app && opam exec -- dune build @demo --profile=dev\nRUN opam clean -a -c -s --logs && rm -rf /home/opam/opam-repository\n\nFROM ocaml/opam:ubuntu-22.04-ocaml-5.4\n\nRUN sudo apt-get update && sudo apt-get install -y --no-install-recommends libev4 libssl3 && \\\n sudo rm -rf /var/lib/apt/lists/*\n\nWORKDIR /app\n\nCOPY --from=builder --chown=opam:opam /home/opam/.opam /home/opam/.opam\nCOPY --from=builder --chown=opam:opam /app /app\n\nENV PATH=\"/home/opam/.opam/5.4/bin:${PATH}\"\n\nEXPOSE 8080\n\nCMD [\"opam\", \"exec\", \"--switch\", \"5.4\", \"--\", \"_build/default/demo/server/server.exe\"]\n"
},
{
"path": "LICENSE.md",
"content": "Copyright 2024 David Sancho & Javier Chavarri (ml-in-barcelona team)\n\nPermission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the \"Software\"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:\n\nThe above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\n"
},
{
"path": "Makefile",
"content": "project_name = server-reason-react\n\nDUNE = opam exec -- dune\nopam_file = $(project_name).opam\n\n.PHONY: help\nhelp: ## Print this help message\n\t@echo \"\";\n\t@echo \"List of available make commands\";\n\t@echo \"\";\n\t@grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = \":.*?## \"}; {printf \" \\033[36m%-15s\\033[0m %s\\n\", $$1, $$2}';\n\t@echo \"\";\n\n.PHONY: build\nbuild: ## Build the project, including non installable libraries and executables\n\t$(DUNE) build --profile=dev\n\n.PHONY: build-prod\nbuild-prod: ## Build for production (--profile=prod)\n\t$(DUNE) build --profile=prod\n\n.PHONY: dev\ndev: ## Build in watch mode\n\t$(DUNE) build -w --profile=dev\n\n.PHONY: clean\nclean: ## Clean artifacts\n\t$(DUNE) clean\n\n.PHONY: test\ntest: ## Run the unit tests\n\t$(DUNE) build @runtest\n\n.PHONY: test-watch\ntest-watch: ## Run the unit tests in watch mode\n\t$(DUNE) build @runtest -w\n\n.PHONY: test-promote\ntest-promote: ## Updates snapshots and promotes it to correct\n\t$(DUNE) build @runtest --auto-promote\n\n.PHONY: format\nformat: ## Format the codebase with ocamlformat\n\t@DUNE_CONFIG__GLOBAL_LOCK=disabled $(DUNE) build @fmt --auto-promote\n\n.PHONY: format-check\nformat-check: ## Checks if format is correct\n\t@DUNE_CONFIG__GLOBAL_LOCK=disabled $(DUNE) build @fmt\n\n.PHONY: init\nsetup-githooks: ## Setup githooks\n\tgit config core.hooksPath .githooks\n\n.PHONY: create-switch\ncreate-switch: ## Create opam switch\n\topam switch create . 5.4.0 --deps-only --with-test -y\n\n.PHONY: install\ninstall:\n\topam install . --deps-only --with-test --with-doc --with-dev-setup -y\n\n.PHONY: install-npm\ninstall-npm:\n\tcd packages/esbuild-plugin && npm install;\n\tcd packages/react-server-dom-esbuild && npm install;\n\tcd demo && npm install;\n\tcd demo/client && npm install\n\n.PHONY: pin\npin: ## Pin dependencies\n\techo \"No pins needed\"\n\n.PHONY: init\ninit: setup-githooks create-switch pin install install-npm ## Create a local dev enviroment\n\n.PHONY: ppx-test\nppx-test: ## Run ppx tests\n\t$(DUNE) runtest packages/server-reason-react-ppx\n\n.PHONY: ppx-test-watch\nppx-test-watch: ## Run ppx tests in watch mode\n\t$(DUNE) runtest packages/server-reason-react-ppx --watch\n\n.PHONY: ppx-test-promote\nppx-test-promote: ## Prommote ppx tests snapshots\n\t$(DUNE) runtest packages/server-reason-react-ppx --auto-promote\n\n.PHONY: lib-test\nlib-test: ## Run library tests\n\t$(DUNE) exec test/test.exe\n\n.PHONY: demo-build\ndemo-build: ## Build the project (client, server and universal)\n\t$(DUNE) build --profile=dev @demo\n\n.PHONY: demo-build-watch\ndemo-build-watch: ## Watch demo (client, server and universal)\n\t$(DUNE) build --profile=dev @demo --force --watch\n\n.PHONY: demo\ndemo-serve: demo-build ## Serve the demo executable\n\t@opam exec -- _build/default/demo/server/server.exe\n\n.PHONY: demo-serve-watch\ndemo-serve-watch: ## Run demo executable on watch mode (listening to built_at.txt changes)\n\t@watchexec --no-vcs-ignore -w demo/.running/built_at.txt -r -c -- \"_build/default/demo/server/server.exe\"\n\n.PHONY: subst\nsubst: ## Run dune substitute\n\t$(DUNE) subst\n\n.PHONY: docs\ndocs: ## Generate odoc documentation\n\t$(DUNE) build @install\n\t$(DUNE) exec -- odoc_driver server-reason-react --remap\n\n# Because if the hack above, we can't have watch mode\n.PHONY: docs-watch\ndocs-watch: ## Generate odoc docs\n\t$(DUNE) build --root . -w @doc-new --profile=prod\n\n.PHONY: docs-open\ndocs-open: ## Open odoc docs with default web browser\n# open _build/default/_doc_new/html/docs/local/server-reason-react/index.html\n\topen _html/server-reason-react/index.html\n\n.PHONY: docs-serve\ndocs-serve: docs docs-open ## Open odoc docs with default web browser\n\n.PHONY: build-bench\nbuild-bench: ## Build benchmark executables\n\t$(DUNE) build --profile=release benchmark/bench.exe\n\n.PHONY: bench\nbench: build-bench ## Run benchmarks\n\t@$(DUNE) exec benchmark/bench.exe --profile=release --display-separate-messages --no-print-directory\n\n.PHONY: bench-json\nbench-json: build-bench ## Run benchmarks with JSON output for CI\n\t@$(DUNE) exec benchmark/bench.exe --profile=release --display-separate-messages --no-print-directory -- --json > bench_results.json\n\n.PHONY: bench-watch\nbench-watch: build-bench ## Run benchmark in watch mode\n\t@$(DUNE) exec benchmark/bench.exe --profile=release --display-separate-messages --no-print-directory --watch\n\n.PHONY: bench-allocation\nbench-allocation: ## Run allocation analysis\n\t@$(DUNE) exec benchmark/allocation.exe --profile=release\n\ncontainer_name = server-reason-react-demo\ncurrent_hash = $(shell git rev-parse HEAD | cut -c1-7)\n\n.PHONY: docker-build\ndocker-build: ## docker build\n\tDOCKER_BUILDKIT=0 docker build . --tag \"$(container_name):$(current_hash)\" --platform linux/amd64\n\n.PHONY: docker-run\ndocker-run: ## docker run\n\t@docker run -d --platform linux/amd64 $(container_name):$(current_hash)\n"
},
{
"path": "README.md",
"content": "# server-reason-react\n\nNative implementation of React's server-side rendering (SSR) and React Server Components (RSC) architecture for Reason.\n\nDesigned to be used with [reason-react](https://github.com/reasonml/reason-react) and [Melange](https://github.com/melange-re/melange). Together it enables developers to write efficient React components using a single language, while target both native executable and JavaScript.\n\n## Features\n\n- **Server-side rendering HTML** with `ReactDOM.renderToString`/`ReactDOM.renderToStaticMarkup`\n- Server-side rendering **streaming HTML** with `ReactDOM.renderToStream` (similar to react@18 `renderToReadableStream`)\n- Includes **`React.Suspense`** and **`React.use()`** implementations\n- **server-reason-react-ppx** - A ppx transformation to support JSX on native\n- All [reason-react](https://reasonml.github.io/reason-react/) interface is either implemented or stubbed (some of the methods, like React.useState need to be stubbed because they aren't used on the server!)\n- **React Server Components** - A ReactServerDOM module for streaming RSC payload, an esbuild plugin to enhance the bundle with client-components mappings, a Dream middleware to serve the RSC endpoint and a dummy implementation of a router (still [work in progress](https://github.com/ml-in-barcelona/server-reason-react/issues/204))\n\n> Warning: This repo contains a few parts that are considered experimental and there's no guarantee of stability. Most of the stable parts are used in production at ahrefs.com, app.ahrefs.com and wordcount.com. Check each module's documentation for more details.\n\n## Why\n\nThere are plenty of motives for it, the main one is that [ahrefs](https://ahrefs.com) (the company I work for) needs it. We use OCaml for the backend and Reason (with React) for the frontend. We wanted to take advantage of the same features from React.js in the server as well.\n\nCurrently 100% of the public site ([ahrefs.com](https://ahrefs.com)), the shell part of the dashboard ([app.ahrefs.com](https://app.ahrefs.com)) and [wordcount.com](https://wordcount.com) are rendered on the server with `server-reason-react`.\n\nWhat made us create this library was mostly:\n\n- Use the same language (Reason) for both server and client\n- Embrace server-client integrations such as type-safe routing, JSON decoding/encoding, sharing types and logic, while keep enjoying functional programming patterns\n- Native performance is better than JavaScript performance (Node.js, Bun, Deno)\n- Writing React from a different language than JavaScript, but still using the brilliant pieces from the ecosystem\n- Exploration of OCaml effects and React\n- Further exploration with OCaml multicore, direct-style and concurrency with React features such as async components, React.use or Suspense\n\nExplained more about the motivation in [this blog post](https://sancho.dev/blog/server-side-rendering-react-in-ocaml) and also in my talk about [**Universal react in OCaml** at fun-ocaml 2024](https://www.youtube.com/watch?v=Oy3lZl2kE-0&t=92s&ab_channel=FUNOCaml) and [**Server side rendering React natively with Reason** at ReactAlicante 2023](https://www.youtube.com/watch?v=e3qY-Eg9zRY&ab_channel=ReactAlicante)\n\n## Other libraries inside this repo\n\nAside from the core (`React`, `ReactDOM` and `ReactServerDOM`), server-reason-react repo contains some common melange libraries to ensure components are universal. Some of them are reimplementations in native of those libraries, and others are new implementations. Currently they are part of the repository, but eventually will be moved out to their own opam packages and repositories.\n\n| Name | Description | Melange equivalent library |\n|---------|-------------|---------|\n| [`server-reason-react.browser_ppx`](https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_only.html) | A ppx to discard code for each platform with different attributes: `let%browser_only`, `switch%platform` and `@platform` |\n| [`server-reason-react.url_js` and `server-reason-react.url_native`](https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/server-reason-react.url_native/URL/index.html) | Universal URL module: binds to `window.URL` in browser, implemented with [`opam-uri`](https://github.com/mirage/ocaml-uri) in native |\n| [`server-reason-react.melange_ppx`](https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/externals-melange-attributes.html) | A ppx to add the melange attributes to native code | [melange.ppx](https://melange.re/v4.0.0/) |\n| `server-reason-react.promise` | Vendored version of [aantron/promise](https://github.com/aantron/promise) with melange support [PR#80](https://github.com/aantron/promise/pull/80) | [promise](https://github.com/aantron/promise) |\n| `server-reason-react.belt` | Implementation of Belt for native [API reference](https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/server-reason-react.belt_native/Belt/index.html) | [melange.belt](https://melange.re/v4.0.0/api/ml/melange/Belt) |\n| `server-reason-react.js` | Implementation of `Js` library for native (unsafe/incomplete). Check the issue [#110](https://github.com/ml-in-barcelona/server-reason-react/issues/110) for more details | [melange.js](https://melange.re/v4.0.0/api/ml/melange/Js) |\n| `server-reason-react.fetch` | Stub of fetch with browser_ppx to compile in native | [melange.fetch](https://github.com/melange-community/melange-fetch) |\n| `server-reason-react.webapi` | Stub version of Webapi library for native code compilation | [melange-webapi](https://github.com/melange-community/melange-webapi) |\n| `server-reason-react.dom` | Stub version of Dom library for native code compilation | [melange-dom](https://melange.re/v4.0.0/) |\n\n## [Documentation](https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/index.html)\n\nThe [documentation site](https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/index.html) is generated with odoc and hosted on GitHub Pages.\n\n## Demo\n\nThe `demo` folder contains a bunch of demos under a server to showcases the usages of `server-reason-react`. Check the [README](demo/README.md) for how to setup and run it.\n\n## Want to contribute?\n\n[DM me](https://x.com/davesnx)\n"
},
{
"path": "arch/browser/.gitignore",
"content": "# See https://help.github.com/articles/ignoring-files/ for more about ignoring files.\n\n# dependencies\n/node_modules\n/.pnp\n.pnp.js\n\n# testing\n/coverage\n\n# production\n/build\n\n# misc\n.DS_Store\n.env.local\n.env.development.local\n.env.test.local\n.env.production.local\n\nnpm-debug.log*\nyarn-debug.log*\nyarn-error.log*\n"
},
{
"path": "arch/browser/package.json",
"content": "{\n \"name\": \"cra\",\n \"version\": \"0.1.0\",\n \"private\": true,\n \"dependencies\": {\n \"@testing-library/dom\": \"^10.4.1\",\n \"@testing-library/jest-dom\": \"^6.6.4\",\n \"@testing-library/react\": \"^16.3.0\",\n \"@testing-library/user-event\": \"^13.5.0\",\n \"react\": \"^19.1.1\",\n \"react-dom\": \"^19.1.1\",\n \"react-scripts\": \"5.0.1\",\n \"web-vitals\": \"^2.1.4\"\n },\n \"scripts\": {\n \"start\": \"react-scripts start\",\n \"build\": \"react-scripts build\",\n \"test\": \"react-scripts test\",\n \"eject\": \"react-scripts eject\"\n },\n \"eslintConfig\": {\n \"extends\": [\n \"react-app\",\n \"react-app/jest\"\n ]\n },\n \"browserslist\": {\n \"production\": [\n \">0.2%\",\n \"not dead\",\n \"not op_mini all\"\n ],\n \"development\": [\n \"last 1 chrome version\",\n \"last 1 firefox version\",\n \"last 1 safari version\"\n ]\n }\n}\n"
},
{
"path": "arch/browser/public/index.html",
"content": "\n\n \n \n \n \n \n \n \n \n \n \n React App\n \n \n \n \n \n \n\n"
},
{
"path": "arch/browser/public/manifest.json",
"content": "{\n \"short_name\": \"React App\",\n \"name\": \"Create React App Sample\",\n \"icons\": [\n {\n \"src\": \"favicon.ico\",\n \"sizes\": \"64x64 32x32 24x24 16x16\",\n \"type\": \"image/x-icon\"\n },\n {\n \"src\": \"logo192.png\",\n \"type\": \"image/png\",\n \"sizes\": \"192x192\"\n },\n {\n \"src\": \"logo512.png\",\n \"type\": \"image/png\",\n \"sizes\": \"512x512\"\n }\n ],\n \"start_url\": \".\",\n \"display\": \"standalone\",\n \"theme_color\": \"#000000\",\n \"background_color\": \"#ffffff\"\n}\n"
},
{
"path": "arch/browser/src/index.css",
"content": "body {\n margin: 0;\n font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', 'Roboto', 'Oxygen',\n 'Ubuntu', 'Cantarell', 'Fira Sans', 'Droid Sans', 'Helvetica Neue',\n sans-serif;\n -webkit-font-smoothing: antialiased;\n -moz-osx-font-smoothing: grayscale;\n}\n\ncode {\n font-family: source-code-pro, Menlo, Monaco, Consolas, 'Courier New',\n monospace;\n}\n"
},
{
"path": "arch/browser/src/index.js",
"content": "import React from 'react';\nimport ReactDOM from 'react-dom/client';\n\nconst App = () => {\n return (\n \n \n \n \n
\n \n
\n \n \n \n \n \n );\n};\n\nconst root = ReactDOM.createRoot(window.document);\n\nroot.render(\n \n \n \n);\n"
},
{
"path": "arch/server/head-ordering.js",
"content": "/**\n * Reference file for React 19.1's head element ordering behavior.\n * Run: node head-ordering.js (from arch/server/)\n *\n * React's server renderer reorders children by priority bucket:\n * 1. meta[charset]\n * 2. meta[name=\"viewport\"]\n * 3. link[rel=\"stylesheet\"][precedence] (stylesheet resources)\n * 4. script[async][src] (async external scripts)\n * 5. everything else (title, regular meta, regular link, plain style, etc.)\n *\n * Within each bucket, elements maintain their relative discovery order.\n * Hoisted body elements appear before head-native elements within the same bucket.\n *\n * The RSC model keeps authored order; only the HTML shell is reordered.\n * React 19's hydration tolerates this mismatch via HostSingleton handling for .\n */\nconst React = require(\"react\");\nconst { renderToPipeableStream } = require(\"react-dom/server\");\nconst { Writable } = require(\"node:stream\");\nconst el = React.createElement;\n\nfunction render(element, label) {\n\treturn new Promise((resolve) => {\n\t\tlet out = \"\";\n\t\tconst writable = new Writable({\n\t\t\twrite(chunk, _, cb) {\n\t\t\t\tout += chunk.toString();\n\t\t\t\tcb();\n\t\t\t},\n\t\t});\n\t\tconst { pipe } = renderToPipeableStream(element, {\n\t\t\tonAllReady() {\n\t\t\t\tpipe(writable);\n\t\t\t},\n\t\t\tonError(err) {\n\t\t\t\tconsole.error(label, err);\n\t\t\t\tprocess.exitCode = 1;\n\t\t\t},\n\t\t});\n\t\twritable.on(\"finish\", () => {\n\t\t\tconsole.log(`\\n=== ${label} ===`);\n\t\t\tconsole.log(out);\n\t\t\tresolve();\n\t\t});\n\t});\n}\n\nasync function main() {\n\t// Case 1: Issue #303 exact sample\n\t// Input order: style, link[precedence], meta[charset], meta[viewport]\n\t// Output order: meta[charset], meta[viewport], link[precedence], style\n\tawait render(\n\t\tel(\n\t\t\t\"html\",\n\t\t\t{ lang: \"en\" },\n\t\t\tel(\n\t\t\t\t\"head\",\n\t\t\t\tnull,\n\t\t\t\tel(\"style\", null),\n\t\t\t\tel(\"link\", { precedence: \"low\", rel: \"stylesheet\", href: \"/foo.css\" }),\n\t\t\t\tel(\"meta\", { charSet: \"utf-8\" }),\n\t\t\t\tel(\"meta\", { name: \"viewport\" }),\n\t\t\t),\n\t\t\tel(\"body\", null),\n\t\t),\n\t\t\"Case 1: Issue #303 sample\",\n\t);\n\n\t// Case 2: Mixed explicit + hoisted elements from \n\tawait render(\n\t\tel(\n\t\t\t\"html\",\n\t\t\tnull,\n\t\t\tel(\n\t\t\t\t\"head\",\n\t\t\t\tnull,\n\t\t\t\tel(\"title\", null, \"My Page\"),\n\t\t\t\tel(\"style\", null, \"body{margin:0}\"),\n\t\t\t\tel(\"link\", {\n\t\t\t\t\trel: \"stylesheet\",\n\t\t\t\t\thref: \"/a.css\",\n\t\t\t\t\tprecedence: \"default\",\n\t\t\t\t}),\n\t\t\t\tel(\"meta\", { charSet: \"utf-8\" }),\n\t\t\t),\n\t\t\tel(\n\t\t\t\t\"body\",\n\t\t\t\tnull,\n\t\t\t\tel(\"link\", {\n\t\t\t\t\trel: \"stylesheet\",\n\t\t\t\t\thref: \"/b.css\",\n\t\t\t\t\tprecedence: \"high\",\n\t\t\t\t}),\n\t\t\t\tel(\"meta\", { name: \"viewport\", content: \"width=device-width\" }),\n\t\t\t\tel(\"title\", null, \"Override Title\"),\n\t\t\t),\n\t\t),\n\t\t\"Case 2: Mixed head + body hoistables\",\n\t);\n\n\t// Case 3: Broader bucket coverage\n\tawait render(\n\t\tel(\n\t\t\t\"html\",\n\t\t\tnull,\n\t\t\tel(\n\t\t\t\t\"head\",\n\t\t\t\tnull,\n\t\t\t\tel(\"title\", null, \"App\"),\n\t\t\t\tel(\"script\", { async: true, src: \"/app.js\" }),\n\t\t\t\tel(\"link\", {\n\t\t\t\t\trel: \"stylesheet\",\n\t\t\t\t\thref: \"/main.css\",\n\t\t\t\t\tprecedence: \"default\",\n\t\t\t\t}),\n\t\t\t\tel(\"meta\", { name: \"viewport\", content: \"width=device-width\" }),\n\t\t\t\tel(\"meta\", { charSet: \"utf-8\" }),\n\t\t\t\tel(\"link\", { rel: \"preconnect\", href: \"https://cdn.example.com\" }),\n\t\t\t\tel(\"link\", {\n\t\t\t\t\trel: \"stylesheet\",\n\t\t\t\t\thref: \"/theme.css\",\n\t\t\t\t\tprecedence: \"low\",\n\t\t\t\t}),\n\t\t\t\tel(\"style\", null, \".app{color:red}\"),\n\t\t\t\tel(\"meta\", { name: \"description\", content: \"A test app\" }),\n\t\t\t),\n\t\t\tel(\"body\", null),\n\t\t),\n\t\t\"Case 3: Broad bucket coverage\",\n\t);\n}\n\nmain();\n"
},
{
"path": "arch/server/package.json",
"content": "{\n \"name\": \"app\",\n \"version\": \"0.0.1\",\n \"scripts\": {\n \"react-dom-server\": \"bun react-dom-server.js\",\n \"render-html-to-stream\": \"bun render-html-to-stream.js\",\n \"render-rsc-to-stream\": \"bun --conditions react-server render-rsc-to-stream.js\"\n },\n \"license\": \"MIT\",\n \"dependencies\": {\n \"react\": \"^19.1.0\",\n \"react-dom\": \"^19.1.0\",\n \"react-server-dom-webpack\": \"^19.1.0\"\n }\n}\n"
},
{
"path": "arch/server/react-dom-server-node-dom-props.js",
"content": "var properties = {}; // These props are reserved by React. They shouldn't be written to the DOM.\n\nvar reservedProps = [\n \"children\",\n \"dangerouslySetInnerHTML\", // TODO: This prevents the assignment of defaultValue to regular\n // elements (not just inputs). Now that ReactDOMInput assigns to the\n // defaultValue property -- do we need this?\n \"defaultValue\",\n \"defaultChecked\",\n \"innerHTML\",\n \"suppressContentEditableWarning\",\n \"suppressHydrationWarning\",\n \"style\",\n];\n\nreservedProps.forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n RESERVED,\n false, // mustUseProperty\n name, // attributeName\n null, // attributeNamespace\n false\n );\n}); // A few React string attributes have a different name.\n// This is a mapping from React prop names to the attribute names.\n\n[\n [\"acceptCharset\", \"accept-charset\"],\n [\"className\", \"class\"],\n [\"htmlFor\", \"for\"],\n [\"httpEquiv\", \"http-equiv\"],\n].forEach(function (_ref) {\n var name = _ref[0],\n attributeName = _ref[1];\n properties[name] = new PropertyInfoRecord(\n name,\n STRING,\n false, // mustUseProperty\n attributeName, // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are \"enumerated\" HTML attributes that accept \"true\" and \"false\".\n// In React, we let users pass `true` and `false` even though technically\n// these aren't boolean attributes (they are coerced to strings).\n\n[\"contentEditable\", \"draggable\", \"spellCheck\", \"value\"].forEach(function (\n name\n) {\n properties[name] = new PropertyInfoRecord(\n name,\n BOOLEANISH_STRING,\n false, // mustUseProperty\n name.toLowerCase(), // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are \"enumerated\" SVG attributes that accept \"true\" and \"false\".\n// In React, we let users pass `true` and `false` even though technically\n// these aren't boolean attributes (they are coerced to strings).\n// Since these are SVG attributes, their attribute names are case-sensitive.\n\n[\n \"autoReverse\",\n \"externalResourcesRequired\",\n \"focusable\",\n \"preserveAlpha\",\n].forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n BOOLEANISH_STRING,\n false, // mustUseProperty\n name, // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are HTML boolean attributes.\n\n[\n \"allowFullScreen\",\n \"async\", // Note: there is a special case that prevents it from being written to the DOM\n // on the client side because the browsers are inconsistent. Instead we call focus().\n \"autoFocus\",\n \"autoPlay\",\n \"controls\",\n \"default\",\n \"defer\",\n \"disabled\",\n \"disablePictureInPicture\",\n \"formNoValidate\",\n \"hidden\",\n \"loop\",\n \"noModule\",\n \"noValidate\",\n \"open\",\n \"playsInline\",\n \"readOnly\",\n \"required\",\n \"reversed\",\n \"scoped\",\n \"seamless\", // Microdata\n \"itemScope\",\n].forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n BOOLEAN,\n false, // mustUseProperty\n name.toLowerCase(), // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are the few React props that we set as DOM properties\n// rather than attributes. These are all booleans.\n\n[\n \"checked\", // Note: `option.selected` is not updated if `select.multiple` is\n // disabled with `removeAttribute`. We have special logic for handling this.\n \"multiple\",\n \"muted\",\n \"selected\", // NOTE: if you add a camelCased prop to this list,\n // you'll need to set attributeName to name.toLowerCase()\n // instead in the assignment below.\n].forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n BOOLEAN,\n true, // mustUseProperty\n name, // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are HTML attributes that are \"overloaded booleans\": they behave like\n// booleans, but can also accept a string value.\n\n[\n \"capture\",\n \"download\", // NOTE: if you add a camelCased prop to this list,\n // you'll need to set attributeName to name.toLowerCase()\n // instead in the assignment below.\n].forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n OVERLOADED_BOOLEAN,\n false, // mustUseProperty\n name, // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are HTML attributes that must be positive numbers.\n\n[\n \"cols\",\n \"rows\",\n \"size\",\n \"span\", // NOTE: if you add a camelCased prop to this list,\n // you'll need to set attributeName to name.toLowerCase()\n // instead in the assignment below.\n].forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n POSITIVE_NUMERIC,\n false, // mustUseProperty\n name, // attributeName\n null, // attributeNamespace\n false\n );\n}); // These are HTML attributes that must be numbers.\n\n[\"rowSpan\", \"start\"].forEach(function (name) {\n properties[name] = new PropertyInfoRecord(\n name,\n NUMERIC,\n false, // mustUseProperty\n name.toLowerCase(), // attributeName\n null, // attributeNamespace\n false\n );\n});\nvar CAMELIZE = /[\\-\\:]([a-z])/g;\n\nvar capitalize = function (token) {\n return token[1].toUpperCase();\n}; // This is a list of all SVG attributes that need special casing, namespacing,\n// or boolean value assignment. Regular attributes that just accept strings\n// and have the same names are omitted, just like in the HTML whitelist.\n// Some of these attributes can be hard to find. This list was created by\n// scraping the MDN documentation.\n\n[\n \"accent-height\",\n \"alignment-baseline\",\n \"arabic-form\",\n \"baseline-shift\",\n \"cap-height\",\n \"clip-path\",\n \"clip-rule\",\n \"color-interpolation\",\n \"color-interpolation-filters\",\n \"color-profile\",\n \"color-rendering\",\n \"dominant-baseline\",\n \"enable-background\",\n \"fill-opacity\",\n \"fill-rule\",\n \"flood-color\",\n \"flood-opacity\",\n \"font-family\",\n \"font-size\",\n \"font-size-adjust\",\n \"font-stretch\",\n \"font-style\",\n \"font-variant\",\n \"font-weight\",\n \"glyph-name\",\n \"glyph-orientation-horizontal\",\n \"glyph-orientation-vertical\",\n \"horiz-adv-x\",\n \"horiz-origin-x\",\n \"image-rendering\",\n \"letter-spacing\",\n \"lighting-color\",\n \"marker-end\",\n \"marker-mid\",\n \"marker-start\",\n \"overline-position\",\n \"overline-thickness\",\n \"paint-order\",\n \"panose-1\",\n \"pointer-events\",\n \"rendering-intent\",\n \"shape-rendering\",\n \"stop-color\",\n \"stop-opacity\",\n \"strikethrough-position\",\n \"strikethrough-thickness\",\n \"stroke-dasharray\",\n \"stroke-dashoffset\",\n \"stroke-linecap\",\n \"stroke-linejoin\",\n \"stroke-miterlimit\",\n \"stroke-opacity\",\n \"stroke-width\",\n \"text-anchor\",\n \"text-decoration\",\n \"text-rendering\",\n \"underline-position\",\n \"underline-thickness\",\n \"unicode-bidi\",\n \"unicode-range\",\n \"units-per-em\",\n \"v-alphabetic\",\n \"v-hanging\",\n \"v-ideographic\",\n \"v-mathematical\",\n \"vector-effect\",\n \"vert-adv-y\",\n \"vert-origin-x\",\n \"vert-origin-y\",\n \"word-spacing\",\n \"writing-mode\",\n \"xmlns:xlink\",\n \"x-height\", // NOTE: if you add a camelCased prop to this list,\n // you'll need to set attributeName to name.toLowerCase()\n // instead in the assignment below.\n].forEach(function (attributeName) {\n var name = attributeName.replace(CAMELIZE, capitalize);\n properties[name] = new PropertyInfoRecord(\n name,\n STRING,\n false, // mustUseProperty\n attributeName,\n null, // attributeNamespace\n false\n );\n}); // String SVG attributes with the xlink namespace.\n\n[\n \"xlink:actuate\",\n \"xlink:arcrole\",\n \"xlink:role\",\n \"xlink:show\",\n \"xlink:title\",\n \"xlink:type\", // NOTE: if you add a camelCased prop to this list,\n // you'll need to set attributeName to name.toLowerCase()\n // instead in the assignment below.\n].forEach(function (attributeName) {\n var name = attributeName.replace(CAMELIZE, capitalize);\n properties[name] = new PropertyInfoRecord(\n name,\n STRING,\n false, // mustUseProperty\n attributeName,\n \"http://www.w3.org/1999/xlink\",\n false\n );\n}); // String SVG attributes with the xml namespace.\n\n[\n \"xml:base\",\n \"xml:lang\",\n \"xml:space\", // NOTE: if you add a camelCased prop to this list,\n // you'll need to set attributeName to name.toLowerCase()\n // instead in the assignment below.\n].forEach(function (attributeName) {\n var name = attributeName.replace(CAMELIZE, capitalize);\n properties[name] = new PropertyInfoRecord(\n name,\n STRING,\n false, // mustUseProperty\n attributeName,\n \"http://www.w3.org/XML/1998/namespace\",\n false\n );\n}); // These attribute exists both in HTML and SVG.\n// The attribute name is case-sensitive in SVG so we can't just use\n// the React name like we do for attributes that exist only in HTML.\n\n[\"tabIndex\", \"crossOrigin\"].forEach(function (attributeName) {\n properties[attributeName] = new PropertyInfoRecord(\n attributeName,\n STRING,\n false, // mustUseProperty\n attributeName.toLowerCase(), // attributeName\n null, // attributeNamespace\n false\n );\n}); // These attributes accept URLs. These must not allow javascript: URLS.\n// These will also need to accept Trusted Types object in the future.\n\nvar xlinkHref = \"xlinkHref\";\nproperties[xlinkHref] = new PropertyInfoRecord(\n \"xlinkHref\",\n STRING,\n false, // mustUseProperty\n \"xlink:href\",\n \"http://www.w3.org/1999/xlink\",\n true\n);\n[\"src\", \"href\", \"action\", \"formAction\"].forEach(function (attributeName) {\n properties[attributeName] = new PropertyInfoRecord(\n attributeName,\n STRING,\n false, // mustUseProperty\n attributeName.toLowerCase(), // attributeName\n null, // attributeNamespace\n true\n );\n});\n\n/* */\n\n// When adding attributes to the HTML or SVG whitelist, be sure to\n// also add them to this module to ensure casing and incorrect name\n// warnings.\nvar possibleStandardNames = {\n // HTML\n accept: \"accept\",\n acceptcharset: \"acceptCharset\",\n \"accept-charset\": \"acceptCharset\",\n accesskey: \"accessKey\",\n action: \"action\",\n allowfullscreen: \"allowFullScreen\",\n alt: \"alt\",\n as: \"as\",\n async: \"async\",\n autocapitalize: \"autoCapitalize\",\n autocomplete: \"autoComplete\",\n autocorrect: \"autoCorrect\",\n autofocus: \"autoFocus\",\n autoplay: \"autoPlay\",\n autosave: \"autoSave\",\n capture: \"capture\",\n cellpadding: \"cellPadding\",\n cellspacing: \"cellSpacing\",\n challenge: \"challenge\",\n charset: \"charSet\",\n checked: \"checked\",\n children: \"children\",\n cite: \"cite\",\n class: \"className\",\n classid: \"classID\",\n classname: \"className\",\n cols: \"cols\",\n colspan: \"colSpan\",\n content: \"content\",\n contenteditable: \"contentEditable\",\n contextmenu: \"contextMenu\",\n controls: \"controls\",\n controlslist: \"controlsList\",\n coords: \"coords\",\n crossorigin: \"crossOrigin\",\n dangerouslysetinnerhtml: \"dangerouslySetInnerHTML\",\n data: \"data\",\n datetime: \"dateTime\",\n default: \"default\",\n defaultchecked: \"defaultChecked\",\n defaultvalue: \"defaultValue\",\n defer: \"defer\",\n dir: \"dir\",\n disabled: \"disabled\",\n disablepictureinpicture: \"disablePictureInPicture\",\n download: \"download\",\n draggable: \"draggable\",\n enctype: \"encType\",\n for: \"htmlFor\",\n form: \"form\",\n formmethod: \"formMethod\",\n formaction: \"formAction\",\n formenctype: \"formEncType\",\n formnovalidate: \"formNoValidate\",\n formtarget: \"formTarget\",\n frameborder: \"frameBorder\",\n headers: \"headers\",\n height: \"height\",\n hidden: \"hidden\",\n high: \"high\",\n href: \"href\",\n hreflang: \"hrefLang\",\n htmlfor: \"htmlFor\",\n httpequiv: \"httpEquiv\",\n \"http-equiv\": \"httpEquiv\",\n icon: \"icon\",\n id: \"id\",\n innerhtml: \"innerHTML\",\n inputmode: \"inputMode\",\n integrity: \"integrity\",\n is: \"is\",\n itemid: \"itemID\",\n itemprop: \"itemProp\",\n itemref: \"itemRef\",\n itemscope: \"itemScope\",\n itemtype: \"itemType\",\n keyparams: \"keyParams\",\n keytype: \"keyType\",\n kind: \"kind\",\n label: \"label\",\n lang: \"lang\",\n list: \"list\",\n loop: \"loop\",\n low: \"low\",\n manifest: \"manifest\",\n marginwidth: \"marginWidth\",\n marginheight: \"marginHeight\",\n max: \"max\",\n maxlength: \"maxLength\",\n media: \"media\",\n mediagroup: \"mediaGroup\",\n method: \"method\",\n min: \"min\",\n minlength: \"minLength\",\n multiple: \"multiple\",\n muted: \"muted\",\n name: \"name\",\n nomodule: \"noModule\",\n nonce: \"nonce\",\n novalidate: \"noValidate\",\n open: \"open\",\n optimum: \"optimum\",\n pattern: \"pattern\",\n placeholder: \"placeholder\",\n playsinline: \"playsInline\",\n poster: \"poster\",\n preload: \"preload\",\n profile: \"profile\",\n radiogroup: \"radioGroup\",\n readonly: \"readOnly\",\n referrerpolicy: \"referrerPolicy\",\n rel: \"rel\",\n required: \"required\",\n reversed: \"reversed\",\n role: \"role\",\n rows: \"rows\",\n rowspan: \"rowSpan\",\n sandbox: \"sandbox\",\n scope: \"scope\",\n scoped: \"scoped\",\n scrolling: \"scrolling\",\n seamless: \"seamless\",\n selected: \"selected\",\n shape: \"shape\",\n size: \"size\",\n sizes: \"sizes\",\n span: \"span\",\n spellcheck: \"spellCheck\",\n src: \"src\",\n srcdoc: \"srcDoc\",\n srclang: \"srcLang\",\n srcset: \"srcSet\",\n start: \"start\",\n step: \"step\",\n style: \"style\",\n summary: \"summary\",\n tabindex: \"tabIndex\",\n target: \"target\",\n title: \"title\",\n type: \"type\",\n usemap: \"useMap\",\n value: \"value\",\n width: \"width\",\n wmode: \"wmode\",\n wrap: \"wrap\",\n // SVG\n about: \"about\",\n accentheight: \"accentHeight\",\n \"accent-height\": \"accentHeight\",\n accumulate: \"accumulate\",\n additive: \"additive\",\n alignmentbaseline: \"alignmentBaseline\",\n \"alignment-baseline\": \"alignmentBaseline\",\n allowreorder: \"allowReorder\",\n alphabetic: \"alphabetic\",\n amplitude: \"amplitude\",\n arabicform: \"arabicForm\",\n \"arabic-form\": \"arabicForm\",\n ascent: \"ascent\",\n attributename: \"attributeName\",\n attributetype: \"attributeType\",\n autoreverse: \"autoReverse\",\n azimuth: \"azimuth\",\n basefrequency: \"baseFrequency\",\n baselineshift: \"baselineShift\",\n \"baseline-shift\": \"baselineShift\",\n baseprofile: \"baseProfile\",\n bbox: \"bbox\",\n begin: \"begin\",\n bias: \"bias\",\n by: \"by\",\n calcmode: \"calcMode\",\n capheight: \"capHeight\",\n \"cap-height\": \"capHeight\",\n clip: \"clip\",\n clippath: \"clipPath\",\n \"clip-path\": \"clipPath\",\n clippathunits: \"clipPathUnits\",\n cliprule: \"clipRule\",\n \"clip-rule\": \"clipRule\",\n color: \"color\",\n colorinterpolation: \"colorInterpolation\",\n \"color-interpolation\": \"colorInterpolation\",\n colorinterpolationfilters: \"colorInterpolationFilters\",\n \"color-interpolation-filters\": \"colorInterpolationFilters\",\n colorprofile: \"colorProfile\",\n \"color-profile\": \"colorProfile\",\n colorrendering: \"colorRendering\",\n \"color-rendering\": \"colorRendering\",\n contentscripttype: \"contentScriptType\",\n contentstyletype: \"contentStyleType\",\n cursor: \"cursor\",\n cx: \"cx\",\n cy: \"cy\",\n d: \"d\",\n datatype: \"datatype\",\n decelerate: \"decelerate\",\n descent: \"descent\",\n diffuseconstant: \"diffuseConstant\",\n direction: \"direction\",\n display: \"display\",\n divisor: \"divisor\",\n dominantbaseline: \"dominantBaseline\",\n \"dominant-baseline\": \"dominantBaseline\",\n dur: \"dur\",\n dx: \"dx\",\n dy: \"dy\",\n edgemode: \"edgeMode\",\n elevation: \"elevation\",\n enablebackground: \"enableBackground\",\n \"enable-background\": \"enableBackground\",\n end: \"end\",\n exponent: \"exponent\",\n externalresourcesrequired: \"externalResourcesRequired\",\n fill: \"fill\",\n fillopacity: \"fillOpacity\",\n \"fill-opacity\": \"fillOpacity\",\n fillrule: \"fillRule\",\n \"fill-rule\": \"fillRule\",\n filter: \"filter\",\n filterres: \"filterRes\",\n filterunits: \"filterUnits\",\n floodopacity: \"floodOpacity\",\n \"flood-opacity\": \"floodOpacity\",\n floodcolor: \"floodColor\",\n \"flood-color\": \"floodColor\",\n focusable: \"focusable\",\n fontfamily: \"fontFamily\",\n \"font-family\": \"fontFamily\",\n fontsize: \"fontSize\",\n \"font-size\": \"fontSize\",\n fontsizeadjust: \"fontSizeAdjust\",\n \"font-size-adjust\": \"fontSizeAdjust\",\n fontstretch: \"fontStretch\",\n \"font-stretch\": \"fontStretch\",\n fontstyle: \"fontStyle\",\n \"font-style\": \"fontStyle\",\n fontvariant: \"fontVariant\",\n \"font-variant\": \"fontVariant\",\n fontweight: \"fontWeight\",\n \"font-weight\": \"fontWeight\",\n format: \"format\",\n from: \"from\",\n fx: \"fx\",\n fy: \"fy\",\n g1: \"g1\",\n g2: \"g2\",\n glyphname: \"glyphName\",\n \"glyph-name\": \"glyphName\",\n glyphorientationhorizontal: \"glyphOrientationHorizontal\",\n \"glyph-orientation-horizontal\": \"glyphOrientationHorizontal\",\n glyphorientationvertical: \"glyphOrientationVertical\",\n \"glyph-orientation-vertical\": \"glyphOrientationVertical\",\n glyphref: \"glyphRef\",\n gradienttransform: \"gradientTransform\",\n gradientunits: \"gradientUnits\",\n hanging: \"hanging\",\n horizadvx: \"horizAdvX\",\n \"horiz-adv-x\": \"horizAdvX\",\n horizoriginx: \"horizOriginX\",\n \"horiz-origin-x\": \"horizOriginX\",\n ideographic: \"ideographic\",\n imagerendering: \"imageRendering\",\n \"image-rendering\": \"imageRendering\",\n in2: \"in2\",\n in: \"in\",\n inlist: \"inlist\",\n intercept: \"intercept\",\n k1: \"k1\",\n k2: \"k2\",\n k3: \"k3\",\n k4: \"k4\",\n k: \"k\",\n kernelmatrix: \"kernelMatrix\",\n kernelunitlength: \"kernelUnitLength\",\n kerning: \"kerning\",\n keypoints: \"keyPoints\",\n keysplines: \"keySplines\",\n keytimes: \"keyTimes\",\n lengthadjust: \"lengthAdjust\",\n letterspacing: \"letterSpacing\",\n \"letter-spacing\": \"letterSpacing\",\n lightingcolor: \"lightingColor\",\n \"lighting-color\": \"lightingColor\",\n limitingconeangle: \"limitingConeAngle\",\n local: \"local\",\n markerend: \"markerEnd\",\n \"marker-end\": \"markerEnd\",\n markerheight: \"markerHeight\",\n markermid: \"markerMid\",\n \"marker-mid\": \"markerMid\",\n markerstart: \"markerStart\",\n \"marker-start\": \"markerStart\",\n markerunits: \"markerUnits\",\n markerwidth: \"markerWidth\",\n mask: \"mask\",\n maskcontentunits: \"maskContentUnits\",\n maskunits: \"maskUnits\",\n mathematical: \"mathematical\",\n mode: \"mode\",\n numoctaves: \"numOctaves\",\n offset: \"offset\",\n opacity: \"opacity\",\n operator: \"operator\",\n order: \"order\",\n orient: \"orient\",\n orientation: \"orientation\",\n origin: \"origin\",\n overflow: \"overflow\",\n overlineposition: \"overlinePosition\",\n \"overline-position\": \"overlinePosition\",\n overlinethickness: \"overlineThickness\",\n \"overline-thickness\": \"overlineThickness\",\n paintorder: \"paintOrder\",\n \"paint-order\": \"paintOrder\",\n panose1: \"panose1\",\n \"panose-1\": \"panose1\",\n pathlength: \"pathLength\",\n patterncontentunits: \"patternContentUnits\",\n patterntransform: \"patternTransform\",\n patternunits: \"patternUnits\",\n pointerevents: \"pointerEvents\",\n \"pointer-events\": \"pointerEvents\",\n points: \"points\",\n pointsatx: \"pointsAtX\",\n pointsaty: \"pointsAtY\",\n pointsatz: \"pointsAtZ\",\n prefix: \"prefix\",\n preservealpha: \"preserveAlpha\",\n preserveaspectratio: \"preserveAspectRatio\",\n primitiveunits: \"primitiveUnits\",\n property: \"property\",\n r: \"r\",\n radius: \"radius\",\n refx: \"refX\",\n refy: \"refY\",\n renderingintent: \"renderingIntent\",\n \"rendering-intent\": \"renderingIntent\",\n repeatcount: \"repeatCount\",\n repeatdur: \"repeatDur\",\n requiredextensions: \"requiredExtensions\",\n requiredfeatures: \"requiredFeatures\",\n resource: \"resource\",\n restart: \"restart\",\n result: \"result\",\n results: \"results\",\n rotate: \"rotate\",\n rx: \"rx\",\n ry: \"ry\",\n scale: \"scale\",\n security: \"security\",\n seed: \"seed\",\n shaperendering: \"shapeRendering\",\n \"shape-rendering\": \"shapeRendering\",\n slope: \"slope\",\n spacing: \"spacing\",\n specularconstant: \"specularConstant\",\n specularexponent: \"specularExponent\",\n speed: \"speed\",\n spreadmethod: \"spreadMethod\",\n startoffset: \"startOffset\",\n stddeviation: \"stdDeviation\",\n stemh: \"stemh\",\n stemv: \"stemv\",\n stitchtiles: \"stitchTiles\",\n stopcolor: \"stopColor\",\n \"stop-color\": \"stopColor\",\n stopopacity: \"stopOpacity\",\n \"stop-opacity\": \"stopOpacity\",\n strikethroughposition: \"strikethroughPosition\",\n \"strikethrough-position\": \"strikethroughPosition\",\n strikethroughthickness: \"strikethroughThickness\",\n \"strikethrough-thickness\": \"strikethroughThickness\",\n string: \"string\",\n stroke: \"stroke\",\n strokedasharray: \"strokeDasharray\",\n \"stroke-dasharray\": \"strokeDasharray\",\n strokedashoffset: \"strokeDashoffset\",\n \"stroke-dashoffset\": \"strokeDashoffset\",\n strokelinecap: \"strokeLinecap\",\n \"stroke-linecap\": \"strokeLinecap\",\n strokelinejoin: \"strokeLinejoin\",\n \"stroke-linejoin\": \"strokeLinejoin\",\n strokemiterlimit: \"strokeMiterlimit\",\n \"stroke-miterlimit\": \"strokeMiterlimit\",\n strokewidth: \"strokeWidth\",\n \"stroke-width\": \"strokeWidth\",\n strokeopacity: \"strokeOpacity\",\n \"stroke-opacity\": \"strokeOpacity\",\n suppresscontenteditablewarning: \"suppressContentEditableWarning\",\n suppresshydrationwarning: \"suppressHydrationWarning\",\n surfacescale: \"surfaceScale\",\n systemlanguage: \"systemLanguage\",\n tablevalues: \"tableValues\",\n targetx: \"targetX\",\n targety: \"targetY\",\n textanchor: \"textAnchor\",\n \"text-anchor\": \"textAnchor\",\n textdecoration: \"textDecoration\",\n \"text-decoration\": \"textDecoration\",\n textlength: \"textLength\",\n textrendering: \"textRendering\",\n \"text-rendering\": \"textRendering\",\n to: \"to\",\n transform: \"transform\",\n typeof: \"typeof\",\n u1: \"u1\",\n u2: \"u2\",\n underlineposition: \"underlinePosition\",\n \"underline-position\": \"underlinePosition\",\n underlinethickness: \"underlineThickness\",\n \"underline-thickness\": \"underlineThickness\",\n unicode: \"unicode\",\n unicodebidi: \"unicodeBidi\",\n \"unicode-bidi\": \"unicodeBidi\",\n unicoderange: \"unicodeRange\",\n \"unicode-range\": \"unicodeRange\",\n unitsperem: \"unitsPerEm\",\n \"units-per-em\": \"unitsPerEm\",\n unselectable: \"unselectable\",\n valphabetic: \"vAlphabetic\",\n \"v-alphabetic\": \"vAlphabetic\",\n values: \"values\",\n vectoreffect: \"vectorEffect\",\n \"vector-effect\": \"vectorEffect\",\n version: \"version\",\n vertadvy: \"vertAdvY\",\n \"vert-adv-y\": \"vertAdvY\",\n vertoriginx: \"vertOriginX\",\n \"vert-origin-x\": \"vertOriginX\",\n vertoriginy: \"vertOriginY\",\n \"vert-origin-y\": \"vertOriginY\",\n vhanging: \"vHanging\",\n \"v-hanging\": \"vHanging\",\n videographic: \"vIdeographic\",\n \"v-ideographic\": \"vIdeographic\",\n viewbox: \"viewBox\",\n viewtarget: \"viewTarget\",\n visibility: \"visibility\",\n vmathematical: \"vMathematical\",\n \"v-mathematical\": \"vMathematical\",\n vocab: \"vocab\",\n widths: \"widths\",\n wordspacing: \"wordSpacing\",\n \"word-spacing\": \"wordSpacing\",\n writingmode: \"writingMode\",\n \"writing-mode\": \"writingMode\",\n x1: \"x1\",\n x2: \"x2\",\n x: \"x\",\n xchannelselector: \"xChannelSelector\",\n xheight: \"xHeight\",\n \"x-height\": \"xHeight\",\n xlinkactuate: \"xlinkActuate\",\n \"xlink:actuate\": \"xlinkActuate\",\n xlinkarcrole: \"xlinkArcrole\",\n \"xlink:arcrole\": \"xlinkArcrole\",\n xlinkhref: \"xlinkHref\",\n \"xlink:href\": \"xlinkHref\",\n xlinkrole: \"xlinkRole\",\n \"xlink:role\": \"xlinkRole\",\n xlinkshow: \"xlinkShow\",\n \"xlink:show\": \"xlinkShow\",\n xlinktitle: \"xlinkTitle\",\n \"xlink:title\": \"xlinkTitle\",\n xlinktype: \"xlinkType\",\n \"xlink:type\": \"xlinkType\",\n xmlbase: \"xmlBase\",\n \"xml:base\": \"xmlBase\",\n xmllang: \"xmlLang\",\n \"xml:lang\": \"xmlLang\",\n xmlns: \"xmlns\",\n \"xml:space\": \"xmlSpace\",\n xmlnsxlink: \"xmlnsXlink\",\n \"xmlns:xlink\": \"xmlnsXlink\",\n xmlspace: \"xmlSpace\",\n y1: \"y1\",\n y2: \"y2\",\n y: \"y\",\n ychannelselector: \"yChannelSelector\",\n z: \"z\",\n zoomandpan: \"zoomAndPan\",\n};\n\n/* */\n"
},
{
"path": "arch/server/react-dom-server.js",
"content": "const React = require(\"react\");\nconst ReactDOM = require(\"react-dom/server\");\n\nlet first = React.createElement(\n\t\"div\",\n\t{ key: \"fi\", value1: \"aaa\", style: { margin: \"1px\" } },\n\t[\"first\"],\n);\nlet clon = React.cloneElement(\n\tfirst,\n\t{ value: \"bbb\", more: 22, style: { margin: \"1\", padding: \"0px\" } },\n\t[\"asdf\"],\n);\n\nconst { Provider, Consumer } = React.createContext(10);\n\nvar app = () => {\n\t/* https://fb.me/react-uselayouteffect-ssr */\n\tReact.useLayoutEffect(() => {\n\t\tconsole.log(\"asdfdsf\");\n\n\t\treturn () => {\n\t\t\tconsole.log(\"asdfsdf\");\n\t\t};\n\t});\n\treturn React.createElement(\"div\", { className: \"contenido\" }, []);\n};\n\nvar app = () => {\n\tlet [state, setState] = React.useState(0);\n\n\tReact.useEffect(() => {\n\t\tsetState(state + 1);\n\t\tconsole.log(\"asdfdsf\");\n\n\t\treturn () => {\n\t\t\tconsole.log(\"asdfsdf\");\n\t\t};\n\t});\n\treturn React.createElement(\"div\", { className: \"contenido\" }, []);\n};\n\nvar app = () => {\n\tlet [state, setState] = React.useState(0);\n\tlet ref = React.useRef(true);\n\tconsole.log(state);\n\tif (ref.current) {\n\t\tsetState(state + 1);\n\t\tref.current = false;\n\t}\n\tReact.useEffect(() => {\n\t\tconsole.log(\"asfsdafsafsadf\");\n\t});\n\tReact.useEffect(() => {\n\t\tconsole.log(\"asfsdafsafsadf\");\n\t}, [state]);\n\tconsole.log(state);\n\treturn React.createElement(\"div\", null, [state]);\n};\n\n/* var app = () => {\n return React.createElement(\"div\", {\n dangerouslySetInnerHTML: { __html: \"asdf\" },\n });\n}; */\n\nvar ctx = React.createContext(10);\n\nvar context_user = () => {\n\tlet a = React.useContext(ctx);\n\tconsole.log(a);\n\treturn React.createElement(\"div\", { key: 1 }, [a]);\n};\n\nvar app = () => {\n\tlet ref = React.useRef(333);\n\tconsole.log(ref);\n\treturn React.createElement(\n\t\tctx.Provider,\n\t\t{ value: 0, ref: ref },\n\t\tReact.createElement(context_user),\n\t);\n};\n\nvar app = React.forwardRef(() => {\n\tlet ref = React.useRef(333);\n\tconsole.log(ref);\n\treturn React.createElement(\n\t\tctx.Provider,\n\t\t{ value: 0, ref: ref },\n\t\tReact.createElement(context_user),\n\t);\n});\n\nvar app = () => {\n\treturn React.createElement(\n\t\t\"script\",\n\t\t{\n\t\t\t\"aria-hidden\": \"true\",\n\t\t},\n\t\t`console.log(\"asdfas\");`,\n\t);\n};\n\nfunction App() {\n\tlet value = \"asdfasdf\";\n\treturn ;\n}\n\nconsole.log(ReactDOM.renderToStaticMarkup());\n"
},
{
"path": "arch/server/render-html-to-stream.js",
"content": "import React from \"react\";\nimport * as ReactDOM from \"react-dom/server\";\nimport { prefetchDNS, preconnect, preload, preinit } from 'react-dom'\n\nconst sleep = (seconds) =>\n\tnew Promise((res) => setTimeout(res, seconds * 1000));\n\nconst DeferredComponent = async ({ by, children }) => {\n\tawait sleep(by);\n\treturn (\n\t\t
`);\n});\n\napp.get(\"/health\", (req, res) => {\n res.json({ status: \"ok\", framework: \"preact\", pid: process.pid });\n});\n\napp.get(\"/scenarios\", (req, res) => {\n const list = Object.entries(preactScenarios).map(([key, val]) => ({\n key,\n name: val.name,\n }));\n res.json(list);\n});\n\napp.listen(PORT, () => {\n console.log(`[preact] Server listening on http://localhost:${PORT}`);\n console.log(`[preact] PID: ${process.pid}`);\n});\n\n"
},
{
"path": "benchmark/frameworks/render-bench.ts",
"content": "/**\n * Pure Render Benchmark - No HTTP\n * Comparable to streaming_bench.ml\n */\n\nif (process.env.NODE_ENV !== \"production\") {\n console.error(\n \"[render-bench] ERROR: NODE_ENV is not 'production' (got \" +\n JSON.stringify(process.env.NODE_ENV) +\n \").\\n\" +\n \"React's development build is slower than production. Re-run with:\\n\" +\n \" NODE_ENV=production bun render-bench.ts\\n\" +\n \" NODE_ENV=production node render-bench-node.mjs\\n\"\n );\n process.exit(1);\n}\n\nimport React from \"react\";\nimport ReactDOMServer from \"react-dom/server\";\nimport * as scenarios from \"./shared/scenarios.jsx\";\n\nconst ITERATIONS = 100;\n\nfunction measureTimeUs(fn: () => string): [string, number] {\n const start = performance.now();\n const result = fn();\n const end = performance.now();\n return [result, (end - start) * 1000]; // Convert ms to µs\n}\n\nfunction formatTimeUs(us: number): string {\n if (us < 1000) return `${us.toFixed(2)}µs`;\n if (us < 1_000_000) return `${(us / 1000).toFixed(2)}ms`;\n return `${(us / 1_000_000).toFixed(2)}s`;\n}\n\ninterface Result {\n name: string;\n avgTimeUs: number;\n outputBytes: number;\n throughputMbS: number;\n}\n\nfunction benchmark(name: string, component: React.ComponentType): Result {\n let totalTime = 0;\n let outputBytes = 0;\n\n for (let i = 0; i < ITERATIONS; i++) {\n const [html, timeUs] = measureTimeUs(() =>\n ReactDOMServer.renderToString(React.createElement(component))\n );\n totalTime += timeUs;\n outputBytes = html.length;\n }\n\n const avgTime = totalTime / ITERATIONS;\n const throughput = (outputBytes / 1_000_000) / (avgTime / 1_000_000);\n\n return {\n name,\n avgTimeUs: avgTime,\n outputBytes,\n throughputMbS: throughput,\n };\n}\n\nconst runtime =\n typeof (globalThis as any).Bun !== \"undefined\"\n ? `Bun ${(globalThis as any).Bun.version}`\n : `Node ${process.versions.node}`;\n\nconsole.log(`Pure Render Benchmark (${runtime} + React, NODE_ENV=production)`);\nconsole.log(`Iterations per scenario: ${ITERATIONS}\\n`);\n\n// Keep this list in sync with benchmark/streaming/streaming_bench.ml so each\nconst testScenarios = [\n \"trivial\",\n \"shallow\",\n \"deep10\",\n \"deep50\",\n \"wide10\",\n \"wide100\",\n \"wide500\",\n \"table10\",\n \"table100\",\n \"table500\",\n \"propsSmall\",\n \"propsMedium\",\n \"ecommerce24\",\n \"ecommerce48\",\n \"dashboard\",\n \"blog50\",\n \"form\",\n];\n\nconst results: Result[] = [];\n\nfor (const key of testScenarios) {\n const scenario = scenarios.scenarios[key as keyof typeof scenarios.scenarios];\n if (scenario) {\n const result = benchmark(key, scenario.component);\n results.push(result);\n console.log(`${key}: ${formatTimeUs(result.avgTimeUs)} (${result.outputBytes}B)`);\n }\n}\n\nconsole.log(\"\\n\" + \"=\".repeat(70));\nconsole.log(\"COMPARISON TABLE\");\nconsole.log(\"=\".repeat(70));\nconsole.log(`${\"Scenario\".padEnd(20)} ${\"Time\".padStart(12)} ${\"Size\".padStart(10)} ${\"Throughput\".padStart(12)}`);\nconsole.log(\"-\".repeat(70));\n\nfor (const r of results) {\n console.log(\n `${r.name.padEnd(20)} ${formatTimeUs(r.avgTimeUs).padStart(12)} ${(r.outputBytes + \"B\").padStart(10)} ${(r.throughputMbS.toFixed(1) + \"MB/s\").padStart(12)}`\n );\n}\nconsole.log(\"=\".repeat(70));\n"
},
{
"path": "benchmark/frameworks/shared/Blog.jsx",
"content": "// Port of benchmark/scenarios/Blog.re\n// Purpose: content-heavy page rendering with nested comments\n\nimport React from \"react\";\nimport { cx } from \"./cx.js\";\n\nconst authors = [\"Alice\", \"Bob\", \"Charlie\", \"Diana\", \"Eve\", \"Frank\"];\nconst avatars = [\"A\", \"B\", \"C\", \"D\", \"E\", \"F\"];\n\nconst generateComments = (count, depth) =>\n Array.from({ length: count }, (_, i) => ({\n id: i + 1,\n author: authors[i % authors.length],\n avatar: avatars[i % avatars.length],\n content: `This is comment #${i + 1}. Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.`,\n date: `${1 + (i % 24)} hours ago`,\n likes: (i * 3) % 50,\n replies:\n depth > 0\n ? Array.from({ length: i % 3 }, (_, j) => ({\n id: i * 100 + j,\n author: authors[(i + j + 1) % authors.length],\n avatar: avatars[(i + j + 1) % avatars.length],\n content: `Reply to comment #${i + 1}. Great point!`,\n date: `${5 + j * 10} minutes ago`,\n likes: j * 2,\n replies: [],\n }))\n : [],\n }));\n\nconst CommentComponent = ({ comment, depth }) => (\n 0\n ? \"ml-12 border-l-2 border-gray-100 pl-4\"\n : \"border-b border-gray-100\",\n ])}\n >\n
\n
\n {comment.avatar}\n
\n
\n
\n {comment.author}\n {comment.date}\n
\n
{comment.content}
\n
\n \n \n \n
\n {comment.replies.length > 0 && (\n
\n {comment.replies.map((reply) => (\n \n ))}\n
\n )}\n
\n
\n \n);\n\nconst ArticleContent = () => (\n \n
\n Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris.\n
\n
Introduction
\n
\n Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.\n
\n
\n Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo.\n
\n
\n
\n \"Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt.\"\n
\n — Famous Author\n
\n
Key Concepts
\n
\n Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem.\n
\n
\n
Ut enim ad minima veniam, quis nostrum exercitationem
\n
Corporis suscipit laboriosam, nisi ut aliquid ex ea commodi
\n
Quis autem vel eum iure reprehenderit qui in ea voluptate
\n
At vero eos et accusamus et iusto odio dignissimos ducimus
\n
\n
\n
💡 Pro Tip
\n
\n Temporibus autem quibusdam et aut officiis debitis aut rerum necessitatibus saepe eveniet ut et voluptates repudiandae sint et molestiae non recusandae.\n
\n
\n
Code Example
\n
\n {`let example = () => {\n let value = computeValue();\n let result = transform(value);\n process(result);\n};`}\n
\n
Conclusion
\n
\n Itaque earum rerum hic tenetur a sapiente delectus, ut aut reiciendis voluptatibus maiores alias consequatur aut perferendis doloribus asperiores repellat.\n
By using our services, you agree to these terms. Please read them carefully.
\n
\n Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.\n
\n
\n Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.\n
\n
\n Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo.\n
\n \n ;\n };\n};\n\nmodule ArticleContent = {\n [@react.component]\n let make = () => {\n \n
\n {React.string(\n \"Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris.\",\n )}\n
\n
\n {React.string(\"Introduction\")}\n
\n
\n {React.string(\n \"Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.\",\n )}\n
\n
\n {React.string(\n \"Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo.\",\n )}\n
\n \n
\n {React.string(\n \"\\\"Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt.\\\"\",\n )}\n
\n \n {React.string(\"— Famous Author\")}\n \n \n
\n {React.string(\"Key Concepts\")}\n
\n
\n {React.string(\n \"Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem.\",\n )}\n
\n
\n
\n {React.string(\n \"Ut enim ad minima veniam, quis nostrum exercitationem\",\n )}\n
\n
\n {React.string(\n \"Corporis suscipit laboriosam, nisi ut aliquid ex ea commodi\",\n )}\n
\n
\n {React.string(\n \"Quis autem vel eum iure reprehenderit qui in ea voluptate\",\n )}\n
\n
\n {React.string(\n \"At vero eos et accusamus et iusto odio dignissimos ducimus\",\n )}\n
\n
\n
\n
\n {React.string(\"💡 Pro Tip\")}\n
\n
\n {React.string(\n \"Temporibus autem quibusdam et aut officiis debitis aut rerum necessitatibus saepe eveniet ut et voluptates repudiandae sint et molestiae non recusandae.\",\n )}\n
\n
\n
\n {React.string(\"Code Example\")}\n
\n \n \n {React.string(\n {|let example = () => {\n let value = computeValue();\n let result = transform(value);\n process(result);\n};|},\n )}\n \n \n
\n {React.string(\"Conclusion\")}\n
\n
\n {React.string(\n \"Itaque earum rerum hic tenetur a sapiente delectus, ut aut reiciendis voluptatibus maiores alias consequatur aut perferendis doloribus asperiores repellat.\",\n )}\n
\n ;\n };\n};\n\nmodule Sidebar = {\n [@react.component]\n let make = () => {\n let relatedPosts = [|\n \"Understanding Server-Side Rendering\",\n \"The Future of Web Development\",\n \"Performance Optimization Tips\",\n \"Building Scalable Applications\",\n \"Modern JavaScript Frameworks\",\n |];\n\n let tags = [|\n \"React\",\n \"SSR\",\n \"Performance\",\n \"JavaScript\",\n \"OCaml\",\n \"Web Development\",\n \"Tutorial\",\n |];\n\n ;\n };\n};\n\nmodule CommentsSection = {\n [@react.component]\n let make = (~comments) => {\n \n
;\n };\n};\n\nmodule CheckboxField = {\n [@react.component]\n let make = (~id, ~label, ~description=?) => {\n
\n
\n \n
\n \n {switch (description) {\n | Some(desc) =>\n
{React.string(desc)}
\n | None => React.null\n }}\n
\n
\n
;\n };\n};\n\nmodule RadioGroup = {\n [@react.component]\n let make = (~name, ~label, ~options) => {\n ;\n };\n};\n\nmodule FormSection = {\n [@react.component]\n let make = (~title, ~description=?, ~children) => {\n
\n
\n {React.string(title)}\n
\n {switch (description) {\n | Some(desc) =>\n
{React.string(desc)}
\n | None => React.null\n }}\n children\n
;\n };\n};\n\nmodule ProgressSteps = {\n [@react.component]\n let make = (~steps, ~currentStep) => {\n ;\n };\n};\n\nmodule PersonalInfoForm = {\n [@react.component]\n let make = () => {\n \n
\n \n \n
\n \n \n \n \n ;\n };\n};\n\nmodule AddressForm = {\n [@react.component]\n let make = () => {\n \n \n \n
\n \n \n
\n
\n \n \n
\n ;\n };\n};\n\nmodule EmploymentForm = {\n [@react.component]\n let make = () => {\n \n \n \n \n \n \n ;\n };\n};\n\nmodule PreferencesForm = {\n [@react.component]\n let make = () => {\n \n \n \n \n
\n
\n {React.string(\"Notification Preferences\")}\n
\n \n \n \n \n
\n ;\n };\n};\n\nmodule AdditionalInfoForm = {\n [@react.component]\n let make = () => {\n \n \n \n \n \n \n ;\n };\n};\n\nmodule TermsForm = {\n [@react.component]\n let make = () => {\n \n \n
\n {React.string(\n \"By using our services, you agree to these terms. Please read them carefully.\",\n )}\n
\n
\n {React.string(\n \"Lorem ipsum dolor sit amet, consectetur adipiscing elit. Sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.\",\n )}\n
\n
\n {React.string(\n \"Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.\",\n )}\n
\n
\n {React.string(\n \"Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo.\",\n )}\n
\n ;\n };\n};\n\nlet generateItems = count =>\n Array.init(\n count,\n i => {\n let id = i + 1;\n let title = Printf.sprintf(\"Product %d\", id);\n let description =\n Printf.sprintf(\n \"This is the description for product %d. It contains useful information.\",\n id,\n );\n let price = 9.99 +. float_of_int(i mod 100);\n let rating = 3.0 +. float_of_int(i mod 20) /. 10.0;\n let inStock = i mod 7 != 0;\n (id, title, description, price, rating, inStock);\n },\n );\n\nmodule Wide10 = {\n let items = generateItems(10);\n\n [@react.component]\n let make = () => {\n
;\n };\n};\n\n[@react.component]\nlet make = () => ;\n"
},
{
"path": "benchmark/scenarios/dune",
"content": "(library\n (name benchmark_scenarios)\n (libraries\n server-reason-react.react\n server-reason-react.reactDom\n server-reason-react.js)\n (preprocess\n (pps server-reason-react.ppx server-reason-react.melange_ppx)))\n"
},
{
"path": "benchmark/streaming/dune",
"content": "(executable\n (name streaming_bench)\n (libraries\n unix\n lwt\n lwt.unix\n server-reason-react.js\n server-reason-react.react\n server-reason-react.reactDom\n benchmark_scenarios)\n (preprocess\n (pps server-reason-react.ppx lwt_ppx)))\n"
},
{
"path": "benchmark/streaming/streaming_bench.ml",
"content": "(** Streaming Benchmark for server-reason-react\n\n Measures:\n - Time to first byte (TTFB)\n - Time to full render\n - Chunk sizes\n - Memory during streaming *)\n\nlet measure_time_us f =\n let start = Unix.gettimeofday () in\n let result = f () in\n let stop = Unix.gettimeofday () in\n let time_us = (stop -. start) *. 1_000_000.0 in\n (result, time_us)\n\nlet format_time_us us =\n if us < 1000.0 then Printf.sprintf \"%.2fµs\" us\n else if us < 1_000_000.0 then Printf.sprintf \"%.2fms\" (us /. 1000.0)\n else Printf.sprintf \"%.2fs\" (us /. 1_000_000.0)\n\ntype scenario_result = {\n name : string;\n avg_static_time_us : float;\n avg_string_time_us : float;\n output_bytes : int;\n throughput_mb_s : float;\n}\n\nlet measure_render_methods ~name ~iterations render_element =\n Printf.printf \"Measuring %s...\\n%!\" name;\n\n let static_times = ref 0.0 in\n let string_times = ref 0.0 in\n let output_bytes = ref 0 in\n\n for _ = 1 to iterations do\n let element = render_element () in\n\n let html_static, static_time = measure_time_us (fun () -> ReactDOM.renderToStaticMarkup element) in\n static_times := !static_times +. static_time;\n\n let _html_string, string_time = measure_time_us (fun () -> ReactDOM.renderToString element) in\n string_times := !string_times +. string_time;\n\n output_bytes := String.length html_static\n done;\n\n let avg_static = !static_times /. float_of_int iterations in\n let avg_string = !string_times /. float_of_int iterations in\n let bytes = !output_bytes in\n let throughput = float_of_int bytes /. 1_000_000.0 /. (avg_static /. 1_000_000.0) in\n\n {\n name;\n avg_static_time_us = avg_static;\n avg_string_time_us = avg_string;\n output_bytes = bytes;\n throughput_mb_s = throughput;\n }\n\nlet print_result r =\n Printf.printf \"\\n%s\\n\" (String.make 60 '-');\n Printf.printf \"Scenario: %s\\n\" r.name;\n Printf.printf \"%s\\n\" (String.make 60 '-');\n Printf.printf \"renderToStaticMarkup: %s\\n\" (format_time_us r.avg_static_time_us);\n Printf.printf \"renderToString: %s\\n\" (format_time_us r.avg_string_time_us);\n Printf.printf \"Output size: %d bytes (%.2f KB)\\n\" r.output_bytes (float_of_int r.output_bytes /. 1024.0);\n Printf.printf \"Throughput: %.2f MB/s\\n\" r.throughput_mb_s;\n Printf.printf \"String overhead: %.1f%%\\n\"\n ((r.avg_string_time_us -. r.avg_static_time_us) /. r.avg_static_time_us *. 100.0)\n\nlet print_comparison_table results =\n Printf.printf \"\\n%s\\n\" (String.make 90 '=');\n Printf.printf \"COMPARISON TABLE\\n\";\n Printf.printf \"%s\\n\" (String.make 90 '=');\n Printf.printf \"%-20s %12s %12s %10s %12s\\n\" \"Scenario\" \"Static\" \"String\" \"Size\" \"Throughput\";\n Printf.printf \"%s\\n\" (String.make 90 '-');\n\n List.iter\n (fun r ->\n Printf.printf \"%-20s %12s %12s %9dB %10.1fMB/s\\n\" r.name (format_time_us r.avg_static_time_us)\n (format_time_us r.avg_string_time_us) r.output_bytes r.throughput_mb_s)\n results;\n\n Printf.printf \"%s\\n\" (String.make 90 '=')\n\nlet main () =\n let iterations = 100 in\n\n Printf.printf \"Streaming/Render Benchmark for server-reason-react\\n\";\n Printf.printf \"Iterations per scenario: %d\\n\\n\" iterations;\n\n let scenarios =\n let open Benchmark_scenarios in\n [\n (\"Trivial\", fun () -> Benchmark_scenarios.Trivial.make (Benchmark_scenarios.Trivial.makeProps ()));\n (\"ShallowTree\", fun () -> ShallowTree.make (ShallowTree.makeProps ()));\n (\"DeepTree10\", fun () -> DeepTree.Depth10.make (DeepTree.Depth10.makeProps ()));\n (\"DeepTree50\", fun () -> DeepTree.Depth50.make (DeepTree.Depth50.makeProps ()));\n (\"WideTree10\", fun () -> WideTree.Wide10.make (WideTree.Wide10.makeProps ()));\n (\"WideTree100\", fun () -> WideTree.Wide100.make (WideTree.Wide100.makeProps ()));\n (\"WideTree500\", fun () -> WideTree.Wide500.make (WideTree.Wide500.makeProps ()));\n (\"Table10\", fun () -> Table.Table10.make (Table.Table10.makeProps ()));\n (\"Table100\", fun () -> Table.Table100.make (Table.Table100.makeProps ()));\n (\"Table500\", fun () -> Table.Table500.make (Table.Table500.makeProps ()));\n (\"PropsSmall\", fun () -> PropsHeavy.Small.make (PropsHeavy.Small.makeProps ()));\n (\"PropsMedium\", fun () -> PropsHeavy.Medium.make (PropsHeavy.Medium.makeProps ()));\n (\"Ecommerce24\", fun () -> Ecommerce.Products24.make (Ecommerce.Products24.makeProps ()));\n (\"Ecommerce48\", fun () -> Ecommerce.Products48.make (Ecommerce.Products48.makeProps ()));\n (\"Dashboard\", fun () -> Dashboard.make (Dashboard.makeProps ()));\n (\"Blog50\", fun () -> Blog.Blog50.make (Blog.Blog50.makeProps ()));\n (\"Form\", fun () -> Form.make (Form.makeProps ()));\n ]\n in\n\n let results =\n List.map\n (fun (name, render_element) ->\n let result = measure_render_methods ~name ~iterations render_element in\n print_result result;\n result)\n scenarios\n in\n\n print_comparison_table results;\n\n Lwt.return ()\n\nlet () = Lwt_main.run (main ())\n"
},
{
"path": "demo/README.md",
"content": "## Requirements\n\n- npm (and run `npm install` from the root of the project)\n- [watchexec](https://github.com/watchexec/watchexec)\n\n# Usage\n\nFrom the root of the project, run\n\n```bash\n# 1 terminal to compile the code\nmake demo-build-watch\n# 2 terminal to run the server\nmake demo-serve-watch\n```\n\n# fs explanation\n\nThe app consist of 3 folders: `universal`, `server` and `client`, which contains each compilation target defined by dune.\n\n## `client/`\n\nA folder that contains the code executed in the client only. It's defined in dune as a `melange.emit` to emit JavaScript from Reason via Melange. It's a a tiny entrypoint to render `Shared_js.App` component.\n\n```re\nswitch (ReactDOM.querySelector(\"#root\")) {\n| Some(el) => ReactDOM.render(, el)\n| None => ()\n};\n```\n\n## `server/`\n\nAn executable that expose a HTTP server using [dream](https://aantron.github.io/dream). It serves a different routes, all of them written in React and send it as a string with `ReactDOM.renderToString` or as an `application/octet-stream` with [`Dream.stream`](https://aantron.github.io/dream/#streams).\n\n## `universal/`\n\nThis folder contains a library for shared code between `client` and `server`. dune generates two sub-libraries `Shared_js` and `Shared_native` (by using `copy_files#`) with separate dependencies and preprocessors for each:\n\n```dune\n; demo/universal/js/dune\n(library\n (name shared_js)\n (modes melange)\n (libraries reason-react)\n (preprocess (pps reason-react-ppx)))\n\n(copy_files# \"../*.re\")\n```\n\n```dune\n; demo/universal/native/dune\n(library\n (name shared_native)\n (modes native)\n (libraries\n server-reason-react.react\n server-reason-react.reactDom)\n (preprocess\n (pps server-reason-react.ppx)))\n```\n\n`shared_js` is used on the `client/dune` melange.emit to be compiled by Melange while `shared_native` is used in the `server/dune` executable compiled by OCaml\n"
},
{
"path": "demo/client/DummyRouterRSC.re",
"content": "module DOM = Webapi.Dom;\nmodule Location = DOM.Location;\nmodule History = DOM.History;\nmodule ReadableStream = Webapi.ReadableStream;\n\n[@mel.scope \"window\"] [@mel.set]\nexternal setNavigate: (Webapi.Dom.Window.t, string => unit) => unit =\n \"__navigate\";\n\nexternal readable_stream: ReadableStream.t =\n \"window.srr_stream.readable_stream\";\n\nlet fetchApp = url => {\n let headers =\n Fetch.HeadersInit.make({ \"Accept\": \"application/react.component\" });\n Fetch.fetchWithInit(\n url,\n Fetch.RequestInit.make(~method_=Fetch.Get, ~headers, ()),\n );\n};\n\nlet callServer = (path: string, args) => {\n let headers =\n Fetch.HeadersInit.make({\n \"Accept\": \"application/react.action\",\n \"ACTION_ID\": path,\n });\n ReactServerDOMEsbuild.encodeReply(args)\n |> Js.Promise.then_(body => {\n let body = Fetch.BodyInit.make(body);\n Fetch.fetchWithInit(\n \"/\",\n Fetch.RequestInit.make(~method_=Fetch.Post, ~headers, ~body, ()),\n )\n |> Js.Promise.then_(result => {\n let body = Fetch.Response.body(result);\n ReactServerDOMEsbuild.createFromReadableStream(body);\n });\n });\n};\n\nmodule App = {\n let initialRSCModel =\n ReactServerDOMEsbuild.createFromReadableStream(\n ~callServer,\n readable_stream,\n );\n\n [@react.component]\n let make = () => {\n let initialElement = React.Experimental.usePromise(initialRSCModel);\n let (layout, setLayout) = React.useState(() => initialElement);\n\n let navigate = search => {\n let location = DOM.window->DOM.Window.location;\n let origin = Location.origin(location);\n let pathname = Location.pathname(location);\n\n let currentSearch = Location.search(location);\n let currentParams = URL.SearchParams.makeExn(currentSearch);\n\n let newSearchParams = Js.Dict.empty();\n\n URL.SearchParams.forEach(currentParams, (value, key) => {\n Js.Dict.set(newSearchParams, key, value)\n });\n\n let newParams = URL.SearchParams.makeExn(search);\n URL.SearchParams.forEach(newParams, (value, key) => {\n Js.Dict.set(newSearchParams, key, value)\n });\n\n let finalSearch =\n newSearchParams\n |> Js.Dict.entries\n |> URL.SearchParams.makeWithArray\n |> URL.SearchParams.toString;\n\n if (currentSearch == \"?\" ++ finalSearch) {\n ();\n } else {\n let finalURL =\n URL.makeExn(origin ++ pathname)\n ->URL.setSearchAsString(finalSearch);\n let response = fetchApp(URL.toString(finalURL));\n ReactServerDOMEsbuild.createFromFetch(response)\n |> Js.Promise.then_(element => {\n History.pushState(\n History.state(DOM.history),\n \"\",\n URL.toString(finalURL),\n DOM.history,\n );\n setLayout(_ => element);\n Js.Promise.resolve();\n })\n |> ignore;\n ();\n };\n };\n\n /* Publish navigate fn into window.__navigate */\n setNavigate(Webapi.Dom.window, navigate);\n\n {\n Js.log(error);\n
{React.string(\"Something went wrong\")}
;\n }}>\n layout\n ;\n };\n};\n\nlet document: option(Webapi.Dom.Element.t) = [%mel.raw \"window.document\"];\n\nlet body =\n Webapi.Dom.document\n ->Webapi.Dom.Document.asHtmlDocument\n ->Option.bind(Webapi.Dom.HtmlDocument.body);\n\nswitch (document) {\n| Some(element) =>\n React.startTransition(() => {\n let _ = ReactDOM.Client.hydrateRoot(element, );\n ();\n })\n| None => Js.log(\"Root element not found\")\n};\n"
},
{
"path": "demo/client/HydrateRoot.re",
"content": "let element = Webapi.Dom.Document.querySelector(\"#root\", Webapi.Dom.document);\n\nswitch (element) {\n| Some(el) =>\n let _ = ReactDOM.Client.hydrateRoot(el, );\n ();\n| None => Js.log(\"No root element found\")\n};\n"
},
{
"path": "demo/client/NestedRouterRSC.re",
"content": "module ReadableStream = Webapi.ReadableStream;\n\nexternal readable_stream: ReadableStream.t =\n \"window.srr_stream.readable_stream\";\n\nlet document: option(Webapi.Dom.Element.t) = [%mel.raw \"window.document\"];\n\nlet callServer = (path: string, args) => {\n let headers =\n Fetch.HeadersInit.make({\n \"Accept\": \"application/react.action\",\n \"ACTION_ID\": path,\n });\n ReactServerDOMEsbuild.encodeReply(args)\n |> Js.Promise.then_(body => {\n let body = Fetch.BodyInit.make(body);\n Fetch.fetchWithInit(\n \"/\",\n Fetch.RequestInit.make(~method_=Fetch.Post, ~headers, ~body, ()),\n )\n |> Js.Promise.then_(result => {\n let body = Fetch.Response.body(result);\n ReactServerDOMEsbuild.createFromReadableStream(body);\n });\n });\n};\n\nlet initialRSCModel =\n ReactServerDOMEsbuild.createFromReadableStream(\n ~callServer,\n readable_stream,\n );\n\nmodule ClientApp = {\n [@react.component]\n let make = () => {\n let initialElement = React.Experimental.usePromise(initialRSCModel);\n\n initialElement;\n };\n};\n\nswitch (document) {\n| Some(element) =>\n React.startTransition(() => {\n let _ = ReactDOM.Client.hydrateRoot(element, );\n ();\n })\n| None => Js.log(\"Root element not found\")\n};\n"
},
{
"path": "demo/client/RenderRoot.re",
"content": "module Dom = Webapi.Dom;\n\nlet element = Dom.Document.querySelector(\"#root\", Dom.document);\n\nswitch (element) {\n| Some(el) =>\n let root = ReactDOM.Client.createRoot(el);\n ReactDOM.Client.render(root, );\n| None => Js.log(\"No root element found\")\n};\n"
},
{
"path": "demo/client/ServerOnlyRSC.re",
"content": "let root =\n Webapi.Dom.document\n |> Webapi.Dom.Document.querySelector(\"#root\")\n |> Option.get;\n\nlet root = ReactDOM.Client.createRoot(root);\nlet headers =\n Fetch.HeadersInit.make({ \"Accept\": \"application/react.component\" });\nlet fetch =\n Fetch.fetchWithInit(\n Routes.serverOnlyRSC,\n Fetch.RequestInit.make(~method_=Fetch.Get, ~headers, ()),\n );\n\nReactServerDOMEsbuild.createFromFetch(fetch)\n|> Js.Promise.then_(app => {\n ReactDOM.Client.render(root, app);\n Js.Promise.resolve();\n })\n|> ignore;\n"
},
{
"path": "demo/client/SinglePageRSC.re",
"content": "let callServer = (path: string, args) => {\n let headers =\n Fetch.HeadersInit.make({\n \"Accept\": \"application/react.action\",\n \"ACTION_ID\": path,\n });\n ReactServerDOMEsbuild.encodeReply(args)\n |> Js.Promise.then_(body => {\n let body = Fetch.BodyInit.make(body);\n Fetch.fetchWithInit(\n \"/\",\n Fetch.RequestInit.make(~method_=Fetch.Post, ~headers, ~body, ()),\n )\n |> Js.Promise.then_(result => {\n let body = Fetch.Response.body(result);\n ReactServerDOMEsbuild.createFromReadableStream(body);\n });\n });\n};\n\nlet root =\n Webapi.Dom.document\n |> Webapi.Dom.Document.querySelector(\"#root\")\n |> Option.get;\n\nlet root = ReactDOM.Client.createRoot(root);\nlet headers =\n Fetch.HeadersInit.make({ \"Accept\": \"application/react.component\" });\nlet fetch =\n Fetch.fetchWithInit(\n Routes.singlePageRSC,\n Fetch.RequestInit.make(~method_=Fetch.Get, ~headers, ()),\n );\n\nReactServerDOMEsbuild.createFromFetch(~callServer, fetch)\n|> Js.Promise.then_(app => {\n ReactDOM.Client.render(root, app);\n Js.Promise.resolve();\n })\n|> ignore;\n"
},
{
"path": "demo/client/build.mjs",
"content": "import Esbuild from \"esbuild\";\nimport Path from \"path\";\nimport extractClientComponents from \"../../packages/esbuild-plugin/plugin.mjs\";\n\nasync function build(entryPoints, { env, output, extract, mockWebpackRequire }) {\n\tconst outfile = output;\n\tconst outdir = Path.dirname(outfile);\n\tconst splitting = true;\n\n\tconst bootstrapOutput = Path.join(Path.dirname(outfile), \"bootstrap.js\");\n\n\tlet plugins = [];\n\tif (extract) {\n\t\tplugins.push(\n\t\t\textractClientComponents({\n\t\t\t\ttarget: \"app\",\n\t\t\t\tmockWebpackRequire,\n\t\t\t\tbootstrapOutput,\n\t\t\t\tentrypoints: [\"SinglePageRSC.re.js\", \"DummyRouterRSC.re.js\", \"NestedRouterRSC.re.js\"],\n\t\t\t}),\n\t\t);\n\t}\n\n\tconst isDev = env === \"development\";\n\n\ttry {\n\t\tconst result = await Esbuild.build({\n\t\t\tentryPoints,\n\t\t\tentryNames: \"[name]\",\n\t\t\tbundle: true,\n\t\t\tlogLevel: \"debug\",\n\t\t\tplatform: \"browser\",\n\t\t\tformat: \"esm\",\n\t\t\tsplitting,\n\t\t\toutdir,\n\t\t\tplugins,\n\t\t\twrite: true,\n\t\t\ttreeShaking: isDev ? false : true,\n\t\t\tminify: isDev ? false : true,\n\t\t\tdefine: {\n\t\t\t\t\"process.env.NODE_ENV\": `\"${env}\"`,\n\t\t\t\t\"__DEV__\": `\"${isDev}\"`, /* __DEV__ is used by react-client code */\n\t\t\t},\n\t\t});\n\n\t\tentryPoints.forEach((entryPoint) => {\n\t\t\tconsole.log('Build completed successfully for \"' + entryPoint + '\"');\n\t\t});\n\t\treturn result;\n\t} catch (error) {\n\t\tconsole.error(\"\\nBuild failed:\", error);\n\t\tprocess.exit(1);\n\t}\n}\n\nfunction parseArgv(argv) {\n\tconst args = argv.slice(2);\n\tconst result = { _: [] };\n\n\tfor (let i = 0; i < args.length; i++) {\n\t\tconst arg = args[i];\n\n\t\tif (arg.startsWith(\"--\")) {\n\t\t\tconst longArg = arg.slice(2);\n\t\t\tif (longArg.includes(\"=\")) {\n\t\t\t\tconst [key, value] = longArg.split(\"=\");\n\t\t\t\tresult[key] = parseValue(value);\n\t\t\t} else if (i + 1 < args.length && !args[i + 1].startsWith(\"-\")) {\n\t\t\t\tresult[longArg] = parseValue(args[++i]);\n\t\t\t} else {\n\t\t\t\tresult[longArg] = true;\n\t\t\t}\n\t\t} else if (arg.startsWith(\"-\")) {\n\t\t\tconst shortArg = arg.slice(1);\n\t\t\tif (shortArg.includes(\"=\")) {\n\t\t\t\tconst [key, value] = shortArg.split(\"=\");\n\t\t\t\tresult[key] = parseValue(value);\n\t\t\t} else if (i + 1 < args.length && !args[i + 1].startsWith(\"-\")) {\n\t\t\t\tresult[shortArg] = parseValue(args[++i]);\n\t\t\t} else {\n\t\t\t\tfor (const char of shortArg) {\n\t\t\t\t\tresult[char] = true;\n\t\t\t\t}\n\t\t\t}\n\t\t} else {\n\t\t\tresult._.push(parseValue(arg));\n\t\t}\n\t}\n\n\treturn result;\n}\n\nfunction parseValue(value) {\n\tif (value === \"true\") return true;\n\tif (value === \"false\") return false;\n\tif (value === \"null\") return null;\n\tif (!isNaN(value)) return Number(value);\n\treturn value;\n}\n\nfunction camelCaseKeys(obj) {\n\treturn Object.fromEntries(\n\t\tObject.entries(obj).map(([key, value]) => [\n\t\t\tkey.replace(/-([a-z])/g, (_, letter) => letter.toUpperCase()),\n\t\t\tvalue,\n\t\t]),\n\t);\n}\n\nconst flags = parseArgv(process.argv);\nconst options = camelCaseKeys(flags);\nconst entryPoints = options._;\n\nbuild(entryPoints, options);\n"
},
{
"path": "demo/client/dune",
"content": "(env\n (_\n (env-vars\n (\"DEMO_ENV\" \"development\"))))\n\n(melange.emit\n (enabled_if\n (= %{profile} dev))\n (target app)\n (module_systems\n (es6 re.js))\n (libraries\n melange\n reason-react\n server-reason-react.react-server-dom-esbuild\n server-reason-react.url_js\n melange.dom\n melange-webapi\n melange-fetch\n demo_shared_js\n nested_router_js)\n (preprocess\n (pps browser_ppx -js reason-react-ppx melange.ppx)))\n\n(rule\n (enabled_if\n (= %{profile} dev))\n (alias client)\n (deps\n (package server-reason-react)\n (alias_rec melange)\n (:script build.mjs)\n (:entrypoints\n \"app/demo/client/HydrateRoot.re.js\"\n \"app/demo/client/RenderRoot.re.js\"\n \"app/demo/client/SinglePageRSC.re.js\"\n \"app/demo/client/DummyRouterRSC.re.js\"\n \"app/demo/client/NestedRouterRSC.re.js\"\n \"app/demo/client/ServerOnlyRSC.re.js\")\n (source_tree node_modules)\n (file package.json)\n (source_tree ../../packages/esbuild-plugin))\n (action\n (run\n node\n %{script}\n %{entrypoints}\n --output=app/demo/client/\n --extract=true\n --env=%{env:DEMO_ENV='production'})))\n"
},
{
"path": "demo/client/package.json",
"content": "{\n \"name\": \"client\",\n \"version\": \"0.0.0\",\n \"keywords\": [],\n \"author\": \"\",\n \"license\": \"ISC\",\n \"dependencies\": {\n \"@pedrobslisboa/react-client\": \"^19.1.0\",\n \"esbuild\": \"^0.21.4\",\n \"react\": \"^19.1.0\",\n \"react-dom\": \"^19.1.0\",\n \"react-server-dom-webpack\": \"^19.1.0\"\n }\n}\n"
},
{
"path": "demo/dream-nested-router/dune",
"content": "(test\n (name test_router_rsc)\n (enabled_if\n (= %{profile} dev))\n (libraries\n alcotest\n dream\n react\n js\n server-reason-react.url_native\n nested_router_native)\n (preprocess\n (pps melange_native_ppx)))\n"
},
{
"path": "demo/dream-nested-router/js/HistoryCache.re",
"content": "/**\n * HistoryCache is a module that caches the pages.\n * It's used to avoid fetching the same page again when navigating back and forward.\n * For FullPage, we cache the whole page element.\n * For SubRoute, we cache only the sub-route element.\n */\n\ntype page =\n | FullPage(React.element)\n | SubRoute(React.element);\n\nmodule Make = (Config: {\n type key;\n }) => {\n type t = {\n cache: Hashtbl.t(Config.key, page),\n keyQueue: Queue.t(Config.key),\n maxSize: int,\n };\n\n let create = (~maxSize=10, ()) => {\n cache: Hashtbl.create(maxSize),\n keyQueue: Queue.create(),\n maxSize,\n };\n\n let set = (t, ~key, ~page) => {\n if (!Hashtbl.mem(t.cache, key)) {\n if (Queue.length(t.keyQueue) >= t.maxSize) {\n let oldestKey = Queue.take(t.keyQueue);\n Hashtbl.remove(t.cache, oldestKey);\n };\n\n Queue.add(key, t.keyQueue);\n };\n\n Hashtbl.replace(t.cache, key, page);\n };\n\n let get = (t, ~key) => {\n Hashtbl.find_opt(t.cache, key);\n };\n};\n"
},
{
"path": "demo/dream-nested-router/js/HistoryState.re",
"content": "module DOM = Webapi.Dom;\nmodule History = DOM.History;\n\n/**\n * Melange webapi don't set state type, so we use Obj.magic to cast it to the correct type while the PR is not merged.\n * https://github.com/melange-community/melange-webapi/blob/80c6ededd06cc66b75445d1ed5c855e050b156a0/src/Webapi/Dom/Webapi__Dom__History.re#L2\n * PR: https://github.com/melange-community/melange-webapi/pull/29\n */\n[@platform js]\ntype t = History.state;\n\nlet fromEvent = event =>\n DOM.Event.target(event)\n ->DOM.EventTarget.unsafeAsWindow\n ->DOM.Window.history\n ->History.state;\n\nlet toJs: History.state => Js.t({..}) = state => state |> Obj.magic;\nlet fromJs: Js.t({..}) => History.state = state => state |> Obj.magic;\n\n[@platform js]\nlet push = (state, path) => {\n History.pushState(state, \"\", path, DOM.history);\n let _ =\n DOM.EventTarget.dispatchEvent(\n DOM.Event.make(\"popstate\"),\n DOM.Window.asEventTarget(DOM.window),\n );\n ();\n};\n\n[@platform js]\nlet replace = (state, path) => {\n History.replaceState(state, \"\", path, DOM.history);\n let _ =\n DOM.EventTarget.dispatchEvent(\n DOM.Event.make(\"popstate\"),\n DOM.Window.asEventTarget(DOM.window),\n );\n ();\n};\n"
},
{
"path": "demo/dream-nested-router/js/VirtualHistory.re",
"content": "/**\n Virtual History is a state of routes that the client has visited.\n It's used to store the routes path and renderPage function.\n This is how the client knows which route is rendered, and which subroute needs to get rendered as pageconsumer (children)\n\n let state = [{\n path: \"/\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/student\",\n renderPage: (pageElement) => {...},\n }]\n\n When the client visits /student/:id, we find the parent route (/student) with VirtualHistory.find and we call the renderPage function to update the page/subroutes.\n The virtual state history will be updated to:\n\n [\n {\n path: \"/\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/student\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/student/:id\",\n renderPage: (pageElement) => {...},\n },\n ]\n */\n\ntype route = {\n path: string,\n renderPage: React.element => unit,\n};\n\nlet state = ref([]);\n\n/* When a route is visited, we add it to the virtual state history */\nlet push = (~path, ~renderPage): unit => {\n let filteredRoutes = List.filter(route => route.path != path, state^);\n\n state :=\n filteredRoutes\n @ [\n {\n path,\n renderPage,\n },\n ];\n};\n\nlet find = (path: string) => {\n List.find_opt(route => route.path == path, state^);\n};\n\nlet cleanup = () => {\n state := [];\n};\n\nlet cleanPathState = path => {\n state :=\n List.filter(\n route => route.path |> String.length <= (path |> String.length),\n state^,\n );\n};\n\nlet getAllRoutes = () => {\n state^;\n};\n"
},
{
"path": "demo/dream-nested-router/js/dune",
"content": "(library\n (name nested_router_js)\n (enabled_if\n (= %{profile} dev))\n (modes melange)\n (wrapped false)\n (libraries\n reason-react\n server-reason-react.react-server-dom-esbuild\n melange-webapi\n melange.belt\n melange.js\n melange-fetch\n melange.dom\n server-reason-react.url_js\n server-reason-react.rsc\n server-reason-react.runtime)\n (preprocess\n (pps\n browser_ppx\n -js\n server-reason-react.ppx\n -melange\n -shared-folder-prefix=js/\n server-reason-react.rsc.ppx\n melange.ppx\n reason-react-ppx)))\n\n(copy_files\n (files \"../native/shared/*.re\"))\n"
},
{
"path": "demo/dream-nested-router/native/README.md",
"content": "# Nested Router\n\nThe Nested Router allows us to navigate through the application while requesting only the minimum required to render the page.\n\n\n\nTo understand how this navigation works, we must understand the concepts behind it:\n\n## Route\n\nA route is composed of a **Layout**, a **page**, and **sub-routes**.\n\nA layout is the UI shared across sub-routes. On navigation, layouts preserve state, remain interactive, and do not rerender, while the page is the dynamic content of the current route and is replaced by the sub-route content when navigate to.\nThe sub-route, as the name suggests, is a route composed of the previous one.\n\nAs we can see in the sample below:\n\n\n\nOn this sample, we can see the `/`, `/students`, and `/students/lola` pages.\nWe can divide those into:\n\n- \"/\"\n - Main Layout (Top bar) (Orange)\n - Main Page (Orange)\n\n- \"/student\"\n - Main Layout (Orange)\n - Students Layout (Sidebar) (Red)\n - Students Page (Red)\n \n- \"/student/lola\"\n - Main Layout (Top bar) (Orange)\n - Students Layout (Sidebar) (Red)\n - Student Page (Blue)\n\nAs we can see, the Main Layout is present on all pages because it is inherited on sub-routes; as such, the Students Layout is present on \"/student\" and \"/student/lola\". On the other hand, the \"page\" is dynamic, defined by the current route.\n\n### How does the control of the route happen?\n\nThe main feature of having the control of the route is to be able to render the page content dynamically, based on the current route, so we can request the minimum required to render the page content, keeping the layouts static and only rendering the page content when the route changes.\n\nFor example:\n- Current route -> /\n ```reason\n module MainLayout = {\n [@react.component]\n let make = (~children) => {\n
\n \n children\n
\n }\n }\n module MainPage = {\n [@react.component]\n let make = (~children) => {\n
\n
\"Home\"
\n \n
\n }\n }\n\n /**\n Visual Representation of the MainLayout and MainPage components\n \n \n \n */\n ```\n- Target route -> /students\n ```reason\n module StudentsLayout = {\n [@react.component]\n let make = (~children) => {\n
\n \n children\n
\n }\n }\n module StudentsPage = {\n [@react.component]\n let make = (~children) => {\n
\n
\"Students\"
\n \n
\n }\n }\n\n /**\n Visual Representation of the StudentsLayout and StudentsPage components\n \n \n \n \n \n */\n ```\n\nIn that case we only need the sub-route content, the /students, composed of StudentsLayout and StudentsPage, taking over the MainPage component as the page content. The MainLayout keeps the same, no rerender as the Layout is server component.\nTo make this work we have a state that stores the route, and a function that updates it when the user navigates to a new route.\nThe module responsible for this is the `Route` module. All routes are Rendered through the `Route` component.\nFor example:\n```reason\n} layout={} />\n} layout={} />\n```\n\nAs soon we navigate to \"/students\", inside the Route component of the \"/\" path, it will render the `` component in the place of the `MainPage` component inside the \"/\" Route component, setting the route state content to the ``.\n\n⚠️ **Important** Route is a client component, so the props must respect the React rules for client components, which means that we can't pass a function component as a prop.\n```reason\n} layout={(~children) => } />\n```\nThis will cause an error because the function component is not client prop.\n\n#### So how can we update the MainPage to StudentsPage when the user navigates to \"/students\" if the cannot call layout(~childre=) inside the Route component?\n\nThe workaround for it is to use the Context API to pass the children to the layout, through a `Consumer`\n```reason\nmodule PageConsumer = {\n [@react.client.component]\n let make = () => {\n let value = React.useContext(context);\n\n value;\n };\n}\n\n[@react.client.component]\nlet make =\n (~path: string, ~layout: React.element, ~page: option(React.element)) => {\n let (page, setPage) =\n React.useState(() => page |> Option.value(~default=React.null));\n\n let%browser_only renderPage = pageElement => setPage(_ => pageElement);\n\n \n layout\n ;\n};\n```\nThat way we send to the client the page content, and the layout will be rendered as: `layout(~children=)`.\nWe can dynamically update the page content by calling the `renderPage` function, updating the page content on the layout. With minimum re-renders.\n\n### Virtual History\n\nTo make all this work, we need to keep track of the visited routes so we can identify the parent route and the sub-route to render the correct page content.\n\n```reason\ntype branch = {\n path: string,\n renderPage: React.element => unit,\n};\n\nlet state = ref([]);\n```\n\nThat way we can find the route by calling the `find` function with the path of the route, and render the page content by calling the `renderPage` function.\nFor example\n```reason\n// Current Virtual History state\n[\n {\n path: \"/\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/students\",\n renderPage: (pageElement) => {...},\n },\n]\n\n// navigating from \"/students\" to \"/students/:name\":\nlet navigate = (~to: string) => {\n // ...\n let route = VirtualHistory.find(\"/students\");\n route.renderPage(} />);\n // ...\n}\n\n// After navigating to \"/students/:name\" the Virtual History state will be updated to:\n[\n {\n path: \"/\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/students\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/students/:name\",\n renderPage: (pageElement) => {...},\n },\n]\n\n// navigating from \"/students/lola\" to \"/students\":\nlet navigate = (~to: string) => {\n // ...\n let route = VirtualHistory.find(\"/\");\n route.renderPage(} layout={} />);\n // ...\n}\n\n// After navigating to \"/\" the Virtual History state will be updated to:\n[\n {\n path: \"/\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/students\",\n renderPage: (pageElement) => {...},\n },\n]\n```\n\nOn every Route component, we push the route to the virtual history, and render the page content by calling the `renderPage` function. That way the Virtual History state is always up to date with the current route.\n```reason\n[@react.client.component]\nlet make =\n (~path: string, ~layout: React.element, ~page: option(React.element)) => {\n let (page, setPage) =\n React.useState(() => page |> Option.value(~default=React.null));\n\n let%browser_only renderPage = pageElement => setPage(_ => pageElement);\n\n (\n if (isFirstRender.current) {\n isFirstRender.current = false;\n VirtualHistory.push(~path, ~renderPage);\n }\n );\n\n \n layout\n ;\n};\n```\n\n## Dynamic Routes\n\nDynamic routes are routes that have a dynamic parameter, like \"/students/:name\". That allows us to render the same route with different content based on the dynamic parameter.\nFor example:\n\n```reason\nmodule StudentPage = {\n [@react.client.component]\n let make = (~dynamicParams: DynamicParams.t) => {\n let name = DynamicParams.find(\"name\", dynamicParams);\n
\n
\"Student \" ++ id
\n \n
\n };\n};\n```\n\nThe dynamic parameters can also be accessed in any client component by using the `Router.use` hook.\n```reason\nlet {dynamicParams, ..._} = Router.use();\nlet name = DynamicParams.find(\"name\", dynamicParams);\n```\n\n## Router\n\nTo control the routes navigation, we need to use the `Router` component, which provides the dynamic params, url and navigation function to the application.\n```reason\n[@react.client.component]\nlet make = () => {\n let {navigate, dynamicParams, url, _} = Router.use();\n\n
\n};\n```\n\n### Navigation\n\nThe navigate function takes care of identifying the sub-route path to render the correct page content, so we request only the minimum required to render the page content.\nExample:\n```reason\n// current route: /students\nnavigate(~to=\"/students/lola\");\n// Parent route: /students\n// Sub-route: /lola\n// Request: /students/lola?toSubRoute=/lola\n```\nIn the sample above, the request is for the `/students/lola` route (In the server it falls into the `/students/:name` route) but we only want to render the `/lola` route, thats why we send the `toSubRoute` query param with the sub-route path. On the Dream handler, we split the target to get the sub-route path and the parent route path. In that case, the parent route path is `/students` and the sub-route path is `/:name`.\nWe then return the `/:name` route and update the Virtual History item `/students` to render the `/:name` route. Updating the Virtual History state to:\n```reason\n[\n {\n path: \"/\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/students\",\n renderPage: (pageElement) => {...},\n },\n {\n path: \"/students/:name\",\n renderPage: (pageElement) => {...},\n },\n]\n```\n\n## Route definitions\n\nAfter knowing how the navigation works, we can now understand how to define the routes.\n\nWe declare the routes as a tree of routes, where each route can have a layout and a page.\n```reason\ntype route = {\n path: string,\n layout: option(React.element),\n page: option(React.element),\n subRoutes: option(list(route)),\n};\n\ntype routeDefinitionsTree = {\n mainLayout: React.element,\n mainPage: React.element,\n routes: list(route),\n};\n\nlet routeDefinitionsTree = {\n mainLayout: ,\n mainPage: ,\n routes: [\n {\n path: \"/\",\n layout: Some(),\n page: Some(),\n subRoutes: Some([\n {\n path: \"/students\",\n layout: Some(),\n page: Some(),\n subRoutes: Some([\n {\n path: \"/students/:name\",\n layout: None,\n page: Some(),\n subRoutes: None,\n },\n ]),\n },\n ]),\n },\n ],\n};\n```\n\n⚠️ The routeDefinitionsTree as the name suggests is a tree of routes, so it starts from a branch and goes down to the leaves, the main branch is the \"/\", so we don't need to define the \"/\" branch. Also, the MainLayout and MainPage are special as they don't have dynamic params.\n\nIt's from the route definitions tree that the Dream handler generates the routes paths and find which route to render based on the current path.\n```reason\nlet routesPaths = [\n \"/\",\n \"/students\",\n \"/students/:name\",\n];\n\nlet route = routes |> RouterRSC.getRoute(~request, ~definition=\"/students/:name\", routes);\n/** Result:\n }\n page={\n Some(\n }\n page={\n Some(\n }\n page={Some()}\n />\n )\n }\n />\n )\n }\n />\n*/\n```\n\n\n# IMPROVEMENTS\n\n- Type safe routes (ppx_deriving_routes?)\n- Loading state\n- 404 state"
},
{
"path": "demo/dream-nested-router/native/RouterRSC.re",
"content": "/**\n* RouterRSC is a module that provides the helpers to build the route and the layout component from the route definitions.\n*/\nmodule type MAIN_LAYOUT = {\n [@react.component]\n let make: (~children: React.element, unit) => React.element;\n};\n\nmodule type MAIN_PAGE = {\n [@react.component]\n let make: (~query: URL.SearchParams.t, unit) => React.element;\n};\n\n/**\n * A layout is the UI that is shared between multiple pages.\n * On navigation, layouts preserve state, remain interactive, and do not rerender.\n * Why there is no queryParams in the layout?\n * As it does not rerender on navigation, it cannot access search params which would otherwise become stale.\n */\nmodule type LAYOUT = {\n [@react.component]\n let make:\n (~children: React.element, ~params: DynamicParams.t, unit) => React.element;\n};\n\n/**\n * A page is the UI that is rendered on a specific route.\n */\nmodule type PAGE = {\n [@react.component]\n let make:\n (~params: DynamicParams.t, ~query: URL.SearchParams.t, unit) =>\n React.element;\n};\n\nmodule type NOT_FOUND = {\n [@react.component]\n let make: (~path: string, unit) => React.element;\n};\n\nmodule type LOADING = {\n [@react.component]\n let make: unit => React.element;\n};\n\ntype routeConfig = {\n path: string,\n layout: option(module LAYOUT),\n page: option(module PAGE),\n loading: option(module LOADING),\n /**\n * children is a list of routes that are nested within the current route.\n * It is used to render a specific UI within a parent route layout.\n * A sub-route \"takes\" the parent page place in the layout.\n */\n children: list(routeConfig),\n};\n\ntype t = {\n layout: option(module MAIN_LAYOUT),\n page: (module MAIN_PAGE),\n notFound: option(module NOT_FOUND),\n loading: option(module LOADING),\n routes: list(routeConfig),\n};\n\nlet route = (~path, ~layout=?, ~page=?, ~loading=?, children, ()) => {\n path,\n layout,\n page,\n loading,\n children,\n};\n\nlet make = (~layout=?, ~page, ~notFound=?, ~loading=?, routes) => {\n layout,\n page,\n notFound,\n loading,\n routes,\n};\n\nlet extractDynamicParam = (request, segment) => {\n String.starts_with(segment, ~prefix=\":\")\n ? {\n let key = segment->String.sub(1, String.length(segment) - 1);\n Some((key, Dream.param(request, key)));\n }\n : None;\n};\n\nlet renderPage = (~pageOpt, ~loadingOpt, ~globalLoading, ~params, ~query) => {\n switch (pageOpt) {\n | None => React.null\n | Some(page) =>\n module Page = (val page: PAGE);\n let pageElement = ;\n let loading =\n switch (loadingOpt, globalLoading) {\n | (Some(_), _) => loadingOpt\n | (None, Some(_)) => globalLoading\n | _ => None\n };\n switch (loading) {\n | None => pageElement\n | Some(loading) =>\n module Loading = (val loading: LOADING);\n }> pageElement ;\n };\n };\n};\n\nlet renderMainPage = (~page, ~globalLoading, ~query) => {\n module Page = (val page: MAIN_PAGE);\n let pageElement = ;\n switch (globalLoading) {\n | None => pageElement\n | Some(loading) =>\n module Loading = (val loading: LOADING);\n }> pageElement ;\n };\n};\n\nmodule DefaultMainLayout = {\n [@react.component]\n let make = (~children) => children;\n};\n\nlet renderMainLayout = (~layoutOpt, ~children) => {\n module Layout = (\n val layoutOpt\n |> Option.value(\n ~default=(module DefaultMainLayout): (module MAIN_LAYOUT),\n )\n );\n children ;\n};\n\nlet renderNotFound = (~notFound, ~path) => {\n switch (notFound) {\n | None => React.null\n | Some(notFound) =>\n module NotFound = (val notFound: NOT_FOUND);\n ;\n };\n};\n\n/**\n * Returns the React.element for the given path definition from the routes tree.\n * Example:\n * - definition: /students/:id\n * - React.element returned:\n * }\n * pageconsumer={\n * }\n * pageconsumer={}\n * />\n * }\n * />\n */\nlet getRoute =\n (\n ~initialDynamicParams=DynamicParams.create(),\n ~globalLoading=None,\n ~definition: string,\n ~request: Dream.request,\n routes: list(routeConfig),\n ) => {\n let pathSegments =\n String.split_on_char('/', definition)\n |> List.filter(segment => segment != \"\");\n let query =\n Dream.all_queries(request)\n |> Array.of_list\n |> URL.SearchParams.makeWithArray;\n\n // Goes through the route definitions to find the correct route from the definition\n let rec aux =\n (\n routes: list(routeConfig),\n pathSegments,\n parentPath,\n currentDynamicParams,\n )\n : option(React.element) => {\n switch (routes, pathSegments) {\n | ([route, ...restRoutes], [segment, ...restSegments]) =>\n let currentRoutePath = parentPath ++ route.path;\n\n /**\n * The page and layout have only access to\n * the dynamic params of the current route and the parent route.\n * So we append the current dynamic params to the parent dynamic params.\n * Example:\n * - Path: /classroom/:classroom_id\n * - Parent dynamic params: [(\"classroom_id\", \"1\")]\n * - Path: /student/:student_id\n * - Request: /classroom/1/student/1\n * - Dynamic params: [(\"student_id\", \"1\"), (\"classroom_id\", \"1\")]\n */\n let dynamicParams =\n extractDynamicParam(request, segment)\n |> Option.map(((key, value)) =>\n DynamicParams.add(currentDynamicParams, key, value)\n )\n |> Option.value(~default=currentDynamicParams);\n\n let renderLayout =\n switch (route.layout) {\n | Some(layout) =>\n module Layout = (val layout: LAYOUT);\n ;\n | None =>\n renderPage(\n ~pageOpt=route.page,\n ~loadingOpt=route.loading,\n ~globalLoading,\n ~params=dynamicParams,\n ~query,\n )\n };\n\n if (route.path == \"/\" ++ segment) {\n let pageconsumer =\n switch (route.children) {\n | [] => None\n | children =>\n Some(\n aux(children, restSegments, currentRoutePath, dynamicParams)\n |> Option.value(\n ~default=\n renderPage(\n ~pageOpt=route.page,\n ~loadingOpt=route.loading,\n ~globalLoading,\n ~params=dynamicParams,\n ~query,\n ),\n ),\n )\n };\n\n Some(\n ,\n );\n } else {\n aux(restRoutes, pathSegments, parentPath, dynamicParams);\n };\n\n // No match\n | _ => None\n };\n };\n\n aux(routes, pathSegments, \"\", initialDynamicParams);\n};\n\n/**\n * Returns the React.element for a specific sub route for the given path definitions\n * using the parents segments to find the correct component\n * Example:\n * - parentPath: /students\n * - subRoutePath: /:id\n * - React.element returned:\n * }\n * pageconsumer={}\n * />\n */\nlet getSubRoute =\n (\n ~request: Dream.request,\n ~parentDefinition: string,\n ~subRouteDefinition: string,\n ~globalLoading=None,\n routes: list(routeConfig),\n ) => {\n let query =\n Dream.all_queries(request)\n |> Array.of_list\n |> URL.SearchParams.makeWithArray;\n let parentPathSegments =\n String.split_on_char('/', parentDefinition)\n |> List.filter(segment => segment != \"\");\n\n // Goes through the parent route definitions to find the correct route from the subRoutePath to render\n let rec aux = (routes, parentSegments, currentDynamicParams) => {\n switch (routes, parentSegments) {\n // When the parent segments are empty, we start rendering the route for the given subRoutePath\n | (routes, []) =>\n getRoute(\n ~initialDynamicParams=currentDynamicParams,\n ~definition=subRouteDefinition,\n ~request,\n ~globalLoading,\n routes,\n )\n | (\n [routeDefinition, ...restRouteDefinitions],\n [parentRouteDefinitionSegment, ...restParentRouteDefinitionSegments],\n ) =>\n let dynamicParams =\n /**\n * The page and layout have only access to\n * the dynamic params of the current route and the parent route.\n * So we append the current dynamic params to the parent dynamic params.\n * Example:\n * - Path: /classroom/:classroom_id\n * - Parent dynamic params: [(\"classroom_id\", \"1\")]\n * - Path: /student/:student_id\n * - Request: /classroom/1/student/1\n * - Dynamic params: [(\"student_id\", \"1\"), (\"classroom_id\", \"1\")]\n */\n extractDynamicParam(request, parentRouteDefinitionSegment)\n |> Option.map(((key, value)) =>\n DynamicParams.add(currentDynamicParams, key, value)\n )\n |> Option.value(~default=currentDynamicParams);\n\n if (routeDefinition.path == \"/\" ++ parentRouteDefinitionSegment) {\n switch (routeDefinition.children) {\n | [] =>\n switch (routeDefinition.page) {\n | None => None\n | Some(_) =>\n Some(\n renderPage(\n ~pageOpt=routeDefinition.page,\n ~loadingOpt=routeDefinition.loading,\n ~globalLoading,\n ~params=dynamicParams,\n ~query,\n ),\n )\n }\n | children =>\n aux(children, restParentRouteDefinitionSegments, dynamicParams)\n };\n } else {\n aux(restRouteDefinitions, parentSegments, dynamicParams);\n };\n\n | _ => None\n };\n };\n\n aux(routes, parentPathSegments, DynamicParams.create());\n};\n\n/**\n Generate all possible routes paths from a given list of routes\n Example:\n - Routes: [\n { path: \"/student\", children: [{ path: \"/student/:student_id\", children: [] }] },\n { path: \"/classroom\", children: [{ path: \"/classroom/:classroom_id\", children: [] }] },\n ]\n - Routes paths: [\"/student\", \"/student/:student_id\", \"/classroom\", \"/classroom/:classroom_id\"]\n */\nlet generated_routes_paths = (~routes: list(routeConfig)) => {\n let rec aux =\n (routes: list(routeConfig), parentPath: string): list(string) => {\n switch (routes) {\n | [] => []\n | [route, ...remainingRoutes] =>\n let fullPath = parentPath ++ route.path;\n\n let childRoutes =\n switch (route.children) {\n | [] => []\n | children => aux(children, fullPath)\n };\n\n [fullPath] @ childRoutes @ aux(remainingRoutes, parentPath);\n };\n };\n\n aux(routes, \"\");\n};\n\nlet buildUrlFromRequest = request => {\n let protocol = Dream.tls(request) ? \"https\" : \"http\";\n let host = Dream.header(request, \"Host\") |> Option.value(~default=\"\");\n let target = Dream.target(request);\n Printf.sprintf(\"%s://%s%s\", protocol, host, target) |> URL.makeExn;\n};\n\nlet renderSubRouteModel =\n (\n ~request,\n ~parentRouteDefinition /* students */,\n ~subRouteDefinition /* :id */,\n ~dynamicParams,\n ~globalLoading,\n ~notFound,\n routes,\n ) => {\n let parentRoute = parentRouteDefinition == \"\" ? \"/\" : parentRouteDefinition;\n let element =\n routes\n |> getSubRoute(\n ~request,\n ~parentDefinition=parentRoute,\n ~subRouteDefinition,\n ~globalLoading,\n )\n |> Option.value(\n ~default=renderNotFound(~notFound, ~path=Dream.target(request)),\n );\n\n DreamRSC.stream_model_value(\n ~location=Dream.target(request),\n React.Model.Element(\n \n element\n ,\n ),\n );\n};\n\nlet renderRouteModel =\n (~request, ~routeDefinition, ~dynamicParams, routeDefinitions) => {\n let globalLoading = routeDefinitions.loading;\n let parentRoute = routeDefinition == \"\" ? \"/\" : routeDefinition;\n let pageconsumer = {\n let isRoot = routeDefinition ++ \"/\" == \"/\";\n Some(\n if (isRoot) {\n renderMainPage(\n ~page=routeDefinitions.page,\n ~globalLoading,\n ~query=\n Dream.all_queries(request)\n |> Array.of_list\n |> URL.SearchParams.makeWithArray,\n );\n } else {\n routeDefinitions.routes\n |> getRoute(~request, ~definition=routeDefinition, ~globalLoading)\n |> Option.value(\n ~default=\n renderNotFound(\n ~notFound=routeDefinitions.notFound,\n ~path=Dream.target(request),\n ),\n );\n },\n );\n };\n DreamRSC.stream_model_value(\n ~location=Dream.target(request),\n React.Model.Element(\n \n ,\n )}\n pageconsumer\n />\n ,\n ),\n );\n};\n\n// Render full route HTML (for initial page load)\nlet renderRouteHtml =\n (\n ~request,\n ~routeDefinition,\n ~dynamicParams,\n ~bootstrapModules,\n ~document,\n routeDefinitions,\n ) => {\n let globalLoading = routeDefinitions.loading;\n let url = buildUrlFromRequest(request);\n DreamRSC.stream_html(\n ~bootstrapModules,\n document(\n ~children=\n \n ,\n )}\n pageconsumer={\n let isRoot = routeDefinition ++ \"/\" == \"/\";\n Some(\n if (isRoot) {\n renderMainPage(\n ~page=routeDefinitions.page,\n ~globalLoading,\n ~query=\n Dream.all_queries(request)\n |> Array.of_list\n |> URL.SearchParams.makeWithArray,\n );\n } else {\n routeDefinitions.routes\n |> getRoute(\n ~request,\n ~definition=routeDefinition,\n ~globalLoading,\n )\n |> Option.value(\n ~default=\n renderNotFound(\n ~notFound=routeDefinitions.notFound,\n ~path=Dream.target(request),\n ),\n );\n },\n );\n }\n />\n ,\n ),\n );\n};\n\nlet routeDefinitionsHandlers =\n (~bootstrapModules, ~document, ~routeDefinitions, basePath, handler) => {\n let routesPaths = [\n \"/\",\n ...generated_routes_paths(~routes=routeDefinitions.routes),\n ];\n\n routesPaths\n |> List.map(path => {\n let normalizedPath = path == \"/\" ? \"\" : path;\n\n [\n handler(\n basePath ++ normalizedPath ++ \"/\",\n request => {\n Dream.log(\"Redirecting to /demo%s\", normalizedPath);\n let query = Dream.target(request) |> Dream.split_target |> snd;\n Dream.redirect(\n request,\n basePath ++ normalizedPath ++ \"?\" ++ query,\n );\n },\n ),\n handler(\n basePath ++ normalizedPath,\n request => {\n let dynamicParams: DynamicParams.t =\n /**\n * Route definition: /students/:id/grades/:grade_id\n * Current path: /students/123/grades/456\n * Dynamic params: [(\"id\", \"123\"), (\"grade_id\", \"456\")]\n */\n normalizedPath\n |> String.split_on_char('/')\n |> List.filter_map(extractDynamicParam(request))\n |> Array.of_list;\n\n switch (Dream.query(request, \"toSubRoute\")) {\n | Some(subRoutePath) =>\n /**\n * When the user navigates to a sub-route path (Example: /grades/456) from a parent route path (Example: /students/123), we need to find this sub-route definition (grades/:grade_id)\n * and the parent route definition (students/:id) so we can match it on the renderSubRouteModel function.\n * To find the sub-route definition, we need to find the index of the sub-route path in the current route definition from the subRoutePath.\n * Then split the current route definition into the sub-route definition and the parent route definition.\n * Request: https://localhost:3000/students/123/grades/456?toSubRoute=/grades/456\n * The toSubRoute means that from the current path, the user wants to navigate from /students/123 to /grades/456.\n * Route definition that matches the current path: /students/:id/grades/:grade_id (server-side only)\n * Sub-route target: [\"grades\", \"456\"] (?toSubRoute=/grades/456) -> Length: 2\n * Split [\"students\", \":id\", \"grades\", \":grade_id\"] into:\n * - [\"students\", \":id\"] (parent route definition)\n * - [\"grades\", \":grade_id\"] (sub-route definition)\n */\n let subRoutePathnamesIndex =\n (normalizedPath |> String.split_on_char('/') |> List.length)\n - (subRoutePath |> String.split_on_char('/') |> List.length);\n\n // Split the route definition into the parent route definition and the sub route definition\n let (parentRouteDefinition, subRouteDefinition) =\n normalizedPath\n |> String.split_on_char('/')\n |> List.fold_left(\n ((parent, sub, remaining), segment) =>\n if (remaining > 0) {\n ([segment, ...parent], sub, remaining - 1);\n } else {\n (parent, [segment, ...sub], remaining);\n },\n ([], [], subRoutePathnamesIndex),\n )\n |> (\n ((parent, sub, _)) => (\n List.rev(parent) |> String.concat(\"/\"),\n List.rev(sub) |> String.concat(\"/\"),\n )\n );\n\n renderSubRouteModel(\n ~request,\n ~parentRouteDefinition,\n ~subRouteDefinition,\n ~dynamicParams,\n ~globalLoading=routeDefinitions.loading,\n ~notFound=routeDefinitions.notFound,\n routeDefinitions.routes,\n );\n\n | None =>\n /* If the request has the header application/react.component, we render the full route as model */\n let isModelRequest =\n Dream.header(request, \"Accept\")\n == Some(\"application/react.component\");\n\n if (isModelRequest) {\n routeDefinitions\n |> renderRouteModel(\n ~request,\n ~routeDefinition=normalizedPath,\n ~dynamicParams,\n );\n } else {\n renderRouteHtml(\n ~bootstrapModules,\n ~request,\n ~routeDefinition=normalizedPath,\n ~dynamicParams,\n ~document,\n routeDefinitions,\n );\n };\n };\n },\n ),\n ];\n })\n |> List.flatten;\n};\n"
},
{
"path": "demo/dream-nested-router/native/RouterRSC.rei",
"content": "module type MAIN_LAYOUT = {\n [@react.component]\n let make: (~children: React.element, unit) => React.element;\n};\n\nmodule type MAIN_PAGE = {\n [@react.component]\n let make: (~query: URL.SearchParams.t, unit) => React.element;\n};\n\nmodule type LAYOUT = {\n [@react.component]\n let make:\n (~children: React.element, ~params: DynamicParams.t, unit) => React.element;\n};\n\nmodule type PAGE = {\n [@react.component]\n let make:\n (~params: DynamicParams.t, ~query: URL.SearchParams.t, unit) =>\n React.element;\n};\n\nmodule type NOT_FOUND = {\n [@react.component]\n let make: (~path: string, unit) => React.element;\n};\n\nmodule type LOADING = {\n [@react.component]\n let make: unit => React.element;\n};\n\ntype routeConfig;\ntype t;\n\nlet route:\n (\n ~path: string,\n ~layout: (module LAYOUT)=?,\n ~page: (module PAGE)=?,\n ~loading: (module LOADING)=?,\n list(routeConfig),\n unit\n ) =>\n routeConfig;\n\nlet make:\n (\n ~layout: (module MAIN_LAYOUT)=?,\n ~page: (module MAIN_PAGE),\n ~notFound: (module NOT_FOUND)=?,\n ~loading: (module LOADING)=?,\n list(routeConfig)\n ) =>\n t;\n\nlet getRoute:\n (\n ~initialDynamicParams: DynamicParams.t=?,\n ~globalLoading: option(module LOADING)=?,\n ~definition: string,\n ~request: Dream.request,\n list(routeConfig)\n ) =>\n option(React.element);\n\nlet getSubRoute:\n (\n ~request: Dream.request,\n ~parentDefinition: string,\n ~subRouteDefinition: string,\n ~globalLoading: option(module LOADING)=?,\n list(routeConfig)\n ) =>\n option(React.element);\n\nlet generated_routes_paths: (~routes: list(routeConfig)) => list(string);\n\nlet buildUrlFromRequest: Dream.request => URL.t;\n\nlet routeDefinitionsHandlers:\n (\n ~bootstrapModules: list(string),\n ~document: (~children: React.element) => React.element,\n ~routeDefinitions: t,\n string,\n (string, Dream.handler) => Dream.route\n ) =>\n list(Dream.route);\n"
},
{
"path": "demo/dream-nested-router/native/dune",
"content": "(include_subdirs unqualified)\n\n(library\n (name nested_router_native)\n (enabled_if\n (= %{profile} dev))\n (wrapped false)\n (flags :standard -w -26-27) ; browser_only removes code from the server, making this warning necessary\n (libraries\n react\n reactDOM\n dream\n js\n server-reason-react.url_native\n server-reason-react.rsc-native\n server-reason-react.runtime\n webapi\n lwt\n server-reason-react.fetch\n dream_rsc)\n (preprocess\n (pps\n lwt_ppx\n melange_native_ppx\n server-reason-react.ppx\n -shared-folder-prefix=/native/shared/\n server-reason-react.browser_ppx\n server-reason-react.rsc-native.ppx)))\n"
},
{
"path": "demo/dream-nested-router/native/shared/DynamicParams.re",
"content": "[@deriving rsc]\ntype t = array((string, string));\n\nlet create = () => [||];\n\nlet add = (t, key, value) => {\n Array.append(t, [|(key, value)|]);\n};\n\nlet find = (paramKey, t) =>\n if (Array.length(t) == 0) {\n None;\n } else {\n Array.find_map(\n ((key, value)) => {key == paramKey ? Some(value) : None},\n t,\n );\n };\n"
},
{
"path": "demo/dream-nested-router/native/shared/NavigationResponse.re",
"content": "type navigationCallback =\n (\n ~parentRoute: string,\n ~dynamicParams: DynamicParams.t,\n ~element: React.element\n ) =>\n unit;\n\nlet internalContext: React.Context.t(option(navigationCallback)) =\n React.createContext(None);\n\nlet internalProvider = React.Context.provider(internalContext);\n\n[@react.client.component]\nlet make =\n (\n ~parentRoute: string,\n ~dynamicParams: DynamicParams.t,\n ~children: React.element,\n ) => {\n let callback = React.useContext(internalContext);\n\n switch%platform (Runtime.platform) {\n | Client =>\n React.useLayoutEffect0(() => {\n switch (callback) {\n | Some(cb) => cb(~parentRoute, ~dynamicParams, ~element=children)\n | None => ()\n };\n None;\n })\n | Server => ()\n };\n\n React.null;\n};\n"
},
{
"path": "demo/dream-nested-router/native/shared/Route.re",
"content": "/**\n* Route is the component that renders the route and provides the renderPage function to update page/subroutes when the route is navigated to.\n* It push the route to the virtual history when mounted.\\\n*\n* As the is a client component, we cannot pass to the component the layout as a function component (~children: React.element) => React.element,\n* so we need to pass the layout as a React.element and use the Provider to pass the children to the layout.\n* That workaround allow us to update the page/subroutes when the route is nested.\n*\n* Path: /about/contact\n*\n* Example:\n* }\n* pageconsumer={\n* }\n* pageconsumer={\n* }\n* pageconsumer={}\n* />\n* }\n* />\n* }\n*\n* Visual representation of the route tree:\n* \n* \n* \n* \n* \n* \n* \n*/\ntype t = React.element;\n\nlet context = React.createContext(React.null);\n\nmodule PageConsumer = {\n [@react.client.component]\n let make = () => {\n let value = React.useContext(context);\n\n value;\n };\n};\n\nmodule Provider = {\n let provider = React.Context.provider(context);\n [@react.client.component]\n let make = (~value: React.element, ~children: React.element) => {\n switch%platform (Runtime.platform) {\n | Client =>\n React.createElement(\n provider,\n {\n \"value\": value,\n \"children\": children,\n },\n )\n | Server => provider(React.Context.makeProps(~value, ~children, ()))\n };\n };\n};\n\n[@react.client.component]\nlet make =\n (\n ~path: string,\n ~layout: React.element,\n ~pageconsumer: option(React.element),\n ) => {\n let (pageconsumer, setPageConsumer) =\n React.useState(() => pageconsumer |> Option.value(~default=React.null));\n let isFirstRender = React.useRef(true);\n let (cachedNodeKey, setCachedNodeKey) = React.useState(() => path);\n\n let%browser_only renderPage = pageElement => {\n setPageConsumer(_ => pageElement);\n // This is a hack to force a re-render of the route by changing the key\n // Is there a better way to do this?\n setCachedNodeKey(_ => Js.Date.now() |> string_of_float);\n };\n\n /**\n * push the route to the virtual history.\n * The renderPage function is used to update the page/subroutes.\n */\n (\n switch%platform (Runtime.platform) {\n | Client =>\n if (isFirstRender.current) {\n isFirstRender.current = false;\n VirtualHistory.push(~path, ~renderPage);\n }\n | Server => ()\n }\n );\n\n /**\n * pageconsumer is the component that will be rendered as\n * the child of the current route, representing the page/subroute content. It's the value of 'children' on\n * the layout component.\n * layout is the component that remains the same across all subroutes.\n * Ref: https://nextjs.org/docs/pages/building-your-application/routing/pages-and-layouts\n */\n pageconsumer }>\n layout\n ;\n};\n"
},
{
"path": "demo/dream-nested-router/native/shared/Router.re",
"content": "/**\n* Router is a component that provides the router context to the application.\n* It provides the dynamic params, url and navigation function to the application.\n* On navigation, it fetches the route component and updates the dynamic params.\n* Depending on the mode (revalidate or not), it either updates the whole page or the specific route component.\n*/\nexception No_provider(string);\nmodule DOM = Webapi.Dom;\nmodule Location = DOM.Location;\nmodule History = DOM.History;\n\ntype url = URL.t;\nlet url_to_rsc = url => url |> URL.toString |> RSC.Primitives.string_to_rsc;\nlet url_of_rsc = rsc => URL.makeExn(rsc |> RSC.Primitives.string_of_rsc);\n\n[@platform js]\nlet watchUrl = callback => {\n let watcherID = _ =>\n callback(URL.makeExn(Location.href(DOM.window->DOM.Window.location)));\n DOM.EventTarget.addEventListener(\n \"popstate\",\n watcherID,\n DOM.Window.asEventTarget(DOM.window),\n );\n watcherID;\n};\n\n[@platform js]\nlet unwatchUrl = watcherID => {\n DOM.EventTarget.removeEventListener(\n \"popstate\",\n watcherID,\n DOM.Window.asEventTarget(DOM.window),\n );\n};\n\n[@platform js]\nmodule HistoryCache = {\n module HistoryCacheConfig = {\n type key = {\n .\n \"path\": string,\n \"dynamicParams\": DynamicParams.t,\n \"parentRoute\": string,\n };\n };\n\n module HistoryCache = HistoryCache.Make(HistoryCacheConfig);\n let cache = HistoryCache.create();\n let set = (~key, ~page) => {\n HistoryCache.set(cache, ~key, ~page);\n };\n let get = (~key) => {\n HistoryCache.get(cache, ~key);\n };\n};\n\n/**\n * Compares two paths and returns the sub-route path between them.\n * Example:\n * - path1: /students/123\n * - path2: /students/123/grades/456\n * - Returns: /grades/456\n */\n[@platform js]\nlet findSubRoutePath = (path1, path2) => {\n let splitPath = path => path |> String.split_on_char('/') |> List.tl;\n\n let rec findSubRoutePath = (p1, p2, acc) => {\n switch (p1, p2) {\n | ([h1, ...t1], [h2, ...t2]) when h1 == h2 =>\n findSubRoutePath(t1, t2, acc)\n | (_, remaining) => remaining |> String.concat(\"/\")\n };\n };\n\n findSubRoutePath(splitPath(path1), splitPath(path2), \"\");\n};\n\nlet%browser_only splitPathAndQuery = to_ => {\n switch (to_ |> String.split_on_char('?')) {\n | [path, queryParams, ..._] => (path, Some(queryParams))\n | _ => (to_, None)\n };\n};\n\nlet%browser_only buildQueryString = (~prefix, queryParamsOpt) => {\n queryParamsOpt |> Option.map(q => prefix ++ q) |> Option.value(~default=\"\");\n};\n\nlet%browser_only fetchComponent = endpoint => {\n let headers =\n Fetch.HeadersInit.make({ \"Accept\": \"application/react.component\" });\n\n Fetch.fetchWithInit(\n endpoint,\n Fetch.RequestInit.make(~method_=Fetch.Get, ~headers, ()),\n )\n |> Js.Promise.then_(response => {\n let body = Fetch.Response.body(response);\n ReactServerDOMEsbuild.createFromReadableStream(body);\n });\n};\n\n[@platform js]\ntype pendingNavigation = {\n revalidate: bool,\n path: string,\n shouldReplace: bool,\n};\n\ntype t =\n (~replace: bool=?, ~revalidate: bool=?, ~shallow: bool=?, string) => unit;\n\ntype router = {\n navigate: t,\n params: DynamicParams.t,\n url: URL.t,\n pathname: string,\n searchParams: URL.SearchParams.t,\n isNavigating: bool,\n};\n\nlet context: React.Context.t(option(router)) = React.createContext(None);\nlet provider = React.Context.provider(context);\n\nlet use = () => {\n switch (React.useContext(context)) {\n | Some(context) => context.navigate\n | None => raise(No_provider(\"Router.use() requires the Router component\"))\n };\n};\n\nlet useRouter = () => {\n switch (React.useContext(context)) {\n | Some(context) => context\n | None =>\n raise(No_provider(\"Router.useRouter() requires the Router component\"))\n };\n};\n\n[@react.client.component]\nlet make =\n (\n ~serverUrl: url,\n ~initialDynamicParams: DynamicParams.t,\n ~children: React.element,\n ) => {\n let (element, setElement) = React.useState(() => children);\n let (pendingNavigationResponse, setPendingNavigationResponse) =\n React.useState(() => React.null);\n let (url, setUrl) = React.useState(() => serverUrl);\n let (dynamicParams, setDynamicParams) =\n React.useState(() => initialDynamicParams);\n let setDynamicParams = params => setDynamicParams(_ => params);\n let pathname = URL.pathname(url);\n let searchParams = URL.searchParams(url);\n\n React.useEffect0(() => {\n let watcherId = watchUrl(url => setUrl(_ => url));\n Some(() => unwatchUrl(watcherId));\n });\n let (cachedNodeKey, setCachedNodeKey) = React.useState(() => \"\");\n let (isNavigating, setIsNavigating) = React.useState(() => false);\n let pendingNavigationRef = React.useRef(None);\n\n let%browser_only renderFullPage = element => {\n /**\n * This is a hack to force a re-render of the route by changing the key\n * react-router do something similar\n * Is there a better way to do this?\n */\n setCachedNodeKey(_ => Js.Date.now() |> string_of_float);\n setElement(_ => element);\n VirtualHistory.cleanup();\n };\n\n let%browser_only renderSubRoute = (~parentRoute, element) => {\n let virtualHistoryRoute =\n VirtualHistory.find(parentRoute)\n |> Option.value(~default=VirtualHistory.state^ |> List.hd);\n\n VirtualHistory.cleanPathState(virtualHistoryRoute.path);\n virtualHistoryRoute.renderPage(element);\n };\n\n let%browser_only handleNavigationResponse =\n (~parentRoute, ~dynamicParams, ~element) => {\n switch (pendingNavigationRef.current) {\n | Some({ revalidate, path, shouldReplace }) =>\n setDynamicParams(dynamicParams);\n\n let historyState = {\n \"dynamicParams\": dynamicParams,\n \"parentRoute\": parentRoute,\n \"path\": path,\n };\n\n let _ =\n shouldReplace\n ? HistoryState.replace(HistoryState.fromJs(historyState), path)\n : HistoryState.push(HistoryState.fromJs(historyState), path);\n\n let _ =\n if (revalidate) {\n HistoryCache.set(~key=historyState, ~page=FullPage(element));\n renderFullPage(element);\n } else {\n HistoryCache.set(~key=historyState, ~page=SubRoute(element));\n renderSubRoute(~parentRoute, element);\n };\n\n pendingNavigationRef.current = None;\n setIsNavigating(_ => false);\n setPendingNavigationResponse(_ => React.null);\n | None => ()\n };\n };\n\n let%browser_only navigate =\n (\n ~replace as shouldReplace=false,\n ~revalidate=false,\n ~shallow=false,\n to_,\n ) => {\n let curPath = Location.pathname(DOM.window->DOM.Window.location);\n let (toPath, queryParamsOpt) = splitPathAndQuery(to_);\n /**\n * Identify the sub-route path from the current path to the target path\n * Example:\n * 1.\n * - Current path: /students/123\n * - Target path: /students/123/grades/456\n * - Sub-route path: /grades/456\n * - Endpoint: /students/123/grades/456?toSubRoute=/grades/456\n * - We only receive the /grades/456 component to render in the /students/123 route\n * 2.\n * - Current path: /students/123/grades/456\n * - Target path: /about/contact\n * - Sub-route path: \"\" (No sub-route)\n * - Endpoint: /about/contact?toSubRoute=\n * - We receive the /about/contact component to render in the /.\n */\n let subRoutePath = findSubRoutePath(curPath, toPath);\n\n let endpoint =\n if (revalidate) {\n toPath ++ buildQueryString(~prefix=\"?\", queryParamsOpt);\n } else {\n toPath\n ++ \"?toSubRoute=\"\n ++ subRoutePath\n ++ buildQueryString(~prefix=\"&\", queryParamsOpt);\n };\n\n if (shallow) {\n ();\n } else {\n setIsNavigating(_ => true);\n pendingNavigationRef.current =\n Some({\n revalidate,\n path: to_,\n shouldReplace,\n });\n\n let _ =\n fetchComponent(endpoint)\n |> Js.Promise.then_((navigationResponse: React.element) => {\n setPendingNavigationResponse(_ => navigationResponse);\n Js.Promise.resolve();\n })\n |> Js.Promise.catch(error => {\n pendingNavigationRef.current = None;\n setIsNavigating(_ => false);\n Js.Promise.reject(Obj.magic(error));\n });\n ();\n };\n\n ();\n };\n\n // Initialize cache and history state after hydration\n React.useEffect0(() => {\n let curPath = Location.pathname(DOM.window->DOM.Window.location);\n let historyState = {\n \"dynamicParams\": dynamicParams,\n \"path\": curPath,\n \"parentRoute\": curPath,\n };\n HistoryCache.set(~key=historyState, ~page=FullPage(element));\n\n /**\n * Replace the history state set by the browser to our own implementation.\n */\n HistoryState.replace(HistoryState.fromJs(historyState), curPath);\n\n None;\n });\n\n // Listen to the popstate event and handle the history navigation.\n React.useEffect0(() => {\n let watcherId = event =>\n /**\n * Event is trusted when it was generated by the user agent, not by EventTarget.dispatchEvent.\n * https://developer.mozilla.org/en-US/docs/Web/API/Event/isTrusted\n */\n (\n if (DOM.Event.isTrusted(event)) {\n let historyState: {\n .\n \"dynamicParams\": DynamicParams.t,\n \"path\": string,\n \"parentRoute\": string,\n } =\n event->HistoryState.fromEvent->HistoryState.toJs;\n\n let dynamicParams = historyState##dynamicParams;\n let parentRoute = historyState##parentRoute;\n setDynamicParams(dynamicParams);\n\n switch (HistoryCache.get(~key=historyState)) {\n | Some(FullPage(page)) => renderFullPage(page)\n | Some(SubRoute(page)) => renderSubRoute(~parentRoute, page)\n | None =>\n /**\n * If we don't find the cached page, we navigate to the path and replace the history state.\n * That may happen when the user refreshes the page, as the cache is in-memory or when the cache was cleared from the cache history due to the max cache size.\n */\n navigate(~replace=true, historyState##path)\n };\n }\n );\n\n DOM.EventTarget.addEventListener(\n \"popstate\",\n watcherId,\n DOM.Window.asEventTarget(DOM.window),\n );\n\n Some(\n () =>\n DOM.EventTarget.removeEventListener(\n \"popstate\",\n watcherId,\n DOM.Window.asEventTarget(DOM.window),\n ),\n );\n });\n\n let routerValue =\n Some({\n navigate,\n params: dynamicParams,\n url,\n pathname,\n searchParams,\n isNavigating,\n });\n\n \n {switch%platform () {\n | Client =>\n React.createElement(\n NavigationResponse.internalProvider,\n {\n \"value\": Some(handleNavigationResponse),\n \"children\":\n React.createElement(\n provider,\n {\n \"value\": routerValue,\n \"children\":\n React.array([|element, pendingNavigationResponse|]),\n },\n ),\n },\n )\n | Server =>\n NavigationResponse.internalProvider(\n React.Context.makeProps(\n ~value=None,\n ~children=\n provider(\n React.Context.makeProps(\n ~value=\n Some({\n navigate: (~replace=?, ~revalidate=?, ~shallow=?, _) =>\n failwith(\"navigate isn't supported on server\"),\n params: dynamicParams,\n url,\n pathname,\n searchParams,\n isNavigating,\n }),\n ~children=element,\n (),\n ),\n ),\n (),\n ),\n )\n }}\n ;\n};\n"
},
{
"path": "demo/dream-nested-router/native/shared/Router.rei",
"content": "exception No_provider(string);\n\ntype url = URL.t;\nlet url_to_rsc: url => RSC.t;\nlet url_of_rsc: RSC.t => url;\n\ntype t =\n (~replace: bool=?, ~revalidate: bool=?, ~shallow: bool=?, string) => unit;\nlet use: unit => t;\n\ntype router = {\n navigate: t,\n params: DynamicParams.t,\n url: URL.t,\n pathname: string,\n searchParams: URL.SearchParams.t,\n isNavigating: bool,\n};\n\nlet useRouter: unit => router;\n\n[@react.client.component]\nlet make:\n (\n ~serverUrl: url,\n ~initialDynamicParams: DynamicParams.t,\n ~children: React.element\n ) =>\n React.element;\n"
},
{
"path": "demo/dream-nested-router/test_router_rsc.ml",
"content": "let test title fn = Alcotest.test_case title `Quick fn\nlet assert_bool left right = Alcotest.check Alcotest.bool \"should be equal\" right left\nlet assert_option_string left right = Alcotest.check Alcotest.(option string) \"should be equal\" right left\nlet assert_string_list left right = Alcotest.check Alcotest.(list string) \"should be equal\" right left\n\nlet run_request ~route ~target f =\n let handler_called = ref false in\n let handler request =\n handler_called := true;\n f request;\n Dream.empty `OK\n in\n let handler_with_router = Dream.router [ Dream.get route handler ] in\n let _response = Dream.test handler_with_router (Dream.request ~target \"\") in\n assert_bool !handler_called true\n\nlet get_route_dynamic_params () =\n let seen_id = ref None in\n let seen_query = ref None in\n let module Page = struct\n let makeProps ~params ~query () : < params : DynamicParams.t ; query : URL.SearchParams.t > Js.t =\n object\n method params = params\n method query = query\n end\n\n let make ?key:_ props =\n seen_id := DynamicParams.find \"id\" props#params;\n seen_query := URL.SearchParams.get props#query \"q\";\n React.null\n end in\n let routes =\n [ RouterRSC.route ~path:\"/students\" [ RouterRSC.route ~path:\"/:id\" ~page:(module Page : RouterRSC.PAGE) [] () ] () ]\n in\n run_request ~route:\"/students/:id\" ~target:\"/students/123?q=cat\" (fun request ->\n let result = RouterRSC.getRoute ~definition:\"/students/:id\" ~request routes in\n assert_bool (Option.is_some result) true);\n assert_option_string !seen_id (Some \"123\");\n assert_option_string !seen_query (Some \"cat\")\n\nlet get_sub_route_dynamic_params () =\n let seen_id = ref None in\n let seen_grade_id = ref None in\n let module Page = struct\n let makeProps ~params ~query () : < params : DynamicParams.t ; query : URL.SearchParams.t > Js.t =\n object\n method params = params\n method query = query\n end\n\n let make ?key:_ props =\n seen_id := DynamicParams.find \"id\" props#params;\n seen_grade_id := DynamicParams.find \"grade_id\" props#params;\n React.null\n end in\n let routes =\n [\n RouterRSC.route ~path:\"/students\"\n [\n RouterRSC.route ~path:\"/:id\"\n [\n RouterRSC.route ~path:\"/grades\"\n [ RouterRSC.route ~path:\"/:grade_id\" ~page:(module Page : RouterRSC.PAGE) [] () ]\n ();\n ]\n ();\n ]\n ();\n ]\n in\n run_request ~route:\"/students/:id/grades/:grade_id\" ~target:\"/students/123/grades/456\" (fun request ->\n let result =\n RouterRSC.getSubRoute ~request ~parentDefinition:\"/students/:id\" ~subRouteDefinition:\"/grades/:grade_id\" routes\n in\n assert_bool (Option.is_some result) true);\n assert_option_string !seen_id (Some \"123\");\n assert_option_string !seen_grade_id (Some \"456\")\n\nlet generated_routes_paths () =\n let routes =\n [\n RouterRSC.route ~path:\"/students\" [ RouterRSC.route ~path:\"/:id\" [] () ] ();\n RouterRSC.route ~path:\"/teachers\" [] ();\n ]\n in\n let actual = RouterRSC.generated_routes_paths ~routes in\n let expected = [ \"/students\"; \"/students/:id\"; \"/teachers\" ] in\n assert_string_list actual expected\n\nlet () =\n Alcotest.run \"RouterRSC\"\n [\n ( \"RouterRSC\",\n [\n test \"getRoute\" get_route_dynamic_params;\n test \"getSubRoute\" get_sub_route_dynamic_params;\n test \"generated_routes_paths\" generated_routes_paths;\n ] );\n ]\n"
},
{
"path": "demo/dream-rsc/DreamRSC.re",
"content": "module RequestContext = {\n type pending_cookie = {\n name: string,\n value: string,\n expires: option(float),\n max_age: option(float),\n domain: option(string),\n path: option(string),\n secure: option(bool),\n http_only: option(bool),\n same_site:\n option(\n [\n | `Strict\n | `Lax\n | `None\n ],\n ),\n };\n\n type phase =\n | Render\n | Action(ref(list(pending_cookie)));\n\n let request_key: Lwt.key(Dream.request) = Lwt.new_key();\n let phase_key: Lwt.key(phase) = Lwt.new_key();\n\n let get_request = () =>\n switch (Lwt.get(request_key)) {\n | Some(request) => request\n | None =>\n failwith(\n \"RequestContext.get_request: no request context. \"\n ++ \"This function must be called inside a server component or server function.\",\n )\n };\n\n let get_header = name => Dream.header(get_request(), name);\n\n let get_cookie = (~decrypt=false, name) =>\n Dream.cookie(~decrypt, get_request(), name);\n\n let set_cookie =\n (\n ~expires=?,\n ~max_age=?,\n ~domain=?,\n ~path=?,\n ~secure=?,\n ~http_only=?,\n ~same_site=?,\n name,\n value,\n ) =>\n switch (Lwt.get(phase_key)) {\n | Some(Action(pending)) =>\n pending :=\n [\n {\n name,\n value,\n expires,\n max_age,\n domain,\n path,\n secure,\n http_only,\n same_site,\n },\n ...pending^,\n ]\n | Some(Render) =>\n failwith(\n \"RequestContext.set_cookie: cookies can only be modified in a server function (action), not during render.\",\n )\n | None =>\n failwith(\n \"RequestContext.set_cookie: no request context. \"\n ++ \"This function must be called inside a server function.\",\n )\n };\n};\n\nlet with_render_context = (request, f) =>\n Lwt.with_value(RequestContext.request_key, Some(request), () =>\n Lwt.with_value(RequestContext.phase_key, Some(RequestContext.Render), f)\n );\n\nlet with_action_context = (request, f) => {\n let pending = ref([]);\n let run = () =>\n Lwt.with_value(RequestContext.request_key, Some(request), () =>\n Lwt.with_value(\n RequestContext.phase_key,\n Some(RequestContext.Action(pending)),\n f,\n )\n );\n (pending, run);\n};\n\nlet serialize_pending_cookies = pending =>\n pending\n |> List.rev\n |> List.map((cookie: RequestContext.pending_cookie) => {\n let header_value =\n Dream.to_set_cookie(\n ~expires=?cookie.expires,\n ~max_age=?cookie.max_age,\n ~domain=?cookie.domain,\n ~path=?cookie.path,\n ~secure=?cookie.secure,\n ~http_only=?cookie.http_only,\n ~same_site=?cookie.same_site,\n cookie.name,\n cookie.value,\n );\n (\"Set-Cookie\", header_value);\n });\n\nlet require_action_id = actionId =>\n switch (actionId) {\n | Some(id) => Ok(id)\n | None =>\n Error(\n \"Missing ACTION_ID header, this request was not created by server-reason-react\",\n )\n };\n\nlet dispatch_handler = (~lookup, actionId, dispatch) =>\n switch (require_action_id(actionId)) {\n | Error(msg) => Lwt.fail_with(msg)\n | Ok(actionId) =>\n switch (lookup(actionId)) {\n | None => Lwt.fail_with(\"Action \" ++ actionId ++ \" is not registered\")\n | Some(handler) => dispatch(actionId, handler)\n }\n };\n\nlet dreamFormDataToJs = formData => {\n let formDataJs = Js.FormData.make();\n formData\n |> List.iter(((name, value)) => {\n let (_filename, value) = value |> List.hd;\n Js.FormData.append(formDataJs, name, `String(value));\n });\n formDataJs;\n};\n\nlet handleFormRequest = (~lookup, actionId, formData) => {\n let formDataJs = dreamFormDataToJs(formData);\n\n switch (ReactServerDOM.decodeFormDataReply(formDataJs)) {\n | Error(msg) => Lwt.fail_with(msg)\n | Ok((args, formData)) =>\n dispatch_handler(~lookup, actionId, (actionId, handler) =>\n switch (handler) {\n | ReactServerDOM.FormData(handler) => handler(args, formData)\n | ReactServerDOM.Body(_) =>\n Lwt.fail_with(\n \"Action \"\n ++ actionId\n ++ \" is registered as Body handler but received FormData request\",\n )\n }\n )\n };\n};\n\nlet handleRequestBody = (~lookup, request, actionId) => {\n let%lwt body = Dream.body(request);\n switch (ReactServerDOM.decodeReply(body)) {\n | Error(msg) => Lwt.fail_with(msg)\n | Ok(args) =>\n dispatch_handler(~lookup, actionId, (actionId, handler) =>\n switch (handler) {\n | ReactServerDOM.Body(handler) => handler(args)\n | ReactServerDOM.FormData(_) =>\n Lwt.fail_with(\n \"Action \"\n ++ actionId\n ++ \" is registered as FormData handler but received JSON body request\",\n )\n }\n )\n };\n};\n\nlet handleNoJsFormRequest = (~lookup, formDataJs) => {\n switch (ReactServerDOM.decodeAction(formDataJs)) {\n | Some((actionId, userFormData)) =>\n switch (lookup(actionId)) {\n | None => Lwt.fail_with(\"Action \" ++ actionId ++ \" is not registered\")\n | Some(handler) =>\n switch (handler) {\n | ReactServerDOM.FormData(handler) => handler([||], userFormData)\n | ReactServerDOM.Body(handler) =>\n /* No-JS form submissions don't carry serialized args; the form data is the entire payload */\n handler([||])\n }\n }\n | None =>\n Lwt.fail_with(\"No ACTION_ID header and no $ACTION_* keys in FormData\")\n };\n};\n\nlet handleRequest = (~lookup, request) => {\n let actionId = Dream.header(request, \"ACTION_ID\");\n let contentType = Dream.header(request, \"Content-Type\");\n\n switch (contentType) {\n | Some(contentType)\n when String.starts_with(contentType, ~prefix=\"multipart/form-data\") =>\n switch%lwt (Dream.multipart(request, ~csrf=false)) {\n | `Ok(formData) =>\n switch (actionId) {\n | Some(_) =>\n /* JS-enabled path: ACTION_ID header present */\n handleFormRequest(~lookup, actionId, formData)\n | None =>\n /* No-JS path: check FormData for $ACTION_* keys */\n handleNoJsFormRequest(~lookup, dreamFormDataToJs(formData))\n }\n | _ =>\n Lwt.fail_with(\n \"Missing form data, this request was not created by server-reason-react\",\n )\n }\n | _ => handleRequestBody(~lookup, request, actionId)\n };\n};\n\nlet streamFunctionResponse = (~debug=false, ~lookup, request) => {\n let (pending, run) =\n with_action_context(request, () => handleRequest(~lookup, request));\n\n /* Run the action. On success we keep pending cookies; on failure we discard them.\n Either way we capture the outcome as a promise for create_action_response,\n which serializes both successes and failures into the RSC stream\n (rather than letting failures become HTTP 500s). */\n let%lwt (action_promise, cookie_headers) =\n Lwt.catch(\n () => {\n let%lwt result = run();\n let cookies = serialize_pending_cookies(pending^);\n Lwt.return((Lwt.return(result), cookies));\n },\n exn => {\n pending := [];\n Lwt.return((Lwt.fail(exn), []));\n },\n );\n\n Dream.stream(\n ~headers=[\n (\"Content-Type\", \"application/react.action\"),\n ...cookie_headers,\n ],\n stream => {\n let%lwt () =\n ReactServerDOM.create_action_response(\n ~debug,\n ~subscribe=\n chunk => {\n if (debug) {\n Dream.log(\"Action response\");\n Dream.log(\"%s\", chunk);\n };\n let%lwt () = Dream.write(stream, chunk);\n Dream.flush(stream);\n },\n action_promise,\n );\n\n Dream.flush(stream);\n },\n );\n};\n\nlet is_react_component_header = str =>\n String.equal(str, \"application/react.component\");\n\nlet stream_model_value = (~debug=false, ~location, app) =>\n Dream.stream(\n ~headers=[\n (\"Content-Type\", \"application/react.component\"),\n (\"X-Content-Type-Options\", \"nosniff\"),\n (\"X-Location\", location),\n ],\n stream => {\n let%lwt () =\n ReactServerDOM.render_model_value(\n ~debug,\n ~subscribe=\n chunk => {\n if (debug) {\n Dream.log(\"Chunk\");\n Dream.log(\"%s\", chunk);\n };\n let%lwt () = Dream.write(stream, chunk);\n Dream.flush(stream);\n },\n app,\n );\n\n Dream.flush(stream);\n },\n );\n\nlet stream_model = (~debug=false, ~location, app) =>\n stream_model_value(~debug, ~location, React.Model.Element(app));\n\nlet stream_html =\n (\n ~debug=false,\n ~skipRoot=false,\n ~bootstrapScriptContent=?,\n ~bootstrapScripts=[],\n ~bootstrapModules=[],\n app,\n ) => {\n Dream.stream(\n ~headers=[(\"Content-Type\", \"text/html\")],\n stream => {\n let%lwt (html, subscribe) =\n ReactServerDOM.render_html(\n ~skipRoot,\n ~bootstrapScriptContent?,\n ~bootstrapScripts,\n ~bootstrapModules,\n ~debug,\n app,\n );\n\n let%lwt () = Dream.write(stream, html);\n let%lwt () = Dream.flush(stream);\n let%lwt () =\n subscribe(chunk => {\n if (debug) {\n Dream.log(\"Chunk\");\n Dream.log(\"%s\", chunk);\n };\n let%lwt () = Dream.write(stream, chunk);\n Dream.flush(stream);\n });\n Dream.flush(stream);\n },\n );\n};\n\nlet createFromRequest =\n (\n ~debug=false,\n ~disableSSR=false,\n ~layout=children => children,\n ~bootstrapModules=[],\n ~bootstrapScripts=[],\n ~bootstrapScriptContent=\"\",\n element,\n request,\n ) =>\n with_render_context(request, () =>\n switch (Dream.header(request, \"Accept\")) {\n | Some(accept) when is_react_component_header(accept) =>\n stream_model(~debug, ~location=Dream.target(request), element)\n | _ =>\n stream_html(\n ~debug,\n ~skipRoot=disableSSR,\n ~bootstrapScriptContent,\n ~bootstrapScripts,\n ~bootstrapModules,\n layout(element),\n )\n }\n );\n"
},
{
"path": "demo/dream-rsc/DreamRSC.rei",
"content": "/** Dream integration for React Server Components.\n\n Provides request context (cookies, headers) accessible from server\n components and server functions via ambient [Lwt.key] storage,\n plus streaming helpers for RSC rendering and action dispatch. */;\n\nmodule RequestContext: {\n /** {2 Reading request data}\n\n These functions are available in both server components (render phase)\n and server functions (action phase). They raise if called outside\n a request context. */;\n\n /** Returns the current [Dream.request]. Raises if no request context. */\n let get_request: unit => Dream.request;\n\n /** Read a request header by name. */\n let get_header: string => option(string);\n\n /** Read a cookie from the request.\n @param decrypt whether to decrypt the cookie value (default: false) */\n let get_cookie: (~decrypt: bool=?, string) => option(string);\n\n /** {2 Writing cookies}\n\n Only available during the action phase (server functions).\n Raises during render or outside a request context. */;\n\n /** Queue a [Set-Cookie] header on the action response.\n\n Raises during render (matching Next.js [ReadonlyRequestCookiesError]). */\n let set_cookie:\n (\n ~expires: float=?,\n ~max_age: float=?,\n ~domain: string=?,\n ~path: string=?,\n ~secure: bool=?,\n ~http_only: bool=?,\n ~same_site:\n [\n | `Strict\n | `Lax\n | `None\n ]\n =?,\n string,\n string\n ) =>\n unit;\n};\n\n/** {1 Streaming} */;\n\n/** Render a React element as a full HTML page or RSC model stream,\n depending on the request's [Accept] header.\n\n Installs a render-phase request context: [RequestContext.get_*] is\n available, [RequestContext.set_cookie] raises. */\nlet createFromRequest:\n (\n ~debug: bool=?,\n ~disableSSR: bool=?,\n ~layout: React.element => React.element=?,\n ~bootstrapModules: list(string)=?,\n ~bootstrapScripts: list(string)=?,\n ~bootstrapScriptContent: string=?,\n React.element,\n Dream.request\n ) =>\n Lwt.t(Dream.response);\n\n/** Handle a server function POST request.\n\n Installs an action-phase request context: both [RequestContext.get_*]\n and [RequestContext.set_cookie] are available. Pending cookies are\n serialized as [Set-Cookie] response headers. If the action raises,\n pending cookies are discarded.\n\n @param lookup maps an action ID to a registered [ReactServerDOM.server_function]\n @param debug enable debug logging (default: false) */\nlet streamFunctionResponse:\n (\n ~debug: bool=?,\n ~lookup: string => option(ReactServerDOM.server_function),\n Dream.request\n ) =>\n Lwt.t(Dream.response);\n\n/** Stream a [React.model_value] as an RSC model response. */\nlet stream_model_value:\n (~debug: bool=?, ~location: string, React.model_value) =>\n Lwt.t(Dream.response);\n\n/** Stream a [React.element] as an RSC model response. */\nlet stream_model:\n (~debug: bool=?, ~location: string, React.element) => Lwt.t(Dream.response);\n\n/** Stream a [React.element] as an HTML response with optional\n bootstrap scripts for client hydration. */\nlet stream_html:\n (\n ~debug: bool=?,\n ~skipRoot: bool=?,\n ~bootstrapScriptContent: string=?,\n ~bootstrapScripts: list(string)=?,\n ~bootstrapModules: list(string)=?,\n React.element\n ) =>\n Lwt.t(Dream.response);\n"
},
{
"path": "demo/dream-rsc/dune",
"content": "(library\n (name dream_rsc)\n (wrapped false)\n (libraries dream react reactDOM js lwt lwt.unix)\n (preprocess\n (pps lwt_ppx)))\n"
},
{
"path": "demo/dune",
"content": "(rule\n (alias demo)\n (enabled_if\n (= %{profile} \"dev\"))\n (deps\n server/server.exe\n (alias_rec client))\n (action\n (progn\n ; we want dune to write the file but not attach any fsevents listeners to it,\n ; so that watchexec can read from it without issues.\n ; this means no (target), no (with-stdout-to), just a bash command with stdout\n ; redirect inside a string\n (bash \"date > %{project_root}/../../demo/.running/built_at.txt\"))))\n\n(install\n (section bin)\n (enabled_if\n (= %{profile} dev))\n (files\n (\"./node_modules/@tailwindcss/cli/dist/index.mjs\" as tailwind)))\n\n(rule\n (target output.css)\n (enabled_if\n (= %{profile} dev))\n (alias client)\n (deps\n (source_tree ./)\n (source_tree ./../server)\n (:config tailwind.config.js)\n (:input styles.css))\n (action\n (progn\n (run tailwind --config=%{config} --input=%{input} --output=%{target}))))\n"
},
{
"path": "demo/package.json",
"content": "{\n \"name\": \"server-reason-react-demo\",\n \"version\": \"0.0.0\",\n \"description\": \"\",\n \"dependencies\": {\n \"@tailwindcss/cli\": \"^4.1.4\",\n \"tailwindcss\": \"^4.1.4\"\n }\n}\n"
},
{
"path": "demo/server/db/notes.json",
"content": "[\n {\n \"id\": 0,\n \"title\": \"Lorem ipsum for markdown, exists\",\n \"content\": \"# Aethere conterminus nec est damno\\n\\nLorem markdownum patiente clade retenta, domos facta cacumine nostris coniunx aspergine intraverat. Petit **et**, est est recens invitaque refert asper vigoris undis sacerdos.\\n\\nEt undis laetos Caystros intellege est auras corpus, montes ambit tum formae pellitis [et inque](#lenta-argo). Sit dicentum nondum, Dorceus debita attonitum nulla cornua vestem si auras.\\n\\n## Dummodo in veretur argenti plenissima quoque damnare\\n\\nSic quae, aula fortibus fratribus longoque abiit mea cava commune spectant uno telis hiemem. Quibus vestigia pugnat prolisque Caesareos bracchia caesae, victoria citi colubris totos penates usum hirta. Perituraque inest promittat Procris mille famaque ursa, hamadryadas rapuere moxque amorem. Domui comites adspicit tabellae euhoe matri duxere dei Dianae Aegyptia celebrare. Veniat gestasset levavit: oras cursus arcebatque quid, herba caput tum praecepta.\\n\\nUrget quod dixi idemque. Timuitque hortis dubiaque meo per cantu admissum manibus lapis minimamque simulacraque currere licet, Fortuna reliquit massa. Positus tenet.\\n\\nLusisse Hymenaeon terrore referebat mortale in Pelopeia, facienda positoque bibisset. Per totum, virginibus dumque cornua modumque domus arma ecquid hoc meo [tertius hic](#mater). Coniugis laudis, *fertur*, postquam nostro, mihi mortale fessam illa quater autumni per sapiens, albentes hippomene, et.\\n\\n## Non sacra tibi superare circa\\n\\nEst per viro est, nec in trunca causa. Viso placet, cadunt quaque ignorant verbenis loquor exceptas in, summe iuga nectare. Mihi domus segetes, ferro, in quodque litoraque dixit, mediis bacis, egit, qua meae iram Boeotaque.\\n\\nCuspide accipit poterat, spreto haec quoque? Turpe quae, iacentia esset fissa vivum, an lacertis ire; spumas. Quis quod concidit Alcmene. Attollo mollia metalla adest terris **cultosque prompsit celsum** minima, saepe. Et mi est laverat totis, videndo dedimus capientur: iamque.\\n\\nHumanas nec, adest hanc iaculum; Phrygiae vae deinde quae neque quodque Nesse caelum chlamydem tamen generosos? Genuit puer placabilis tamen, invito et nervos tuam hoc.\\n\\nOpus nec. Motu omne vates negate fluere, nec sic membra Hennaeis pleno, arcana toto non. Quicquid se opta saepe! Tibi litis sunt saliente herba. Stamina huius sceptra iuvenes turbasti et mihi votique qua tanta, uno super ero vacuus fluminis tepida.\",\n \"updated_at\": 1716604800\n },\n {\n \"id\": 1,\n \"title\": \"Our markdown parser is poor, don't stress it plz\",\n \"content\": \"\\n# Murra acta una cretum refert\\n## Undas pati incola cognoscit Arethusa\\nPatrium utentem: illa tempora; reddit seque, ab fuga notas Charaxi! Mater bibulas o mollia elisi veribus,\\n[virtute](http: //www.de.com/iuncta-iactanti.html) tutus sub nam strictumque gens animasse,\\n[anni inde](http: //aera.org/) illuc tellus. Munus generosos militis quoque sit.\\n## Semper plura tempora tantae effodit cervix subito\\nUllam vero: duris mea bellis pulvere! Cervice placidi, ignes, Laelapa pectore languentique fugitque; utroque Medusaeo. Pereat des, argento gemmas praestantes Amore referre. Tamen lanugine novercae frigora miser cum.\\nPallas iam solet salix transit; causa fugio animalibus currant verba aversata, faciam tenus, unda. Opem tereti lecto ferventibus pater: Festa fictus nihil: mea quidem quem quodque leonis ad urbes: deus? Tantae corpus; o audit vox animam peteret presso sua quatere Venus.\\n## Quem et recondidit puer conlapsa currus\\nCeycis mallem bracchia. Minimas si invitae et catulo in detestatur fuit, dea pares, viscera flebant Elin solet annis frondescere sordidus. Laborem ut Troezena grandia at certans posses et Minyeides **nobis** tracti natae.\\n## Posse ulla templo Iove aliter\\nPictae aeraque sceptro, stupet, levi nec amans hoc breve inplet, gravidamque, locus. Foribusque simul, caput amplexa, silvis titulis: e removit aderat: orbae frenis, ingenium ardua gradere **esse**. Sine et *pessima percusso* est tener aduncis funibus claro: *sumptis* hostibus et, ore venti iamdudum. Laniare novis scopulis, tu priora veniens, nec quodque se novorum tribuam nomine?\\n\\n## Quodque cervicibus luces\\nDedit socios esset, exarsit et movere Saturnia pudici, herede. Nec optima, non hanc spisso, sum gladii qua descendunt **noceat altoque me**. Patrium utentem: illa tempora; reddit seque, ab fuga notas Charaxi.\\nPede tota, ligati: subduci succedit animas recessit inde aut, salva, ista. Artes carebat nutrix, arte primus sceptra accipis subit manibusque.\\n> Rudentes quaque nec error tecta aves sic obsistere, ignis non nisi expalluit quater harpen; domus. Sine exilibus caerula quo modico et imagine, cana cognoscenda pars torvum cupidine membra: Achilli negabamus manu nec? Tenebant et rubigine tremuere deorum, ora. [Quae agmine patriaeque](http: //incurvatasortemque.io/) fuerit obverterat quoque; sum reticere; huic quaque **adspergine exsangues**! Protegat **verso** fama limite [ligno dextera](http: //intendens-in.net/lentinavis.html), lusisse at haeserat > pro exarsit deae: magni hamo altior.\\n\",\n \"updated_at\": 1716604800\n },\n {\n \"id\": 2,\n \"title\": \"Another important note\",\n \"content\": \"# Ad Latous\\n\\n## Verba nostra\\n\\nRemovere vicimus quid nisi fluctibus Dictys. Tutus ictu amborum iniere inque, quod, omnes, neu pariter Andraemone nequiquam quod suo; luctantia. Feris ara fusum reliquit spirat longique alitibus, ab capillis movi persequitur.\\n\\n## Crimina Fames\\n\\nErat qui quodque decusque te tibi nil volucrem [in audaci](#in-et) obliquis **rebus tacuit**. Virtute est annis arma aequora, tenet vellem Eurydices dixerunt supplice animal.\\n\\n## Ab ego saxum ab tecta tympana mentita\\n\\nMei mutabit lacerata. Voti aguntur teloque, adest *vocabant*, unde defecto habet.\\n\\n- Ait pondere\\n- Flamma putares cursu genitore plagas conabar manibus\\n- Guttis recepta\\n- Dixit electus\\n- Exaudi tremulo\\n- Natique duroque intrat sperat\\n\\n## Damnarat velox acerris mihi invitus celebrantur mali\\n\\nRemovere vicimus quid nisi. Est sed in neque patietur foramen exi haec ait. Ter laverat sociis quasque potitur si [est columnis](#dominoque) tempora dum audito et omnia *Pharosque est*.\\n\\n```cgiKeyboard(myspace_blacklist_streaming.ebook.browserUatBcc(5 / 45, ofRwSecondary), ccd);```\\n\\nFunda **Gorgoneum tenera ardet** condar viros cannae sequiturque *claro* quicumque. Serpens innumeraeque Cereris foret agitat socios gravem aquae nescisse, deus acie. Demissaque unum dubitabile erepta sanguinea surgis scindere illic meae credidit **dummodo maius** dat aures Illyricos coercet concipe roganti repetitaque.\\n\",\n \"updated_at\": 1716804800\n },\n {\n \"id\": 3,\n \"title\": \"RSC with navigation, yuhu! 🎉\",\n \"content\": \"# Scrobibus luctu sunt cognoscenda erat iuvenis\\n\\n## Ciboque exuit quoque toris portae sed equos\\n\\nStygiam colle porrigit et stipite\\ncuraque muneris. Aram labens admonitu prensam status, vox undis et\\n**percussit**, quoque; nec mando ripae!\\n\\n## Per nec rudentes auras\\n\\nIxionis talia, nam de quaerere limine, illa non neu flevit! Suis cui nec esset\\nquid crura. Quae fore uterum summa.\\n\\n## Populo refluitque deprensa\\n\\nPergama et fuerunt signa commemorare ecce, non ferit, impetus ab sustinui resto,\\npiscem *inductus*, quem. Manum cruentior obruit. Alis Epiros; tum alti aurum\\nvideri *et siqua tecta*, vitamque vellera quam superatus per matris mollescat,\\n*si*.\\n\\nMei [signa](#satis-in-illo) evitata Elin flumina; divum\\n[puer](#figuram-tot-vocari), reppulit ira arcton. Epulis ut incepti quod. Ter\\naliis acta *ira*: obstitit!\\n\\n## Ipse forte ille remittat\\n\\nIpse que, nexu vana sequar fui opus perstant! Post hospes.\\n\\nUt quae illi vidit et in me, *sonumque coniunx* gravitate montis legum pars? Ait\\ne addidit guttur, **habitantque** saxum Mopsopium innuba et Peragit sedisti et\\nglaebis, ambitae quo currere. Ante per ignem; infantem inpositus tu enim qui:\\nhostis mihi mirum euntem, quid? Spicis et frontem repressit deinde, ut residens\\nbella vocatum [plumbum](#leto-per-his). Voce documenta stant, inhonorati viaeque\\nvidet iterum sanguine, aras veste futuri, argumenta arcus milite non, non?\\n\\nMaenades Turnusque consulat morsu, sive *mille tenuere ossibus*. Amor duo, ecce\\nimperio muneraque contemptus quodcumque quam tetigere tibi, petit, ubi aurumque\\n**rogant**. Loca nubes colla ademit: cognoscenda atque. Funereum habebit dixit\\nest gemitum viroque Megareus quibus: bracchia signa meus, filia; lucem decent\\ntacito?\\n\",\n \"updated_at\": 1716904800\n }\n]\n"
},
{
"path": "demo/server/dune",
"content": "(include_subdirs qualified)\n\n(executable\n (enabled_if\n (= %{profile} \"dev\"))\n (name server)\n (libraries\n dream\n dream_rsc\n demo_shared_native\n nested_router_native\n server-reason-react.url_native\n react\n reactDOM\n html\n js\n lwt.unix\n str\n unix\n belt\n yojson)\n (preprocess\n (pps\n server-reason-react.ppx\n server-reason-react.melange_ppx\n server-reason-react.rsc-native.ppx\n lwt_ppx)))\n"
},
{
"path": "demo/server/pages/Comments.re",
"content": "module Post = {\n [@react.component]\n let make = () => {\n \n
\n {React.string(\n \"Notice how HTML for comments 'streams in' before the JavaScript (or React) has loaded on the page. In fact, the demo is entirely rendered in the server and doesn't use client-side JavaScript at all\",\n )}\n
\n
\n {React.string(\"This demo is \")}\n {React.string(\"artificially slowed down\")} \n {React.string(\" while loading the comments data.\")}\n
\n ;\n };\n};\n\nmodule Data = {\n let delay = 4.0;\n\n let fakeData = [\n \"Wait, it doesn't wait for React to load?\",\n \"How does this even work?\",\n \"I like marshmallows\",\n \"!1!1!1! This is a comment\",\n \"This is actually static from the server\",\n \"But, imagine it's dynamic\",\n ];\n\n let get = () => fakeData;\n\n let cached = ref(false);\n let destroy = () => cached := false;\n let promise = () => {\n cached.contents\n ? Lwt.return(fakeData)\n : {\n let%lwt () = Lwt_unix.sleep(delay);\n cached.contents = true;\n Lwt.return(fakeData);\n };\n };\n};\n\nmodule Comments = {\n [@react.async.component]\n let make = () => {\n let comments = React.Experimental.usePromise(Data.promise());\n\n Lwt.return(\n
\n \n \"This is a list of links to all the demos for server-reason-react's features\"\n \n \n \n \"If you want to learn more about server-reason-react, check out the \"\n \n \n \"documentation\"\n \n \" or \" \n \n \"repository\"\n \n \".\" \n
\n \n {React.string(\n \"The client will fetch the server component from the server and run createFromFetch\",\n )}\n \n {React.string(\"asking for the current time (in seconds) since\")}\n \n {React.string(\"00:00:00 GMT, Jan. 1, 1970\")}\n \n \n {React.string(string_of_float(Unix.gettimeofday()))}\n \n
\n ;\n\n DreamRSC.createFromRequest(\n ~bootstrapModules=[\"/static/demo/ServerOnlyRSC.re.js\"],\n ~layout=children => children ,\n app,\n request,\n );\n};\n"
},
{
"path": "demo/server/pages/SidebarNote.re",
"content": "[@react.component]\nlet make = (~note: Note.t) => {\n let lastUpdatedAt =\n if (Date.is_today(note.updated_at)) {\n Date.format_time(note.updated_at);\n } else {\n Date.format_date(note.updated_at);\n };\n\n let summary =\n note.content |> Markdown.extract_text |> Markdown.summarize(~words=20);\n\n \n {switch (String.trim(summary)) {\n | \"\" => {React.string(\"(No content)\")} \n | s => s \n }}\n \n }>\n \n {note.title} \n lastUpdatedAt \n \n ;\n};\n"
},
{
"path": "demo/server/pages/SinglePageRSC.re",
"content": "module Section = {\n [@react.component]\n let make = (~title, ~children, ~description=?) => {\n \n \n {React.string(title)}\n \n {switch (description) {\n | Some(description) =>\n description \n | None => React.null\n }}\n \n children\n ;\n };\n};\n\nmodule ExpandedContent = {\n [@react.component]\n let make = (~id, ~content: string, ~updatedAt: float, ~title: string) => {\n let lastUpdatedAt =\n if (Date.is_today(updatedAt)) {\n Date.format_time(updatedAt);\n } else {\n Date.format_date(updatedAt);\n };\n\n let summary =\n content |> Markdown.extract_text |> Markdown.summarize(~words=20);\n\n \n {switch (String.trim(summary)) {\n | \"\" => {React.string(\"(No content)\")} \n | s => s \n }}\n \n \n }>\n \n title \n lastUpdatedAt \n \n ;\n };\n};\n\nmodule CacheDemo = {\n let calls = ref(0);\n let get =\n React.cache(label => {\n calls.contents = calls.contents + 1;\n label ++ \" #\" ++ Int.to_string(calls.contents);\n });\n};\n\nmodule Page = {\n [@react.async.component]\n let make = () => {\n let promiseIn2 =\n Lwt.bind(Lwt_unix.sleep(2.0), _ =>\n Lwt.return(\"Solusionao in 2 seconds!\")\n );\n let promiseIn4 =\n Lwt.bind(Lwt_unix.sleep(4.0), _ =>\n Lwt.return(\"Solusionao in 4 seconds!\")\n );\n let cachedValueFirst = CacheDemo.get(\"Cached value\");\n let cachedValueSecond = CacheDemo.get(\"Cached value\");\n Lwt.return(\n \n \n \n {React.string(\n \"Server side rendering server components and client components\",\n )}\n \n \n {React.string(\n \"React server components. Lazy loading of client components. Client props encodings, such as promises, React elements, and primitive types.\",\n )}\n \n \n \n \n \n {\"First call: \" ++ cachedValueFirst} \n {\"Second call: \" ++ cachedValueSecond} \n \n \n \n \n \n \n \n \n {React.string(\"H E A D E R\")} )}\n string_list=[\"Item 1\", \"Item 2\"]\n promise=promiseIn2>\n
\n {React.string(\n \"This footer is a React.element as a server component into client prop, yay!\",\n )}\n
\n \n \n \n \n {React.string(\"H E A D E R\")} )}\n string_list=[\"Item 1\", \"Item 2\"]\n promise=promiseIn2>\n
\n {React.string(\n \"This footer is a React.element as a server component into client prop, yay!\",\n )}\n
\n \n \"Click 'Read request context' again to see the updated cookie value.\"\n \n
\n : React.null}\n \n \n
;\n};\n"
},
{
"path": "demo/universal/native/shared/Routes.re",
"content": "let home = \"/\";\nlet renderToStaticMarkup = \"/demo/renderToStaticMarkup\";\nlet renderToString = \"/demo/renderToString\";\nlet renderToStream = \"/demo/renderToStream\";\nlet serverOnlyRSC = \"/demo/serverOnlyRSC\";\nlet singlePageRSC = \"/demo/singlePageRSC\";\nlet dummyRouterRSC = \"/demo/dummyRouterRSC\";\nlet dummyRouterRSCNoSSR = \"/demo/dummyRouterRSC?ssr=false\";\nlet router = \"/demo/router\";\n\nlet links = [|\n (\n \"renderToString\",\n \"Server side render a component (React.element) defining a static document into a string, the client rerenders the component (createRoot / render)\",\n renderToString,\n ),\n (\n \"renderToStaticMarkup\",\n \"Server side render a component (React.element) defining a document into a markup string (contains a few differences on the output compared to the renderToString version). The client hydrates it with the same component (hydrateRoot)\",\n renderToStaticMarkup,\n ),\n (\n \"renderToStream\",\n \"Server side render into a stream. A comments page that loads without any additional client-side code and just Suspense + streaming the HTML\",\n renderToStream,\n ),\n (\n \"serverOnlyRSC\",\n \"A client fetching a single react server component with createFromFetch\",\n serverOnlyRSC,\n ),\n (\n \"singlePageRSC\",\n \"A single page to with server components and SSR (with hydration), client components to test all props serialisation, including React.element and Js.Promise\",\n singlePageRSC,\n ),\n (\n \"dummyRouterRSC\",\n \"A dummy implementation of a router (only a few queryStrings) as a single page app. Server components with SSR, client components and Suspense + React.use\",\n dummyRouterRSC,\n ),\n (\n \"dummyRouterRSC - without SSR\",\n \"The same demo as dummyRouterRSC but without SSR. It SSR the shell of the page (head, body, etc), but not the app itself.\",\n dummyRouterRSCNoSSR,\n ),\n (\n \"nestedRouterRSC\",\n \"A nested router with server components and SSR, client components and Suspense + React.use. It uses the same design as the dummyRouterRSC but with a more complex structure that can handle nested routes and dynamic segments.\",\n router,\n ),\n|];\n\nmodule Menu = {\n [@react.component]\n let make = () => {\n
{React.string(\"This is Light Server Component\")}
\n
{React.string(\"Heavy Server Component\")}
\n
;\n"
},
{
"path": "demo/universal/native/shared/Text.re",
"content": "type size =\n | XSmall\n | Small\n | Medium\n | Large\n | XLarge\n | XXLarge\n | XXXLarge;\n\nlet size_to_string = size =>\n switch (size) {\n | XSmall => \"text-xs\"\n | Small => \"text-sm\"\n | Medium => \"text-base\"\n | Large => \"text-lg\"\n | XLarge => \"text-xl\"\n | XXLarge => \"text-2xl\"\n | XXXLarge => \"text-3xl\"\n };\n\ntype weight =\n | Thin\n | Light\n | Regular\n | Semibold\n | Bold\n | Extrabold\n | Black;\n\ntype align =\n | Left\n | Center\n | Right\n | Justify;\n\n[@react.component]\nlet make =\n (\n ~color=Theme.Color.Gray12,\n ~size: size=Small,\n ~weight: weight=Regular,\n ~align=Left,\n ~children,\n ~role=?,\n ) => {\n let className =\n Cx.make([\n Theme.text(color),\n size_to_string(size),\n switch (weight) {\n | Thin => \"font-thin\"\n | Light => \"font-light\"\n | Regular => \"font-normal\"\n | Semibold => \"font-semibold\"\n | Bold => \"font-bold\"\n | Extrabold => \"font-extrabold\"\n | Black => \"font-black\"\n },\n switch (align) {\n | Left => \"text-left\"\n | Right => \"text-right\"\n | Justify => \"text-justify\"\n | Center => \"text-center\"\n },\n ]);\n\n {React.string(children)} ;\n};\n"
},
{
"path": "demo/universal/native/shared/Textarea.re",
"content": "[@react.component]\nlet make = (~rows=10, ~value, ~onChange, ~id=\"\", ~placeholder=\"\") =>\n ;\n"
},
{
"path": "demo/universal/native/shared/Theme.re",
"content": "type align = [\n | `start\n | `center\n | `end_\n];\n\ntype justify = [\n | `around\n | `between\n | `evenly\n | `start\n | `center\n | `end_\n];\n\nmodule Media = {\n let onDesktop = rules => {\n String.concat(\" md:\", rules);\n };\n};\n\nmodule Color = {\n type t =\n | None\n | Transparent\n | Gray0\n | Gray1\n | Gray2\n | Gray3\n | Gray4\n | Gray5\n | Gray6\n | Gray7\n | Gray8\n | Gray9\n | Gray10\n | Gray11\n | Gray12\n | Gray13\n | Gray14\n | Primary;\n\n let oneScaleUp = color => {\n switch (color) {\n | Gray0 => Gray1\n | Gray1 => Gray2\n | Gray2 => Gray3\n | Gray3 => Gray4\n | Gray4 => Gray5\n | Gray5 => Gray6\n | Gray6 => Gray7\n | Gray7 => Gray8\n | Gray8 => Gray9\n | Gray9 => Gray10\n | Gray10 => Gray11\n | Gray11 => Gray12\n | Gray12 => Gray13\n | Gray13 => Gray14\n | Gray14 => Gray14\n | _ => color\n };\n };\n\n let primary = \"#FFC53D\";\n let gray0 = \"#080808\";\n let gray1 = \"#0F0F0F\";\n let gray2 = \"#151515\";\n let gray3 = \"#191919\";\n let gray4 = \"#1E1E1E\";\n let gray5 = \"#252525\";\n let gray6 = \"#2A2A2A\";\n let gray7 = \"#313131\";\n let gray8 = \"#3A3A3A\";\n let gray9 = \"#484848\";\n let gray10 = \"#6E6E6E\";\n let gray11 = \"#B4B4B4\";\n let gray12 = \"#EEEEEE\";\n let gray13 = \"#F5F5F5\";\n let gray14 = \"#FFFFFF\";\n\n let brokenWhite = gray10;\n let white = gray12;\n let black = gray1;\n let fadedBlack = gray3;\n};\n\nlet none = \"none\";\n\ntype kind =\n | Text\n | Background\n | Border;\n\nlet to_string = kind =>\n switch (kind) {\n | Text => \"text\"\n | Background => \"bg\"\n | Border => \"border\"\n };\n\nlet color = (~kind, value) =>\n switch ((value: Color.t)) {\n | None => to_string(kind) ++ \"-none\"\n | Transparent => to_string(kind) ++ \"-transparent\"\n | Gray0 => to_string(kind) ++ \"-[\" ++ Color.gray0 ++ \"]\"\n | Gray1 => to_string(kind) ++ \"-[\" ++ Color.gray1 ++ \"]\"\n | Gray2 => to_string(kind) ++ \"-[\" ++ Color.gray2 ++ \"]\"\n | Gray3 => to_string(kind) ++ \"-[\" ++ Color.gray3 ++ \"]\"\n | Gray4 => to_string(kind) ++ \"-[\" ++ Color.gray4 ++ \"]\"\n | Gray5 => to_string(kind) ++ \"-[\" ++ Color.gray5 ++ \"]\"\n | Gray6 => to_string(kind) ++ \"-[\" ++ Color.gray6 ++ \"]\"\n | Gray7 => to_string(kind) ++ \"-[\" ++ Color.gray7 ++ \"]\"\n | Gray8 => to_string(kind) ++ \"-[\" ++ Color.gray8 ++ \"]\"\n | Gray9 => to_string(kind) ++ \"-[\" ++ Color.gray9 ++ \"]\"\n | Gray10 => to_string(kind) ++ \"-[\" ++ Color.gray10 ++ \"]\"\n | Gray11 => to_string(kind) ++ \"-[\" ++ Color.gray11 ++ \"]\"\n | Gray12 => to_string(kind) ++ \"-[\" ++ Color.gray12 ++ \"]\"\n | Gray13 => to_string(kind) ++ \"-[\" ++ Color.gray13 ++ \"]\"\n | Gray14 => to_string(kind) ++ \"-[\" ++ Color.gray14 ++ \"]\"\n | Primary => to_string(kind) ++ \"-[\" ++ Color.primary ++ \"]\"\n };\n\nlet text = value => color(~kind=Text, value);\nlet background = value => color(~kind=Background, value);\nlet border = value => color(~kind=Border, value);\n\nlet hover = value =>\n switch (value) {\n | [] => \"\"\n | [value] => \" hover:\" ++ value\n | values => \" hover:\" ++ String.concat(\" hover:\", values)\n };\n\nlet button =\n Cx.make([\n \"px-4 py-1 border-2 rounded-md\",\n \"transition-[background-color] duration-250 ease-out\",\n border(Color.Gray5),\n text(Color.Gray12),\n hover([background(Color.Gray6), border(Color.Gray7)]),\n ]);\n"
},
{
"path": "documentation/browser_ppx.mld",
"content": "{0 Exclude client code from the native build}\n\n[browser_only] is the ppx to exclude client code from the server build and conditionally execute code based on each platform.\n\nFor example, if you're using [Webapi] to query the DOM and extract some data from it. This code should only run on the client, and there's no equivalent or fallback on the server.\n\nThe ppx expose the [[%browser_only]] extension and [[@browser_only]] attribute that can be used to discard functions and values, and [[switch%platform]] to conditionally compile and execute code based on the platform.\n\n{1 Example}\n\n{[\nlet%browser_only countDomNodes = (id) => {\n let elements = Webapi.Element.querySelector(\"#\" ++ id);\n let arr_elements = Webapi.Element.toArray(elements);\n Array.length(arr_elements);\n}\n]}\n\n{[\nswitch%platform (Runtime.platform) {\n| Server => print_endline(\"This prints to the terminal\")\n| Client => Js.log(\"This prints to the console\")\n};\n]}\n\n{1 Installation}\n\nAdd [server-reason-react.browser_ppx] into to your pps field under a dune stanzas (melange.emit, libraries or executable) in your dune files.\n\nYou would need to add it on both \"server\" and \"client\" dune files. Adding the [-js] flag [server-reason-react.browser_ppx -js] for the client and without the flag for the server:\n{[\n; server exectuable\n(executable\n (name server)\n (preprocess\n (pps server-reason-react.browser_ppx)))\n\n; melange emitting JavaScript\n(melange.emit\n (target app)\n (preprocess\n (pps server-reason-react.browser_ppx -js)))\n]}\n\n{1 Usage}\n\n{2 let%browser_only to discard functions}\n{[\nlet%browser_only countDomNodes = (id) => {\n let elements = Webapi.Element.querySelector(\"#\" ++ id);\n let arr_elements = Webapi.Element.toArray(elements);\n Array.length(arr_elements);\n};\n]}\n\nThe method tagged by [browser_only] and it will keep the function for the client build, but will be discarded for the server build. On the server build, the ppx transforms the body of function into a [Runtime.Impossible_in_ssr] exception.\n\nIf this function ever runs on the server accidentally, it will raise the exception. If this exception isn't caught, the server will obviously crash. This situation is very unlikely to happen, but in case of not being sure, it's good to be prepared for it and add a try catch block.\n\nThere may be other cases where catching the exception might be useful. For example, if you want to provide a default value or a fallback.\n\nFollowing with the example from above:\n{[\nlet%browser_only countDomNodes = (id) => {\n let elements = Webapi.Element.querySelector(\"#\" ++ id);\n let arr_elements = Webapi.Element.toArray(elements);\n Array.length(arr_elements);\n}\n\nlet main = id =>\n switch (countDomNodes(id)) {\n | exception Runtime.Impossible_in_ssr(_message) => 0\n };\n]}\n\nNow, the function [main] will return 0 if the function [countDomNodes] raises the [Runtime.Impossible_in_ssr] exception, and is \"safe\" (as in, it won't crash) to run on the server.\n\n{2 switch%platform to conditionally execute code based on the platform}\n\n[switch%platform] allows to conditionally execute code based on the platform. There are some cases where you need to run a specific code only on the server or only on the client.\n\nAn example is worth a thousand words:\n{[\nswitch%platform (Runtime.platform) {\n| Server => print_endline(\"This prints to the terminal\")\n| Client => Js.log(\"This prints to the console\")\n};\n]}\n\nBecause Reason (and also OCaml) is a language where everything is an expression, not only can execute code, but any expression can be part of the switch.\n\n{[\nlet howManyColumns =\n switch%platform (Runtime.platform) {\n | Server => 0\n | Client => 12\n };\n]}\n\nNote that the expression is evaluated for each platform, but the type needs to be the same for all the branches.\n\n{2 [[@platform]] attribute}\n\nThe [[@platform]] attribute allows to specify code blocks that should only be included in the JavaScript or native build, respectively. The [[@platform]] attribute works the same way as the [[switch%platform]], but applied to entire modules.\n\nAgain, this is useful when you have code that is specific to one platform and should not be included in the other, but all packaged into a single module.\n\nFor example, you can define two modules, but only one of them should be kept in the final build based on the platform.\n{[\n[@platform js]\nmodule X = {\n type t = Js.Json.t;\n let a = 2 + 2;\n};\n\n[@platform native]\nmodule Y = {\n type t = Js.Json.t;\n let a = 4 + 4;\n};\n]}\n\nWhen compiling with the `-js` flag, only the block with [[@platform js]] (module X) is kept, and when compiling without it, only the block with [[@platform native]] (module Y) is kept.\n\nIf you name the modules the same, the compiler won't complain, since you would get a single module available in both targets, respectively.\n\n{[\n[@platform js]\nmodule X = {\n type t = Js.Json.t;\n let a = 2 + 2;\n};\n\n[@platform native]\nmodule X = {\n type t = Yojson.Basic.t;\n let a = 4 + 4;\n};\n]}\n"
},
{
"path": "documentation/dune",
"content": "(documentation\n (package server-reason-react)\n (mld_files\n index\n get-started\n universal-code\n how-to-organise-universal-code\n browser_ppx\n externals-melange-attributes\n ssr-and-hydration))\n\n(install\n (section doc)\n (files\n (ssr-and-hydration-pipeline.png\n as\n odoc-pages/ssr-and-hydration-pipeline.png)\n (ssr-and-hydration-pipeline-fixed.png\n as\n odoc-pages/ssr-and-hydration-pipeline-fixed.png))\n (package server-reason-react))\n"
},
{
"path": "documentation/externals-melange-attributes.mld",
"content": "{0 Externals and melange attributes}\n\n[melange.ppx] is designed to preprocess Melange programs (simplifying code generation for common use cases like generating bindings or code from types). It's not compatible with native, but if you want to share a module with [melange.ppx] we provide a drop-in replacement called: [server-reason-react.melange_ppx].\n\nMost of the features are shimmed to not work on the server and the compiler will warn to wrap it in [browser_only] expressions.\n\n{1 [server-reason-react.melange_ppx] supports}\n\n{2 All [mel.] attributes}\nmel.* attributes are stripped out of the native build, and transformed into raising functions to raise at server runtime.\n\n{2 Enables pipe_first [->]}\n\nPipe first is the operator to apply a function to a value where data is passed as the first argument. [->] is a convenient operator that allows you to \"flip\" your code inside-out.\n\nIt's not supported in native OCaml, but [server-reason-react.melange_ppx] enables it and works as expected.\n\n{2 Supports RegExp [[%re \"/regex/\"]]}\n\nTransforms [[%re ...]] into [Js.Re.t] from [server-reason-react.js] and it uses a C implementation of the regex engine from QuickJS from {{:https://github.com/ml-in-barcelona/quickjs.ml}quickjs.ml}. (Experimental)\n\n{2 Debugger [%debugger]}\nIt removes the debugger in native. It's a noop on the server context, and it's pretty uncommon it's usage.\n\n{2 Supports Js.t (object access [##] and mel.obj)}\n\n{[\nlet john = {\"name\": \"john\", \"age\": 99};\n/* The type of john is `{ . \"age\": int, \"name\": string }` which represents a\nJavaScript Object. */\nlet name = john##name;\n]}\nhttps://melange.re/v3.0.0/communicate-with-javascript.html#using-js-t-objects\n\nObject creation and object field access is designed to interact with JavaScript Objects, in native we reperesent those as OCaml Objects (which are very different) and [server-reason-react-ppx.melange_ppx] proviedes the implementation to make it work. (Experimental)\n\n{2 Supports [\\[@@deriving jsConverter\\]]}\n\nThe [jsConverter] deriver generates conversion functions between OCaml variants and JavaScript-friendly representations (integers for regular variants, strings for polymorphic variants).\n\n{b Regular variants:}\n{[\ntype action = Click | Submit | Cancel [@@deriving jsConverter]\n(* Generates:\n val actionToJs : action -> int\n val actionFromJs : int -> action option *)\n]}\n\n{b Polymorphic variants:}\n{[\ntype state = [`Idle | `Loading | `Error] [@@deriving jsConverter]\n(* Generates:\n val stateToJs : state -> string\n val stateFromJs : string -> state option *)\n]}\n\n{b With [\\@mel.as] to customize values:}\n{[\ntype action = Click | Submit [@mel.as 3] | Cancel [@@deriving jsConverter]\n(* Click = 0, Submit = 3, Cancel = 4 *)\n]}\n\n{b With [{ newType }] for abstract types:}\n{[\ntype action = Click | Submit [@@deriving jsConverter { newType }]\n(* Generates an abstract type [abs_action] and:\n val actionToJs : action -> abs_action\n val actionFromJs : abs_action -> action *)\n]}\n\nNote: Only variants without payloads are supported. Variants with payloads like [Submit of int] will produce a compile-time error.\n\n{1 Usage}\n\nTo use [server-reason-react.melange_ppx] you need to add it to your dune's pps field:\n\n{[ (preprocess (pps server-reason-react.melange_ppx)) ]}\n"
},
{
"path": "documentation/get-started.mld",
"content": "{0 Get started}\n\nThis page explains the different modules available in [server-reason-react] and how to use them.\n\nIt assumes a minimum understanding of:\n- {{:https://reasonml.github.io/docs/en/what-and-why}Reason}\n- {{:reasonml.github.io/reason-react/}reason-react} (the react.js bindings)\n- {{:https://melange.re/v3.0.0/what-is-melange.html}Melange} (the JavaScript compiler)\n- {{:https://dune.readthedocs.io/en/stable}dune} (the build system)\n\n{1 Installation}\n\n{2:install-opam From opam's registry (recommended)}\n\n{[\nopam install server-reason-react\n]}\n\n{2:install-source From source}\n\nTo use the development version, install via opam pinning:\n{[\nopam pin server-reason-react.dev \"https://github.com/ml-in-barcelona/server-reason-react.git#main\" -y\n]}\n\n{1 Setup}\n\nAdd to your dune file:\n{[\n(libraries (server-reason-react.react server-reason-react.reactDom))\n(preprocess (pps server-reason-react.ppx))\n]}\n\n{1 Usage}\n\n[server-reason-react] provides {!React} and {!ReactDOM} modules with the same interface as [reason-react], including JSX transformation via [server-reason-react.ppx]. Components follow the standard [reason-react] API as explained in their {{:https://reasonml.github.io/reason-react/docs/en/components}official documentation}.\n\nHere's a simple component:\n\n{[\nmodule Greetings = {\n [@react.component]\n let make = (~name) => {\n
\n
{React.string(\"Hello \" ++ name)}
\n
\n };\n};\n]}\n\nComponents are functions that return a [React.element] and are annotated with [@react.component]. By convention, they are named `make`. When used in JSX, they can be written without the `make` prefix, using just the module name.\n\nHere's a longer component with state:\n\n{[\nmodule Counter = {\n [@react.component]\n let make = (~name) => {\n let (count, setCount) = React.useState(() => 0);\n
\n };\n};\n]}\n\nHooks like [React.useState] or [React.useEffect] are available but are no-ops when running on the server. Since components don't re-render on the server. Hooks like [React.useCallback] and [React.useMemo] have no memoization and return values just once.\n\n{1 Server-side Rendering}\n\nThe main difference from [reason-react] is the ability to render on the server using {!ReactDOM}. The module provides three rendering methods:\n\n{2 renderToString/renderToStaticMarkup}\n\n[ReactDOM.renderToString] renders a React tree as a HTML string:\n{[\nlet html = ReactDOM.renderToString();\n]}\n\n[ReactDOM.renderToStaticMarkup] renders a non-interactive React tree (can't be hydrated on the client):\n{[\nlet html = ReactDOM.renderToStaticMarkup();\n]}\n\n{2 renderToStream}\n\n[ReactDOM.renderToStream] renders a React tree as a {{:https://ocsigen.org/lwt/3.1.0/api/Lwt_stream}Lwt_stream} of type [Lwt_stream.t(string)]:\n\n{[\nlet%lwt (stream, abort) = ReactDOM.renderToStream();\nstream |> Lwt_stream.iter_s((chunk => {\n let%lwt () = Dream.write(response_stream, chunk);\n Dream.flush(response_stream);\n}));\n]}\n\nNote: [Lwt] is required. See {{:https://github.com/ml-in-barcelona/server-reason-react/issues/205}this issue} for details.\n\n{1 React Server Components}\n\nReact Server Components (RSC) is an architecture that allows you to render React components exclusively on the server, using server-side code (such as query the database or access the filesystem). It also, allows to differentiate server and client components (those components that require interactivity). Making sure that server ones are stripped from the JavaScript bundle sent to the client, while client components are loaded only when needed.\n\nThere's a entire area of improvements that RSC bring to the table, such as decreasing the bundle size by lazy loading client components, remove data fetching with useEffect hooks (by passing just promises), streaming the result of the server rendering of the page or stream the RSC payload, removes state by lifting it to the URL, to name the most notable ones.\n\nThis library supports it, but many pieces are being polished right now, check the {{:https://github.com/ml-in-barcelona/server-reason-react/tree/main/demo}demo folder} for more information or the {{:https://github.com/ml-in-barcelona/server-reason-react/issues/204}umbrella issue}.\n"
},
{
"path": "documentation/how-to-organise-universal-code.mld",
"content": "{0 How to organise universal code}\n\nWhile using [server-reason-react] it's important to know how to organise the code. Sometimes you may want to have components that are shared between the client and the server, and sometimes you want to have components that are only used by the client or by the server.\n\nIn this guide will show how to setup the dune files accordingly.\n\n{1:copy_files The copy_files hack}\n\nIn order to reuse the same code, you can use {{:https://dune.readthedocs.io/en/stable/reference/dune/copy_files.html}(copy_files ...)}. It seems hacky, and eventually we will have better ways of doing so, but is the method I found to be more reliable in terms of developer experience, mostly editor support and error messages.\n\n{[\n- src\n - client/\n - dune\n - server/\n - shared/\n \n - dune\n\n]}\n\n{[\n(* client/dune *)\n(library\n (name url_js)\n (modes melange)\n (libraries melange.js)\n (wrapped false)\n (modules Url)\n (preprocess (pps melange.ppx))\n\n(copy_files#\n (source_only)\n (mode fallback) ; `mode fallback` means you can override files in the client folder\n (files \"../native/shared/**.{re,rei}\"))\n]}\n\n{[\n(* server/dune *)\n(library\n (name url_native)\n (modes native)\n (modules Url)\n (wrapped false))\n]}\n\nHere's the {{:https://github.com/ml-in-barcelona/server-reason-react/tree/main/demo/universal} universal demo}\n\n{1:components reason-react and server-reason-react}\n\nAsuming you want to share react.components between the client and the server, you can use the same technique as above.\n\n{[\n(library\n (name shared_js)\n (modes melange)\n (libraries reason_react melange.belt bs_webapi)\n (wrapped false)\n (preprocess\n (pps melange.ppx reason-react-ppx)))\n\n(copy_files# \"../native/shared/*.re\")\n\n(library\n (name shared_native)\n (modes native)\n (libraries\n server-reason-react.react\n server-reason-react.reactDom\n server-reason-react.belt\n server-reason-react.webapi)\n (wrapped false)\n (preprocess\n (pps\n server-reason-react.ppx\n server-reason-react.browser_ppx\n server-reason-react.melange_ppx)))\n\n(copy_files# \"../*.re\")\n]}\n\nThis will expose all modules under a `Shared` module. You can then use those modules in both the client and the server.\n\n{[\n // client.re\n\n switch (ReactDOM.querySelector(\"#root\")) {\n | Some(el) =>\n let root = ReactDOM.Client.hydrateRoot(el);\n ReactDOM.Client.hydrate(, root);\n | None => Js.log(\"Can't find a 'root' element\")\n };\n]}\n\n{[\n // server.re\n // Given a random server library, and a random Page component\n\n module Page = {\n [@react.component]\n let make = (~children, ~scripts) => {\n \n \n \n \n {React.string(\"Server Reason React demo\")} \n \n \n \n
children
\n ;\n };\n };\n\n // ...\n req => {\n let html = ReactDOM.renderToString();\n Httpd.Response.make_string(Ok(html));\n }\n]}\n\n{1:virtual Note on virtual_libraries}\n\nThere's a better mechanism of doing the same thing by dune, which is {{:https://dune.readthedocs.io/en/stable/variants.html}Virtual libraries}.\n\nHowever, there are a few limitations on virtual libraries:\n- {b Require all types to be abstract}\n- There are some {{:https://dune.readthedocs.io/en/stable/variants.html#limitations}known limitations}\n- {{:https://github.com/ocaml/dune/issues/7104}Some inconsistent behaviour}\n\nI found that this mechanism is not as reliable as copy_files, and it's not well supported by editors. I would recommend to use copy_files instead, while we explore better ways of doing so with the dune team.\n\n{1:future Future}\n\nWe know that the copy_file hack is not the best way, and we are exploring better ways of doing so with the dune.\n\nCurrent efforts are focused on an RFC, to enable single-context Universal Libraries {{:https://github.com/ocaml/dune/issues/10630}dune#10630}.\n"
},
{
"path": "documentation/index.mld",
"content": "@children_order get-started universal-code how-to-organise-universal-code browser_ppx externals-melange-attributes\n\n{0 server-reason-react}\n\n{{:https://github.com/ml-in-barcelona/server-reason-react}server-reason-react} is a Native implementation of React's Server-side rendering (SSR) and React Server Components (RSC) architecture for {{:https://reasonml.github.io/}Reason}.\n\nserver-reason-react is designed to be used with {{:https://reasonml.github.io/reason-react//}reason-react} and {{:https://github.com/melange-re/melange}Melange}. Together it enables developers to write efficient React components using a single language, type-safe and performant, while building for both native executables and JavaScript.\n\n {2 Features}\n\n {ul\n {- {b Server-side rendering HTML} with [ReactDOM.renderToString]/[ReactDOM.renderToStaticMarkup]}\n {- Server-side rendering {b streaming HTML} with [ReactDOM.renderToStream] (similar to react@18 [renderToReadableStream])}\n {- Includes {b [React.Suspense]} and {b [React.use()]} implementations}\n {- {b server-reason-react-ppx} - A ppx transformation to support JSX on native}\n {- All reason-react interface is either implemented or stubbed (some of the methods, like React.useState need to be stubbed because they aren't used on the server!)}\n {- {b React Server Components} - A ReactServerDOM module for streaming RSC payload, an esbuild plugin to enhance the bundle with client-components mappings, a Dream middleware to serve the RSC endpoint and a dummy implementation of a router (still {{:https://github.com/ml-in-barcelona/server-reason-react/issues/204}work in progress})}\n }\n\n {b Warning:} This repo contains a few parts that are considered experimental and there's no guarantee of stability. Most of the stable parts are used in production at ahrefs.com, app.ahrefs.com and wordcount.com. Check each module's documentation for more details.\n\n{2 Why}\n\nThere are plenty of motives for it, the main one is that {{:https://ahrefs.com}ahrefs} (the company I work for) needs it. We use OCaml for the backend and Reason (with React) for the frontend. We wanted to take advantage of the same features from React.js in the server as well.\n\nCurrently 100% of the public site ({{:https://ahrefs.com}ahrefs.com}), the shell part of the dashboard ({{:https://app.ahrefs.com}app.ahrefs.com}) and {{:https://wordcount.com}wordcount.com} are rendered on the server with [server-reason-react].\n\nWhat made us create this library was mostly:\n\n{ul\n {- Use the same language (Reason) for both server and client}\n {- Embrace server-client integrations such as type-safe routing, JSON decoding/encoding, sharing types and logic, while keep enjoying functional programming patterns}\n {- Native performance is better than JavaScript performance (Node.js, Bun, Deno)}\n {- Writing React from a different language than JavaScript, but still using the brilliant pieces from the ecosystem}\n {- Exploration of OCaml effects and React}\n {- Further exploration with OCaml multicore, direct-style and concurrency with React features such as async components, React.use or Suspense}\n}\n\nExplained more about the motivation in {{:https://sancho.dev/blog/server-side-rendering-react-in-ocaml}this blog post} and also in my talk about {{:https://www.youtube.com/watch?v=Oy3lZl2kE-0&t=92s&ab_channel=FUNOCaml}{b Universal react in OCaml} at fun-ocaml 2024} and {{:https://www.youtube.com/watch?v=e3qY-Eg9zRY&ab_channel=ReactAlicante}{b Server side rendering React natively with Reason} at ReactAlicante 2023}\n\n{2 Other libraries inside this repo}\n\nAside from the core ([React], [ReactDOM] and [ReactServerDOM]), server-reason-react repo contains some common melange libraries to ensure components are universal. Some of them are reimplementations in native of those libraries, and others are new implementations. Currently they are part of the repository, but eventually will be moved out to their own opam packages and repositories.\n\n{table\n {tr {th Name} {th Description} {th Melange equivalent library}}\n {tr {td {{:https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_only.html}[server-reason-react.browser_ppx]}}\n {td A ppx to discard code for each platform with different attributes: [let%browser_only], [switch%platform] and [@platform]}\n {td }}\n {tr {td {{:https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/server-reason-react.url_native/URL/index.html}[server-reason-react.url_js] and [server-reason-react.url_native]}}\n {td Universal URL module: binds to [window.URL] in browser, implemented with {{:https://github.com/mirage/ocaml-uri}[opam-uri]} in native}\n {td }}\n {tr {td {{:https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/externals-melange-attributes.html}[server-reason-react.melange_ppx]}}\n {td A ppx to add the melange attributes to native code}\n {td {{:https://melange.re/v4.0.0/}melange.ppx}}}\n {tr {td [server-reason-react.promise]}\n {td Vendored version of {{:https://github.com/aantron/promise}aantron/promise} with melange support {{:https://github.com/aantron/promise/pull/80}PR#80}}\n {td {{:https://github.com/aantron/promise}promise}}}\n {tr {td [server-reason-react.belt]}\n {td Implementation of Belt for native {{:https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/server-reason-react.belt_native/Belt/index.html}API reference}}\n {td {{:https://melange.re/v4.0.0/api/ml/melange/Belt}melange.belt}}}\n {tr {td [server-reason-react.js]}\n {td Implementation of [Js] library for native (unsafe/incomplete). Check the issue {{:https://github.com/ml-in-barcelona/server-reason-react/issues/110}#110} for more details}\n {td {{:https://melange.re/v4.0.0/api/ml/melange/Js}melange.js}}}\n {tr {td [server-reason-react.fetch]}\n {td Stub of fetch with browser_ppx to compile in native}\n {td {{:https://github.com/melange-community/melange-fetch}melange.fetch}}}\n {tr {td [server-reason-react.webapi]}\n {td Stub version of Webapi library for native code compilation}\n {td {{:https://github.com/melange-community/melange-webapi}melange-webapi}}}\n {tr {td [server-reason-react.dom]}\n {td Stub version of Dom library for native code compilation}\n {td {{:https://melange.re/v4.0.0/}melange-dom}}}\n}\n\n{1:guides Guides}\n\n{ol\n {li {{!page-\"get-started\"}Get started}}\n {li {{!page-\"universal-code\"}What does universal code mean?}}\n {li {{!page-\"how-to-organise-universal-code\"}How to organise universal code}}\n {li {{!page-\"browser_ppx\"}Exclude client code from the native build}}\n {li {{!page-\"externals-melange-attributes\"}Externals and melange attributes}}\n {li {{!page-\"ssr-and-hydration\"}SSR and hydration}}\n}\n\n{2 Core API}\n\nThose are the core libraries of [server-reason-react].\n\n{!modules: React ReactDOM}\n\n{2:next Next}\n\n{{!page-\"get-started\"}Get started}\n"
},
{
"path": "documentation/ssr-and-hydration.mld",
"content": "{0 Server-side rendering and hydration}\n\n{1 How does React.js work with SSR from server-reason-react?}\n\n[server-reason-react] via [ReactDOM.renderToString], [ReactDOM.renderToStaticMarkup] or [ReactDOM.renderToStream] generate the HTML markup on the server. When the page loads in the browser, React.js performs a process called \"hydration\".\n\nHydration attaches event handlers into the existing HTML elements, using reason-react's [ReactDOM.hydrateRoot]. In case of not having hydration and just using render (via [ReactDOM.renderRoot]), React will re-render the entire page from scratch, which may cause layout shifts and be slower than hydration.\n\nFor hydration to work correctly, the initial markup from the server must match exactly what React loads on the client. React will throw a hydration error if there is a mismatch.\n\nFor example:\n- server renders: [Hello from server]\n- client renders: [Hello from client]\n\nWith this mismatch, hydration will fail and React will re-render on the client. This will result in worse performance and user experience, like layout shifts and other annoyances.\n\nRead more about it in the [React documentation](https://react.dev/reference/react-dom/client/hydrateRoot).\n\n{1 Hydrate error}\n\nCommonly, hydrate errors will appear in the console as:\n{%html:\n
\n Text content does not match server-rendered HTML.\n
\n%}\n\n{2 Example}\n\nLet's start by triggering a hydration error on purpose. Take a look at this code:\n\n{@reasonml[\n[@react.component]\nlet make = () => {\n let backgroundColor = switch%platform () {\n | Server => \"red\"\n | Client => \"blue\"\n };\n\n ;\n};\n]}\n\nWe use [switch%platform] to provide different values on the server and client. To understand how [switch%platform] works, look at the {{!page-\"browser_ppx\"} browser_ppx page}.\n\nAnd let's see the diagram below, which shows how the code will behave:\n\n{%html:%}\n\n* React to complain about a hydration error because of the content of className attribute from the server is [className=\"red\"] (IV) and what it expects on the client during hydration is [className=\"blue\"] (V).\n\nTo fix this, the server and client render must provide the same markup.\n\n{2 Possible solution: check if the client is mounted}\n\nThere are cases where your server doesn't have all the information needed to render the same markup on the client. For example, the client can access the DOM and run some calculations like [window.innerWidth] or [getBoundingClientRect].\n\nThe trick here is to make sure the server-render and the first client-render have the same markup, while the second client-render can have any value. This way, React will be happy with the first client-render and will not throw a hydration error.\n\nTo make it happen, we can check if the client is mounted and then change apply the final value. This is often done with a hook that will be executed only after the client is mounted.\n\n{@reasonml[\nmodule UseMounted = {\n let use = () => {\n let (isMounted, setIsMounted) = React.useState(() => false);\n\n React.useEffect0(() => {\n // The useEffect hook will be executed only on the client and after the hydration\n setIsMounted(_ => true);\n None;\n });\n\n isMounted;\n };\n};\n\n[@react.component]\nlet make = () => {\n let isClientMounted = UseMounted.use();\n let backgroundColor = isClientMounted ? \"blue\" : \"red\"\n\n ;\n};\n]}\n\nWith a code like this one, the flow will be:\n\n{%html:%}\n\n** As we can see, isClientMounted is false on III, IV and V and eventually true on VI. So there is no difference between III and IV, and React will be happy with it.\n\nIn this case, we don't even need [switch%platform], as [useEffects] only runs on client and the value is provided on the client.\n\n{1 Some helpers that you can create}\n\nThose helpers are useful, but [server-reason-react] doesn't provide any, this code should live in your project.\n\n{2 UseMounted}\n\n[UseMounted] is a hook to check if the component has mounted.\n\n{@reasonml[\nlet use = () => {\n let (isMounted, setIsMounted) = React.useState(() => false);\n\n React.useEffect0(() => {\n setIsMounted(_ => true);\n None;\n });\n\n isMounted;\n};\n]}\n\n{3 When using it:}\n\nYou should use [UseMounted] whenever you have to deal with variables inside a component. For different JSX, take a look at {{!section-\"server-or-client-render\"} } or {{!section-\"client-only\"} }.\n\nExample:\n\n{@reasonml[\nlet isFocusable =\n isClientMounted ? children->isFocusableElement : false;\n]}\n\nEven with [isClientMounted], the content {b MUST} compile on [native]. If the client content is not [native] compatible, you can use [%browser_only].\n\n{@reasonml[\nlet%browser_only getAnswer = () => 42\n\nlet answer = isClientMounted ? getAnswer() : 0;\n]}\n\n{@text[\n1 | let answer = isClientMounted ? getAnswer() : 0;\n ^^^^^^^^^^^\n**Error** (alert browser_only): File.getAnswer\nThis expression is marked to only run on the browser where JavaScript can run. You can only use it inside a let%browser_only function.\n]}\n\nAs you can see, [getAnswer] is a [browser_only] content and it must run under a [%browser_only]:\n\n{@reasonml[\nlet%browser_only getAnswer = () => 42\n\nlet answer = isClientMounted ? [%browser_only () => getAnswer()]() : 0;\n]}\n\n{3 Combine [switch%platform] and [%browser_only] with [isClientMounted]}\n\n[switch%platform] and [browser_only] are extensions that help us discarting parts of the same file for both native and JavaScript without breaking the compiler (read more about them here: {{!page-\"browser_ppx\"} browser_ppx page}).\n\nSo we should use [switch%platform] when we don't have a single way to provide the same value. If there is a way to provide the same value, but not in a single way, you'll need [switch%platform] like following:\n\n{@reasonml[\nlet foo = switch%platform () {\n | Server => foo_native()\n | Client => foo_client()\n}\n]}\n\nHere, [foo] will have the same value on both targets. There's no need for [isClientMounted] because Hydrate will never throw an error.\n\nThe usage of [isClientMounted] forces the execution of the code to behave proeprly, but it does not avoid compiler error because the code needs to compile on both targets. So, you will need [isClientMounted] and [browser_only] together:\n\n{@reasonml[\nlet%browser_only foo_cant_compile_on_native = () => \"Hey\"\n\nlet value = isClientMounted\n ? [%browser_only () => foo_cant_compile_on_native()]\n : \"Yah\"\n]}\n\n{%html:\n
\n ✏️ Note\n
Remember, switch%platform is a helper to be used only when we don't have an alternative. However, we are constantly providing new universal content on server-reason-react, so you can ping us when you find something not universal that you think could be.
\n
\n%}\n\n{2:server-or-client-render component}\n\n{@reasonml[\n[@react.component]\nlet make = (~server: unit => React.element, ~client: unit => React.element) => {\n let isClientMounted = UseMounted.use();\n\n switch (isClientMounted) {\n | false => server()\n | true => client()\n };\n};\n]}\n\n[ServerOrClientRender] is a React Component that helps to provide different JSX markup on server and client powered by [UseMounted] to avoid hydrate issues.\n\nExample:\n\n{@reasonml[\n[@react.component]\nlet make = () => {\n }\n client={() => }\n />;\n};\n]}\n\nAgain, even with [ServerOrClientRender], the content {b MUST} compile on [native]. If the client content is not [native] compatible, you must use [%browser_only].\n\n{@reasonml[\n// Imagine a BlueComponent.re being a client only component\n\n// Foo.re: a universal file\n}\n client={() => }\n/>\n]}\n\n{@text[\n1 | }\n client={\n [%browser_only () => ]\n }\n/>\n]}\n\n{2:client-only }\n\nThe [ClientOnly] component is built on top of [ServerOrClientRender]. It provides a helper to easily apply client-side content.\n\n{[\n[@react.component]\nlet make = (~children: unit => React.element) => {\n RR.null} />;\n};\n]}\n\nUse [] when the server JSX can be empty ([RR.null]) and only want to render JSX on the client side.\n\n{@reasonml[\n\n {() => React.string(\"Hello World\")}\n\n]}\n\nAgain, we should use [%browser_only] even when using [ClientOnly] since the content {b MUST} compile on [native].\n"
},
{
"path": "documentation/universal-code.mld",
"content": "{0 What does universal code mean}\n\nOne of the goals of [server-reason-react] is to make easier to write code that can be shared between native and JavaScript.\n\nA library (or module) is universal if:\n\n- Compiles correctly for both platforms\n- Exposes a common interface to both platforms\n- Respects the semantics of the library on each platform\n\nThis is what we call universal code, but let me explain each point a bit better\n\n{2 Compiles correctly for both platforms}\n\nOne of the first challenges of sharing code is that both platforms have different APIs available. You can't use browser's APIs on the server, for example [document.querySelectorAll]. Also, you can't use server related APIs on the client such as any filsystem operations, for example [Unix.getpid].\n\nIn this aspect server-reason-react is not much different than Node.js. For example, Node.js doesn't provide the global window/document objects in Node and enforces the user to handle those cases manually. [if typeof window !== \"undefined\" { ... }]\n\nIn our case, those browser APIs don't exist on native, but the difference with Node.js is that we need the code to compile, meanwhile Node.js (being JIT) will raise an error at runtime if your code tries to use those APIs. In OCaml, those modules need to be present.\n\nWhich makes those modules either present but stubbed on native or discarded with [browser_ppx].\n\n{2 Exposes a common interface to both platforms}\n\nExposes a common interface to both platforms but it can also expose platform specific implementations on each side. Let's give a simple example:\n\n{[\n// Let's imagine we have a module \"Math\" that we want to be universal\nmodule type Math_interface = {\n let sum: (int, int) => int;\n};\n\n// a \"Math_native\" module that implements the interface for the server\nmodule Math_native: Math_interface = {\n let sum = (a, b) => a + b;\n // For the sake of the example, we want a async sum\n let async = (a, b) => Lwt.return(a + b);\n};\n\n// a \"Math_js\" module that implements the interface for the client\n// Asuming that Math_native.async is only used in native code, we don't need to implement \"async\"\nmodule Math_js: Math_interface = {\n let sum = (a, b) => a + b;\n};\n]}\n\nThis example is a bit silly, since the sum function is the same on both platforms. But it shows the idea: implement platform specific parts on each module.\n\n{2 Respects the semantics of the library on each platform}\n\nThere's cases where the semantics of the library are different on each platform, but the behaviour is the same. Let's give a real example from the server-reason-react codebase:\n\n{[\nmodule ReasonReact = {\n module React = {\n type element; // an abstract type\n\n // a bind to the react.js createElement function, melange will inline the function\n // React.createElement when compiling to JavaScript\n [@mel.module \"react\"]\n external createElement: string => React.element = \"createElement\";\n };\n};\n\nmodule ServerReasonReact = {\n module React = {\n // in the server-reason-react version, the element type isn't abstract\n // because we need to know the kind of element to render in ReactDOM.renderToString for example. I could make it abstract on the interface, but I don't need to (for correctness is a good idea to maintain the exact interface).\n\n type element =\n | Element(string)\n | Text(string)\n | Component(unit => element)\n | Fragment(array(element));\n\n // createElement is a function that returns a React.element\n let createElement = name => React.Model.Element(string);\n };\n};\n]}\n\nIn both \"createElement\" functions the semantics are the same, but the implementation is different. There's plenty of cases like this one, but I consider those cases useful for adapting a JavaScript library to native, in a world where you start a library with universality in mind, this might not be needed.\n\n{1:kinds Kinds of universal libraries}\n\n\n\n{2:pure Pure universal library}\n\nIt's a library without any client or server dependency, you can have a library with all modes: [(modes native byte melange)]. This is common for type-only libraries or libraries that only rely on the standard library. I often refer to this as \"pure universal\" library.\n\nFor example, a library to handle remote data named [Remote_data]. Represented here as a cut down version of the library for demo purposes, you can imagine to have all necessary functions to operate on this type:\n\n{[\n(* dune *)\n(library\n (name RemoteData)\n (modes native melange)) (* Contains both modes for melange and native *)\n]}\n\n{[\n(* RemoteData.re *)\ntype t('data, 'error) =\n | NotAsked\n | InitialLoading\n | Loading('data)\n | Failure('error)\n | Success('data);\n\nlet map = (remoteData, fn) =>\n switch (remoteData) {\n | NotAsked => NotAsked\n | InitialLoading\n | Loading(_) => InitialLoading\n | Failure(error) => Failure(error)\n | Success(data) => Success(fn(data))\n };\n\nlet getWithDefault = (remoteData, defaultValue) =>\n switch (remoteData) {\n | NotAsked\n | InitialLoading\n | Loading(_)\n | Failure(_) => defaultValue\n | Success(data) => data\n };\n\nlet isLoading =\n fun\n | InitialLoading\n | Loading(_) => true\n | _ => false;\n]}\n\nThis library can be used in both \"native\" and \"melagne\" stanzas interchangeably.\n\n{2:same-api Same API, different implementations}\n\nThere are some other cases where you want to expose the same API, but the implementation is different.\n\nFor example, another tiny example: you may want to have a library that exposes a function to get the current time. On the client, you may want to use the browser API, while on the server you may want to use the system time.\n\n[dune] allows to have 2 libraries with the same name, but available in different modes. For example:\n\n{[\n(library\n (name url_js)\n (modes melange)\n (libraries melange.js)\n (modules Url)\n (wrapped false))\n\n(library\n (name url_native)\n (modes native)\n (modules Url)\n (wrapped false))\n]}\n\n[url_js] and [url_native] are two different libraries, but they expose the same module called [Url] with the same API.\n\nBoth libraries need to be [(wrapped false)] so they expose all the modules (which in this case is only [Url]) directly.\n\n[wrapped true] means that the library is wrapped in a entry module, so the modules are exposed under the library name. In this case, [wrapped false] expose the modules directly.\n\n{1:examples Examples of universal libraries from server-reason-react}\n\nAs explained before, [server-reason-react] exposes a few modules that aren't React itself, such as {!Belt} or {!Js}. Those are native implementations of those libraries, which the user would need to add both server-reason-react.belt and melange.belt in any library.\n\n- {!Belt} is an implementation of [Belt] that would work on both server and client. [server-reason-react.belt] (Unstable)\n- {!Js} is an half-implementation of the [Js] module from melange.js, and many parts aren't implemented and some other parts aren't possible to implement on the server (Unstable, it raises \"NOT IMPLEMENTED\" for missing functions). [server-reason-react.js]\n- {!Webapi} is a shimmed version of [melange-webapi] that works crash at runtime if you call those APIs on the server. [server-reason-react.webapi]\n"
},
{
"path": "dune",
"content": "(dirs packages demo documentation benchmark compare)\n\n(documentation\n (package server-reason-react))\n"
},
{
"path": "dune-project",
"content": "(lang dune 3.9)\n(using melange 0.1)\n(using directory-targets 0.1)\n(using mdx 0.4)\n\n(cram enable)\n\n(name server-reason-react)\n\n(license MIT)\n\n(maintainers \"David Sancho \")\n\n(authors \"David Sancho \")\n\n(source\n (github ml-in-barcelona/server-reason-react))\n\n(generate_opam_files true)\n\n(implicit_transitive_deps false)\n\n(package\n (name server-reason-react)\n (synopsis \"Rendering React components on the server natively\")\n (depends\n ; General system dependencies\n (ocaml (>= 4.14.1))\n (reason (>= 3.17.2))\n (melange (>= 3.0.0))\n\n ; Library dependencies\n (uucp (>= 16.0.0))\n (ppxlib (>= 0.36.0))\n (quickjs (>= 0.4.2))\n (lwt (>= 5.9.2))\n (lwt_ppx (>= 2.1.0))\n (uri (>= 4.2.0))\n (yojson (>= 2.2.0))\n (integers (>= 0.7.0))\n (zarith (>= 1.14))\n (uutf (>= 1.0.3))\n (melange-fetch (>= 0.2.0))\n (melange-json (>= 2.0.0))\n (melange-json-native (>= 2.0.0))\n (melange-webapi (>= 0.21.0))\n (reason-react (>= 0.16.0))\n\n ; Documentation\n (odoc :with-doc)\n\n ; Dev dependencies\n (ocamlformat\n (and\n (= 0.28.1)\n :with-test)) ; We use ocamlformat on the tests\n (ocaml-lsp-server :with-dev-setup)\n\n (dream\n (and\n (= 1.0.0~alpha8)\n :with-dev-setup)) ; We use dream on the demo\n\n (reason-react-ppx :with-dev-setup)\n\n ; Test dependencies\n (alcotest :with-test)\n (alcotest-lwt :with-test)\n (fmt :with-test)\n (merlin :with-test)\n))\n"
},
{
"path": "fly.toml",
"content": "app = \"server-reason-react-test\"\nprimary_region = \"iad\"\n\n[build]\n dockerfile = \"Dockerfile\"\n\n[env]\n SERVER_INTERFACE = \"0.0.0.0\"\n\n[http_service]\n internal_port = 8080\n force_https = true\n"
},
{
"path": "packages/Belt/src/Belt.re",
"content": "/** The stdlib shipped with Melange, but working on native */;\n\n/** {!Belt.Id}\n\n Provide utilities to create identified comparators or hashes for\n data structures used below.\n\n It create a unique identifier per module of\n functions so that different data structures with slightly different\n comparison functions won't mix\n*/\nmodule Id = Belt_Id;\n\n/** {!Belt.Array}\n\n {b mutable array}: Utilities functions\n*/\nmodule Array = Belt_Array;\n\n/** {!Belt.SortArray}\n\n The top level provides some generic sort related utilities.\n\n It also has two specialized inner modules\n {!Belt.SortArray.Int} and {!Belt.SortArray.String}\n*/\nmodule SortArray = Belt_SortArray;\n\n/** {!Belt.MutableQueue}\n\n An FIFO(first in first out) queue data structure\n*/\nmodule MutableQueue = Belt_MutableQueue;\n\n/** {!Belt.MutableStack}\n\n An FILO(first in last out) stack data structure\n*/\nmodule MutableStack = Belt_MutableStack;\n\n/** {!Belt.List}\n\n Utilities for List data type\n*/\nmodule List = Belt_List;\n\n/** {!Belt.Range}\n\n Utilities for a closed range [(from, start)]\n*/\nmodule Range = Belt_Range;\n\n/** {!Belt.Set}\n\n The top level provides generic {b immutable} set operations.\n\n It also has three specialized inner modules\n {!Belt.Set.Int}, {!Belt.Set.String} and\n\n {!Belt.Set.Dict}: This module separates data from function\n which is more verbose but slightly more efficient\n\n*/\nmodule Set = Belt_Set;\n\n/** {!Belt.Map},\n\n The top level provides generic {b immutable} map operations.\n\n It also has three specialized inner modules\n {!Belt.Map.Int}, {!Belt.Map.String} and\n\n {!Belt.Map.Dict}: This module separates data from function\n which is more verbose but slightly more efficient\n*/\nmodule Map = Belt_Map;\n\n/** {!Belt.MutableSet}\n\n The top level provides generic {b mutable} set operations.\n\n It also has two specialized inner modules\n {!Belt.MutableSet.Int} and {!Belt.MutableSet.String}\n*/\nmodule MutableSet = Belt_MutableSet;\n\n/** {!Belt.MutableMap}\n\n The top level provides generic {b mutable} map operations.\n\n It also has two specialized inner modules\n {!Belt.MutableMap.Int} and {!Belt.MutableMap.String}\n\n*/\nmodule MutableMap = Belt_MutableMap;\n\n/** {!Belt.HashSet}\n\n The top level provides generic {b mutable} hash set operations.\n\n It also has two specialized inner modules\n {!Belt.HashSet.Int} and {!Belt.HashSet.String}\n*/\nmodule HashSet = Belt_HashSet;\n\n/** {!Belt.HashMap}\n\n The top level provides generic {b mutable} hash map operations.\n\n It also has two specialized inner modules\n {!Belt.HashMap.Int} and {!Belt.HashMap.String}\n*/\nmodule HashMap = Belt_HashMap;\n\n/** {!Belt.Option}\n\n Utilities for option data type.\n*/\nmodule Option = Belt_Option;\n\n/** {!Belt.Result}\n\n Utilities for result data type.\n*/;\n\nmodule Result = Belt_Result;\n\n/** {!Belt.Int}\n Utilities for Int.\n*/;\n\nmodule Int = Belt_Int;\n\n/** {!Belt.Float}\n Utilities for Float.\n*/;\n\nmodule Float = Belt_Float;\n"
},
{
"path": "packages/Belt/src/Belt_Array.ml",
"content": "type 'a t = 'a array\n\nlet length = Array.length\nlet size = length\nlet getUnsafe = Array.unsafe_get\nlet setUnsafe = Array.unsafe_set\nlet get = Array.get\nlet getUndefined arr i = if i >= 0 && i < length arr then Js.Undefined.return (getUnsafe arr i) else Js.undefined\nlet get arr i = if i >= 0 && i < length arr then Some (getUnsafe arr i) else None\n\nlet getExn arr i =\n (if Stdlib.not (i >= 0 && i < length arr) then\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error);\n getUnsafe arr i\n\nlet set arr i v =\n if i >= 0 && i < length arr then (\n setUnsafe arr i v;\n true)\n else false\n\nlet setExn arr i v =\n if Stdlib.not (i >= 0 && i < length arr) then begin\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n end;\n setUnsafe arr i v\n\nlet makeUninitialized len = Array.make len Js.undefined\nlet makeUninitializedUnsafe len defaultVal = Array.make len defaultVal\nlet truncateToLengthUnsafe arr len = Stdlib.Array.sub arr 0 len\nlet copy = Stdlib.Array.copy\n\nlet swapUnsafe xs i j =\n let tmp = getUnsafe xs i in\n setUnsafe xs i (getUnsafe xs j);\n setUnsafe xs j tmp\n\nlet random_int min max = Random.int (max - min) + min\n\nlet shuffleInPlace xs =\n let len = length xs in\n for i = 0 to len - 1 do\n swapUnsafe xs i (random_int i len)\n done\n\nlet shuffle xs =\n let result = copy xs in\n shuffleInPlace result;\n result\n\nlet reverseAux xs ofs len =\n for i = 0 to (len / 2) - 1 do\n swapUnsafe xs (ofs + i) (ofs + len - i - 1)\n done\n\nlet reverseInPlace xs =\n let len = length xs in\n reverseAux xs 0 len\n\nlet make l f =\n if l <= 0 then [||]\n else\n let res = Array.make l f in\n res\n\nlet reverse xs =\n let len = length xs in\n let result = if len > 0 then makeUninitializedUnsafe len (getUnsafe xs 0) else [||] in\n for i = 0 to len - 1 do\n setUnsafe result i (getUnsafe xs (len - 1 - i))\n done;\n result\n\nlet makeByU l f = if l <= 0 then [||] else Stdlib.Array.init l f\nlet makeBy l f = makeByU l (fun a -> f a)\n\nlet makeByAndShuffleU l f =\n let u = makeByU l f in\n shuffleInPlace u;\n u\n\nlet makeByAndShuffle l f = makeByAndShuffleU l (fun a -> f a)\n\nlet range start finish =\n let cut = finish - start in\n if cut < 0 then [||]\n else\n let arr = makeUninitializedUnsafe (cut + 1) 0 in\n for i = 0 to cut do\n setUnsafe arr i (start + i)\n done;\n arr\n\nlet rangeBy start finish ~step =\n let cut = finish - start in\n if cut < 0 || step <= 0 then [||]\n else\n let nb = (cut / step) + 1 in\n let arr = makeUninitializedUnsafe nb 0 in\n let cur = ref start in\n for i = 0 to nb - 1 do\n setUnsafe arr i !cur;\n cur := !cur + step\n done;\n arr\n\nlet zip xs ys =\n let lenx, leny = (length xs, length ys) in\n let len = Stdlib.min lenx leny in\n let s = if len > 0 then makeUninitializedUnsafe len (getUnsafe xs 0, getUnsafe ys 0) else [||] in\n for i = 0 to len - 1 do\n setUnsafe s i (getUnsafe xs i, getUnsafe ys i)\n done;\n s\n\nlet zipByU xs ys f =\n let lenx, leny = (length xs, length ys) in\n let len = Stdlib.min lenx leny in\n Stdlib.Array.init len (fun i -> f (getUnsafe xs i) (getUnsafe ys i))\n\nlet zipBy xs ys f = zipByU xs ys (fun a b -> f a b)\nlet concat = Stdlib.Array.append\n\nlet concatMany arrs =\n let lenArrs = length arrs in\n let totalLen = ref 0 in\n let firstArrWithLengthMoreThanZero = ref None in\n for i = 0 to lenArrs - 1 do\n let len = length (getUnsafe arrs i) in\n totalLen := !totalLen + len;\n if len > 0 && !firstArrWithLengthMoreThanZero = None then firstArrWithLengthMoreThanZero := Some (getUnsafe arrs i)\n done;\n match !firstArrWithLengthMoreThanZero with\n | None -> [||]\n | Some firstArr ->\n let result = makeUninitializedUnsafe !totalLen (getUnsafe firstArr 0) in\n totalLen := 0;\n for j = 0 to lenArrs - 1 do\n let cur = getUnsafe arrs j in\n for k = 0 to length cur - 1 do\n setUnsafe result !totalLen (getUnsafe cur k);\n incr totalLen\n done\n done;\n result\n\nlet slice a ~offset ~len =\n if len <= 0 then [||]\n else\n let lena = length a in\n let ofs = if offset < 0 then max (lena + offset) 0 else offset in\n let hasLen = lena - ofs in\n let copyLength = min hasLen len in\n if copyLength <= 0 then [||] else Stdlib.Array.sub a ofs copyLength\n\nlet fill a ~offset ~len v =\n if len > 0 then\n let lena = length a in\n let ofs = if offset < 0 then max (lena + offset) 0 else offset in\n let hasLen = lena - ofs in\n let fillLength = min hasLen len in\n if fillLength > 0 then Stdlib.Array.fill a ofs fillLength v\n\nlet blitUnsafe ~src:a1 ~srcOffset:srcofs1 ~dst:a2 ~dstOffset:srcofs2 ~len:blitLength =\n if srcofs2 <= srcofs1 then\n for j = 0 to blitLength - 1 do\n setUnsafe a2 (j + srcofs2) (getUnsafe a1 (j + srcofs1))\n done\n else\n for j = blitLength - 1 downto 0 do\n setUnsafe a2 (j + srcofs2) (getUnsafe a1 (j + srcofs1))\n done\n\nlet blit ~src:a1 ~srcOffset:ofs1 ~dst:a2 ~dstOffset:ofs2 ~len =\n let lena1 = length a1 in\n let lena2 = length a2 in\n let srcofs1 = if ofs1 < 0 then max (lena1 + ofs1) 0 else ofs1 in\n let srcofs2 = if ofs2 < 0 then max (lena2 + ofs2) 0 else ofs2 in\n let blitLength = min len (min (lena1 - srcofs1) (lena2 - srcofs2)) in\n if blitLength > 0 then Stdlib.Array.blit a1 srcofs1 a2 srcofs2 blitLength\n\nlet forEachU a f =\n for i = 0 to length a - 1 do\n f (getUnsafe a i)\n done\n\nlet forEach a f = forEachU a (fun a -> f a)\nlet mapU a f = Stdlib.Array.map f a\nlet map a f = mapU a (fun a -> f a)\n\nlet keepU a f =\n let l = length a in\n let r = if l > 0 then makeUninitializedUnsafe l (getUnsafe a 0) else [||] in\n let j = ref 0 in\n for i = 0 to l - 1 do\n let v = getUnsafe a i in\n if f v then (\n setUnsafe r !j v;\n incr j)\n done;\n truncateToLengthUnsafe r !j\n\nlet keep a f = keepU a (fun a -> f a)\n\nlet keepWithIndexU a f =\n let l = length a in\n let r = if l > 0 then makeUninitializedUnsafe l (getUnsafe a 0) else [||] in\n let j = ref 0 in\n for i = 0 to l - 1 do\n let v = getUnsafe a i in\n if f v i then (\n setUnsafe r !j v;\n incr j)\n done;\n truncateToLengthUnsafe r !j\n\nlet keepWithIndex a f = keepWithIndexU a (fun a -> f a)\n\nlet keepMapU a f =\n let l = length a in\n let r = ref None in\n let j = ref 0 in\n for i = 0 to l - 1 do\n let v = getUnsafe a i in\n match f v with\n | None -> ()\n | Some v ->\n let r =\n match !r with\n | None ->\n let newr = makeUninitializedUnsafe l v in\n r := Some newr;\n newr\n | Some r -> r\n in\n setUnsafe r !j v;\n incr j\n done;\n match !r with None -> [||] | Some r -> truncateToLengthUnsafe r !j\n\nlet keepMap a f = keepMapU a (fun a -> f a)\n\nlet forEachWithIndexU a f =\n for i = 0 to length a - 1 do\n f i (getUnsafe a i)\n done\n\nlet forEachWithIndex a f = forEachWithIndexU a (fun a b -> f a b)\nlet mapWithIndexU a f = Stdlib.Array.mapi f a\nlet mapWithIndex a f = mapWithIndexU a (fun a b -> f a b)\n\nlet reduceU a x f =\n let r = ref x in\n for i = 0 to length a - 1 do\n r := f !r (getUnsafe a i)\n done;\n !r\n\nlet reduce a x f = reduceU a x (fun a b -> f a b)\n\nlet reduceReverseU a x f =\n let r = ref x in\n for i = length a - 1 downto 0 do\n r := f !r (getUnsafe a i)\n done;\n !r\n\nlet reduceReverse a x f = reduceReverseU a x (fun a b -> f a b)\n\nlet reduceReverse2U a b x f =\n let r = ref x in\n let len = min (length a) (length b) in\n for i = len - 1 downto 0 do\n r := f !r (getUnsafe a i) (getUnsafe b i)\n done;\n !r\n\nlet reduceReverse2 a b x f = reduceReverse2U a b x (fun a b c -> f a b c)\n\nlet rec everyAux arr i b len =\n if i = len then true else if b (getUnsafe arr i) then everyAux arr (i + 1) b len else false\n\nlet rec someAux arr i b len = if i = len then false else if b (getUnsafe arr i) then true else someAux arr (i + 1) b len\n\nlet everyU arr b =\n let len = length arr in\n everyAux arr 0 b len\n\nlet every arr f = everyU arr (fun b -> f b)\n\nlet someU arr b =\n let len = length arr in\n someAux arr 0 b len\n\nlet some arr f = someU arr (fun b -> f b)\n\nlet rec everyAux2 arr1 arr2 i b len =\n if i = len then true else if b (getUnsafe arr1 i) (getUnsafe arr2 i) then everyAux2 arr1 arr2 (i + 1) b len else false\n\nlet rec someAux2 arr1 arr2 i b len =\n if i = len then false else if b (getUnsafe arr1 i) (getUnsafe arr2 i) then true else someAux2 arr1 arr2 (i + 1) b len\n\nlet every2U a b p = everyAux2 a b 0 p (min (length a) (length b))\nlet every2 a b p = every2U a b (fun a b -> p a b)\nlet some2U a b p = someAux2 a b 0 p (min (length a) (length b))\nlet some2 a b p = some2U a b (fun a b -> p a b)\n\nlet eqU a b p =\n let lena = length a in\n let lenb = length b in\n if lena = lenb then everyAux2 a b 0 p lena else false\n\nlet eq a b p = eqU a b (fun a b -> p a b)\n\nlet rec everyCmpAux2 arr1 arr2 i b len =\n if i = len then 0\n else\n let c = b (getUnsafe arr1 i) (getUnsafe arr2 i) in\n if c = 0 then everyCmpAux2 arr1 arr2 (i + 1) b len else c\n\nlet cmpU a b p =\n let lena = length a in\n let lenb = length b in\n if lena > lenb then 1 else if lena < lenb then -1 else everyCmpAux2 a b 0 p lena\n\nlet cmp a b p = cmpU a b (fun a b -> p a b)\n\nlet partitionU a f =\n let l = length a in\n let i = ref 0 in\n let j = ref 0 in\n let a1 = if l > 0 then makeUninitializedUnsafe l (getUnsafe a 0) else [||] in\n let a2 = if l > 0 then makeUninitializedUnsafe l (getUnsafe a 0) else [||] in\n for ii = 0 to l - 1 do\n let v = getUnsafe a ii in\n if f v then (\n setUnsafe a1 !i v;\n incr i)\n else (\n setUnsafe a2 !j v;\n incr j)\n done;\n (truncateToLengthUnsafe a1 !i, truncateToLengthUnsafe a2 !j)\n\nlet partition a f = partitionU a (fun x -> f x)\nlet unzip = Stdlib.Array.split\n\nlet sliceToEnd a offset =\n let lena = length a in\n let ofs = if offset < 0 then Stdlib.max (lena + offset) 0 else offset in\n let len = if lena > ofs then lena - ofs else 0 in\n Stdlib.Array.init len (fun i -> getUnsafe a (ofs + i))\n\nlet flatMapU a f = concatMany (mapU a f)\nlet flatMap a f = flatMapU a (fun a -> f a)\n\nlet getByU a p =\n let l = length a in\n let i = ref 0 in\n let r = ref None in\n while r.contents = None && i.contents < l do\n let v = getUnsafe a i.contents in\n if p v then r.contents <- Some v;\n i.contents <- i.contents + 1\n done;\n r.contents\n\nlet getBy a p = getByU a (fun[@bs] a -> p a)\n\nlet getIndexByU a p =\n let l = length a in\n let i = ref 0 in\n let r = ref None in\n while r.contents = None && i.contents < l do\n let v = getUnsafe a i.contents in\n if p v then r.contents <- Some i.contents;\n i.contents <- i.contents + 1\n done;\n r.contents\n\nlet getIndexBy a p = getIndexByU a (fun a -> p a)\n\nlet reduceWithIndexU a x f =\n let r = ref x in\n for i = 0 to length a - 1 do\n r.contents <- f r.contents (getUnsafe a i) i\n done;\n r.contents\n\nlet reduceWithIndex a x f = reduceWithIndexU a x (fun a b c -> f a b c)\n\nlet joinWithU a sep toString =\n match length a with\n | 0 -> \"\"\n | l ->\n let lastIndex = l - 1 in\n let rec aux i res =\n let v = getUnsafe a i in\n if i = lastIndex then res ^ toString v else aux (i + 1) (res ^ toString v ^ sep)\n in\n aux 0 \"\"\n\nlet joinWith a sep toString = joinWithU a sep (fun x -> toString x)\nlet initU n f = Stdlib.Array.init n f\nlet init n f = initU n (fun i -> f i)\nlet push _arr _i = `Do_not_use_Array_push_in_native\n"
},
{
"path": "packages/Belt/src/Belt_Array.mli",
"content": "(***********************************************************************)\n(* *)\n(* OCaml *)\n(* *)\n(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)\n(* *)\n(* Copyright 1996 Institut National de Recherche en Informatique et *)\n(* en Automatique. All rights reserved. This file is distributed *)\n(* under the terms of the GNU Library General Public License, with *)\n(* the special exception on linking described in file ../LICENSE. *)\n(* *)\n(***********************************************************************)\n(* Adapted significantly by Authors of ReScript *)\n\n(** {!Belt.Array} Utililites for Array functions *)\n\ntype 'a t = 'a array\n\nval length : 'a t -> int\n(** [length xs] return the size of the array *)\n\nval size : 'a t -> int\n(** {b See} {!length} *)\n\nval get : 'a t -> int -> 'a option\n(** [get arr i]\n\n If [i <= 0 <= length arr];returns [Some value] where [value] is the item at index [i] If [i] is out of range;returns\n [None]\n\n {[\n Belt.Array.get [| \"a\"; \"b\"; \"c\" |] 0 = Some \"a\";;\n Belt.Array.get [| \"a\"; \"b\"; \"c\" |] 3 = None;;\n Belt.Array.get [| \"a\"; \"b\"; \"c\" |] (-1) = None\n ]} *)\n\nval getExn : 'a t -> int -> 'a\n(** [getExn arr i]\n\n {b raise} an exception if [i] is out of range;otherwise return the value at index [i] in [arr] *)\n\nval getUnsafe : 'a t -> int -> 'a\n(** [getUnsafe arr i]\n\n {b Unsafe}\n\n no bounds checking;this would cause type error if [i] does not stay within range *)\n\nval getUndefined : 'a t -> int -> 'a Js.undefined\n(** [getUndefined arr i]\n\n It does the same thing in the runtime as {!getUnsafe}; it is {i type safe} since the return type still tracks\n whether it is in range or not. On native this is represented using the same option-backed encoding as\n [Js.Undefined]. *)\n\nval set : 'a t -> int -> 'a -> bool\n(** [set arr n x] modifies [arr] in place; it replaces the nth element of [arr] with [x]\n @return false means not updated due to out of range *)\n\nval setExn : 'a t -> int -> 'a -> unit\n(** [setExn arr i x] {b raise} an exception if [i] is out of range *)\n\nval setUnsafe : 'a t -> int -> 'a -> unit\n\nval shuffleInPlace : 'a t -> unit\n(** [shuffleInPlace arr] randomly re-orders the items in [arr] *)\n\nval shuffle : 'a t -> 'a t\n(** [shuffle xs]\n @return a fresh array with items in original array randomly shuffled *)\n\nval reverseInPlace : 'a t -> unit\n(** [reverseInPlace arr] reverses items in [arr] in place\n\n {[\n let arr = [| 10; 11; 12; 13; 14 |]\n let () = reverseInPlace arr;;\n\n arr = [| 14; 13; 12; 11; 10 |]\n ]} *)\n\nval reverse : 'a t -> 'a t\n(** [reverse arr]\n @return a fresh array with items in [arr] in reverse order\n\n {[\n reverse [| 10; 11; 12; 13; 14 |] = [| 14; 13; 12; 11; 10 |]\n ]} *)\n\nval makeUninitialized : int -> 'a Js.undefined array\n(** [makeUninitialized n] creates an array of length [n] filled with the undefined value. You must specify the type of\n data that will eventually fill the array.\n\n {[\n let arr : string Js.undefined array = makeUninitialized 5;;\n\n getExn arr 0 = Js.undefined\n ]} *)\n\nval makeUninitializedUnsafe : int -> 'a -> 'a array\n(** [makeUninitializedUnsafe n filler]\n\n {b Unsafe}\n\n Native approximation of the JavaScript [makeUninitializedUnsafe]. Since OCaml arrays must be fully initialized, the\n [filler] value is used to allocate the array before callers overwrite the slots they need. Unread slots therefore\n contain [filler], not JavaScript-style holes or [undefined].\n\n {[\n let arr = Belt.Array.makeUninitializedUnsafe 5 \"placeholder\";;\n\n Belt.Array.setExn arr 0 \"example\";;\n Belt.Array.getExn arr 0 = \"example\"\n ]} *)\n\nval make : int -> 'a -> 'a t\n(** [make n e] return an array of size [n] filled with value [e]\n @return an empty array when [n] is negative. *)\n\nval range : int -> int -> int t\n(** [range start finish] create an inclusive array\n {[\n range 0 3 = [| 0; 1; 2; 3 |];;\n range 3 0 = [||];;\n range 3 3 = [| 3 |]\n ]} *)\n\nval rangeBy : int -> int -> step:int -> int t\n(** [rangeBy start finish ~step]\n\n @return empty array when step is 0 or negative it also return empty array when [start > finish]\n\n {[\n rangeBy 0 10 ~step:3 = [| 0; 3; 6; 9 |];;\n rangeBy 0 12 ~step:3 = [| 0; 3; 6; 9; 12 |];;\n rangeBy 33 0 ~step:1 = [||];;\n rangeBy 33 0 ~step:(-1) = [||];;\n rangeBy 3 12 ~step:(-1) = [||];;\n rangeBy 3 3 ~step:0 = [||];;\n rangeBy 3 3 ~step:1 = [| 3 |]\n ]} *)\n\nval makeByU : int -> ((int -> 'a)[@bs]) -> 'a t\n\nval makeBy : int -> (int -> 'a) -> 'a t\n(** [makeBy n f]\n\n return an empty array when [n] is negative return an array of size [n] populated by [f i] start from [0] to [n - 1]\n\n {[\n makeBy 5 (fun i -> i) = [| 0; 1; 2; 3; 4 |];;\n makeBy 5 (fun i -> i * i) = [| 0; 1; 4; 9; 16 |]\n ]} *)\n\nval makeByAndShuffleU : int -> ((int -> 'a)[@bs]) -> 'a t\n\nval makeByAndShuffle : int -> (int -> 'a) -> 'a t\n(** [makeByAndShuffle n f]\n\n Equivalent to [shuffle (makeBy n f)] *)\n\nval zip : 'a t -> 'b array -> ('a * 'b) array\n(** [zip a b]\n\n Create an array of pairs from corresponding elements of [a] and [b]. Stop with the shorter array\n\n {[\n zip [| 1; 2 |] [| 3; 4; 5 |] = [| (1, 3); (2, 4) |]\n ]} *)\n\nval zipByU : 'a t -> 'b array -> (('a -> 'b -> 'c)[@bs]) -> 'c array\n\nval zipBy : 'a t -> 'b array -> ('a -> 'b -> 'c) -> 'c array\n(** [zipBy xs ys f]\n\n Create an array by applying [f] to corresponding elements of [xs] and [ys] Stops with shorter array\n\n Equivalent to [map (zip xs ys) (fun (a,b) -> f a b) ]\n\n {[\n zipBy [| 1; 2; 3 |] [| 4; 5 |] (fun a b -> (2 * a) + b) = [| 6; 9 |]\n ]} *)\n\nval unzip : ('a * 'b) array -> 'a t * 'b array\n(** [unzip a] takes an array of pairs and creates a pair of arrays. The first array contains all the first items of the\n pairs; the second array contains all the second items.\n\n {[\n unzip [| (1, 2); (3, 4) |] = ([| 1; 3 |], [| 2; 4 |]);;\n unzip [| (1, 2); (3, 4); (5, 6); (7, 8) |] = ([| 1; 3; 5; 7 |], [| 2; 4; 6; 8 |])\n ]} *)\n\nval concat : 'a t -> 'a t -> 'a t\n(** [concat xs ys]\n\n @return\n a fresh array containing the concatenation of the arrays [v1] and [v2];so even if [v1] or [v2] is empty;it can not\n be shared\n\n {[\n concat [| 1; 2; 3 |] [| 4; 5 |] = [| 1; 2; 3; 4; 5 |];;\n concat [||] [| \"a\"; \"b\"; \"c\" |] = [| \"a\"; \"b\"; \"c\" |]\n ]} *)\n\nval concatMany : 'a t t -> 'a t\n(** [concatMany xss]\n\n @return a fresh array as the concatenation of [xss] (an array of arrays)\n\n {[\n concatMany [| [| 1; 2; 3 |]; [| 4; 5; 6 |]; [| 7; 8 |] |] = [| 1; 2; 3; 4; 5; 6; 7; 8 |]\n ]} *)\n\nval slice : 'a t -> offset:int -> len:int -> 'a t\n(** [slice xs offset len] creates a new array with the [len] elements of [xs] starting at [offset] for\n\n [offset] can be negative;and is evaluated as [length xs - offset] [slice xs -1 1] means get the last element as a\n singleton array\n\n [slice xs (-len) len] will return a copy of the array\n\n if the array does not have enough data;[slice] extracts through the end of sequence.\n\n if [len] is negative;returns the empty array.\n\n {[\n slice [| 10; 11; 12; 13; 14; 15; 16 |] ~offset:2 ~len:3 = [| 12; 13; 14 |];;\n slice [| 10; 11; 12; 13; 14; 15; 16 |] ~offset:(-4) ~len:3 = [| 13; 14; 15 |];;\n slice [| 10; 11; 12; 13; 14; 15; 16 |] ~offset:4 ~len:9 = [| 14; 15; 16 |]\n ]} *)\n\nval sliceToEnd : 'a t -> int -> 'a t\n(** [sliceToEnd xs offset] creates a new array with the elements of [xs] starting at [offset]\n\n [offset] can be negative;and is evaluated as [length xs - offset] [sliceToEnd xs -1] means get the last element as a\n singleton array\n\n [sliceToEnd xs 0] will return a copy of the array\n\n {[\n sliceToEnd [| 10; 11; 12; 13; 14; 15; 16 |] 2 = [| 12; 13; 14; 15; 16 |];;\n sliceToEnd [| 10; 11; 12; 13; 14; 15; 16 |] (-4) = [| 13; 14; 15; 16 |]\n ]} *)\n\n(* external copy : 'a t -> (_[@mel.as 0]) -> 'a t = \"slice\"\n [@@mel.send] *)\nval copy : 'a t -> 'a t\n(** [copy a]\n\n @return a copy of [a];that is;a fresh array containing the same elements as [a]. *)\n\nval fill : 'a t -> offset:int -> len:int -> 'a -> unit\n(** [fill arr ~offset ~len x]\n\n Modifies [arr] in place, storing [x] in elements number [offset] to [offset + len - 1].\n\n [offset] can be negative;and is evaluated as [length arr - offset]\n\n [fill arr ~offset:(-1) ~len:1] means fill the last element, if the array does not have enough data;[fill] will\n ignore it\n\n {[\n let arr = makeBy 5 (fun i -> i);;\n\n fill arr ~offset:2 ~len:2 9;;\n arr = [| 0; 1; 9; 9; 4 |];;\n fill arr ~offset:7 ~len:2 8;;\n arr = [| 0; 1; 9; 9; 4 |]\n ]} *)\n\nval blit : src:'a t -> srcOffset:int -> dst:'a t -> dstOffset:int -> len:int -> unit\n(** [blit ~src:v1 ~srcOffset:o1 ~dst:v2 ~dstOffset:o2 ~len]\n\n copies [len] elements from array [v1];starting at element number [o1];to array [v2], starting at element number\n [o2].\n\n It works correctly even if [v1] and [v2] are the same array;and the source and destination chunks overlap.\n\n [offset] can be negative;[-1] means [len - 1];if [len + offset] is still negative;it will be set as 0\n\n For each of the examples;presume that [v1 = [|10;11;12;13;14;15;16;17|]] and [v2 = [|20;21;22;23;24;25;26;27|]]. The\n result shown is the content of the destination array.\n\n {[\n Belt.Array.blit ~src:v1 ~srcOffset:4 ~dst:v2 ~dstOffset:2 ~len:3\n |. [| 20; 21; 14; 15; 16; 25; 26; 27 |] Belt.Array.blit ~src:v1 ~srcOffset:4 ~dst:v1 ~dstOffset:2 ~len:3\n |. [| 10; 11; 14; 15; 16; 15; 16; 17 |]\n ]} *)\n\nval blitUnsafe : src:'a t -> srcOffset:int -> dst:'a t -> dstOffset:int -> len:int -> unit\n(** {b Unsafe} blit without bounds checking *)\n\nval forEachU : 'a t -> (('a -> unit)[@bs]) -> unit\n\nval forEach : 'a t -> ('a -> unit) -> unit\n(** [forEach xs f]\n\n Call [f] on each element of [xs] from the beginning to end. [f] returns [unit];so no new array is created. Use\n [forEach] when you are primarily concerned with repetitively creating side effects.\n\n {[\n forEach [| \"a\"; \"b\"; \"c\" |] (fun x -> Js.log (\"Item: \" ^ x));;\n\n (* prints:\n Item: a\n Item: b\n Item: c\n *)\n\n let total = ref 0;;\n\n forEach [| 1; 2; 3; 4 |] (fun x -> total := !total + x);;\n !total = 1 + 2 + 3 + 4\n ]} *)\n\nval mapU : 'a t -> (('a -> 'b)[@bs]) -> 'b array\n\nval map : 'a t -> ('a -> 'b) -> 'b array\n(** [map xs f ]\n\n @return a new array by calling [f] for each element of [xs] from the beginning to end\n\n {[\n map [| 1; 2 |] (fun x -> x + 10) = [| 11; 12 |]\n ]} *)\n\nval flatMapU : 'a t -> (('a -> 'b t)[@bs]) -> 'b t\n\nval flatMap : 'a t -> ('a -> 'b t) -> 'b t\n(** [flatMap xs f] **return** a new array by calling `f` for each element of `xs` from the beginning to end, and then\n concatenating the results ``` flatMap [|1;2|] (fun x-> [|x + 10;x + 20|]) = [|11;21;12;22|] ``` *)\n\nval getByU : 'a t -> (('a -> bool)[@bs]) -> 'a option\n\nval getBy : 'a t -> ('a -> bool) -> 'a option\n(** [getBy xs p] returns [Some value] for the first value in [xs] that satisifies the predicate function [p]; returns\n [None] if no element satisifies the function.\n\n {[\n getBy [|1;4;3;2|] (fun x -> x mod 2 = 0) = Some 4\n getBy [|15;13;11|] (fun x -> x mod 2 = 0) = None\n ]} *)\n\nval getIndexByU : 'a t -> (('a -> bool)[@bs]) -> int option\n\nval getIndexBy : 'a t -> ('a -> bool) -> int option\n(** [getIndexBy xs p] returns [Some index] for the first value in [xs] that satisifies the predicate function [p];\n returns [None] if no element satisifies the function.\n\n {[\n getIndexBy [|1;4;3;2|] (fun x -> x mod 2 = 0) = Some 1\n getIndexBy [|15;13;11|] (fun x -> x mod 2 = 0) = None\n ]} *)\n\nval keepU : 'a t -> (('a -> bool)[@bs]) -> 'a t\n\nval keep : 'a t -> ('a -> bool) -> 'a t\n(** [keep xs p ]\n @return a new array that keeps all elements satisfying [p]\n\n {[\n keep [| 1; 2; 3 |] (fun x -> x mod 2 = 0) = [| 2 |]\n ]} *)\n\nval keepWithIndexU : 'a t -> (('a -> int -> bool)[@bs]) -> 'a t\n\nval keepWithIndex : 'a t -> ('a -> int -> bool) -> 'a t\n(** [keepWithIndex xs p ]\n @return\n a new array that keeps all elements satisfying [p]. The predicate [p] takes two arguments: the element from [xs]\n and the index starting from 0.\n\n {[\n keepWithIndex [| 1; 2; 3 |] (fun _x i -> i = 1) = [| 2 |]\n ]} *)\n\nval keepMapU : 'a t -> (('a -> 'b option)[@bs]) -> 'b array\n\nval keepMap : 'a t -> ('a -> 'b option) -> 'b array\n(** [keepMap xs p]\n @return a new array that keeps all elements that return a non-None when applied to [p]\n\n {[\n keepMap [| 1; 2; 3 |] (fun x -> if x mod 2 = 0 then Some x else None) = [| 2 |]\n ]} *)\n\nval forEachWithIndexU : 'a t -> ((int -> 'a -> unit)[@bs]) -> unit\n\nval forEachWithIndex : 'a t -> (int -> 'a -> unit) -> unit\n(** [forEachWithIndex xs f]\n\n The same as {!forEach}; except that [f] is supplied with two arguments: the index starting from 0 and the element\n from [xs]\n\n {[\n forEachWithIndex [| \"a\"; \"b\"; \"c\" |] (fun i x -> Js.log (\"Item \" ^ string_of_int i ^ \" is \" ^ x));;\n\n (* prints:\n Item 0 is a\n Item 1 is b\n Item 2 is c\n *)\n\n let total = ref 0;;\n\n forEachWithIndex [| 10; 11; 12; 13 |] (fun i x -> total := !total + x + i);;\n !total = 0 + 10 + 1 + 11 + 2 + 12 + 3 + 13\n ]} *)\n\nval mapWithIndexU : 'a t -> ((int -> 'a -> 'b)[@bs]) -> 'b t\n\nval mapWithIndex : 'a t -> (int -> 'a -> 'b) -> 'b t\n(** [mapWithIndex xs f] applies [f] to each element of [xs]. Function [f] takes two arguments: the index starting from 0\n and the element from [xs].\n\n {[\n mapWithIndex [| 1; 2; 3 |] (fun i x -> i + x) = [| 0 + 1; 1 + 2; 2 + 3 |]\n ]} *)\n\nval partitionU : 'a t -> (('a -> bool)[@bs]) -> 'a t * 'a t\n\nval partition : 'a t -> ('a -> bool) -> 'a t * 'a t\n(** [partition f a] split array into tuple of two arrays based on predicate f; first of tuple where predicate cause\n true, second where predicate cause false\n\n {[\n partition [| 1; 2; 3; 4; 5 |] (fun x -> x mod 2 = 0) = ([| 2; 4 |], [| 1; 2; 3 |]);;\n partition [| 1; 2; 3; 4; 5 |] (fun x -> x mod 2 <> 0) = ([| 1; 2; 3 |], [| 2; 4 |])\n ]} *)\n\nval reduceU : 'b array -> 'a -> (('a -> 'b -> 'a)[@bs]) -> 'a\n\nval reduce : 'b array -> 'a -> ('a -> 'b -> 'a) -> 'a\n(** [reduce xs init f]\n\n Applies [f] to each element of [xs] from beginning to end. Function [f] has two parameters: the item from the list\n and an “accumulator”;which starts with a value of [init]. [reduce] returns the final value of the accumulator.\n\n {[\n reduce [| 2; 3; 4 |] 1 ( + ) = 10;;\n reduce [| \"a\"; \"b\"; \"c\"; \"d\" |] \"\" ( ^ ) = \"abcd\"\n ]} *)\n\nval reduceReverseU : 'b array -> 'a -> (('a -> 'b -> 'a)[@bs]) -> 'a\n\nval reduceReverse : 'b array -> 'a -> ('a -> 'b -> 'a) -> 'a\n(** [reduceReverse xs init f]\n\n Works like {!reduce};except that function [f] is applied to each item of [xs] from the last back to the first.\n\n {[\n reduceReverse [| \"a\"; \"b\"; \"c\"; \"d\" |] \"\" ( ^ ) = \"dcba\"\n ]} *)\n\nval reduceReverse2U : 'a t -> 'b array -> 'c -> (('c -> 'a -> 'b -> 'c)[@bs]) -> 'c\n\nval reduceReverse2 : 'a t -> 'b array -> 'c -> ('c -> 'a -> 'b -> 'c) -> 'c\n(** [reduceReverse2 xs ys init f] Reduces two arrays [xs] and [ys];taking items starting at\n [min (length xs) (length ys)] down to and including zero.\n\n {[\n reduceReverse2 [| 1; 2; 3 |] [| 1; 2 |] 0 (fun acc x y -> acc + x + y) = 6\n ]} *)\n\nval reduceWithIndexU : 'a t -> 'b -> (('b -> 'a -> int -> 'b)[@bs]) -> 'b\n\nval reduceWithIndex : 'a t -> 'b -> ('b -> 'a -> int -> 'b) -> 'b\n(** [reduceWithIndex xs f]\n\n Applies [f] to each element of [xs] from beginning to end. Function [f] has three parameters: the item from the\n array and an “accumulator”, which starts with a value of [init] and the index of each element. [reduceWithIndex]\n returns the final value of the accumulator.\n\n {[\n reduceWithIndex [| 1; 2; 3; 4 |] 0 (fun acc x i -> acc + x + i) = 16\n ]} *)\n\nval joinWithU : 'a t -> string -> (('a -> string)[@bs]) -> string\n\nval joinWith : 'a t -> string -> ('a -> string) -> string\n(** [joinWith xs sep toString]\n\n Concatenates all the elements of [xs] converted to string with [toString], each separated by [sep], the string given\n as the second argument, into a single string. If the array has only one element, then that element will be returned\n without using the separator. If the array is empty, the empty string will be returned.\n {[\n joinWith [| 0; 1 |] \", \" string_of_int\n = \"0, 1\" joinWith [||] \" \" string_of_int\n = \"\" joinWith [| 1 |] \" \" string_of_int = \"1\"\n ]} *)\n\nval someU : 'a t -> (('a -> bool)[@bs]) -> bool\n\nval some : 'a t -> ('a -> bool) -> bool\n(** [some xs p]\n\n @return\n true if at least one of the elements in [xs] satifies [p];where [p] is a {i predicate}: a function taking an\n element and returning a [bool].\n\n {[\n some [| 2; 3; 4 |] (fun x -> x mod 2 = 1) = true;;\n some [| -1; -3; -5 |] (fun x -> x > 0) = false\n ]} *)\n\nval everyU : 'a t -> (('a -> bool)[@bs]) -> bool\n\nval every : 'a t -> ('a -> bool) -> bool\n(** [every xs p]\n\n @return\n true if all elements satisfy [p];where [p] is a {i predicate}: a function taking an element and returning a\n [bool].\n\n {[\n every [| 1; 3; 5 |] (fun x -> x mod 2 = 1) = true;;\n every [| 1; -3; 5 |] (fun x -> x > 0) = false\n ]} *)\n\nval every2U : 'a t -> 'b t -> (('a -> 'b -> bool)[@bs]) -> bool\n\nval every2 : 'a t -> 'b t -> ('a -> 'b -> bool) -> bool\n(** [every2 xs ys p] returns true if [p xi yi] is true for all pairs of elements up to the shorter length (i.e.\n [min (length xs) (length ys)])\n {[\n every2 [| 1; 2; 3 |] [| 0; 1 |] ( > ) = true;;\n every2 [||] [| 1 |] (fun x y -> x > y) = true;;\n every2 [| 2; 3 |] [| 1 |] (fun x y -> x > y) = true;;\n every2 [| 0; 1 |] [| 5; 0 |] (fun x y -> x > y) = false\n ]} *)\n\nval some2U : 'a t -> 'b t -> (('a -> 'b -> bool)[@bs]) -> bool\n\nval some2 : 'a t -> 'b t -> ('a -> 'b -> bool) -> bool\n(** [some2 xs ys p] returns true if [p xi yi] is true for any pair of elements up to the shorter length (i.e.\n [min (length xs) (length ys)])\n\n {[\n some2 [| 0; 2 |] [| 1; 0; 3 |] ( > ) = true;;\n some2 [||] [| 1 |] (fun x y -> x > y) = false;;\n some2 [| 2; 3 |] [| 1; 4 |] (fun x y -> x > y) = true\n ]} *)\n\nval cmpU : 'a t -> 'a t -> (('a -> 'a -> int)[@bs]) -> int\n\nval cmp : 'a t -> 'a t -> ('a -> 'a -> int) -> int\n(** [cmp xs ys f]\n\n - Compared by length if [length xs <> length ys];returning -1 if[length xs < length ys] or 1 if\n [length xs > length ys]\n - Otherwise compare one by one [f x y]. [f] returns\n - a negative number if [x] is “less than” [y]\n - zero if [x] is “equal to” [y]\n - a positive number if [x] is “greater than” [y]\n - The comparison returns the first non-zero result of [f];or zero if [f] returns zero for all [x] and [y].\n\n {[\n cmp [| 1; 3; 5 |] [| 1; 4; 2 |] (fun a b -> compare a b) = -1;;\n cmp [| 1; 3; 5 |] [| 1; 2; 3 |] (fun a b -> compare a b) = 1;;\n cmp [| 1; 3; 5 |] [| 1; 3; 5 |] (fun a b -> compare a b) = 0\n ]} *)\n\nval eqU : 'a t -> 'a t -> (('a -> 'a -> bool)[@bs]) -> bool\n\nval eq : 'a t -> 'a t -> ('a -> 'a -> bool) -> bool\n(** [eq xs ys]\n\n - return false if length is not the same\n - otherwise compare items one by one using [f xi yi];and return true if all results are true;false otherwise\n\n {[\n eq [| 1; 2; 3 |] [| -1; -2; -3 |] (fun a b -> abs a = abs b) = true\n ]} *)\n\n(* external truncateToLengthUnsafe : 'a t -> int -> unit = \"length\"\n [@@mel.set] *)\n\nval truncateToLengthUnsafe : 'a t -> int -> 'a t\n(** {b Unsafe} Native-only approximation of the JavaScript [truncateToLengthUnsafe].\n\n On native this returns a fresh truncated copy of [xs]. It does not mutate the input array length, and it cannot grow\n the array because OCaml arrays are fixed length.\n\n Raises [Invalid_argument] if [n] is negative or larger than [length xs].\n\n {[\n let arr = [| \"ant\"; \"bee\"; \"cat\"; \"dog\"; \"elk\" |]\n let truncated = truncateToLengthUnsafe arr 3;;\n\n truncated = [| \"ant\"; \"bee\"; \"cat\" |];;\n arr = [| \"ant\"; \"bee\"; \"cat\"; \"dog\"; \"elk\" |]\n ]} *)\n\nval initU : int -> ((int -> 'a)[@bs]) -> 'a t\nval init : int -> (int -> 'a) -> 'a t\n\nval push : 'a t -> 'a -> [ `Do_not_use_Array_push_in_native ]\n[@@alert not_implemented \"is not implemented in native under server-reason-react.belt\"]\n(** Native-only sentinel value for the JavaScript [push] operation. OCaml arrays are fixed length and cannot grow in\n place like JavaScript arrays. Use a copy-based helper instead when you need to append on native. *)\n"
},
{
"path": "packages/Belt/src/Belt_Float.ml",
"content": "let toInt = Stdlib.int_of_float\nlet fromInt = Stdlib.float_of_int\nlet fromString i = try Some (float_of_string i) with _ -> None\n\nlet toString value =\n let string = Stdlib.string_of_float value in\n let length = String.length string in\n if length > 0 && string.[length - 1] = '.' then String.sub string 0 (length - 1) else string\n\nlet ( + ) = Stdlib.( +. )\nlet ( - ) = Stdlib.( -. )\nlet ( * ) = Stdlib.( *. )\nlet ( / ) = Stdlib.( /. )\n"
},
{
"path": "packages/Belt/src/Belt_Float.mli",
"content": "val toInt : float -> int\nval fromInt : int -> float\nval fromString : string -> float option\nval toString : float -> string\nval ( + ) : float -> float -> float\nval ( - ) : float -> float -> float\nval ( * ) : float -> float -> float\nval ( / ) : float -> float -> float\n"
},
{
"path": "packages/Belt/src/Belt_HashMap.ml",
"content": "module N = Belt_internalBuckets\nmodule C = Belt_internalBucketsType\nmodule A = Belt_Array\n\ntype ('a, 'id) eq = ('a, 'id) Belt_Id.eq\ntype ('a, 'id) hash = ('a, 'id) Belt_Id.hash\ntype ('a, 'id) id = ('a, 'id) Belt_Id.hashable\ntype ('a, 'b, 'id) t = (('a, 'id) hash, ('a, 'id) eq, 'a, 'b) N.t\n\nlet clear = C.clear\nlet size = C.size\nlet forEach = N.forEach\nlet forEachU = N.forEachU\nlet reduce = N.reduce\nlet reduceU = N.reduceU\nlet logStats = N.logStats\nlet keepMapInPlaceU = N.keepMapInPlaceU\nlet keepMapInPlace = N.keepMapInPlace\nlet toArray = N.toArray\nlet copy = N.copy\nlet keysToArray = N.keysToArray\nlet valuesToArray = N.valuesToArray\nlet getBucketHistogram = N.getBucketHistogram\nlet isEmpty = C.isEmpty\n\nlet rec copyBucketReHash ~hash ~h_buckets ~ndata_tail old_bucket =\n match C.toOpt old_bucket with\n | None -> ()\n | Some cell ->\n let nidx = hash (N.key cell) land (A.length h_buckets - 1) in\n let v = C.return cell in\n (match C.toOpt (A.getUnsafe ndata_tail nidx) with\n | None -> A.setUnsafe h_buckets nidx v\n | Some tail -> N.nextSet tail v);\n A.setUnsafe ndata_tail nidx v;\n copyBucketReHash ~hash ~h_buckets ~ndata_tail (N.next cell)\n\nlet resize ~hash h =\n let odata = C.buckets h in\n let osize = A.length odata in\n let nsize = osize * 2 in\n if nsize >= osize then (\n let h_buckets = A.makeUninitialized nsize in\n let ndata_tail = A.makeUninitialized nsize in\n C.bucketsSet h h_buckets;\n for i = 0 to osize - 1 do\n copyBucketReHash ~hash ~h_buckets ~ndata_tail (A.getUnsafe odata i)\n done;\n for i = 0 to nsize - 1 do\n match C.toOpt (A.getUnsafe ndata_tail i) with None -> () | Some tail -> N.nextSet tail C.emptyOpt\n done)\n\nlet rec replaceInBucket ~eq key info cell =\n if eq (N.key cell) key then (\n N.valueSet cell info;\n false)\n else match C.toOpt (N.next cell) with None -> true | Some cell -> replaceInBucket ~eq key info cell\n\nlet set0 h key value ~eq ~hash =\n let h_buckets = C.buckets h in\n let buckets_len = A.length h_buckets in\n let i = hash key land (buckets_len - 1) in\n let l = A.getUnsafe h_buckets i in\n (match C.toOpt l with\n | None ->\n A.setUnsafe h_buckets i (C.return (N.bucket ~key ~value ~next:C.emptyOpt));\n C.sizeSet h (C.size h + 1)\n | Some bucket ->\n if replaceInBucket ~eq key value bucket then (\n A.setUnsafe h_buckets i (C.return (N.bucket ~key ~value ~next:l));\n C.sizeSet h (C.size h + 1)));\n if C.size h > buckets_len lsl 1 then resize ~hash h\n\nlet set h key value = set0 h key value ~eq:(Belt_Id.getEqInternal (C.eq h)) ~hash:(Belt_Id.getHashInternal (C.hash h))\n\nlet rec removeInBucket h h_buckets i key prec bucket ~eq =\n match C.toOpt bucket with\n | None -> ()\n | Some cell ->\n let cell_next = N.next cell in\n if eq (N.key cell) key then (\n N.nextSet prec cell_next;\n C.sizeSet h (C.size h - 1))\n else removeInBucket ~eq h h_buckets i key cell cell_next\n\nlet remove h key =\n let h_buckets = C.buckets h in\n let i = (Belt_Id.getHashInternal (C.hash h)) key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets i in\n match C.toOpt bucket with\n | None -> ()\n | Some cell ->\n let eq = Belt_Id.getEqInternal (C.eq h) in\n if eq (N.key cell) key then (\n A.setUnsafe h_buckets i (N.next cell);\n C.sizeSet h (C.size h - 1))\n else removeInBucket ~eq h h_buckets i key cell (N.next cell)\n\nlet rec getAux ~eq key buckets =\n match C.toOpt buckets with\n | None -> None\n | Some cell -> if eq key (N.key cell) then Some (N.value cell) else getAux ~eq key (N.next cell)\n\nlet get h key =\n let h_buckets = C.buckets h in\n let nid = (Belt_Id.getHashInternal (C.hash h)) key land (A.length h_buckets - 1) in\n match C.toOpt @@ A.getUnsafe h_buckets nid with\n | None -> None\n | Some cell1 -> (\n let eq = Belt_Id.getEqInternal (C.eq h) in\n if eq key (N.key cell1) then Some (N.value cell1)\n else\n match C.toOpt (N.next cell1) with\n | None -> None\n | Some cell2 -> (\n if eq key (N.key cell2) then Some (N.value cell2)\n else\n match C.toOpt (N.next cell2) with\n | None -> None\n | Some cell3 -> if eq key (N.key cell3) then Some (N.value cell3) else getAux ~eq key (N.next cell3)))\n\nlet rec memInBucket key cell ~eq =\n eq (N.key cell) key\n || match C.toOpt (N.next cell) with None -> false | Some nextCell -> memInBucket ~eq key nextCell\n\nlet has h key =\n let h_buckets = C.buckets h in\n let nid = (Belt_Id.getHashInternal (C.hash h)) key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets nid in\n match C.toOpt bucket with None -> false | Some bucket -> memInBucket ~eq:(Belt_Id.getEqInternal (C.eq h)) key bucket\n\nlet make (type key identity) ~hintSize ~(id : (key, identity) id) =\n let module M = (val id) in\n C.make ~hash:M.hash ~eq:M.eq ~hintSize\n\nlet fromArray (type a identity) arr ~(id : (a, identity) id) =\n let module M = (val id) in\n let hash, eq = (M.hash, M.eq) in\n let len = A.length arr in\n let v = C.make ~hash ~eq ~hintSize:len in\n let eq, hash = (Belt_Id.getEqInternal eq, Belt_Id.getHashInternal hash) in\n for i = 0 to len - 1 do\n let key, value = A.getUnsafe arr i in\n set0 ~eq ~hash v key value\n done;\n v\n\nlet mergeMany h arr =\n let hash, eq = (Belt_Id.getHashInternal (C.hash h), Belt_Id.getEqInternal (C.eq h)) in\n let len = A.length arr in\n for i = 0 to len - 1 do\n let key, value = A.getUnsafe arr i in\n set0 h ~eq ~hash key value\n done\n\nmodule Int = Belt_HashMapInt\nmodule String = Belt_HashMapString\n"
},
{
"path": "packages/Belt/src/Belt_HashMap.mli",
"content": "(* Copyright (C) 2018 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** A {b mutable} Hash map which allows customized hash behavior.\n\n All data are parameterized by not its only type but also a unique identity in the time of initialization, so that\n two {i HashMaps of ints} initialized with different {i hash} functions will have different type.\n\n For example:\n {[\n type t = int\n module I0 =\n (val Belt.Id.hashableU\n ~hash:(fun[\\@u] (a : t) -> a & 0xff_ff)\n ~eq:(fun[\\@u] a b -> a = b)\n )\n let s0 : (_, string,_) t = make ~hintSize:40 ~id:(module I0)\n module I1 =\n (val Belt.Id.hashableU\n ~hash:(fun[\\@u] (a : t) -> a & 0xff)\n ~eq:(fun[\\@u] a b -> a = b)\n )\n let s1 : (_, string,_) t = make ~hintSize:40 ~id:(module I1)\n ]}\n\n The invariant must be held: for two elements who are {i equal}, their hashed value should be the same\n\n Here the compiler would infer [s0] and [s1] having different type so that it would not mix.\n\n {[\n val s0 : (int, I0.identity) t\n val s1 : (int, I1.identity) t\n ]}\n\n We can add elements to the collection:\n\n {[\n let () =\n add s1 0 \"3\";\n add s1 1 \"3\"\n ]}\n\n Since this is an mutable data strucure, [s1] will contain two pairs. *)\n\nmodule Int = Belt_HashMapInt\n(** Specalized when key type is [int], more efficient than the generic type *)\n\nmodule String = Belt_HashMapString\n(** Specalized when key type is [string], more efficient than the generic type *)\n\ntype ('key, 'value, 'id) t\n(** The type of hash tables from type ['key] to type ['value]. *)\n\ntype ('a, 'id) id = ('a, 'id) Belt_Id.hashable\n\nval make : hintSize:int -> id:('key, 'id) id -> ('key, 'value, 'id) t\n(*TODO: allow randomization for security *)\n\nval clear : ('key, 'value, 'id) t -> unit\n(** Empty a hash table. *)\n\nval isEmpty : _ t -> bool\n\nval set : ('key, 'value, 'id) t -> 'key -> 'value -> unit\n(** [set tbl k v] if [k] does not exist, add the binding [k,v], otherwise, update the old value with the new [v] *)\n\nval copy : ('key, 'value, 'id) t -> ('key, 'value, 'id) t\nval get : ('key, 'value, 'id) t -> 'key -> 'value option\n\nval has : ('key, 'value, 'id) t -> 'key -> bool\n(** [has tbl x] checks if [x] is bound in [tbl]. *)\n\nval remove : ('key, 'value, 'id) t -> 'key -> unit\nval forEachU : ('key, 'value, 'id) t -> (('key -> 'value -> unit)[@u]) -> unit\n\nval forEach : ('key, 'value, 'id) t -> ('key -> 'value -> unit) -> unit\n(** [forEach tbl f] applies [f] to all bindings in table [tbl]. [f] receives the key as first argument, and the\n associated value as second argument. Each binding is presented exactly once to [f]. *)\n\nval reduceU : ('key, 'value, 'id) t -> 'c -> (('c -> 'key -> 'value -> 'c)[@u]) -> 'c\n\nval reduce : ('key, 'value, 'id) t -> 'c -> ('c -> 'key -> 'value -> 'c) -> 'c\n(** [reduce tbl init f] computes [(f kN dN ... (f k1 d1 init)...)], where [k1 ... kN] are the keys of all bindings in\n [tbl], and [d1 ... dN] are the associated values. Each binding is presented exactly once to [f].\n\n The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings\n for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is\n passed first. *)\n\nval keepMapInPlaceU : ('key, 'value, 'id) t -> (('key -> 'value -> 'value option)[@u]) -> unit\nval keepMapInPlace : ('key, 'value, 'id) t -> ('key -> 'value -> 'value option) -> unit\n\nval size : _ t -> int\n(** [size tbl] returns the number of bindings in [tbl]. It takes constant time. *)\n\nval toArray : ('key, 'value, 'id) t -> ('key * 'value) array\nval keysToArray : ('key, _, _) t -> 'key array\nval valuesToArray : (_, 'value, _) t -> 'value array\nval fromArray : ('key * 'value) array -> id:('key, 'id) id -> ('key, 'value, 'id) t\nval mergeMany : ('key, 'value, 'id) t -> ('key * 'value) array -> unit\nval getBucketHistogram : _ t -> int array\nval logStats : _ t -> unit\n"
},
{
"path": "packages/Belt/src/Belt_HashMapInt.ml",
"content": "[@@@ocaml.text \" Adapted by Authors of BuckleScript 2017 \"]\n\ntype key = int\ntype seed = int\n\nlet caml_hash_mix_int = Caml_hash.caml_hash_mix_int\nlet final_mix = Caml_hash.caml_hash_final_mix\nlet hash (s : key) = Nativeint.to_int (final_mix (caml_hash_mix_int Nativeint.zero (Nativeint.of_int s)))\n\nmodule N = Belt_internalBuckets\nmodule C = Belt_internalBucketsType\nmodule A = Belt_Array\n\ntype 'b t = (unit, unit, key, 'b) N.t\n\nlet rec copyBucketReHash ~h_buckets ~ndata_tail old_bucket =\n match C.toOpt old_bucket with\n | None -> ()\n | Some cell ->\n let nidx = hash (N.key cell) land (A.length h_buckets - 1) in\n let v = C.return cell in\n (match C.toOpt (A.getUnsafe ndata_tail nidx) with\n | None -> A.setUnsafe h_buckets nidx v\n | Some tail -> N.nextSet tail v);\n A.setUnsafe ndata_tail nidx v;\n copyBucketReHash ~h_buckets ~ndata_tail (N.next cell)\n\nlet resize h =\n let odata = C.buckets h in\n let osize = A.length odata in\n let nsize = osize * 2 in\n if nsize >= osize then (\n let h_buckets = A.makeUninitialized nsize in\n let ndata_tail = A.makeUninitialized nsize in\n C.bucketsSet h h_buckets;\n for i = 0 to osize - 1 do\n copyBucketReHash ~h_buckets ~ndata_tail (A.getUnsafe odata i)\n done;\n for i = 0 to nsize - 1 do\n match C.toOpt (A.getUnsafe ndata_tail i) with None -> () | Some tail -> N.nextSet tail C.emptyOpt\n done)\n\nlet rec replaceInBucket (key : key) info cell =\n if N.key cell = key then (\n N.valueSet cell info;\n false)\n else match C.toOpt (N.next cell) with None -> true | Some cell -> replaceInBucket key info cell\n\nlet set h (key : key) value =\n let h_buckets = C.buckets h in\n let buckets_len = A.length h_buckets in\n let i = hash key land (buckets_len - 1) in\n let l = A.getUnsafe h_buckets i in\n (match C.toOpt l with\n | None ->\n A.setUnsafe h_buckets i (C.return (N.bucket ~key ~value ~next:C.emptyOpt));\n C.sizeSet h (C.size h + 1)\n | Some bucket ->\n if replaceInBucket key value bucket then (\n A.setUnsafe h_buckets i (C.return (N.bucket ~key ~value ~next:l));\n C.sizeSet h (C.size h + 1)));\n if C.size h > buckets_len lsl 1 then resize h\n\nlet rec removeInBucket h h_buckets i (key : key) prec buckets =\n match C.toOpt buckets with\n | None -> ()\n | Some cell ->\n let cell_next = N.next cell in\n if N.key cell = key then (\n N.nextSet prec cell_next;\n C.sizeSet h (C.size h - 1))\n else removeInBucket h h_buckets i key cell cell_next\n\nlet remove h key =\n let h_buckets = C.buckets h in\n let i = hash key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets i in\n match C.toOpt bucket with\n | None -> ()\n | Some cell ->\n if N.key cell = key then (\n A.setUnsafe h_buckets i (N.next cell);\n C.sizeSet h (C.size h - 1))\n else removeInBucket h h_buckets i key cell (N.next cell)\n\nlet rec getAux (key : key) buckets =\n match C.toOpt buckets with\n | None -> None\n | Some cell -> if key = N.key cell then Some (N.value cell) else getAux key (N.next cell)\n\nlet get h (key : key) =\n let h_buckets = C.buckets h in\n let nid = hash key land (A.length h_buckets - 1) in\n match C.toOpt @@ A.getUnsafe h_buckets nid with\n | None -> None\n | Some cell1 -> (\n if key = N.key cell1 then Some (N.value cell1)\n else\n match C.toOpt (N.next cell1) with\n | None -> None\n | Some cell2 -> (\n if key = N.key cell2 then Some (N.value cell2)\n else\n match C.toOpt (N.next cell2) with\n | None -> None\n | Some cell3 -> if key = N.key cell3 then Some (N.value cell3) else getAux key (N.next cell3)))\n\nlet rec memInBucket (key : key) cell =\n N.key cell = key || match C.toOpt (N.next cell) with None -> false | Some nextCell -> memInBucket key nextCell\n\nlet has h key =\n let h_buckets = C.buckets h in\n let nid = hash key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets nid in\n match C.toOpt bucket with None -> false | Some bucket -> memInBucket key bucket\n\nlet make ~hintSize = C.make ~hintSize ~hash:() ~eq:()\nlet clear = C.clear\nlet size = C.size\nlet forEachU = N.forEachU\nlet forEach = N.forEach\nlet reduceU = N.reduceU\nlet reduce = N.reduce\nlet logStats = N.logStats\nlet keepMapInPlaceU = N.keepMapInPlaceU\nlet keepMapInPlace = N.keepMapInPlace\nlet toArray = N.toArray\nlet copy = N.copy\nlet keysToArray = N.keysToArray\nlet valuesToArray = N.valuesToArray\nlet getBucketHistogram = N.getBucketHistogram\nlet isEmpty = C.isEmpty\n\nlet fromArray arr =\n let len = A.length arr in\n let v = make len in\n for i = 0 to len - 1 do\n let k, value = A.getUnsafe arr i in\n set v k value\n done;\n v\n\nlet mergeMany h arr =\n let len = A.length arr in\n for i = 0 to len - 1 do\n let k, v = A.getUnsafe arr i in\n set h k v\n done\n"
},
{
"path": "packages/Belt/src/Belt_HashMapInt.mli",
"content": "type key = int\ntype 'b t\n\nval make : hintSize:int -> 'b t\nval clear : 'b t -> unit\nval isEmpty : _ t -> bool\n\nval set : 'a t -> key -> 'a -> unit\n(** [setDone tbl k v] if [k] does not exist, add the binding [k,v], otherwise, update the old value with the new [v] *)\n\nval copy : 'a t -> 'a t\nval get : 'a t -> key -> 'a option\nval has : 'b t -> key -> bool\nval remove : 'a t -> key -> unit\nval forEachU : 'b t -> ((key -> 'b -> unit)[@u]) -> unit\nval forEach : 'b t -> (key -> 'b -> unit) -> unit\nval reduceU : 'b t -> 'c -> (('c -> key -> 'b -> 'c)[@u]) -> 'c\nval reduce : 'b t -> 'c -> ('c -> key -> 'b -> 'c) -> 'c\nval keepMapInPlaceU : 'a t -> ((key -> 'a -> 'a option)[@u]) -> unit\nval keepMapInPlace : 'a t -> (key -> 'a -> 'a option) -> unit\nval size : _ t -> int\nval toArray : 'a t -> (key * 'a) array\nval keysToArray : 'a t -> key array\nval valuesToArray : 'a t -> 'a array\nval fromArray : (key * 'a) array -> 'a t\nval mergeMany : 'a t -> (key * 'a) array -> unit\nval getBucketHistogram : _ t -> int array\nval logStats : _ t -> unit\n"
},
{
"path": "packages/Belt/src/Belt_HashMapString.ml",
"content": "[@@@ocaml.text \" Adapted by Authors of BuckleScript 2017 \"]\n\ntype key = string\ntype seed = int\n\nlet caml_hash_mix_string = Caml_hash.caml_hash_mix_string\nlet final_mix = Caml_hash.caml_hash_final_mix\nlet hash (s : key) = Nativeint.to_int (final_mix (caml_hash_mix_string Nativeint.zero s))\n\nmodule N = Belt_internalBuckets\nmodule C = Belt_internalBucketsType\nmodule A = Belt_Array\n\ntype 'b t = (unit, unit, key, 'b) N.t\n\nlet rec copyBucketReHash ~h_buckets ~ndata_tail old_bucket =\n match C.toOpt old_bucket with\n | None -> ()\n | Some cell ->\n let nidx = hash (N.key cell) land (A.length h_buckets - 1) in\n let v = C.return cell in\n (match C.toOpt (A.getUnsafe ndata_tail nidx) with\n | None -> A.setUnsafe h_buckets nidx v\n | Some tail -> N.nextSet tail v);\n A.setUnsafe ndata_tail nidx v;\n copyBucketReHash ~h_buckets ~ndata_tail (N.next cell)\n\nlet resize h =\n let odata = C.buckets h in\n let osize = A.length odata in\n let nsize = osize * 2 in\n if nsize >= osize then (\n let h_buckets = A.makeUninitialized nsize in\n let ndata_tail = A.makeUninitialized nsize in\n C.bucketsSet h h_buckets;\n for i = 0 to osize - 1 do\n copyBucketReHash ~h_buckets ~ndata_tail (A.getUnsafe odata i)\n done;\n for i = 0 to nsize - 1 do\n match C.toOpt (A.getUnsafe ndata_tail i) with None -> () | Some tail -> N.nextSet tail C.emptyOpt\n done)\n\nlet rec replaceInBucket (key : key) info cell =\n if N.key cell = key then (\n N.valueSet cell info;\n false)\n else match C.toOpt (N.next cell) with None -> true | Some cell -> replaceInBucket key info cell\n\nlet set h (key : key) value =\n let h_buckets = C.buckets h in\n let buckets_len = A.length h_buckets in\n let i = hash key land (buckets_len - 1) in\n let l = A.getUnsafe h_buckets i in\n (match C.toOpt l with\n | None ->\n A.setUnsafe h_buckets i (C.return (N.bucket ~key ~value ~next:C.emptyOpt));\n C.sizeSet h (C.size h + 1)\n | Some bucket ->\n if replaceInBucket key value bucket then (\n A.setUnsafe h_buckets i (C.return (N.bucket ~key ~value ~next:l));\n C.sizeSet h (C.size h + 1)));\n if C.size h > buckets_len lsl 1 then resize h\n\nlet rec removeInBucket h h_buckets i (key : key) prec buckets =\n match C.toOpt buckets with\n | None -> ()\n | Some cell ->\n let cell_next = N.next cell in\n if N.key cell = key then (\n N.nextSet prec cell_next;\n C.sizeSet h (C.size h - 1))\n else removeInBucket h h_buckets i key cell cell_next\n\nlet remove h key =\n let h_buckets = C.buckets h in\n let i = hash key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets i in\n match C.toOpt bucket with\n | None -> ()\n | Some cell ->\n if N.key cell = key then (\n A.setUnsafe h_buckets i (N.next cell);\n C.sizeSet h (C.size h - 1))\n else removeInBucket h h_buckets i key cell (N.next cell)\n\nlet rec getAux (key : key) buckets =\n match C.toOpt buckets with\n | None -> None\n | Some cell -> if key = N.key cell then Some (N.value cell) else getAux key (N.next cell)\n\nlet get h (key : key) =\n let h_buckets = C.buckets h in\n let nid = hash key land (A.length h_buckets - 1) in\n match C.toOpt @@ A.getUnsafe h_buckets nid with\n | None -> None\n | Some cell1 -> (\n if key = N.key cell1 then Some (N.value cell1)\n else\n match C.toOpt (N.next cell1) with\n | None -> None\n | Some cell2 -> (\n if key = N.key cell2 then Some (N.value cell2)\n else\n match C.toOpt (N.next cell2) with\n | None -> None\n | Some cell3 -> if key = N.key cell3 then Some (N.value cell3) else getAux key (N.next cell3)))\n\nlet rec memInBucket (key : key) cell =\n N.key cell = key || match C.toOpt (N.next cell) with None -> false | Some nextCell -> memInBucket key nextCell\n\nlet has h key =\n let h_buckets = C.buckets h in\n let nid = hash key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets nid in\n match C.toOpt bucket with None -> false | Some bucket -> memInBucket key bucket\n\nlet make ~hintSize = C.make ~hintSize ~hash:() ~eq:()\nlet clear = C.clear\nlet size = C.size\nlet forEachU = N.forEachU\nlet forEach = N.forEach\nlet reduceU = N.reduceU\nlet reduce = N.reduce\nlet logStats = N.logStats\nlet keepMapInPlaceU = N.keepMapInPlaceU\nlet keepMapInPlace = N.keepMapInPlace\nlet toArray = N.toArray\nlet copy = N.copy\nlet keysToArray = N.keysToArray\nlet valuesToArray = N.valuesToArray\nlet getBucketHistogram = N.getBucketHistogram\nlet isEmpty = C.isEmpty\n\nlet fromArray arr =\n let len = A.length arr in\n let v = make len in\n for i = 0 to len - 1 do\n let k, value = A.getUnsafe arr i in\n set v k value\n done;\n v\n\nlet mergeMany h arr =\n let len = A.length arr in\n for i = 0 to len - 1 do\n let k, v = A.getUnsafe arr i in\n set h k v\n done\n"
},
{
"path": "packages/Belt/src/Belt_HashMapString.mli",
"content": "type key = string\ntype 'b t\n\nval make : hintSize:int -> 'b t\nval clear : 'b t -> unit\nval isEmpty : _ t -> bool\n\nval set : 'a t -> key -> 'a -> unit\n(** [setDone tbl k v] if [k] does not exist, add the binding [k,v], otherwise, update the old value with the new [v] *)\n\nval copy : 'a t -> 'a t\nval get : 'a t -> key -> 'a option\nval has : 'b t -> key -> bool\nval remove : 'a t -> key -> unit\nval forEachU : 'b t -> ((key -> 'b -> unit)[@u]) -> unit\nval forEach : 'b t -> (key -> 'b -> unit) -> unit\nval reduceU : 'b t -> 'c -> (('c -> key -> 'b -> 'c)[@u]) -> 'c\nval reduce : 'b t -> 'c -> ('c -> key -> 'b -> 'c) -> 'c\nval keepMapInPlaceU : 'a t -> ((key -> 'a -> 'a option)[@u]) -> unit\nval keepMapInPlace : 'a t -> (key -> 'a -> 'a option) -> unit\nval size : _ t -> int\nval toArray : 'a t -> (key * 'a) array\nval keysToArray : 'a t -> key array\nval valuesToArray : 'a t -> 'a array\nval fromArray : (key * 'a) array -> 'a t\nval mergeMany : 'a t -> (key * 'a) array -> unit\nval getBucketHistogram : _ t -> int array\nval logStats : _ t -> unit\n"
},
{
"path": "packages/Belt/src/Belt_HashSet.ml",
"content": "module Int = Belt_HashSetInt\nmodule String = Belt_HashSetString\nmodule N = Belt_internalSetBuckets\nmodule C = Belt_internalBucketsType\nmodule A = Belt_Array\n\ntype ('a, 'id) eq = ('a, 'id) Belt_Id.eq\ntype ('a, 'id) hash = ('a, 'id) Belt_Id.hash\ntype ('a, 'id) id = ('a, 'id) Belt_Id.hashable\ntype ('a, 'id) t = (('a, 'id) hash, ('a, 'id) eq, 'a) N.t\n\nlet rec copyBucket ~hash ~h_buckets ~ndata_tail old_bucket =\n match C.toOpt old_bucket with\n | None -> ()\n | Some cell ->\n let nidx = (Belt_Id.getHashInternal hash) (N.key cell) land (A.length h_buckets - 1) in\n let v = C.return cell in\n (match C.toOpt (A.getUnsafe ndata_tail nidx) with\n | None -> A.setUnsafe h_buckets nidx v\n | Some tail -> N.nextSet tail v);\n A.setUnsafe ndata_tail nidx v;\n copyBucket ~hash ~h_buckets ~ndata_tail (N.next cell)\n\nlet tryDoubleResize ~hash h =\n let odata = C.buckets h in\n let osize = A.length odata in\n let nsize = osize * 2 in\n if nsize >= osize then (\n let h_buckets = A.makeUninitialized nsize in\n C.bucketsSet h h_buckets;\n let rec reinsertBucket bucket =\n match C.toOpt bucket with\n | None -> ()\n | Some cell ->\n let next = N.next cell in\n let index = (Belt_Id.getHashInternal hash) (N.key cell) land (nsize - 1) in\n A.setUnsafe h_buckets index (C.return @@ N.bucket ~key:(N.key cell) ~next:(A.getUnsafe h_buckets index));\n reinsertBucket next\n in\n for i = 0 to osize - 1 do\n reinsertBucket (A.getUnsafe odata i)\n done)\n\nlet rec removeBucket ~eq h h_buckets i key prec cell =\n let cell_next = N.next cell in\n if (Belt_Id.getEqInternal eq) (N.key cell) key then (\n N.nextSet prec cell_next;\n C.sizeSet h (C.size h - 1))\n else match C.toOpt cell_next with None -> () | Some cell_next -> removeBucket ~eq h h_buckets i key cell cell_next\n\nlet remove h key =\n let eq = C.eq h in\n let h_buckets = C.buckets h in\n let i = (Belt_Id.getHashInternal (C.hash h)) key land (A.length h_buckets - 1) in\n let l = A.getUnsafe h_buckets i in\n match C.toOpt l with\n | None -> ()\n | Some cell -> (\n let next_cell = N.next cell in\n if (Belt_Id.getEqInternal eq) (N.key cell) key then (\n C.sizeSet h (C.size h - 1);\n A.setUnsafe h_buckets i next_cell)\n else\n match C.toOpt next_cell with None -> () | Some next_cell -> removeBucket ~eq h h_buckets i key cell next_cell)\n\nlet rec missingInBucket ~eq key cell =\n if (Belt_Id.getEqInternal eq) (N.key cell) key then false\n else match C.toOpt (N.next cell) with None -> true | Some next -> missingInBucket ~eq key next\n\nlet add0 h key ~hash ~eq =\n let h_buckets = C.buckets h in\n let buckets_len = A.length h_buckets in\n let i = (Belt_Id.getHashInternal hash) key land (buckets_len - 1) in\n let l = A.getUnsafe h_buckets i in\n (match C.toOpt l with\n | None ->\n C.sizeSet h (C.size h + 1);\n A.setUnsafe h_buckets i (C.return @@ N.bucket ~key ~next:C.emptyOpt)\n | Some cell when missingInBucket ~eq key cell ->\n C.sizeSet h (C.size h + 1);\n A.setUnsafe h_buckets i (C.return @@ N.bucket ~key ~next:l)\n | Some _ -> ());\n if C.size h > buckets_len lsl 1 then tryDoubleResize ~hash h\n\nlet add h key = add0 ~hash:(C.hash h) ~eq:(C.eq h) h key\n\nlet rec memInBucket ~eq key cell =\n (Belt_Id.getEqInternal eq) (N.key cell) key\n || match C.toOpt (N.next cell) with None -> false | Some nextCell -> memInBucket ~eq key nextCell\n\nlet has h key =\n let eq, h_buckets = (C.eq h, C.buckets h) in\n let nid = (Belt_Id.getHashInternal (C.hash h)) key land (A.length h_buckets - 1) in\n let bucket = A.getUnsafe h_buckets nid in\n match C.toOpt bucket with None -> false | Some bucket -> memInBucket ~eq key bucket\n\nlet make (type value identity) ~hintSize ~(id : (value, identity) id) =\n let module M = (val id) in\n C.make ~hintSize ~hash:M.hash ~eq:M.eq\n\nlet clear = C.clear\nlet size = C.size\nlet forEachU = N.forEachU\nlet forEach = N.forEach\nlet reduceU = N.reduceU\nlet reduce = N.reduce\nlet logStats = N.logStats\nlet toArray = N.toArray\nlet copy = N.copy\nlet getBucketHistogram = N.getBucketHistogram\nlet isEmpty = C.isEmpty\n\nlet fromArray (type a identity) arr ~(id : (a, identity) id) =\n let module M = (val id) in\n let eq, hash = (M.eq, M.hash) in\n let len = A.length arr in\n let v = C.make ~hintSize:len ~hash ~eq in\n for i = 0 to len - 1 do\n add0 ~eq ~hash v (A.getUnsafe arr i)\n done;\n v\n\nlet mergeMany h arr =\n let eq, hash = (C.eq h, C.hash h) in\n let len = A.length arr in\n for i = 0 to len - 1 do\n add0 h ~eq ~hash (A.getUnsafe arr i)\n done\n"
},
{
"path": "packages/Belt/src/Belt_HashSet.mli",
"content": "(* Copyright (C) 2018 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** A {b mutable} Hash set which allows customized hash behavior.\n\n All data are parameterized by not its only type but also a unique identity in the time of initialization, so that\n two {i HashSets of ints} initialized with different {i hash} functions will have different type.\n\n For example:\n {[\n type t = int\n module I0 =\n (val Belt.Id.hashableU\n ~hash:(fun[\\@u] (a : t) -> a & 0xff_ff)\n ~eq:(fun[\\@u] a b -> a = b)\n )\n let s0 = make ~id:(module I0) ~hintSize:40\n module I1 =\n (val Belt.Id.hashableU\n ~hash:(fun[\\@u] (a : t) -> a & 0xff)\n ~eq:(fun[\\@u] a b -> a = b)\n )\n let s1 = make ~id:(module I1) ~hintSize:40\n ]}\n\n The invariant must be held: for two elements who are {i equal}, their hashed value should be the same\n\n Here the compiler would infer [s0] and [s1] having different type so that it would not mix.\n\n {[\n val s0 : (int, I0.identity) t\n val s1 : (int, I1.identity) t\n ]}\n\n We can add elements to the collection:\n\n {[\n let () =\n add s1 0;\n add s1 1\n ]}\n\n Since this is an mutable data strucure, [s1] will contain two pairs. *)\n\nmodule Int = Belt_HashSetInt\n(** Specalized when key type is [int], more efficient than the generic type *)\n\nmodule String = Belt_HashSetString\n(** Specalized when key type is [string], more efficient than the generic type *)\n\n(* TODO: add a poly module\n module Poly = Belt_HashSetPoly\n challenge:\n - generic equal handles JS data structure\n - eq/hash consistent\n*)\n\ntype ('a, 'id) t\n\n(** The type of hash tables from type ['a] to type ['b]. *)\n\ntype ('a, 'id) id = ('a, 'id) Belt_Id.hashable\n\nval make : hintSize:int -> id:('a, 'id) id -> ('a, 'id) t\nval clear : ('a, 'id) t -> unit\nval isEmpty : _ t -> bool\nval add : ('a, 'id) t -> 'a -> unit\nval copy : ('a, 'id) t -> ('a, 'id) t\nval has : ('a, 'id) t -> 'a -> bool\nval remove : ('a, 'id) t -> 'a -> unit\nval forEachU : ('a, 'id) t -> (('a -> unit)[@u]) -> unit\n\nval forEach : ('a, 'id) t -> ('a -> unit) -> unit\n(** Order unspecified. *)\n\nval reduceU : ('a, 'id) t -> 'c -> (('c -> 'a -> 'c)[@u]) -> 'c\n\nval reduce : ('a, 'id) t -> 'c -> ('c -> 'a -> 'c) -> 'c\n(** Order unspecified. *)\n\nval size : ('a, 'id) t -> int\nval logStats : _ t -> unit\nval toArray : ('a, 'id) t -> 'a array\nval fromArray : 'a array -> id:('a, 'id) id -> ('a, 'id) t\nval mergeMany : ('a, 'id) t -> 'a array -> unit\nval getBucketHistogram : _ t -> int array\n"
},
{
"path": "packages/Belt/src/Belt_HashSetInt.ml",
"content": "type key = int\ntype t = (key, unit) Hashtbl.t\n\nlet make ~hintSize = Hashtbl.create hintSize\nlet clear = Hashtbl.clear\nlet isEmpty h = Hashtbl.length h = 0\nlet add h key = Hashtbl.replace h key ()\nlet copy = Hashtbl.copy\nlet has = Hashtbl.mem\nlet remove = Hashtbl.remove\nlet forEachU h f = Hashtbl.iter (fun key () -> f key) h\nlet forEach h f = forEachU h (fun key -> f key)\n\nlet reduceU h init f =\n let acc = ref init in\n Hashtbl.iter (fun key () -> acc := f !acc key) h;\n !acc\n\nlet reduce h init f = reduceU h init (fun acc key -> f acc key)\nlet size = Hashtbl.length\n\nlet logStats h =\n let stats = Hashtbl.stats h in\n Printf.printf \"{\\n\\tbindings: %d,\\n\\tbuckets: %d\\n\\thistogram: %s\\n}\" stats.num_bindings stats.num_buckets\n (Belt_Array.reduceU stats.bucket_histogram \"\" (fun acc x -> acc ^ string_of_int x))\n\nlet toArray h = Hashtbl.fold (fun key () acc -> key :: acc) h [] |> Array.of_list\n\nlet fromArray arr =\n let h = make ~hintSize:(Belt_Array.length arr) in\n Belt_Array.forEachU arr (fun key -> add h key);\n h\n\nlet mergeMany h arr = Belt_Array.forEachU arr (fun key -> add h key)\nlet getBucketHistogram h = (Hashtbl.stats h).bucket_histogram\n"
},
{
"path": "packages/Belt/src/Belt_HashSetInt.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This module is {!Belt.HashSet} specialized with key type to be a primitive type.\n\n It is more efficient in general, the API is the same with {!Belt.HashSet} except its key type is fixed, and identity\n is not needed(using the built-in one)\n\n {b See} {!Belt.HashSet} *)\n\ntype key = int\ntype t\n\nval make : hintSize:int -> t\nval clear : t -> unit\nval isEmpty : t -> bool\nval add : t -> key -> unit\nval copy : t -> t\nval has : t -> key -> bool\nval remove : t -> key -> unit\nval forEachU : t -> ((key -> unit)[@u]) -> unit\nval forEach : t -> (key -> unit) -> unit\nval reduceU : t -> 'c -> (('c -> key -> 'c)[@u]) -> 'c\nval reduce : t -> 'c -> ('c -> key -> 'c) -> 'c\nval size : t -> int\nval logStats : t -> unit\nval toArray : t -> key array\nval fromArray : key array -> t\nval mergeMany : t -> key array -> unit\nval getBucketHistogram : t -> int array\n"
},
{
"path": "packages/Belt/src/Belt_HashSetString.ml",
"content": "type key = string\ntype t = (key, unit) Hashtbl.t\n\nlet make ~hintSize = Hashtbl.create hintSize\nlet clear = Hashtbl.clear\nlet isEmpty h = Hashtbl.length h = 0\nlet add h key = Hashtbl.replace h key ()\nlet copy = Hashtbl.copy\nlet has = Hashtbl.mem\nlet remove = Hashtbl.remove\nlet forEachU h f = Hashtbl.iter (fun key () -> f key) h\nlet forEach h f = forEachU h (fun key -> f key)\n\nlet reduceU h init f =\n let acc = ref init in\n Hashtbl.iter (fun key () -> acc := f !acc key) h;\n !acc\n\nlet reduce h init f = reduceU h init (fun acc key -> f acc key)\nlet size = Hashtbl.length\n\nlet logStats h =\n let stats = Hashtbl.stats h in\n Printf.printf \"{\\n\\tbindings: %d,\\n\\tbuckets: %d\\n\\thistogram: %s\\n}\" stats.num_bindings stats.num_buckets\n (Belt_Array.reduceU stats.bucket_histogram \"\" (fun acc x -> acc ^ string_of_int x))\n\nlet toArray h = Hashtbl.fold (fun key () acc -> key :: acc) h [] |> Array.of_list\n\nlet fromArray arr =\n let h = make ~hintSize:(Belt_Array.length arr) in\n Belt_Array.forEachU arr (fun key -> add h key);\n h\n\nlet mergeMany h arr = Belt_Array.forEachU arr (fun key -> add h key)\nlet getBucketHistogram h = (Hashtbl.stats h).bucket_histogram\n"
},
{
"path": "packages/Belt/src/Belt_HashSetString.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This module is {!Belt.HashSet} specialized with key type to be a primitive type.\n\n It is more efficient in general, the API is the same with {!Belt.HashSet} except its key type is fixed, and identity\n is not needed(using the built-in one)\n\n {b See} {!Belt.HashSet} *)\n\ntype key = string\ntype t\n\nval make : hintSize:int -> t\nval clear : t -> unit\nval isEmpty : t -> bool\nval add : t -> key -> unit\nval copy : t -> t\nval has : t -> key -> bool\nval remove : t -> key -> unit\nval forEachU : t -> ((key -> unit)[@u]) -> unit\nval forEach : t -> (key -> unit) -> unit\nval reduceU : t -> 'c -> (('c -> key -> 'c)[@u]) -> 'c\nval reduce : t -> 'c -> ('c -> key -> 'c) -> 'c\nval size : t -> int\nval logStats : t -> unit\nval toArray : t -> key array\nval fromArray : key array -> t\nval mergeMany : t -> key array -> unit\nval getBucketHistogram : t -> int array\n"
},
{
"path": "packages/Belt/src/Belt_Id.ml",
"content": "type ('a, 'id) hash = 'a -> int\ntype ('a, 'id) eq = 'a -> 'a -> bool\ntype ('a, 'id) cmp = 'a -> 'a -> int\n\nlet getHashInternal : ('a, 'id) hash -> 'a -> int = Obj.magic\nlet getEqInternal : ('a, 'id) eq -> 'a -> 'a -> bool = Obj.magic\nlet getCmpInternal : ('a, 'id) cmp -> 'a -> 'a -> int = Obj.magic\n\nmodule type Comparable = sig\n type identity\n type t\n\n val cmp : (t, identity) cmp\nend\n\ntype ('key, 'id) comparable = (module Comparable with type t = 'key and type identity = 'id)\n\nmodule MakeComparableU (M : sig\n type t\n\n val cmp : t -> t -> int\nend) =\nstruct\n type identity\n type t = M.t\n\n let cmp = M.cmp\nend\n\nmodule MakeComparable (M : sig\n type t\n\n val cmp : t -> t -> int\nend) =\nstruct\n type identity\n type t = M.t\n\n let cmp =\n let cmp = M.cmp in\n fun a b -> cmp a b\nend\n\nlet comparableU (type key) ~cmp =\n let module N = MakeComparableU (struct\n type t = key\n\n let cmp = cmp\n end) in\n (module N : Comparable with type t = key)\n\nlet comparable (type key) ~cmp =\n let module N = MakeComparable (struct\n type t = key\n\n let cmp = cmp\n end) in\n (module N : Comparable with type t = key)\n\nmodule type Hashable = sig\n type identity\n type t\n\n val hash : (t, identity) hash\n val eq : (t, identity) eq\nend\n\ntype ('key, 'id) hashable = (module Hashable with type t = 'key and type identity = 'id)\n\nmodule MakeHashableU (M : sig\n type t\n\n val hash : t -> int\n val eq : t -> t -> bool\nend) =\nstruct\n type identity\n type t = M.t\n\n let hash = M.hash\n let eq = M.eq\nend\n\nmodule MakeHashable (M : sig\n type t\n\n val hash : t -> int\n val eq : t -> t -> bool\nend) =\nstruct\n type identity\n type t = M.t\n\n let hash =\n let hash = M.hash in\n fun a -> hash a\n\n let eq =\n let eq = M.eq in\n fun a b -> eq a b\nend\n\nlet hashableU (type key) ~hash ~eq =\n let module N = MakeHashableU (struct\n type t = key\n\n let hash = hash\n let eq = eq\n end) in\n (module N : Hashable with type t = key)\n\nlet hashable (type key) ~hash ~eq =\n let module N = MakeHashable (struct\n type t = key\n\n let hash = hash\n let eq = eq\n end) in\n (module N : Hashable with type t = key)\n"
},
{
"path": "packages/Belt/src/Belt_Id.mli",
"content": "type ('a, 'id) hash = 'a -> int\ntype ('a, 'id) eq = 'a -> 'a -> bool\ntype ('a, 'id) cmp = 'a -> 'a -> int\n\nval getHashInternal : ('a, 'id) hash -> 'a -> int\nval getEqInternal : ('a, 'id) eq -> 'a -> 'a -> bool\nval getCmpInternal : ('a, 'id) cmp -> 'a -> 'a -> int\n\nmodule type Comparable = sig\n type identity\n type t\n\n val cmp : (t, identity) cmp\nend\n\ntype ('key, 'id) comparable = (module Comparable with type identity = 'id and type t = 'key)\n\nmodule MakeComparableU : functor\n (M : sig\n type t\n\n val cmp : t -> t -> int\n end)\n -> sig\n type identity\n type t = M.t\n\n val cmp : M.t -> M.t -> int\nend\n\nmodule MakeComparable : functor\n (M : sig\n type t\n\n val cmp : t -> t -> int\n end)\n -> sig\n type identity\n type t = M.t\n\n val cmp : M.t -> M.t -> int\nend\n\nval comparableU : cmp:('key -> 'key -> int) -> (module Comparable with type t = 'key)\nval comparable : cmp:('key -> 'key -> int) -> (module Comparable with type t = 'key)\n\nmodule type Hashable = sig\n type identity\n type t\n\n val hash : (t, identity) hash\n val eq : (t, identity) eq\nend\n\ntype ('key, 'id) hashable = (module Hashable with type identity = 'id and type t = 'key)\n\nmodule MakeHashableU : functor\n (M : sig\n type t\n\n val hash : t -> int\n val eq : t -> t -> bool\n end)\n -> sig\n type identity\n type t = M.t\n\n val hash : M.t -> int\n val eq : M.t -> M.t -> bool\nend\n\nmodule MakeHashable : functor\n (M : sig\n type t\n\n val hash : t -> int\n val eq : t -> t -> bool\n end)\n -> sig\n type identity\n type t = M.t\n\n val hash : M.t -> int\n val eq : M.t -> M.t -> bool\nend\n\nval hashableU : hash:('key -> int) -> eq:('key -> 'key -> bool) -> (module Hashable with type t = 'key)\nval hashable : hash:('key -> int) -> eq:('key -> 'key -> bool) -> (module Hashable with type t = 'key)\n"
},
{
"path": "packages/Belt/src/Belt_Int.ml",
"content": "let toFloat = Stdlib.float_of_int\nlet fromFloat = Stdlib.int_of_float\n\nlet fromString input =\n match int_of_string_opt input with\n | Some value -> Some value\n | None -> ( try Some (int_of_float (float_of_string input)) with _ -> None)\n\nlet toString = string_of_int\nlet ( + ) = Stdlib.( + )\nlet ( - ) = Stdlib.( - )\nlet ( * ) = Stdlib.( * )\nlet ( / ) = Stdlib.( / )\n"
},
{
"path": "packages/Belt/src/Belt_Int.mli",
"content": "val toFloat : int -> float\nval fromFloat : float -> int\nval fromString : string -> int option\nval toString : int -> string\nval ( + ) : int -> int -> int\nval ( - ) : int -> int -> int\nval ( * ) : int -> int -> int\nval ( / ) : int -> int -> int\n"
},
{
"path": "packages/Belt/src/Belt_List.ml",
"content": "type 'a t = 'a list\n\nmodule A = Belt_Array\n\nexternal mutableCell : 'a -> 'a t -> 'a t = \"belt_makemutablelist\"\n\nlet unsafeMutateTail a b = Obj.set_field (Obj.repr a) 1 (Obj.repr b)\nlet unsafeTail a = Obj.obj (Obj.field (Obj.repr a) 1)\nlet head x = match x with [] -> None | x :: _ -> Some x\n\nlet headExn x =\n match x with\n | [] ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n | x :: _ -> x\n\nlet tail x = match x with [] -> None | _ :: xs -> Some xs\n\nlet tailExn x =\n match x with\n | [] ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n | _ :: t -> t\n\nlet add xs x = x :: xs\nlet rec nthAux x n = match x with h :: t -> if n = 0 then Some h else nthAux t (n - 1) | _ -> None\n\nlet rec nthAuxAssert x n =\n match x with\n | h :: t -> if n = 0 then h else nthAuxAssert t (n - 1)\n | _ ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n\nlet get x n = if n < 0 then None else nthAux x n\n\nlet getExn x n =\n if n < 0 then\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n else nthAuxAssert x n\n\nlet rec partitionAux p cell precX precY =\n match cell with\n | [] -> ()\n | h :: t ->\n let next = mutableCell h [] in\n if p h then (\n unsafeMutateTail precX next;\n partitionAux p t next precY)\n else (\n unsafeMutateTail precY next;\n partitionAux p t precX next)\n\nlet rec splitAux cell precX precY =\n match cell with\n | [] -> ()\n | (a, b) :: t ->\n let nextA = mutableCell a [] in\n let nextB = mutableCell b [] in\n unsafeMutateTail precX nextA;\n unsafeMutateTail precY nextB;\n splitAux t nextA nextB\n\nlet rec copyAuxCont cellX prec =\n match cellX with\n | [] -> prec\n | h :: t ->\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n copyAuxCont t next\n\nlet rec copyAuxWitFilter f cellX prec =\n match cellX with\n | [] -> ()\n | h :: t ->\n if f h then (\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n copyAuxWitFilter f t next)\n else copyAuxWitFilter f t prec\n\nlet rec copyAuxWitFilterMap f cellX prec =\n match cellX with\n | [] -> ()\n | h :: t -> (\n match f h with\n | Some h ->\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n copyAuxWitFilterMap f t next\n | None -> copyAuxWitFilterMap f t prec)\n\nlet rec removeAssocAuxWithMap cellX x prec f =\n match cellX with\n | [] -> false\n | ((a, _) as h) :: t ->\n if f a x then (\n unsafeMutateTail prec t;\n true)\n else\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n removeAssocAuxWithMap t x next f\n\nlet rec setAssocAuxWithMap cellX x k prec eq =\n match cellX with\n | [] -> false\n | ((a, _) as h) :: t ->\n if eq a x then (\n unsafeMutateTail prec ((x, k) :: t);\n true)\n else\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n setAssocAuxWithMap t x k next eq\n\nlet rec copyAuxWithMap cellX prec f =\n match cellX with\n | [] -> ()\n | h :: t ->\n let next = mutableCell (f h) [] in\n unsafeMutateTail prec next;\n copyAuxWithMap t next f\n\nlet rec zipAux cellX cellY prec =\n match (cellX, cellY) with\n | h1 :: t1, h2 :: t2 ->\n let next = mutableCell (h1, h2) [] in\n unsafeMutateTail prec next;\n zipAux t1 t2 next\n | [], _ | _, [] -> ()\n\nlet rec copyAuxWithMap2 f cellX cellY prec =\n match (cellX, cellY) with\n | h1 :: t1, h2 :: t2 ->\n let next = mutableCell (f h1 h2) [] in\n unsafeMutateTail prec next;\n copyAuxWithMap2 f t1 t2 next\n | [], _ | _, [] -> ()\n\nlet rec copyAuxWithMapI f i cellX prec =\n match cellX with\n | h :: t ->\n let next = mutableCell (f i h) [] in\n unsafeMutateTail prec next;\n copyAuxWithMapI f (i + 1) t next\n | [] -> ()\n\nlet rec takeAux n cell prec =\n if n = 0 then true\n else\n match cell with\n | [] -> false\n | x :: xs ->\n let cell = mutableCell x [] in\n unsafeMutateTail prec cell;\n takeAux (n - 1) xs cell\n\nlet rec splitAtAux n cell prec =\n if n = 0 then Some cell\n else\n match cell with\n | [] -> None\n | x :: xs ->\n let cell = mutableCell x [] in\n unsafeMutateTail prec cell;\n splitAtAux (n - 1) xs cell\n\nlet take lst n =\n if n < 0 then None\n else if n = 0 then Some []\n else\n match lst with\n | [] -> None\n | x :: xs ->\n let cell = mutableCell x [] in\n let has = takeAux (n - 1) xs cell in\n if has then Some cell else None\n\nlet rec dropAux l n = if n = 0 then Some l else match l with _ :: tl -> dropAux tl (n - 1) | [] -> None\nlet drop lst n = if n < 0 then None else dropAux lst n\n\nlet splitAt lst n =\n if n < 0 then None\n else if n = 0 then Some ([], lst)\n else\n match lst with\n | [] -> None\n | x :: xs -> (\n let cell = mutableCell x [] in\n let rest = splitAtAux (n - 1) xs cell in\n match rest with Some rest -> Some (cell, rest) | None -> None)\n\nlet concat xs ys =\n match xs with\n | [] -> ys\n | h :: t ->\n let cell = mutableCell h [] in\n unsafeMutateTail (copyAuxCont t cell) ys;\n cell\n\nlet mapU xs f =\n match xs with\n | [] -> []\n | h :: t ->\n let cell = mutableCell (f h) [] in\n copyAuxWithMap t cell f;\n cell\n\nlet map xs f = mapU xs (fun x -> f x)\n\nlet zipByU l1 l2 f =\n match (l1, l2) with\n | a1 :: l1, a2 :: l2 ->\n let cell = mutableCell (f a1 a2) [] in\n copyAuxWithMap2 f l1 l2 cell;\n cell\n | [], _ | _, [] -> []\n\nlet zipBy l1 l2 f = zipByU l1 l2 (fun x y -> f x y)\n\nlet mapWithIndexU xs f =\n match xs with\n | [] -> []\n | h :: t ->\n let cell = mutableCell (f 0 h) [] in\n copyAuxWithMapI f 1 t cell;\n cell\n\nlet mapWithIndex xs f = mapWithIndexU xs (fun i x -> f i x)\n\nlet makeByU n f =\n if n <= 0 then []\n else\n let headX = mutableCell (f 0) [] in\n let cur = ref headX in\n let i = ref 1 in\n while !i < n do\n let v = mutableCell (f !i) [] in\n unsafeMutateTail !cur v;\n cur := v;\n incr i\n done;\n headX\n\nlet makeBy n f = makeByU n (fun x -> f x)\n\nlet make n v =\n if n <= 0 then []\n else\n let headX = mutableCell v [] in\n let cur = ref headX in\n let i = ref 1 in\n while !i < n do\n let v = mutableCell v [] in\n unsafeMutateTail !cur v;\n cur := v;\n incr i\n done;\n headX\n\nlet rec lengthAux x acc = match x with [] -> acc | _ :: t -> lengthAux t (acc + 1)\nlet length xs = lengthAux xs 0\nlet size = length\n\nlet rec fillAux arr i x =\n match x with\n | [] -> ()\n | h :: t ->\n A.setUnsafe arr i h;\n fillAux arr (i + 1) t\n\nlet rec fromArrayAux a i res = if i < 0 then res else fromArrayAux a (i - 1) (A.getUnsafe a i :: res)\nlet fromArray a = fromArrayAux a (A.length a - 1) []\n\nlet toArray (x : _ t) =\n let len = length x in\n let arr = match x with x :: _ -> A.makeUninitializedUnsafe len x | _ -> [||] in\n fillAux arr 0 x;\n arr\n\nlet shuffle xs =\n let v = toArray xs in\n A.shuffleInPlace v;\n fromArray v\n\nlet rec fillAuxMap arr i x f =\n match x with\n | [] -> ()\n | h :: t ->\n A.setUnsafe arr i (f h);\n fillAuxMap arr (i + 1) t f\n\nlet rec reverseConcat l1 l2 = match l1 with [] -> l2 | a :: l -> reverseConcat l (a :: l2)\nlet reverse l = reverseConcat l []\n\nlet rec flattenAux prec xs =\n match xs with [] -> unsafeMutateTail prec [] | h :: r -> flattenAux (copyAuxCont h prec) r\n\nlet rec flatten xs =\n match xs with\n | [] -> []\n | [] :: xs -> flatten xs\n | (h :: t) :: r ->\n let cell = mutableCell h [] in\n flattenAux (copyAuxCont t cell) r;\n cell\n\nlet concatMany xs =\n match xs with\n | [||] -> []\n | [| x |] -> x\n | _ ->\n let len = A.length xs in\n let v = ref (A.getUnsafe xs (len - 1)) in\n for i = len - 2 downto 0 do\n v := concat (A.getUnsafe xs i) !v\n done;\n !v\n\nlet rec mapRevAux f accu xs = match xs with [] -> accu | a :: l -> mapRevAux f (f a :: accu) l\nlet mapReverseU l f = mapRevAux f [] l\nlet mapReverse l f = mapReverseU l (fun x -> f x)\n\nlet rec forEachU xs f =\n match xs with\n | [] -> ()\n | a :: l ->\n f a;\n forEachU l f\n\nlet forEach xs f = forEachU xs (fun x -> f x)\n\nlet rec iteri xs i f =\n match xs with\n | [] -> ()\n | a :: l ->\n f i a;\n iteri l (i + 1) f\n\nlet forEachWithIndexU l f = iteri l 0 f\nlet forEachWithIndex l f = forEachWithIndexU l (fun i x -> f i x)\nlet rec reduceU l accu f = match l with [] -> accu | a :: l -> reduceU l (f accu a) f\nlet reduce l accu f = reduceU l accu (fun acc x -> f acc x)\nlet rec reduceReverseUnsafeU l accu f = match l with [] -> accu | a :: l -> f (reduceReverseUnsafeU l accu f) a\n\nlet reduceReverseU (type a b) (l : a list) (acc : b) f =\n let len = length l in\n if len < 1000 then reduceReverseUnsafeU l acc f else A.reduceReverseU (toArray l) acc f\n\nlet reduceReverse l accu f = reduceReverseU l accu (fun a b -> f a b)\n\nlet rec mapRevAux2 l1 l2 accu f =\n match (l1, l2) with a1 :: l1, a2 :: l2 -> mapRevAux2 l1 l2 (f a1 a2 :: accu) f | _, [] | [], _ -> accu\n\nlet mapReverse2U l1 l2 f = mapRevAux2 l1 l2 [] f\nlet mapReverse2 l1 l2 f = mapReverse2U l1 l2 (fun a b -> f a b)\n\nlet rec forEach2U l1 l2 f =\n match (l1, l2) with\n | a1 :: l1, a2 :: l2 ->\n f a1 a2;\n forEach2U l1 l2 f\n | [], _ | _, [] -> ()\n\nlet forEach2 l1 l2 f = forEach2U l1 l2 (fun a b -> f a b)\n\nlet rec reduce2U l1 l2 accu f =\n match (l1, l2) with a1 :: l1, a2 :: l2 -> reduce2U l1 l2 (f accu a1 a2) f | [], _ | _, [] -> accu\n\nlet reduce2 l1 l2 acc f = reduce2U l1 l2 acc (fun a b c -> f a b c)\n\nlet rec reduceReverse2UnsafeU l1 l2 accu f =\n match (l1, l2) with\n | [], [] -> accu\n | a1 :: l1, a2 :: l2 -> f (reduceReverse2UnsafeU l1 l2 accu f) a1 a2\n | _, [] | [], _ -> accu\n\nlet reduceReverse2U (type a b c) (l1 : a list) (l2 : b list) (acc : c) f =\n let len = length l1 in\n if len < 1000 then reduceReverse2UnsafeU l1 l2 acc f else A.reduceReverse2U (toArray l1) (toArray l2) acc f\n\nlet reduceReverse2 l1 l2 acc f = reduceReverse2U l1 l2 acc (fun a b c -> f a b c)\nlet rec everyU xs p = match xs with [] -> true | a :: l -> p a && everyU l p\nlet every xs p = everyU xs (fun x -> p x)\nlet rec someU xs p = match xs with [] -> false | a :: l -> p a || someU l p\nlet some xs p = someU xs (fun x -> p x)\nlet rec every2U l1 l2 p = match (l1, l2) with _, [] | [], _ -> true | a1 :: l1, a2 :: l2 -> p a1 a2 && every2U l1 l2 p\nlet every2 l1 l2 p = every2U l1 l2 (fun a b -> p a b)\n\nlet rec cmpByLength l1 l2 =\n match (l1, l2) with [], [] -> 0 | _, [] -> 1 | [], _ -> -1 | _ :: l1s, _ :: l2s -> cmpByLength l1s l2s\n\nlet rec cmpU l1 l2 p =\n match (l1, l2) with\n | [], [] -> 0\n | _, [] -> 1\n | [], _ -> -1\n | a1 :: l1, a2 :: l2 ->\n let c = p a1 a2 in\n if c = 0 then cmpU l1 l2 p else c\n\nlet cmp l1 l2 f = cmpU l1 l2 (fun x y -> f x y)\n\nlet rec eqU l1 l2 p =\n match (l1, l2) with\n | [], [] -> true\n | _, [] | [], _ -> false\n | a1 :: l1, a2 :: l2 -> if p a1 a2 then eqU l1 l2 p else false\n\nlet eq l1 l2 f = eqU l1 l2 (fun x y -> f x y)\nlet rec some2U l1 l2 p = match (l1, l2) with [], _ | _, [] -> false | a1 :: l1, a2 :: l2 -> p a1 a2 || some2U l1 l2 p\nlet some2 l1 l2 p = some2U l1 l2 (fun a b -> p a b)\nlet rec hasU xs x eq = match xs with [] -> false | a :: l -> eq a x || hasU l x eq\nlet has xs x eq = hasU xs x (fun a b -> eq a b)\nlet rec getAssocU xs x eq = match xs with [] -> None | (a, b) :: l -> if eq a x then Some b else getAssocU l x eq\nlet getAssoc xs x eq = getAssocU xs x (fun a b -> eq a b)\nlet rec hasAssocU xs x eq = match xs with [] -> false | (a, b) :: l -> eq a x || hasAssocU l x eq\nlet hasAssoc xs x eq = hasAssocU xs x (fun a b -> eq a b)\n\nlet removeAssocU xs x eq =\n match xs with\n | [] -> []\n | ((a, _) as pair) :: l ->\n if eq a x then l\n else\n let cell = mutableCell pair [] in\n let removed = removeAssocAuxWithMap l x cell eq in\n if removed then cell else xs\n\nlet removeAssoc xs x eq = removeAssocU xs x (fun a b -> eq a b)\n\nlet setAssocU xs x k eq =\n match xs with\n | [] -> [ (x, k) ]\n | ((a, _) as pair) :: l ->\n if eq a x then (x, k) :: l\n else\n let cell = mutableCell pair [] in\n let replaced = setAssocAuxWithMap l x k cell eq in\n if replaced then cell else (x, k) :: xs\n\nlet setAssoc xs x k eq = setAssocU xs x k (fun a b -> eq a b)\n\nlet sortU xs cmp =\n let arr = toArray xs in\n Belt_SortArray.stableSortInPlaceByU arr cmp;\n fromArray arr\n\nlet sort xs cmp = sortU xs (fun x y -> cmp x y)\nlet rec getByU xs p = match xs with [] -> None | x :: l -> if p x then Some x else getByU l p\nlet getBy xs p = getByU xs (fun a -> p a)\n\nlet rec keepU xs p =\n match xs with\n | [] -> []\n | h :: t ->\n if p h then (\n let cell = mutableCell h [] in\n copyAuxWitFilter p t cell;\n cell)\n else keepU t p\n\nlet keep xs p = keepU xs (fun x -> p x)\n\nlet rec copyAuxWithFilterIndex f cellX prec i =\n match cellX with\n | [] -> ()\n | h :: t ->\n if f h i then (\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n copyAuxWithFilterIndex f t next (i + 1))\n else copyAuxWithFilterIndex f t prec (i + 1)\n\nlet rec copyAuxWitFilterMap f cellX prec =\n match cellX with\n | [] -> ()\n | h :: t -> (\n match f h with\n | Some h ->\n let next = mutableCell h [] in\n unsafeMutateTail prec next;\n copyAuxWitFilterMap f t next\n | None -> copyAuxWitFilterMap f t prec)\n\nlet keepWithIndexU xs p =\n let rec auxKeepWithIndex xs p i =\n match xs with\n | [] -> []\n | h :: t ->\n if p h i then (\n let cell = mutableCell h [] in\n copyAuxWithFilterIndex p t cell (i + 1);\n cell)\n else auxKeepWithIndex t p (i + 1)\n in\n auxKeepWithIndex xs p 0\n\nlet keepWithIndex xs p = keepWithIndexU xs (fun x i -> p x i)\n\nlet rec keepMapU xs p =\n match xs with\n | [] -> []\n | h :: t -> (\n match p h with\n | Some h ->\n let cell = mutableCell h [] in\n copyAuxWitFilterMap p t cell;\n cell\n | None -> keepMapU t p)\n\nlet keepMap xs p = keepMapU xs (fun x -> p x)\n\nlet partitionU l p =\n match l with\n | [] -> ([], [])\n | h :: t ->\n let nextX = mutableCell h [] in\n let nextY = mutableCell h [] in\n let b = p h in\n partitionAux p t nextX nextY;\n if b then (nextX, unsafeTail nextY) else (unsafeTail nextX, nextY)\n\nlet partition l p = partitionU l (fun x -> p x)\n\nlet rec unzip xs =\n match xs with\n | [] -> ([], [])\n | (x, y) :: l ->\n let cellX = mutableCell x [] in\n let cellY = mutableCell y [] in\n splitAux l cellX cellY;\n (cellX, cellY)\n\nlet rec zip l1 l2 =\n match (l1, l2) with\n | _, [] | [], _ -> []\n | a1 :: l1, a2 :: l2 ->\n let cell = mutableCell (a1, a2) [] in\n zipAux l1 l2 cell;\n cell\n\nlet rec reduceWithIndexAuxU l acc f i =\n match l with [] -> acc | x :: xs -> reduceWithIndexAuxU xs (f acc x i [@bs]) f (i + 1)\n\nlet reduceWithIndexU l acc f = reduceWithIndexAuxU l acc f 0\nlet reduceWithIndex l acc f = reduceWithIndexU l acc (fun[@bs] acc x i -> f acc x i)\nlet filter = keep\nlet filterWithIndex = keepWithIndexU\n"
},
{
"path": "packages/Belt/src/Belt_List.mli",
"content": "(** {!Belt.List}\n\n Utilities for List data type.\n\n This module is compatible with original ocaml stdlib. In general, all functions comes with the original stdlib also\n applies to this collection, however, this module provides faster and stack safer utilities *)\n\ntype 'a t = 'a list\n(** ['a t] is compatible with built-in [list] type *)\n\nval length : 'a t -> int\n(** [length xs]\n\n @return the length of the list [xs] *)\n\nval size : 'a t -> int\n(** {b See} {!length} *)\n\nval head : 'a t -> 'a option\n(** [head xs] returns [None] if [xs] is the empty list, otherwise it returns [Some value] where [value] is the first\n element in the list.\n {[\n head [] = None;;\n head [ 1; 2; 3 ] = Some 1\n ]} *)\n\nval headExn : 'a t -> 'a\n(** [headExn xs]\n\n {b See} {!head}\n\n {b raise} an exception if [xs] is empty *)\n\nval tail : 'a t -> 'a t option\n(** [tail xs] returns [None] if [xs] is empty; otherwise it returns [Some xs2] where [xs2] is everything except the\n first element of [xs];\n\n {[\n tail [] = None;;\n tail [ 1; 2; 3; 4 ] = Some [ 2; 3; 4 ]\n ]} *)\n\nval tailExn : 'a t -> 'a t\n(** [tailExn xs]\n\n {b See} {!tail}\n\n {b raise} an exception if [xs] is empty *)\n\nval add : 'a t -> 'a -> 'a t\n(** [add xs y] adds [y] to the beginning of list [xs]\n\n {[\n add [ 1 ] 3 = [ 3; 1 ]\n ]} *)\n\nval get : 'a t -> int -> 'a option\n(** [get xs n]\n\n return the nth element in [xs], or [None] if [n] is larger than the length\n\n {[\n get [ 0; 3; 32 ] 2 = Some 32;;\n get [ 0; 3; 32 ] 3 = None\n ]} *)\n\nval getExn : 'a t -> int -> 'a\n(** [getExn xs n]\n\n {b See} {!get}\n\n {b raise} an exception if [n] is larger than the length *)\n\nval make : int -> 'a -> 'a t\n(** [make n v]\n\n - return a list of length [n] with each element filled with value [v]\n - return the empty list if [n] is negative\n\n {[\n make 3 1 = [ 1; 1; 1 ]\n ]} *)\n\nval makeByU : int -> ((int -> 'a)[@bs]) -> 'a t\n\nval makeBy : int -> (int -> 'a) -> 'a t\n(** [makeBy n f]\n\n - return a list of length [n] with element [i] initialized with [f i]\n - return the empty list if [n] is negative\n\n {[\n makeBy 5 (fun i -> i) = [ 0; 1; 2; 3; 4 ];;\n makeBy 5 (fun i -> i * i) = [ 0; 1; 4; 9; 16 ]\n ]} *)\n\nval shuffle : 'a t -> 'a t\n(** [shuffle xs]\n @return a new list in random order *)\n\nval drop : 'a t -> int -> 'a t option\n(** [drop xs n]\n\n return the list obtained by dropping the first [n] elements, or [None] if [xs] has fewer than [n] elements\n\n {[\n drop [ 1; 2; 3 ] 2 = Some [ 3 ];;\n drop [ 1; 2; 3 ] 3 = Some [];;\n drop [ 1; 2; 3 ] 4 = None\n ]} *)\n\nval take : 'a t -> int -> 'a t option\n(** [take xs n]\n\n return a list with the first [n] elements from [xs], or [None] if [xs] has fewer than [n] elements\n\n {[\n take [ 1; 2; 3 ] 1 = Some [ 1 ];;\n take [ 1; 2; 3 ] 2 = Some [ 1; 2 ];;\n take [ 1; 2; 3 ] 4 = None\n ]} *)\n\nval splitAt : 'a t -> int -> ('a list * 'a list) option\n(** [splitAt xs n] split the list [xs] at position [n] return None when the length of [xs] is less than [n]\n\n {[\n splitAt [ 0; 1; 2; 3; 4 ] 2 = Some ([ 0; 1 ], [ 2; 3; 4 ])\n ]} *)\n\nval concat : 'a t -> 'a t -> 'a t\n(** [concat xs ys]\n\n @return the list obtained by adding [ys] after [xs]\n\n {[\n concat [ 1; 2; 3 ] [ 4; 5 ] = [ 1; 2; 3; 4; 5 ]\n ]} *)\n\nval concatMany : 'a t array -> 'a t\n(** [concatMany a] return the list obtained by concatenating in order all the lists in array [a]\n\n {[\n concatMany [| [ 1; 2; 3 ]; []; [ 3 ]; [ 4 ] |] = [ 1; 2; 3; 3; 4 ]\n ]} *)\n\nval reverseConcat : 'a t -> 'a t -> 'a t\n(** [reverseConcat xs ys] is equivalent to [concat (reverse xs) ys]\n {[\n reverseConcat [ 1; 2 ] [ 3; 4 ] = [ 2; 1; 3; 4 ]\n ]} *)\n\nval flatten : 'a t t -> 'a t\n(** [flatten ls] return the list obtained by concatenating in order all the lists in list [ls]\n\n {[\n flatten [ [ 1; 2; 3 ]; []; [ 3 ]; [ 4 ] ] = [ 1; 2; 3; 3; 4 ]\n ]} *)\n\nval mapU : 'a t -> (('a -> 'b)[@bs]) -> 'b t\n\nval map : 'a t -> ('a -> 'b) -> 'b t\n(** [map xs f]\n\n return the list obtained by applying [f] to each element of [xs]\n\n {[\n map [ 1; 2 ] (fun x -> x + 1) = [ 3; 4 ]\n ]} *)\n\nval zip : 'a t -> 'b t -> ('a * 'b) t\n(** [zip xs ys]\n\n @return a list of pairs from the two lists with the length of the shorter list\n\n {[\n zip [ 1; 2 ] [ 3; 4; 5 ] = [ (1, 3); (2, 4) ]\n ]} *)\n\nval zipByU : 'a t -> 'b t -> (('a -> 'b -> 'c)[@bs]) -> 'c t\n\nval zipBy : 'a t -> 'b t -> ('a -> 'b -> 'c) -> 'c t\n(** [zipBy xs ys f]\n\n {b See} {!zip}\n\n Equivalent to [zip xs ys |> List.map (fun (x,y) -> f x y)]\n\n {[\n zipBy [ 1; 2; 3 ] [ 4; 5 ] (fun a b -> (2 * a) + b) = [ 6; 9 ]\n ]} *)\n\nval mapWithIndexU : 'a t -> ((int -> 'a -> 'b)[@bs]) -> 'b t\n\nval mapWithIndex : 'a t -> (int -> 'a -> 'b) -> 'b t\n(** [mapWithIndex xs f] applies [f] to each element of [xs]. Function [f] takes two arguments: the index starting from 0\n and the element from [xs].\n\n {[\n mapWithIndex [ 1; 2; 3 ] (fun i x -> i + x) = [ 0 + 1; 1 + 2; 2 + 3 ]\n ]} *)\n\nval fromArray : 'a array -> 'a t\n(** [fromArray arr] converts the given array to a list\n\n {[\n fromArray [| 1; 2; 3 |] = [ 1; 2; 3 ]\n ]} *)\n\nval toArray : 'a t -> 'a array\n(** [toArray xs] converts the given list to an array\n {[\n toArray [ 1; 2; 3 ] = [| 1; 2; 3 |]\n ]} *)\n(* type json = Js_json.t *)\n\n(* val toJson : 'a t -> ('a -> json [@bs]) -> json *)\n(* val fromJson : json -> (json -> 'a [@bs]) -> 'a t *)\n\nval reverse : 'a t -> 'a t\n(** [reverse xs] returns a new list whose elements are those of [xs] in reverse order.\n {[\n reverse [ 1; 2; 3 ] = [ 3; 2; 1 ]\n ]} *)\n\nval mapReverseU : 'a t -> (('a -> 'b)[@bs]) -> 'b t\n\nval mapReverse : 'a t -> ('a -> 'b) -> 'b t\n(** [mapReverse xs f]\n\n Equivalent to [reverse (map xs f)]\n\n {[\n mapReverse [ 3; 4; 5 ] (fun x -> x * x) = [ 25; 16; 9 ]\n ]} *)\n\nval forEachU : 'a t -> (('a -> unit)[@bs]) -> unit\n\nval forEach : 'a t -> ('a -> unit) -> unit\n(** [forEach xs f ] Call [f] on each element of [xs] from the beginning to end. [f] returns [unit], so no new array is\n created. Use [foreach] when you are primarily concerned with repetitively creating side effects.\n\n {[\n forEach [ \"a\"; \"b\"; \"c\" ] (fun x -> Js.log (\"Item: \" ^ x));;\n\n (* prints:\n Item: a\n Item: b\n Item: c\n *)\n\n let us = ref 0;;\n\n forEach [ 1; 2; 3; 4 ] (fun x -> us := !us + x);;\n !us = 1 + 2 + 3 + 4\n ]} *)\n\nval forEachWithIndexU : 'a t -> ((int -> 'a -> unit)[@bs]) -> unit\n\nval forEachWithIndex : 'a t -> (int -> 'a -> unit) -> unit\n(** [forEachWithIndex xs f]\n\n {[\n forEach [ \"a\"; \"b\"; \"c\" ] (fun i x -> Js.log (\"Item \" ^ string_of_int i ^ \" is \" ^ x));;\n\n (* prints:\n Item 0 is a\n Item 1 is b\n Item 2 is cc\n *)\n\n let total = ref 0;;\n\n forEachWithIndex [ 10; 11; 12; 13 ] (fun i x -> total := !total + x + i);;\n !total = 0 + 10 + 1 + 11 + 2 + 12 + 3 + 13\n ]} *)\n\nval reduceU : 'a t -> 'b -> (('b -> 'a -> 'b)[@bs]) -> 'b\n\nval reduce : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b\n(** [reduce xs f]\n\n Applies [f] to each element of [xs] from beginning to end. Function [f] has two parameters: the item from the list\n and an “accumulator”, which starts with a value of [init]. [reduce] returns the final value of the accumulator.\n\n {[\n reduce [ 1; 2; 3; 4 ] 0 ( + ) = 10;;\n reduce [ 1; 2; 3; 4 ] 10 ( - ) = 0;;\n reduce [ 1; 2; 3; 4 ] [] add = [ 4; 3; 2; 1 ]\n ]} *)\n\nval reduceWithIndexU : 'a t -> 'b -> (('b -> 'a -> int -> 'b)[@bs]) -> 'b\n\nval reduceWithIndex : 'a t -> 'b -> ('b -> 'a -> int -> 'b) -> 'b\n(** [reduceWithIndex xs f]\n\n Applies [f] to each element of [xs] from beginning to end. Function [f] has three parameters: the item from the list\n and an “accumulator”, which starts with a value of [init] and the index of each element. [reduceWithIndex] returns\n the final value of the accumulator.\n\n {[\n reduceWithIndex [ 1; 2; 3; 4 ] 0 (fun acc x i -> acc + x + i) = 16\n ]} *)\n\nval reduceReverseU : 'a t -> 'b -> (('b -> 'a -> 'b)[@bs]) -> 'b\n\nval reduceReverse : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b\n(** [reduceReverse xs f]\n\n Works like {!reduce}, except that function [f] is applied to each item of [xs] from the last back to the first.\n\n {[\n reduceReverse [ 1; 2; 3; 4 ] 0 ( + ) = 10;;\n reduceReverse [ 1; 2; 3; 4 ] 10 ( - ) = 0;;\n reduceReverse [ 1; 2; 3; 4 ] [] add = [ 1; 2; 3; 4 ]\n ]} *)\n\nval mapReverse2U : 'a t -> 'b t -> (('a -> 'b -> 'c)[@bs]) -> 'c t\n\nval mapReverse2 : 'a t -> 'b t -> ('a -> 'b -> 'c) -> 'c t\n(** [mapReverse2 xs ys f]\n\n equivalent to [reverse (zipBy xs ys f)]\n\n {[\n mapReverse2 [ 1; 2; 3 ] [ 1; 2 ] ( + ) = [ 4; 2 ]\n ]} *)\n\nval forEach2U : 'a t -> 'b t -> (('a -> 'b -> unit)[@bs]) -> unit\n\nval forEach2 : 'a t -> 'b t -> ('a -> 'b -> unit) -> unit\n(** [forEach2 xs ys f] stop with the shorter list *)\n\nval reduce2U : 'b t -> 'c t -> 'a -> (('a -> 'b -> 'c -> 'a)[@bs]) -> 'a\n\nval reduce2 : 'b t -> 'c t -> 'a -> ('a -> 'b -> 'c -> 'a) -> 'a\n(** [reduce2 xs ys init f ]\n\n Applies [f] to each element of [xs] and [ys] from beginning to end. Stops with the shorter list. Function [f] has\n three parameters: an “accumulator” which starts with a value of [init], an item from [xs], and an item from [ys].\n [reduce2] returns the final value of the accumulator.\n\n {[\n reduce2 [1;2;3] [4;5] 0 (fun acc x y -> acc + x * x + y) = 0 + (1 * 1 + 4) + (2 * 2 + 5);;\n reduce2 [1;2;3] [4;5] [] (fun acc x y -> add acc (x + y) = [2 +5;1 + 4 ];; (*add appends at end *)\n ]} *)\n\nval reduceReverse2U : 'a t -> 'b t -> 'c -> (('c -> 'a -> 'b -> 'c)[@bs]) -> 'c\n\nval reduceReverse2 : 'a t -> 'b t -> 'c -> ('c -> 'a -> 'b -> 'c) -> 'c\n(** [reduceReverse2 xs ys init f ]\n\n Applies [f] to each element of [xs] and [ys] from end to beginning. Stops with the shorter list. Function [f] has\n three parameters: an “accumulator” which starts with a value of [init], an item from [xs], and an item from [ys].\n [reduce2] returns the final value of the accumulator.\n\n {[\n reduceReverse2 [1;2;3] [4;5] 0 (fun acc x y -> acc + x * x + y) = 0 + (1 * 1 + 4) + (2 * 2 + 5);;\n reduceReverse2 [1;2;3] [4;5] [] (fun acc x y -> add acc (x + y) = [1 + 4;2 + 5];; (*add appends at end *)\n ]}*)\n\nval everyU : 'a t -> (('a -> bool)[@bs]) -> bool\n\nval every : 'a t -> ('a -> bool) -> bool\n(** [every xs p]\n\n @return\n true if all elements satisfy [p], where [p] is a {i predicate}: a function taking an element and returning a\n [bool].\n\n {[\n every [] (fun x -> x mod 2 = 0) = true;;\n every [ 2; 4; 6 ] (fun x -> x mod 2 = 0) = true;;\n every [ 1; -3; 5 ] (fun x -> x > 0) = false\n ]} *)\n\nval someU : 'a t -> (('a -> bool)[@bs]) -> bool\n\nval some : 'a t -> ('a -> bool) -> bool\n(** [some xs p]\n @return\n true if at least one of the elements in [xs] satifies [p], where [p] is a {i predicate}: a function taking an\n element and returning a [bool].\n\n {[\n some [] (fun x -> x mod 2 = 0) = false;;\n some [ 1; 2; 4 ] (fun x -> x mod 2 = 0) = true;;\n some [ -1; -3; -5 ] (fun x -> x > 0) = false\n ]} *)\n\nval every2U : 'a t -> 'b t -> (('a -> 'b -> bool)[@bs]) -> bool\n\nval every2 : 'a t -> 'b t -> ('a -> 'b -> bool) -> bool\n(** [every2 xs ys p] returns true if predicate [p xi yi] is true for all pairs of elements up to the shorter length\n (i.e. [min (length xs) (length ys)])\n {[\n every2 [ 1; 2; 3 ] [ 0; 1 ] ( > ) = true;;\n every2 [] [ 1 ] (fun x y -> x > y) = true;;\n every2 [ 2; 3 ] [ 1 ] (fun x y -> x > y) = true;;\n every2 [ 0; 1 ] [ 5; 0 ] (fun x y -> x > y) = false\n ]} *)\n\nval some2U : 'a t -> 'b t -> (('a -> 'b -> bool)[@bs]) -> bool\n\nval some2 : 'a t -> 'b t -> ('a -> 'b -> bool) -> bool\n(** [some2 xs ys p] returns true if [p xi yi] is true for any pair of elements up to the shorter length (i.e.\n [min (length xs) (length ys)])\n\n {[\n some2 [ 0; 2 ] [ 1; 0; 3 ] ( > ) = true;;\n some2 [] [ 1 ] (fun x y -> x > y) = false;;\n some2 [ 2; 3 ] [ 1; 4 ] (fun x y -> x > y) = true\n ]} *)\n\nval cmpByLength : 'a t -> 'a t -> int\n(** [cmpByLength l1 l2]\n\n Compare two lists solely by length. Returns -1 if [length l1] is less than [length l2], 0 if [length l1] equals\n [length l2], and 1 if [length l1] is greater than [length l2].\n\n {[\n cmpByLength [ 1; 2 ] [ 3; 4; 5; 6 ] = -1;;\n cmpByLength [ 1; 2; 3 ] [ 4; 5; 6 ] = 0;;\n cmpByLength [ 1; 2; 3; 4 ] [ 5; 6 ] = 1\n ]} *)\n\nval cmpU : 'a t -> 'a t -> (('a -> 'a -> int)[@bs]) -> int\n\nval cmp : 'a t -> 'a t -> ('a -> 'a -> int) -> int\n(** Compare elements one by one [f x y]. [f] returns\n - a negative number if [x] is “less than” [y]\n - zero if [x] is “equal to” [y]\n - a positive number if [x] is “greater than” [y] The comparison returns the first non-zero result of [f], or zero if\n [f] returns zero for all [x] and [y]. If all items have compared equal, but [xs] is exhausted first, return -1.\n ([xs] is shorter) If all items have compared equal, but [ys] is exhausted first, return 1 ([xs] is longer)\n\n {[\n cmp [ 3 ] [ 3; 7 ] (fun a b -> compare a b)\n = -1 cmp [ 5; 3 ] [ 5 ] (fun a b -> compare a b)\n = 1 cmp [| 1; 3; 5 |] [| 1; 4; 2 |] (fun a b -> compare a b)\n = -1\n ;;\n\n cmp [| 1; 3; 5 |] [| 1; 2; 3 |] (fun a b -> compare a b) = 1;;\n cmp [| 1; 3; 5 |] [| 1; 3; 5 |] (fun a b -> compare a b) = 0\n ]}\n\n {b Attention}: The total ordering of List is different from Array, for Array, we compare the length first and, only\n if the lengths are equal, elements one by one. For lists, we just compare elements one by one *)\n\nval eqU : 'a t -> 'a t -> (('a -> 'a -> bool)[@bs]) -> bool\n\nval eq : 'a t -> 'a t -> ('a -> 'a -> bool) -> bool\n(** [eq xs ys eqElem] check equality of [xs] and [ys] using [eqElem] for equality on elements, where [eqElem] is a\n function that returns true if items [x] and [y] meet some criterion for equality, false otherwise. [eq] false if\n length of [xs] and [ys] are not the same.\n\n {[\n eq [ 1; 2; 3 ] [ 1; 2 ] ( = ) = false;;\n eq [ 1; 2 ] [ 1; 2 ] ( = ) = true;;\n eq [ 1; 2; 3 ] [ -1; -2; -3 ] (fun a b -> abs a = abs b) = true\n ]} *)\n\nval hasU : 'a t -> 'b -> (('a -> 'b -> bool)[@bs]) -> bool\n\nval has : 'a t -> 'b -> ('a -> 'b -> bool) -> bool\n(** [has xs eqFcn] returns true if the list contains at least one element for which [eqFcn x] returns true\n {[\n has [ 1; 2; 3 ] 2 ( = ) = true;;\n has [ 1; 2; 3 ] 4 ( = ) = false;;\n has [ -1; -2; -3 ] 2 (fun a b -> abs a = abs b) = true\n ]} *)\n\nval getByU : 'a t -> (('a -> bool)[@bs]) -> 'a option\n\nval getBy : 'a t -> ('a -> bool) -> 'a option\n(** [getBy xs p] returns [Some value] for the first value in [xs] that satisifies the predicate function [p]; returns\n [None] if no element satisifies the function.\n\n {[\n getBy [1;4;3;2] (fun x -> x mod 2 = 0) = Some 4\n getBy [15;13;11] (fun x -> x mod 2 = 0) = None\n ]} *)\n\nval keepU : 'a t -> (('a -> bool)[@bs]) -> 'a t\n\nval keep : 'a t -> ('a -> bool) -> 'a t\n(** [keep xs p] returns a list of all elements in [xs] which satisfy the predicate function [p]\n\n {[\n keep [ 1; 2; 3; 4 ] (fun x -> x mod 2 = 0) = [ 2; 4 ]\n ]} *)\n\nval keepWithIndexU : 'a t -> (('a -> int -> bool)[@bs]) -> 'a t\n\nval keepWithIndex : 'a t -> ('a -> int -> bool) -> 'a t\n(** [keepWithIndex xs p] returns a list of all elements in [xs] which satisfy the predicate function [p]\n\n {[\n keepWithIndex [ 1; 2; 3; 4 ] (fun _x i -> i mod 2 = 0) = [ 1; 3 ]\n ]} *)\n\nval keepMapU : 'a t -> (('a -> 'b option)[@bs]) -> 'b t\n\nval keepMap : 'a t -> ('a -> 'b option) -> 'b t\n(** [keepMap xs f] applies [f] to each element of [xs]. If [f xi] returns [Some value], then [value] is kept in the\n resulting list; if [f xi] returns [None], the element is not retained in the result.\n\n {[\n keepMap [ 1; 2; 3; 4 ] (fun x -> if x mod 2 = 0 then Some (-x) else None) = [ -2; -4 ]\n ]} *)\n\nval partitionU : 'a t -> (('a -> bool)[@bs]) -> 'a t * 'a t\n\nval partition : 'a t -> ('a -> bool) -> 'a t * 'a t\n(** [partition xs p] creates a pair of lists; the first list consists of all elements of [xs] that satisfy the predicate\n function [p]; the second list consists of all elements of [xs] that do not satisfy [p]\n\n {[\n partition [ 1; 2; 3; 4 ] (fun x -> x mod 2 = 0) = ([ 2; 4 ], [ 1; 3 ])\n ]} *)\n\nval unzip : ('a * 'b) t -> 'a t * 'b t\n(** [unzip xs] takes a list of pairs and creates a pair of lists. The first list contains all the first items of the\n pairs; the second list contains all the second items.\n\n {[\n unzip [ (1, 2); (3, 4) ] = ([ 1; 3 ], [ 2; 4 ]);;\n unzip [ (1, 2); (3, 4); (5, 6); (7, 8) ] = ([ 1; 3; 5; 7 ], [ 2; 4; 6; 8 ])\n ]} *)\n\nval getAssocU : ('a * 'c) t -> 'b -> (('a -> 'b -> bool)[@bs]) -> 'c option\n\nval getAssoc : ('a * 'c) t -> 'b -> ('a -> 'b -> bool) -> 'c option\n(** [getAssoc xs k eq]\n\n return the second element of a pair in [xs] where the first element equals [x] as per the predicate function [eq],\n or [None] if not found\n {[\n getAssoc [ 1, \"a\"; 2, \"b\"; 3, \"c\"] 2 (=) = Some \"b\"\n getAssoc [9, \"morning\"; 15, \"afternoon\"; 22, \"night\"] 3 (fun a b -> a mod 12 = b mod 12) = Some \"afternoon\"\n ]} *)\n\nval hasAssocU : ('a * 'c) t -> 'b -> (('a -> 'b -> bool)[@bs]) -> bool\n\nval hasAssoc : ('a * 'c) t -> 'b -> ('a -> 'b -> bool) -> bool\n(** [hasAssoc xs k eq] return true if there is a pair in [xs] where the first element equals [k] as per the predicate\n funtion [eq]\n {[\n hasAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 1 ( = ) = true;;\n hasAssoc [ (9, \"morning\"); (15, \"afternoon\"); (22, \"night\") ] 3 (fun a b -> a mod 12 = b mod 12) = true\n ]} *)\n\nval removeAssocU : ('a * 'c) t -> 'b -> (('a -> 'b -> bool)[@bs]) -> ('a * 'c) t\n\nval removeAssoc : ('a * 'c) t -> 'b -> ('a -> 'b -> bool) -> ('a * 'c) t\n(** [removeAssoc xs k eq] Return a list after removing the first pair whose first value is [k] per the equality\n predicate [eq]; if not found, return a new list identical to [xs].\n {[\n removeAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 1 ( = )\n = [ (2, \"b\"); (3, \"c\") ] removeAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 99 ( = )\n = [ (1, \"a\"); (2, \"b\"); (3, \"c\") ]\n ]} *)\n\nval setAssocU : ('a * 'c) t -> 'a -> 'c -> (('a -> 'a -> bool)[@bs]) -> ('a * 'c) t\n\nval setAssoc : ('a * 'c) t -> 'a -> 'c -> ('a -> 'a -> bool) -> ('a * 'c) t\n(** [setAssoc xs k v eq] if [k] exists in [xs] by satisfying the [eq] predicate, return a new list with the key and\n value replaced by the new [k] and [v]; otherwise, return a new list with the pair [k, v] added to the head of [xs].\n {[\n setAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 2 \"x\" ( = ) = [ (1, \"a\"); (2, \"x\"); (3, \"c\") ];;\n\n setAssoc [ (1, \"a\"); (3, \"c\") ] 2 \"b\" ( = )\n = [ (2, \"b\"); (1, \"a\"); (3, \"c\") ]\n setAssoc\n [ (9, \"morning\"); (3, \"morning?!\"); (22, \"night\") ]\n 15 \"afternoon\"\n (fun a b -> a mod 12 = b mod 12)\n = [ (9, \"morning\"); (15, \"afternoon\"); (22, \"night\") ]\n ]}\n\n Note carefully the last example! Since [15 mod 12] equals [3 mod 12], {i both} the key and value are replaced in the\n list. *)\n\nval sortU : 'a t -> (('a -> 'a -> int)[@bs]) -> 'a t\n\nval sort : 'a t -> ('a -> 'a -> int) -> 'a t\n(** [sort xs] Returns a sorted list.\n {[\n sort [ 5; 4; 9; 3; 7 ] (fun a b -> a - b) = [ 3; 4; 5; 7; 9 ]\n ]} *)\n"
},
{
"path": "packages/Belt/src/Belt_Map.ml",
"content": "module Int = Belt_MapInt\n(** specalized when key type is [int], more efficient than the generic type *)\n\nmodule String = Belt_MapString\n(** specalized when key type is [string], more efficient than the generic type *)\n\nmodule Dict = Belt_MapDict\n(** seprate function from data, a more verboe but slightly more efficient *)\n\ntype ('key, 'id) id = ('key, 'id) Belt_Id.comparable\ntype ('key, 'id) cmp = ('key, 'id) Belt_Id.cmp\ntype ('k, 'v, 'id) t = { cmp : ('k, 'id) cmp; data : ('k, 'v, 'id) Dict.t }\n\nmodule S = struct\n include (\n struct\n let t : cmp:('k, 'id) cmp -> data:('k, 'v, 'id) Dict.t -> ('k, 'v, 'id) t = fun ~cmp ~data -> { cmp; data }\n let cmp : ('k, 'v, 'id) t -> ('k, 'id) cmp = fun o -> o.cmp\n let data : ('k, 'v, 'id) t -> ('k, 'v, 'id) Dict.t = fun o -> o.data\n end :\n sig\n val t : cmp:('k, 'id) cmp -> data:('k, 'v, 'id) Dict.t -> ('k, 'v, 'id) t\n val cmp : ('k, 'v, 'id) t -> ('k, 'id) cmp\n val data : ('k, 'v, 'id) t -> ('k, 'v, 'id) Dict.t\n end)\nend\n\nlet fromArray (type k idx) data ~(id : (k, idx) id) =\n let module M = (val id) in\n let cmp = M.cmp in\n S.t ~cmp ~data:(Dict.fromArray ~cmp data)\n\nlet remove m x =\n let cmp, odata =\n let open S in\n (cmp m, data m)\n in\n let newData = Dict.remove odata x ~cmp in\n if newData == odata then m else S.t ~cmp ~data:newData\n\nlet removeMany m x =\n let cmp, odata = (S.cmp m, S.data m) in\n let newData = Dict.removeMany odata x ~cmp in\n S.t ~cmp ~data:newData\n\nlet set m key d =\n let cmp = S.cmp m in\n S.t ~cmp ~data:(Dict.set ~cmp (S.data m) key d)\n\nlet mergeMany m e =\n let cmp = S.cmp m in\n S.t ~cmp ~data:(Dict.mergeMany ~cmp (S.data m) e)\n\nlet updateU m key f =\n let cmp = S.cmp m in\n S.t ~cmp ~data:(Dict.updateU ~cmp (S.data m) key f)\n\nlet update m key f = updateU m key (fun a -> f a)\n\nlet split m x =\n let cmp = S.cmp m in\n let (l, r), b = Dict.split ~cmp (S.data m) x in\n ((S.t ~cmp ~data:l, S.t ~cmp ~data:r), b)\n\nlet mergeU s1 s2 f =\n let cmp = S.cmp s1 in\n S.t ~cmp ~data:(Dict.mergeU ~cmp (S.data s1) (S.data s2) f)\n\nlet merge s1 s2 f = mergeU s1 s2 (fun a b c -> f a b c)\n\nlet make (type key idx) ~(id : (key, idx) id) =\n let module M = (val id) in\n S.t ~cmp:M.cmp ~data:Dict.empty\n\nlet isEmpty map = Dict.isEmpty (S.data map)\nlet forEachU m f = Dict.forEachU (S.data m) f\nlet forEach m f = forEachU m (fun a b -> f a b)\nlet reduceU m acc f = Dict.reduceU (S.data m) acc f\nlet reduce m acc f = reduceU m acc (fun a b c -> f a b c)\nlet everyU m f = Dict.everyU (S.data m) f\nlet every m f = everyU m (fun a b -> f a b)\nlet someU m f = Dict.someU (S.data m) f\nlet some m f = someU m (fun a b -> f a b)\nlet keepU m f = S.t ~cmp:(S.cmp m) ~data:(Dict.keepU (S.data m) f)\nlet keep m f = keepU m (fun a b -> f a b)\n\nlet partitionU m p =\n let cmp = S.cmp m in\n let l, r = Dict.partitionU (S.data m) p in\n (S.t ~cmp ~data:l, S.t ~cmp ~data:r)\n\nlet partition m p = partitionU m (fun a b -> p a b)\nlet mapU m f = S.t ~cmp:(S.cmp m) ~data:(Dict.mapU (S.data m) f)\nlet map m f = mapU m (fun a -> f a)\nlet mapWithKeyU m f = S.t ~cmp:(S.cmp m) ~data:(Dict.mapWithKeyU (S.data m) f)\nlet mapWithKey m f = mapWithKeyU m (fun a b -> f a b)\nlet size map = Dict.size (S.data map)\nlet toList map = Dict.toList (S.data map)\nlet toArray m = Dict.toArray (S.data m)\nlet keysToArray m = Dict.keysToArray (S.data m)\nlet valuesToArray m = Dict.valuesToArray (S.data m)\nlet minKey m = Dict.minKey (S.data m)\nlet minKeyUndefined m = Dict.minKeyUndefined (S.data m)\nlet maxKey m = Dict.maxKey (S.data m)\nlet maxKeyUndefined m = Dict.maxKeyUndefined (S.data m)\nlet minimum m = Dict.minimum (S.data m)\nlet minUndefined m = Dict.minUndefined (S.data m)\nlet maximum m = Dict.maximum (S.data m)\nlet maxUndefined m = Dict.maxUndefined (S.data m)\nlet get map x = Dict.get ~cmp:(S.cmp map) (S.data map) x\nlet getUndefined map x = Dict.getUndefined ~cmp:(S.cmp map) (S.data map) x\nlet getWithDefault map x def = Dict.getWithDefault ~cmp:(S.cmp map) (S.data map) x def\nlet getExn map x = Dict.getExn ~cmp:(S.cmp map) (S.data map) x\nlet has map x = Dict.has ~cmp:(S.cmp map) (S.data map) x\nlet checkInvariantInternal m = Dict.checkInvariantInternal (S.data m)\nlet eqU m1 m2 veq = Dict.eqU ~kcmp:(S.cmp m1) ~veq (S.data m1) (S.data m2)\nlet eq m1 m2 veq = eqU m1 m2 (fun a b -> veq a b)\nlet cmpU m1 m2 vcmp = Dict.cmpU ~kcmp:(S.cmp m1) ~vcmp (S.data m1) (S.data m2)\nlet cmp m1 m2 vcmp = cmpU m1 m2 (fun a b -> vcmp a b)\nlet getData = S.data\n\nlet getId (type key identity) (m : (key, _, identity) t) : (key, identity) id =\n let module T = struct\n type nonrec identity = identity\n type nonrec t = key\n\n let cmp = S.cmp m\n end in\n (module T)\n\nlet packIdData (type key idx) ~(id : (key, idx) id) ~data =\n let module M = (val id) in\n S.t ~cmp:M.cmp ~data\n\nlet findFirstByU m f = Dict.findFirstByU m.data f\nlet findFirstBy m f = findFirstByU m (fun a b -> f a b)\n"
},
{
"path": "packages/Belt/src/Belt_Map.mli",
"content": "(***********************************************************************)\n(* *)\n(* OCaml *)\n(* *)\n(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)\n(* *)\n(* Copyright 1996 Institut National de Recherche en Informatique et *)\n(* en Automatique. All rights reserved. This file is distributed *)\n(* under the terms of the GNU Library General Public License, with *)\n(* the special exception on linking described in file ../LICENSE. *)\n(* *)\n(* Adapted by authors of ReScript without using functors *)\n(***********************************************************************)\n\n(** A {i immutable} sorted map module which allows customize {i compare} behavior.\n\n The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the\n size of the map.\n\n For more info on this module's usage of identity, `make` and others, please see the top level documentation of Belt,\n {b A special encoding for collection safety}.\n\n Example usage:\n\n {[\n module PairComparator = Belt.Id.MakeComparable (struct\n type t = int * int\n\n let cmp (a0, a1) (b0, b1) = match Pervasives.compare a0 b0 with 0 -> Pervasives.compare a1 b1 | c -> c\n end)\n\n let myMap = Belt.Map.make ~id:(module PairComparator)\n let myMap2 = Belt.Map.set myMap (1, 2) \"myValue\"\n ]}\n\n The API documentation below will assume a predeclared comparator module for integers, IntCmp *)\n\nmodule Int = Belt_MapInt\n(** Specalized when key type is [int], more efficient than the generic type, its compare behavior is fixed using the\n built-in comparison *)\n\nmodule String = Belt_MapString\n(** specalized when key type is [string], more efficient than the generic type, its compare behavior is fixed using the\n built-in comparison *)\n\nmodule Dict = Belt_MapDict\n(** This module seprate identity from data, it is a bit more verboe but slightly more efficient due to the fact that\n there is no need to pack identity and data back after each operation\n\n {b Advanced usage only} *)\n\ntype ('key, 'value, 'identity) t\n(** [('key, 'identity) t]\n\n ['key] is the field type\n\n ['value] is the element type\n\n ['identity] the identity of the collection *)\n\ntype ('key, 'id) id = ('key, 'id) Belt_Id.comparable\n(** The identity needed for making an empty map*)\n\n(*\n How we retain soundness:\n The only way to create a value of type [_ t] from scratch\n is through [empty] which requires [_ Belt_Id.t]\n The only way to create [_ Belt_Id.t] is using [Belt_Id.Make] which\n will create a fresh type [id] per module\n\n Generic operations over tree without [cmp] are still exported\n (for efficient reasons) so that [data] does not need be boxed and unboxed.\n\n The soundness is guaranteed in two aspects:\n When create a value of [_ t] it needs both [_ Belt_Id.t] and [_ t0].\n [_ Belt_Id.t] is an abstract type. Note [add0] requires [_ Belt_Id.cmp] which\n is also an abstract type which can only come from [_ Belt_Id.t]\n\n When destructing a value of [_ t], the ['id] parameter is threaded.\n\n*)\n\n(* should not export [Belt_Id.compare].\n should only export [Belt_Id.t] or [Belt_Id.cmp] instead *)\n\nval make : id:('k, 'id) id -> ('k, 'v, 'id) t\n(** [make ~id] creates a new map by taking in the comparator\n {[\n let m = Belt.Map.make ~id:(module IntCmp)\n ]} *)\n\nval isEmpty : _ t -> bool\n(** [isEmpty m] checks whether a map m is empty\n {[\n isEmpty (fromArray [| (1, \"1\") |] ~id:(module IntCmp)) = false\n ]} *)\n\nval has : ('k, 'v, 'id) t -> 'k -> bool\n(** [has m k] checks whether m has the key k\n {[\n has (fromArray [| (1, \"1\") |] ~id:(module IntCmp)) 1 = true\n ]} *)\n\nval cmpU : ('k, 'v, 'id) t -> ('k, 'v, 'id) t -> (('v -> 'v -> int)[@u]) -> int\n\nval cmp : ('k, 'v, 'id) t -> ('k, 'v, 'id) t -> ('v -> 'v -> int) -> int\n(** [cmp m0 m1 vcmp]\n\n Total ordering of map given total ordering of value function.\n\n It will compare size first and each element following the order one by one. *)\n\nval eqU : ('k, 'v, 'id) t -> ('k, 'v, 'id) t -> (('v -> 'v -> bool)[@u]) -> bool\n\nval eq : ('k, 'v, 'id) t -> ('k, 'v, 'id) t -> ('v -> 'v -> bool) -> bool\n(** [eq m1 m2 veq] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with\n equal data. [veq] is the equality predicate used to compare the data associated with the keys. *)\n\nval findFirstByU : ('k, 'v, 'id) t -> (('k -> 'v -> bool)[@u]) -> ('k * 'v) option\n\nval findFirstBy : ('k, 'v, 'id) t -> ('k -> 'v -> bool) -> ('k * 'v) option\n(** [findFirstBy m p] uses funcion [f] to find the first key value pair to match predicate [p].\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| (4, \"4\"); (1, \"1\"); (2, \"2,\" 3 \"\") |];;\n\n findFirstBy s0 (fun k v -> k = 4) = option (4, \"4\")\n ]} *)\n\nval forEachU : ('k, 'v, 'id) t -> (('k -> 'v -> unit)[@u]) -> unit\n\nval forEach : ('k, 'v, 'id) t -> ('k -> 'v -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the 'k as first argument, and the associated\n value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the\n type of the keys.\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| (4, \"4\"); (1, \"1\"); (2, \"2,\" 3 \"\") |]\n let acc = ref [];;\n\n forEach s0 (fun k v -> acc := (k, v) :: !acc);;\n !acc = [ (4, \"4\"); (3, \"3\"); (2, \"2\"); (1, \"1\") ]\n ]} *)\n\nval reduceU : ('k, 'v, 'id) t -> 'acc -> (('acc -> 'k -> 'v -> 'acc)[@u]) -> 'acc\n\nval reduce : ('k, 'v, 'id) t -> 'acc -> ('acc -> 'k -> 'v -> 'acc) -> 'acc\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data.\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| (4, \"4\"); (1, \"1\"); (2, \"2,\" 3 \"\") |];;\n\n reduce s0 [] (fun acc k v -> (k, v) acc) = [ (4, \"4\"); (3, \"3\"); (2, \"2\"); (1, \"1\") ]\n ]} *)\n\nval everyU : ('k, 'v, 'id) t -> (('k -> 'v -> bool)[@u]) -> bool\n\nval every : ('k, 'v, 'id) t -> ('k -> 'v -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. Order unspecified *)\n\nval someU : ('k, 'v, 'id) t -> (('k -> 'v -> bool)[@u]) -> bool\n\nval some : ('k, 'v, 'id) t -> ('k -> 'v -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. Order unspecified *)\n\nval size : ('k, 'v, 'id) t -> int\n(** [size s]\n\n {[\n size (fromArray [ (2, \"2\"); (2, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) = 2\n ]} *)\n\nval toArray : ('k, 'v, 'id) t -> ('k * 'v) array\n(** [toArray s]\n\n {[\n toArray (fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) = [ (1, \"1\"); (2, \"2\"); (3, \"3\") ]\n ]} *)\n\nval toList : ('k, 'v, 'id) t -> ('k * 'v) list\n(** In increasing order\n\n {b See} {!toArray} *)\n\nval fromArray : ('k * 'v) array -> id:('k, 'id) id -> ('k, 'v, 'id) t\n(** [fromArray kvs ~id]\n {[\n toArray (fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) = [ (1, \"1\"); (2, \"2\"); (3, \"3\") ]\n ]} *)\n\nval keysToArray : ('k, 'v, 'id) t -> 'k array\n(** [keysToArray s]\n {[\n keysToArray (fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) = [| 1; 2; 3 |]\n ]} *)\n\nval valuesToArray : ('k, 'v, 'id) t -> 'v array\n(** [valuesToArray s]\n {[\n valuesToArray (fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) = [| \"1\"; \"2\"; \"3\" |]\n ]} *)\n\nval minKey : ('k, _, _) t -> 'k option\n(** [minKey s]\n @return the minimum key, None if not exist *)\n\nval minKeyUndefined : ('k, _, _) t -> 'k Js.undefined\n(** {b See} {!minKey}*)\n\nval maxKey : ('k, _, _) t -> 'k option\n(** [maxKey s]\n @return the maximum key, None if not exist *)\n\nval maxKeyUndefined : ('k, _, _) t -> 'k Js.undefined\n(** {b See} {!maxKey} *)\n\nval minimum : ('k, 'v, _) t -> ('k * 'v) option\n(** [minimum s]\n @return the minimum key value pair, None if not exist *)\n\nval minUndefined : ('k, 'v, _) t -> ('k * 'v) Js.undefined\n(** {b See} {!minimum} *)\n\nval maximum : ('k, 'v, _) t -> ('k * 'v) option\n(** [maximum s]\n @return the maximum key value pair, None if not exist *)\n\nval maxUndefined : ('k, 'v, _) t -> ('k * 'v) Js.undefined\n(** {b See} {!maximum} *)\n\nval get : ('k, 'v, 'id) t -> 'k -> 'v option\n(** [get s k]\n\n {[\n get (fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) 2 = Some \"2\";;\n get (fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)) 2 = None\n ]} *)\n\nval getUndefined : ('k, 'v, 'id) t -> 'k -> 'v Js.undefined\n(** {b See} {!get}\n\n @return [undefined] when not found *)\n\nval getWithDefault : ('k, 'v, 'id) t -> 'k -> 'v -> 'v\n(** [getWithDefault s k default]\n\n {b See} {!get}\n\n @return [default] when [k] is not found *)\n\nval getExn : ('k, 'v, 'id) t -> 'k -> 'v\n(** [getExn s k]\n\n {b See} {!getExn}\n\n {b raise} when [k] not exist *)\n\n(****************************************************************************)\n\nval remove : ('k, 'v, 'id) t -> 'k -> ('k, 'v, 'id) t\n(** [remove m x] when [x] is not in [m], [m] is returned reference unchanged.\n\n {[\n let s0 = fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)\n let s1 = remove s0 1\n let s2 = remove s1 1;;\n\n s1 == s2;;\n keysToArray s1 = [| 2; 3 |]\n ]} *)\n\nval removeMany : ('k, 'v, 'id) t -> 'k array -> ('k, 'v, 'id) t\n(** [removeMany s xs]\n\n Removing each of [xs] to [s], note unlike {!remove}, the reference of return value might be changed even if none in\n [xs] exists [s] *)\n\nval set : ('k, 'v, 'id) t -> 'k -> 'v -> ('k, 'v, 'id) t\n(** [set m x y ] returns a map containing the same bindings as [m], with a new binding of [x] to [y]. If [x] was already\n bound in [m], its previous binding disappears.\n\n {[\n let s0 = fromArray [ (2, \"2\"); (1, \"1\"); (3, \"3\") ] ~id:(module IntCmp)\n let s1 = set s0 2 \"3\";;\n\n valuesToArray s1 = [ \"1\"; \"3\"; \"3\" ]\n ]} *)\n\nval updateU : ('k, 'v, 'id) t -> 'k -> (('v option -> 'v option)[@u]) -> ('k, 'v, 'id) t\n\nval update : ('k, 'v, 'id) t -> 'k -> ('v option -> 'v option) -> ('k, 'v, 'id) t\n(** [update m x f] returns a map containing the same bindings as [m], except for the binding of [x]. Depending on the\n value of [y] where [y] is [f (get x m)], the binding of [x] is added, removed or updated. If [y] is [None], the\n binding is removed if it exists; otherwise, if [y] is [Some z] then [x] is associated to [z] in the resulting map.\n*)\n\nval mergeMany : ('k, 'v, 'id) t -> ('k * 'v) array -> ('k, 'v, 'id) t\n(** [mergeMany s xs]\n\n Add each of [xs] to [s], note unlike {!set}, the reference of return value might be changed even if all values in\n [xs] exist [s] *)\n\nval mergeU :\n ('k, 'v, 'id) t -> ('k, 'v2, 'id) t -> (('k -> 'v option -> 'v2 option -> 'v3 option)[@u]) -> ('k, 'v3, 'id) t\n\nval merge : ('k, 'v, 'id) t -> ('k, 'v2, 'id) t -> ('k -> 'v option -> 'v2 option -> 'v3 option) -> ('k, 'v3, 'id) t\n(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such\n binding, and the corresponding value, is determined with the function [f]. *)\n\nval keepU : ('k, 'v, 'id) t -> (('k -> 'v -> bool)[@u]) -> ('k, 'v, 'id) t\n\nval keep : ('k, 'v, 'id) t -> ('k -> 'v -> bool) -> ('k, 'v, 'id) t\n(** [keep m p] returns the map with all the bindings in [m] that satisfy predicate [p]. *)\n\nval partitionU : ('k, 'v, 'id) t -> (('k -> 'v -> bool)[@u]) -> ('k, 'v, 'id) t * ('k, 'v, 'id) t\n\nval partition : ('k, 'v, 'id) t -> ('k -> 'v -> bool) -> ('k, 'v, 'id) t * ('k, 'v, 'id) t\n(** [partition m p] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the\n predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *)\n\nval split : ('k, 'v, 'id) t -> 'k -> (('k, 'v, 'id) t * ('k, 'v, 'id) t) * 'v option\n(** [split x m] returns a tuple [(l r), data], where [l] is the map with all the bindings of [m] whose 'k is strictly\n less than [x]; [r] is the map with all the bindings of [m] whose 'k is strictly greater than [x]; [data] is [None]\n if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *)\n\nval mapU : ('k, 'v, 'id) t -> (('v -> 'v2)[@u]) -> ('k, 'v2, 'id) t\n\nval map : ('k, 'v, 'id) t -> ('v -> 'v2) -> ('k, 'v2, 'id) t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : ('k, 'v, 'id) t -> (('k -> 'v -> 'v2)[@u]) -> ('k, 'v2, 'id) t\n\nval mapWithKey : ('k, 'v, 'id) t -> ('k -> 'v -> 'v2) -> ('k, 'v2, 'id) t\n(** [mapWithKey m f]\n\n The same as {!map} except that [f] is supplied with one more argument: the key *)\n\nval getData : ('k, 'v, 'id) t -> ('k, 'v, 'id) Belt_MapDict.t\n(** [getData s0]\n\n {b Advanced usage only}\n\n @return\n the raw data (detached from comparator), but its type is still manifested, so that user can pass identity directly\n without boxing *)\n\nval getId : ('k, 'v, 'id) t -> ('k, 'id) id\n(** [getId s0]\n\n {b Advanced usage only}\n\n @return the identity of [s0] *)\n\nval packIdData : id:('k, 'id) id -> data:('k, 'v, 'id) Belt_MapDict.t -> ('k, 'v, 'id) t\n(** [packIdData ~id ~data]\n\n {b Advanced usage only}\n\n @return the packed collection *)\n\n(**/**)\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\n(**/**)\n"
},
{
"path": "packages/Belt/src/Belt_MapDict.ml",
"content": "module N = Belt_internalAVLtree\nmodule A = Belt_Array\n\ntype ('key, 'a, 'id) t = ('key, 'a) N.t\ntype ('key, 'id) cmp = ('key, 'id) Belt_Id.cmp\n\nlet empty = N.empty\nlet fromArray = N.fromArray\nlet isEmpty = N.isEmpty\nlet cmp = N.cmp\nlet cmpU = N.cmpU\nlet eq = N.eq\nlet eqU = N.eqU\nlet has = N.has\nlet forEach = N.forEach\nlet forEachU = N.forEachU\nlet reduce = N.reduce\nlet reduceU = N.reduceU\nlet every = N.every\nlet everyU = N.everyU\nlet some = N.some\nlet someU = N.someU\nlet size = N.size\nlet toList = N.toList\nlet toArray = N.toArray\nlet keysToArray = N.keysToArray\nlet valuesToArray = N.valuesToArray\nlet minimum = N.minimum\nlet maximum = N.maximum\nlet minKey = N.minKey\nlet maxKey = N.maxKey\nlet minKeyUndefined = N.minKeyUndefined\nlet maxKeyUndefined = N.maxKeyUndefined\nlet minUndefined = N.minUndefined\nlet maxUndefined = N.maxUndefined\nlet get = N.get\nlet getUndefined = N.getUndefined\nlet getWithDefault = N.getWithDefault\nlet getExn = N.getExn\nlet mapWithKey = N.mapWithKey\nlet mapWithKeyU = N.mapWithKeyU\nlet mapU = N.mapU\nlet map = N.map\nlet keep = N.keepShared\nlet keepU = N.keepSharedU\nlet partitionU = N.partitionSharedU\nlet partition = N.partitionShared\nlet checkInvariantInternal = N.checkInvariantInternal\n\nlet rec set (t : _ t) newK newD ~cmp =\n match N.toOpt t with\n | None -> N.singleton newK newD\n | Some n ->\n let k = N.key n in\n let c = (Belt_Id.getCmpInternal cmp) newK k in\n if c = 0 then N.return (N.updateValue n newD)\n else\n let l, r, v = (N.left n, N.right n, N.value n) in\n if c < 0 then N.bal (set ~cmp l newK newD) k v r else N.bal l k v (set ~cmp r newK newD)\n\nlet rec updateU (t : _ t) newK f ~cmp : _ t =\n match N.toOpt t with\n | None -> ( match f None with None -> t | Some newD -> N.singleton newK newD)\n | Some n ->\n let k = N.key n in\n let c = (Belt_Id.getCmpInternal cmp) newK k in\n if c = 0 then\n match f (Some (N.value n)) with\n | None -> (\n let l, r = (N.left n, N.right n) in\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r)\n | Some newD -> N.return (N.updateValue n newD)\n else\n let l, r, v = (N.left n, N.right n, N.value n) in\n if c < 0 then\n let ll = updateU ~cmp l newK f in\n if l == ll then t else N.bal ll k v r\n else\n let rr = updateU ~cmp r newK f in\n if r == rr then t else N.bal l k v rr\n\nlet update t newK f ~cmp = updateU t newK (fun a -> f a) ~cmp\n\nlet rec remove t x ~cmp =\n match N.toOpt t with\n | None -> t\n | Some n ->\n let l, v, d, r =\n let open N in\n (left n, key n, value n, right n)\n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r\n else if c < 0 then\n let ll = remove l x ~cmp in\n if ll == l then t else N.bal ll v d r\n else\n let rr = remove r x ~cmp in\n if rr == r then t else N.bal l v d rr\n\nlet mergeMany h arr ~cmp =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key, value = A.getUnsafe arr i in\n v := set !v ~cmp key value\n done;\n !v\n\nlet rec splitAuxPivot n x pres ~cmp =\n let l, v, d, r =\n let open N in\n (left n, key n, value n, right n)\n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then (\n pres := Some d;\n (l, r))\n else if c < 0 then\n match N.toOpt l with\n | None ->\n let open N in\n (empty, return n)\n | Some l ->\n let ll, rl = splitAuxPivot ~cmp l x pres in\n (ll, N.join rl v d r)\n else\n match N.toOpt r with\n | None ->\n let open N in\n (return n, empty)\n | Some r ->\n let lr, rr = splitAuxPivot ~cmp r x pres in\n (N.join l v d lr, rr)\n\nlet split n x ~cmp =\n match N.toOpt n with\n | None ->\n ( (let open N in\n (empty, empty)),\n None )\n | Some n ->\n let pres = ref None in\n let v = splitAuxPivot ~cmp n x pres in\n (v, !pres)\n\nlet rec mergeU s1 s2 f ~cmp =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, None -> N.empty\n | Some _, None -> N.keepMapU s1 (fun k v -> f k (Some v) None)\n | None, Some _ -> N.keepMapU s2 (fun k v -> f k None (Some v))\n | Some s1n, Some s2n ->\n if N.height s1n >= N.height s2n then\n let l1, v1, d1, r1 =\n let open N in\n (left s1n, key s1n, value s1n, right s1n)\n in\n let d2 = ref None in\n let l2, r2 = splitAuxPivot ~cmp s2n v1 d2 in\n let d2 = !d2 in\n let newLeft = mergeU ~cmp l1 l2 f in\n let newD = f v1 (Some d1) d2 in\n let newRight = mergeU ~cmp r1 r2 f in\n N.concatOrJoin newLeft v1 newD newRight\n else\n let l2, v2, d2, r2 =\n let open N in\n (left s2n, key s2n, value s2n, right s2n)\n in\n let d1 = ref None in\n let l1, r1 = splitAuxPivot ~cmp s1n v2 d1 in\n let d1 = !d1 in\n let newLeft = mergeU ~cmp l1 l2 f in\n let newD = f v2 d1 (Some d2) in\n let newRight = mergeU ~cmp r1 r2 f in\n N.concatOrJoin newLeft v2 newD newRight\n\nlet merge s1 s2 f ~cmp = mergeU s1 s2 (fun a b c -> f a b c) ~cmp\n\nlet removeMany t keys ~cmp =\n let len = A.length keys in\n let rec loop current i = if i < len then loop (remove current (A.getUnsafe keys i) ~cmp) (i + 1) else current in\n loop t 0\n\nlet findFirstByU = N.findFirstByU\nlet findFirstBy = N.findFirstBy\n"
},
{
"path": "packages/Belt/src/Belt_MapDict.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\ntype ('key, 'value, 'id) t\ntype ('key, 'id) cmp = ('key, 'id) Belt_Id.cmp\n\nval empty : ('k, 'v, 'id) t\nval isEmpty : ('k, 'v, 'id) t -> bool\nval has : ('k, 'a, 'id) t -> 'k -> cmp:('k, 'id) cmp -> bool\nval cmpU : ('k, 'v, 'id) t -> ('k, 'v, 'id) t -> kcmp:('k, 'id) cmp -> vcmp:(('v -> 'v -> int)[@u]) -> int\nval cmp : ('k, 'v, 'id) t -> ('k, 'v, 'id) t -> kcmp:('k, 'id) cmp -> vcmp:('v -> 'v -> int) -> int\nval eqU : ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> kcmp:('k, 'id) cmp -> veq:(('a -> 'a -> bool)[@u]) -> bool\n\nval eq : ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> kcmp:('k, 'id) cmp -> veq:('a -> 'a -> bool) -> bool\n(** [eq m1 m2 cmp] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with\n equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *)\n\nval findFirstByU : ('k, 'v, 'id) t -> (('k -> 'v -> bool)[@u]) -> ('k * 'v) option\n\nval findFirstBy : ('k, 'v, 'id) t -> ('k -> 'v -> bool) -> ('k * 'v) option\n(** [findFirstBy m p] uses funcion [f] to find the first key value pair to match predicate [p].\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| (4, \"4\"); (1, \"1\"); (2, \"2,\" 3 \"\") |];;\n\n findFirstBy s0 (fun k v -> k = 4) = option (4, \"4\")\n ]} *)\n\nval forEachU : ('k, 'a, 'id) t -> (('k -> 'a -> unit)[@u]) -> unit\n\nval forEach : ('k, 'a, 'id) t -> ('k -> 'a -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated\n value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the\n type of the keys. *)\n\nval reduceU : ('k, 'a, 'id) t -> 'b -> (('b -> 'k -> 'a -> 'b)[@u]) -> 'b\n\nval reduce : ('k, 'a, 'id) t -> 'b -> ('b -> 'k -> 'a -> 'b) -> 'b\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data. *)\n\nval everyU : ('k, 'a, 'id) t -> (('k -> 'a -> bool)[@u]) -> bool\n\nval every : ('k, 'a, 'id) t -> ('k -> 'a -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. Order unspecified *)\n\nval someU : ('k, 'a, 'id) t -> (('k -> 'a -> bool)[@u]) -> bool\n\nval some : ('k, 'a, 'id) t -> ('k -> 'a -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. Order unspecified *)\n\nval size : ('k, 'a, 'id) t -> int\n\nval toList : ('k, 'a, 'id) t -> ('k * 'a) list\n(** In increasing order. *)\n\nval toArray : ('k, 'a, 'id) t -> ('k * 'a) array\nval fromArray : ('k * 'a) array -> cmp:('k, 'id) cmp -> ('k, 'a, 'id) t\nval keysToArray : ('k, 'a, 'id) t -> 'k array\nval valuesToArray : ('k, 'a, 'id) t -> 'a array\nval minKey : ('k, _, _) t -> 'k option\nval minKeyUndefined : ('k, _, _) t -> 'k Js.undefined\nval maxKey : ('k, _, _) t -> 'k option\nval maxKeyUndefined : ('k, _, _) t -> 'k Js.undefined\nval minimum : ('k, 'a, _) t -> ('k * 'a) option\nval minUndefined : ('k, 'a, _) t -> ('k * 'a) Js.undefined\nval maximum : ('k, 'a, _) t -> ('k * 'a) option\nval maxUndefined : ('k, 'a, _) t -> ('k * 'a) Js.undefined\nval get : ('k, 'a, 'id) t -> 'k -> cmp:('k, 'id) cmp -> 'a option\nval getUndefined : ('k, 'a, 'id) t -> 'k -> cmp:('k, 'id) cmp -> 'a Js.undefined\nval getWithDefault : ('k, 'a, 'id) t -> 'k -> 'a -> cmp:('k, 'id) cmp -> 'a\nval getExn : ('k, 'a, 'id) t -> 'k -> cmp:('k, 'id) cmp -> 'a\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\nval remove : ('a, 'b, 'id) t -> 'a -> cmp:('a, 'id) cmp -> ('a, 'b, 'id) t\n(** [remove m x] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map.\n*)\n\nval removeMany : ('a, 'b, 'id) t -> 'a array -> cmp:('a, 'id) cmp -> ('a, 'b, 'id) t\n\nval set : ('a, 'b, 'id) t -> 'a -> 'b -> cmp:('a, 'id) cmp -> ('a, 'b, 'id) t\n(** [set m x y] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already\n bound in [m], its previous binding disappears. *)\n\nval updateU : ('a, 'b, 'id) t -> 'a -> (('b option -> 'b option)[@u]) -> cmp:('a, 'id) cmp -> ('a, 'b, 'id) t\nval update : ('a, 'b, 'id) t -> 'a -> ('b option -> 'b option) -> cmp:('a, 'id) cmp -> ('a, 'b, 'id) t\n\nval mergeU :\n ('a, 'b, 'id) t ->\n ('a, 'c, 'id) t ->\n (('a -> 'b option -> 'c option -> 'd option)[@u]) ->\n cmp:('a, 'id) cmp ->\n ('a, 'd, 'id) t\n\nval merge :\n ('a, 'b, 'id) t ->\n ('a, 'c, 'id) t ->\n ('a -> 'b option -> 'c option -> 'd option) ->\n cmp:('a, 'id) cmp ->\n ('a, 'd, 'id) t\n(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such\n binding, and the corresponding value, is determined with the function [f]. *)\n\nval mergeMany : ('a, 'b, 'id) t -> ('a * 'b) array -> cmp:('a, 'id) cmp -> ('a, 'b, 'id) t\nval keepU : ('k, 'a, 'id) t -> (('k -> 'a -> bool)[@u]) -> ('k, 'a, 'id) t\n\nval keep : ('k, 'a, 'id) t -> ('k -> 'a -> bool) -> ('k, 'a, 'id) t\n(** [keep m p] returns the map with all the bindings in [m] that satisfy predicate [p]. *)\n\nval partitionU : ('k, 'a, 'id) t -> (('k -> 'a -> bool)[@u]) -> ('k, 'a, 'id) t * ('k, 'a, 'id) t\n\nval partition : ('k, 'a, 'id) t -> ('k -> 'a -> bool) -> ('k, 'a, 'id) t * ('k, 'a, 'id) t\n(** [partition m p] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the\n predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *)\n\nval split : ('a, 'b, 'id) t -> 'a -> cmp:('a, 'id) cmp -> (('a, 'b, 'id) t * ('a, 'b, 'id) t) * 'b option\n(** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly\n less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None]\n if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *)\n\nval mapU : ('k, 'a, 'id) t -> (('a -> 'b)[@u]) -> ('k, 'b, 'id) t\n\nval map : ('k, 'a, 'id) t -> ('a -> 'b) -> ('k, 'b, 'id) t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : ('k, 'a, 'id) t -> (('k -> 'a -> 'b)[@u]) -> ('k, 'b, 'id) t\nval mapWithKey : ('k, 'a, 'id) t -> ('k -> 'a -> 'b) -> ('k, 'b, 'id) t\n"
},
{
"path": "packages/Belt/src/Belt_MapInt.ml",
"content": "type key = int\n\nmodule I = Belt_internalMapInt\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\n\ntype 'a t = (key, 'a) N.t\n\nlet empty = N.empty\nlet isEmpty = N.isEmpty\nlet singleton = N.singleton\nlet minKey = N.minKey\nlet minKeyUndefined = N.minKeyUndefined\nlet maxKey = N.maxKey\nlet maxKeyUndefined = N.maxKeyUndefined\nlet minimum = N.minimum\nlet minUndefined = N.minUndefined\nlet maximum = N.maximum\nlet maxUndefined = N.maxUndefined\nlet forEachU = N.forEachU\nlet forEach = N.forEach\nlet mapU = N.mapU\nlet map = N.map\nlet mapWithKeyU = N.mapWithKeyU\nlet mapWithKey = N.mapWithKey\nlet reduceU = N.reduceU\nlet reduce = N.reduce\nlet everyU = N.everyU\nlet every = N.every\nlet someU = N.someU\nlet some = N.some\nlet keepU = N.keepSharedU\nlet keep = N.keepShared\nlet partitionU = N.partitionSharedU\nlet partition = N.partitionShared\nlet size = N.size\nlet toList = N.toList\nlet toArray = N.toArray\nlet keysToArray = N.keysToArray\nlet valuesToArray = N.valuesToArray\nlet checkInvariantInternal = N.checkInvariantInternal\n\nlet rec set t (newK : key) (newD : _) =\n match N.toOpt t with\n | None -> N.singleton newK newD\n | Some n ->\n let k = N.key n in\n if newK = k then N.return (N.updateValue n newD)\n else\n let v = N.value n in\n if newK < k then N.bal (set (N.left n) newK newD) k v (N.right n)\n else N.bal (N.left n) k v (set (N.right n) newK newD)\n\nlet rec updateU t (x : key) f =\n match N.toOpt t with\n | None -> ( match f None with None -> t | Some data -> N.singleton x data)\n | Some n ->\n let k = N.key n in\n if x = k then\n match f (Some (N.value n)) with\n | None -> (\n let l, r = (N.left n, N.right n) in\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r)\n | Some data -> N.return (N.updateValue n data)\n else\n let l, r, v = (N.left n, N.right n, N.value n) in\n if x < k then\n let ll = updateU l x f in\n if l == ll then t else N.bal ll k v r\n else\n let rr = updateU r x f in\n if r == rr then t else N.bal l k v rr\n\nlet update t x f = updateU t x (fun a -> f a)\n\nlet rec removeAux n (x : key) =\n let l, v, r =\n let open N in\n (left n, key n, right n)\n in\n if x = v then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r\n else if x < v then\n match N.toOpt l with\n | None -> N.return n\n | Some left ->\n let ll = removeAux left x in\n if ll == l then N.return n\n else\n let open N in\n bal ll v (value n) r\n else\n match N.toOpt r with\n | None -> N.return n\n | Some right ->\n let rr = removeAux right x in\n N.bal l v (N.value n) rr\n\nlet remove n x = match N.toOpt n with None -> N.empty | Some n -> removeAux n x\n\nlet rec removeMany0 t xs i len =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = removeAux t ele in\n match N.toOpt u with None -> u | Some t -> removeMany0 t xs (i + 1) len\n else N.return t\n\nlet removeMany t keys =\n let len = A.length keys in\n match N.toOpt t with None -> N.empty | Some t -> removeMany0 t keys 0 len\n\nlet mergeMany h arr =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key, value = A.getUnsafe arr i in\n v := set !v key value\n done;\n !v\n\nlet mergeArray = mergeMany\nlet has = I.has\nlet cmpU = I.cmpU\nlet cmp = I.cmp\nlet eqU = I.eqU\nlet eq = I.eq\nlet findFirstByU = N.findFirstByU\nlet findFirstBy t f = findFirstByU t (fun[@u] a b -> f a b)\nlet get = I.get\nlet getUndefined = I.getUndefined\nlet getWithDefault = I.getWithDefault\nlet getExn = I.getExn\nlet split = I.split\nlet mergeU = I.mergeU\nlet merge = I.merge\nlet fromArray = I.fromArray\n"
},
{
"path": "packages/Belt/src/Belt_MapInt.mli",
"content": "type key = int\n\ntype 'value t\n(** The type of maps from type [key] to type ['value]. *)\n\nval empty : 'v t\nval isEmpty : 'v t -> bool\nval has : 'v t -> key -> bool\nval cmpU : 'v t -> 'v t -> (('v -> 'v -> int)[@u]) -> int\nval cmp : 'v t -> 'v t -> ('v -> 'v -> int) -> int\nval eqU : 'v t -> 'v t -> (('v -> 'v -> bool)[@u]) -> bool\n\nval eq : 'v t -> 'v t -> ('v -> 'v -> bool) -> bool\n(** [eq m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal\n data. *)\n\nval findFirstByU : 'v t -> ((key -> 'v -> bool)[@u]) -> (key * 'v) option\n\nval findFirstBy : 'v t -> (key -> 'v -> bool) -> (key * 'v) option\n(** [findFirstBy m p] uses funcion [f] to find the first key value pair to match predicate [p].\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| (4, \"4\"); (1, \"1\"); (2, \"2,\" 3 \"\") |];;\n\n findFirstBy s0 (fun k v -> k = 4) = option (4, \"4\")\n ]} *)\n\nval forEachU : 'v t -> ((key -> 'v -> unit)[@u]) -> unit\n\nval forEach : 'v t -> (key -> 'v -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated\n value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the\n type of the keys. *)\n\nval reduceU : 'v t -> 'v2 -> (('v2 -> key -> 'v -> 'v2)[@u]) -> 'v2\n\nval reduce : 'v t -> 'v2 -> ('v2 -> key -> 'v -> 'v2) -> 'v2\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data. *)\n\nval everyU : 'v t -> ((key -> 'v -> bool)[@u]) -> bool\n\nval every : 'v t -> (key -> 'v -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. Order unspecified *)\n\nval someU : 'v t -> ((key -> 'v -> bool)[@u]) -> bool\n\nval some : 'v t -> (key -> 'v -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. Order unspecified *)\n\nval size : 'v t -> int\n\nval toList : 'v t -> (key * 'v) list\n(** In increasing order. *)\n\nval toArray : 'v t -> (key * 'v) array\nval fromArray : (key * 'v) array -> 'v t\nval keysToArray : 'v t -> key array\nval valuesToArray : 'v t -> 'v array\nval minKey : _ t -> key option\nval minKeyUndefined : _ t -> key Js.undefined\nval maxKey : _ t -> key option\nval maxKeyUndefined : _ t -> key Js.undefined\nval minimum : 'v t -> (key * 'v) option\nval minUndefined : 'v t -> (key * 'v) Js.undefined\nval maximum : 'v t -> (key * 'v) option\nval maxUndefined : 'v t -> (key * 'v) Js.undefined\nval get : 'v t -> key -> 'v option\nval getUndefined : 'v t -> key -> 'v Js.undefined\nval getWithDefault : 'v t -> key -> 'v -> 'v\nval getExn : 'v t -> key -> 'v\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\nval remove : 'v t -> key -> 'v t\n(** [remove m x] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map.\n*)\n\nval removeMany : 'v t -> key array -> 'v t\n\nval set : 'v t -> key -> 'v -> 'v t\n(** [set m x y] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already\n bound in [m], its previous binding disappears. *)\n\nval updateU : 'v t -> key -> (('v option -> 'v option)[@u]) -> 'v t\nval update : 'v t -> key -> ('v option -> 'v option) -> 'v t\nval mergeU : 'v t -> 'v2 t -> ((key -> 'v option -> 'v2 option -> 'c option)[@u]) -> 'c t\n\nval merge : 'v t -> 'v2 t -> (key -> 'v option -> 'v2 option -> 'c option) -> 'c t\n(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such\n binding, and the corresponding value, is determined with the function [f]. *)\n\nval mergeMany : 'v t -> (key * 'v) array -> 'v t\nval keepU : 'v t -> ((key -> 'v -> bool)[@u]) -> 'v t\n\nval keep : 'v t -> (key -> 'v -> bool) -> 'v t\n(** [keep m p] returns the map with all the bindings in [m] that satisfy predicate [p]. *)\n\nval partitionU : 'v t -> ((key -> 'v -> bool)[@u]) -> 'v t * 'v t\n\nval partition : 'v t -> (key -> 'v -> bool) -> 'v t * 'v t\n(** [partition m p] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the\n predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *)\n\nval split : key -> 'v t -> 'v t * 'v option * 'v t\n(** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly\n less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None]\n if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *)\n\nval mapU : 'v t -> (('v -> 'v2)[@u]) -> 'v2 t\n\nval map : 'v t -> ('v -> 'v2) -> 'v2 t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : 'v t -> ((key -> 'v -> 'v2)[@u]) -> 'v2 t\nval mapWithKey : 'v t -> (key -> 'v -> 'v2) -> 'v2 t\n"
},
{
"path": "packages/Belt/src/Belt_MapString.ml",
"content": "type key = string\n\nmodule I = Belt_internalMapString\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\n\ntype 'a t = (key, 'a) N.t\n\nlet empty = N.empty\nlet isEmpty = N.isEmpty\nlet singleton = N.singleton\nlet minKey = N.minKey\nlet minKeyUndefined = N.minKeyUndefined\nlet maxKey = N.maxKey\nlet maxKeyUndefined = N.maxKeyUndefined\nlet minimum = N.minimum\nlet minUndefined = N.minUndefined\nlet maximum = N.maximum\nlet maxUndefined = N.maxUndefined\nlet forEachU = N.forEachU\nlet forEach = N.forEach\nlet mapU = N.mapU\nlet map = N.map\nlet mapWithKeyU = N.mapWithKeyU\nlet mapWithKey = N.mapWithKey\nlet reduceU = N.reduceU\nlet reduce = N.reduce\nlet everyU = N.everyU\nlet every = N.every\nlet someU = N.someU\nlet some = N.some\nlet keepU = N.keepSharedU\nlet keep = N.keepShared\nlet partitionU = N.partitionSharedU\nlet partition = N.partitionShared\nlet size = N.size\nlet toList = N.toList\nlet toArray = N.toArray\nlet keysToArray = N.keysToArray\nlet valuesToArray = N.valuesToArray\nlet checkInvariantInternal = N.checkInvariantInternal\n\nlet rec set t (newK : key) (newD : _) =\n match N.toOpt t with\n | None -> N.singleton newK newD\n | Some n ->\n let k = N.key n in\n if newK = k then N.return (N.updateValue n newD)\n else\n let v = N.value n in\n if newK < k then N.bal (set (N.left n) newK newD) k v (N.right n)\n else N.bal (N.left n) k v (set (N.right n) newK newD)\n\nlet rec updateU t (x : key) f =\n match N.toOpt t with\n | None -> ( match f None with None -> t | Some data -> N.singleton x data)\n | Some n ->\n let k = N.key n in\n if x = k then\n match f (Some (N.value n)) with\n | None -> (\n let l, r = (N.left n, N.right n) in\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r)\n | Some data -> N.return (N.updateValue n data)\n else\n let l, r, v = (N.left n, N.right n, N.value n) in\n if x < k then\n let ll = updateU l x f in\n if l == ll then t else N.bal ll k v r\n else\n let rr = updateU r x f in\n if r == rr then t else N.bal l k v rr\n\nlet update t x f = updateU t x (fun a -> f a)\n\nlet rec removeAux n (x : key) =\n let l, v, r =\n let open N in\n (left n, key n, right n)\n in\n if x = v then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r\n else if x < v then\n match N.toOpt l with\n | None -> N.return n\n | Some left ->\n let ll = removeAux left x in\n if ll == l then N.return n\n else\n let open N in\n bal ll v (value n) r\n else\n match N.toOpt r with\n | None -> N.return n\n | Some right ->\n let rr = removeAux right x in\n N.bal l v (N.value n) rr\n\nlet remove n x = match N.toOpt n with None -> N.empty | Some n -> removeAux n x\n\nlet rec removeMany0 t xs i len =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = removeAux t ele in\n match N.toOpt u with None -> u | Some t -> removeMany0 t xs (i + 1) len\n else N.return t\n\nlet removeMany t keys =\n let len = A.length keys in\n match N.toOpt t with None -> N.empty | Some t -> removeMany0 t keys 0 len\n\nlet mergeMany h arr =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key, value = A.getUnsafe arr i in\n v := set !v key value\n done;\n !v\n\nlet mergeArray = mergeMany\nlet has = I.has\nlet cmpU = I.cmpU\nlet cmp = I.cmp\nlet eqU = I.eqU\nlet eq = I.eq\nlet findFirstByU = N.findFirstByU\nlet findFirstBy t f = findFirstByU t (fun[@u] a b -> f a b)\nlet get = I.get\nlet getUndefined = I.getUndefined\nlet getWithDefault = I.getWithDefault\nlet getExn = I.getExn\nlet split = I.split\nlet mergeU = I.mergeU\nlet merge = I.merge\nlet fromArray = I.fromArray\n"
},
{
"path": "packages/Belt/src/Belt_MapString.mli",
"content": "type key = string\n\ntype 'value t\n(** The type of maps from type [key] to type ['value]. *)\n\nval empty : 'v t\nval isEmpty : 'v t -> bool\nval has : 'v t -> key -> bool\nval cmpU : 'v t -> 'v t -> (('v -> 'v -> int)[@u]) -> int\nval cmp : 'v t -> 'v t -> ('v -> 'v -> int) -> int\nval eqU : 'v t -> 'v t -> (('v -> 'v -> bool)[@u]) -> bool\n\nval eq : 'v t -> 'v t -> ('v -> 'v -> bool) -> bool\n(** [eq m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal\n data. *)\n\nval findFirstByU : 'v t -> ((key -> 'v -> bool)[@u]) -> (key * 'v) option\n\nval findFirstBy : 'v t -> (key -> 'v -> bool) -> (key * 'v) option\n(** [findFirstBy m p] uses funcion [f] to find the first key value pair to match predicate [p].\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| (4, \"4\"); (1, \"1\"); (2, \"2,\" 3 \"\") |];;\n\n findFirstBy s0 (fun k v -> k = 4) = option (4, \"4\")\n ]} *)\n\nval forEachU : 'v t -> ((key -> 'v -> unit)[@u]) -> unit\n\nval forEach : 'v t -> (key -> 'v -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated\n value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the\n type of the keys. *)\n\nval reduceU : 'v t -> 'v2 -> (('v2 -> key -> 'v -> 'v2)[@u]) -> 'v2\n\nval reduce : 'v t -> 'v2 -> ('v2 -> key -> 'v -> 'v2) -> 'v2\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data. *)\n\nval everyU : 'v t -> ((key -> 'v -> bool)[@u]) -> bool\n\nval every : 'v t -> (key -> 'v -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. Order unspecified *)\n\nval someU : 'v t -> ((key -> 'v -> bool)[@u]) -> bool\n\nval some : 'v t -> (key -> 'v -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. Order unspecified *)\n\nval size : 'v t -> int\n\nval toList : 'v t -> (key * 'v) list\n(** In increasing order. *)\n\nval toArray : 'v t -> (key * 'v) array\nval fromArray : (key * 'v) array -> 'v t\nval keysToArray : 'v t -> key array\nval valuesToArray : 'v t -> 'v array\nval minKey : _ t -> key option\nval minKeyUndefined : _ t -> key Js.undefined\nval maxKey : _ t -> key option\nval maxKeyUndefined : _ t -> key Js.undefined\nval minimum : 'v t -> (key * 'v) option\nval minUndefined : 'v t -> (key * 'v) Js.undefined\nval maximum : 'v t -> (key * 'v) option\nval maxUndefined : 'v t -> (key * 'v) Js.undefined\nval get : 'v t -> key -> 'v option\nval getUndefined : 'v t -> key -> 'v Js.undefined\nval getWithDefault : 'v t -> key -> 'v -> 'v\nval getExn : 'v t -> key -> 'v\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\nval remove : 'v t -> key -> 'v t\n(** [remove m x] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map.\n*)\n\nval removeMany : 'v t -> key array -> 'v t\n\nval set : 'v t -> key -> 'v -> 'v t\n(** [set m x y] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already\n bound in [m], its previous binding disappears. *)\n\nval updateU : 'v t -> key -> (('v option -> 'v option)[@u]) -> 'v t\nval update : 'v t -> key -> ('v option -> 'v option) -> 'v t\nval mergeU : 'v t -> 'v2 t -> ((key -> 'v option -> 'v2 option -> 'c option)[@u]) -> 'c t\n\nval merge : 'v t -> 'v2 t -> (key -> 'v option -> 'v2 option -> 'c option) -> 'c t\n(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such\n binding, and the corresponding value, is determined with the function [f]. *)\n\nval mergeMany : 'v t -> (key * 'v) array -> 'v t\nval keepU : 'v t -> ((key -> 'v -> bool)[@u]) -> 'v t\n\nval keep : 'v t -> (key -> 'v -> bool) -> 'v t\n(** [keep m p] returns the map with all the bindings in [m] that satisfy predicate [p]. *)\n\nval partitionU : 'v t -> ((key -> 'v -> bool)[@u]) -> 'v t * 'v t\n\nval partition : 'v t -> (key -> 'v -> bool) -> 'v t * 'v t\n(** [partition m p] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the\n predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. *)\n\nval split : key -> 'v t -> 'v t * 'v option * 'v t\n(** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly\n less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None]\n if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. *)\n\nval mapU : 'v t -> (('v -> 'v2)[@u]) -> 'v2 t\n\nval map : 'v t -> ('v -> 'v2) -> 'v2 t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : 'v t -> ((key -> 'v -> 'v2)[@u]) -> 'v2 t\nval mapWithKey : 'v t -> (key -> 'v -> 'v2) -> 'v2 t\n"
},
{
"path": "packages/Belt/src/Belt_MutableMap.ml",
"content": "module Int = Belt_MutableMapInt\nmodule String = Belt_MutableMapString\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\n\ntype ('key, 'id) id = ('key, 'id) Belt_Id.comparable\ntype ('key, 'id) cmp = ('key, 'id) Belt_Id.cmp\n\nmodule S = struct\n include (\n struct\n type ('k, 'v, 'id) t = { cmp : ('k, 'id) cmp; mutable data : ('k, 'v) N.t }\n\n let t : cmp:('k, 'id) cmp -> data:('k, 'v) N.t -> ('k, 'v, 'id) t = fun ~cmp ~data -> { cmp; data }\n let cmp : ('k, 'v, 'id) t -> ('k, 'id) cmp = fun o -> o.cmp\n let dataSet : ('k, 'v, 'id) t -> ('k, 'v) N.t -> unit = fun o v -> o.data <- v\n let data : ('k, 'v, 'id) t -> ('k, 'v) N.t = fun o -> o.data\n end :\n sig\n type ('k, 'v, 'id) t\n\n val t : cmp:('k, 'id) cmp -> data:('k, 'v) N.t -> ('k, 'v, 'id) t\n val cmp : ('k, 'v, 'id) t -> ('k, 'id) cmp\n val dataSet : ('k, 'v, 'id) t -> ('k, 'v) N.t -> unit\n val data : ('k, 'v, 'id) t -> ('k, 'v) N.t\n end)\nend\n\ntype ('k, 'v, 'id) t = ('k, 'v, 'id) S.t\n\nlet rec removeMutateAux nt x ~cmp =\n let k = N.key nt in\n let c = (Belt_Id.getCmpInternal cmp) x k in\n if c = 0 then\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt)\n | None, Some _ -> r\n | (Some _ | None), None -> l\n else if c < 0 then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (removeMutateAux ~cmp l x);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (removeMutateAux ~cmp r x);\n N.return (N.balMutate nt)\n\nlet remove d k =\n let oldRoot = S.data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some oldRoot2 ->\n let newRoot = removeMutateAux ~cmp:(S.cmp d) oldRoot2 k in\n if newRoot != oldRoot then S.dataSet d newRoot\n\nlet rec removeArrayMutateAux t xs i len ~cmp =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = removeMutateAux t ele ~cmp in\n match N.toOpt u with None -> N.empty | Some t -> removeArrayMutateAux t xs (i + 1) len ~cmp\n else N.return t\n\nlet removeMany d xs =\n let oldRoot = S.data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some nt ->\n let len = A.length xs in\n let newRoot = removeArrayMutateAux nt xs 0 len ~cmp:(S.cmp d) in\n if newRoot != oldRoot then S.dataSet d newRoot\n\nlet rec updateDone t x f ~cmp =\n match N.toOpt t with\n | None -> ( match f None with Some data -> N.singleton x data | None -> t)\n | Some nt ->\n let k = N.key nt in\n let c = (Belt_Id.getCmpInternal cmp) x k in\n if c = 0 then (\n match f (Some (N.value nt)) with\n | None -> (\n let l, r = (N.left nt, N.right nt) in\n match (N.toOpt l, N.toOpt r) with\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt)\n | None, Some _ -> r\n | (Some _ | None), None -> l)\n | Some data ->\n N.valueSet nt data;\n N.return nt)\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if c < 0 then\n let ll = updateDone l x f ~cmp in\n N.leftSet nt ll\n else N.rightSet nt (updateDone r x f ~cmp);\n N.return (N.balMutate nt)\n\nlet updateU t x f =\n let oldRoot = S.data t in\n let newRoot = updateDone oldRoot x f ~cmp:(S.cmp t) in\n if newRoot != oldRoot then S.dataSet t newRoot\n\nlet update t x f = updateU t x (fun a -> f a)\n\nlet make (type key identity) ~(id : (key, identity) id) =\n let module M = (val id) in\n S.t ~cmp:M.cmp ~data:N.empty\n\nlet clear m = S.dataSet m N.empty\nlet isEmpty d = N.isEmpty (S.data d)\nlet minKey m = N.minKey (S.data m)\nlet minKeyUndefined m = N.minKeyUndefined (S.data m)\nlet maxKey m = N.maxKey (S.data m)\nlet maxKeyUndefined m = N.maxKeyUndefined (S.data m)\nlet minimum m = N.minimum (S.data m)\nlet minUndefined m = N.minUndefined (S.data m)\nlet maximum m = N.maximum (S.data m)\nlet maxUndefined m = N.maxUndefined (S.data m)\nlet forEachU d f = N.forEachU (S.data d) f\nlet forEach d f = forEachU d (fun a b -> f a b)\nlet reduceU d acc cb = N.reduceU (S.data d) acc cb\nlet reduce d acc cb = reduceU d acc (fun a b c -> cb a b c)\nlet everyU d p = N.everyU (S.data d) p\nlet every d p = everyU d (fun a b -> p a b)\nlet someU d p = N.someU (S.data d) p\nlet some d p = someU d (fun a b -> p a b)\nlet size d = N.size (S.data d)\nlet toList d = N.toList (S.data d)\nlet toArray d = N.toArray (S.data d)\nlet keysToArray d = N.keysToArray (S.data d)\nlet valuesToArray d = N.valuesToArray (S.data d)\n\nlet fromSortedArrayUnsafe (type key identity) ~(id : (key, identity) id) xs : _ t =\n let module M = (val id) in\n S.t ~data:(N.fromSortedArrayUnsafe xs) ~cmp:M.cmp\n\nlet checkInvariantInternal d = N.checkInvariantInternal (S.data d)\nlet cmpU m1 m2 cmp = N.cmpU ~kcmp:(S.cmp m1) ~vcmp:cmp (S.data m1) (S.data m2)\nlet cmp m1 m2 cmp = cmpU m1 m2 (fun a b -> cmp a b)\nlet eqU m1 m2 cmp = N.eqU ~kcmp:(S.cmp m1) ~veq:cmp (S.data m1) (S.data m2)\nlet eq m1 m2 cmp = eqU m1 m2 (fun a b -> cmp a b)\nlet mapU m f = S.t ~cmp:(S.cmp m) ~data:(N.mapU (S.data m) f)\nlet map m f = mapU m (fun a -> f a)\nlet mapWithKeyU m f = S.t ~cmp:(S.cmp m) ~data:(N.mapWithKeyU (S.data m) f)\nlet mapWithKey m f = mapWithKeyU m (fun a b -> f a b)\nlet get m x = N.get ~cmp:(S.cmp m) (S.data m) x\nlet getUndefined m x = N.getUndefined ~cmp:(S.cmp m) (S.data m) x\nlet getWithDefault m x def = N.getWithDefault ~cmp:(S.cmp m) (S.data m) x def\nlet getExn m x = N.getExn ~cmp:(S.cmp m) (S.data m) x\nlet has m x = N.has ~cmp:(S.cmp m) (S.data m) x\n\nlet fromArray (type k identity) data ~(id : (k, identity) id) =\n let module M = (val id) in\n let cmp = M.cmp in\n S.t ~cmp ~data:(N.fromArray ~cmp data)\n\nlet set m e v =\n let oldRoot = S.data m in\n let newRoot = N.updateMutate ~cmp:(S.cmp m) oldRoot e v in\n if newRoot != oldRoot then S.dataSet m newRoot\n\nlet mergeManyAux t xs ~cmp =\n let v = ref t in\n for i = 0 to A.length xs - 1 do\n let key, value = A.getUnsafe xs i in\n v := N.updateMutate !v key value ~cmp\n done;\n !v\n\nlet mergeMany d xs =\n let oldRoot = S.data d in\n let newRoot = mergeManyAux oldRoot xs ~cmp:(S.cmp d) in\n if newRoot != oldRoot then S.dataSet d newRoot\n"
},
{
"path": "packages/Belt/src/Belt_MutableMap.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\nmodule Int = Belt_MutableMapInt\nmodule String = Belt_MutableMapString\n\n(** A {b mutable} sorted map module which allows customize {i compare} behavior.\n\n Same as Belt.Map, but mutable. *)\n\ntype ('k, 'v, 'id) t\ntype ('key, 'id) id = ('key, 'id) Belt_Id.comparable\n\nval make : id:('k, 'id) id -> ('k, 'a, 'id) t\nval clear : _ t -> unit\nval isEmpty : _ t -> bool\nval has : ('k, _, _) t -> 'k -> bool\nval cmpU : ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> (('a -> 'a -> int)[@u]) -> int\n\nval cmp : ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> ('a -> 'a -> int) -> int\n(** [cmp m1 m2 cmp] First compare by size, if size is the same, compare by key, value pair *)\n\nval eqU : ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> (('a -> 'a -> bool)[@u]) -> bool\n\nval eq : ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> ('a -> 'a -> bool) -> bool\n(** [eq m1 m2 eqf] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with\n equal data. [eqf] is the equality predicate used to compare the data associated with the keys. *)\n\nval forEachU : ('k, 'a, 'id) t -> (('k -> 'a -> unit)[@u]) -> unit\n\nval forEach : ('k, 'a, 'id) t -> ('k -> 'a -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the 'k as first argument, and the associated\n value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the\n type of the keys. *)\n\nval reduceU : ('k, 'a, 'id) t -> 'b -> (('b -> 'k -> 'a -> 'b)[@u]) -> 'b\n\nval reduce : ('k, 'a, 'id) t -> 'b -> ('b -> 'k -> 'a -> 'b) -> 'b\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data. *)\n\nval everyU : ('k, 'a, 'id) t -> (('k -> 'a -> bool)[@u]) -> bool\n\nval every : ('k, 'a, 'id) t -> ('k -> 'a -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. *)\n\nval someU : ('k, 'a, 'id) t -> (('k -> 'a -> bool)[@u]) -> bool\n\nval some : ('k, 'a, 'id) t -> ('k -> 'a -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. *)\n\nval size : ('k, 'a, 'id) t -> int\n\nval toList : ('k, 'a, 'id) t -> ('k * 'a) list\n(** In increasing order*)\n\nval toArray : ('k, 'a, 'id) t -> ('k * 'a) array\n(** In increasing order*)\n\nval fromArray : ('k * 'a) array -> id:('k, 'id) id -> ('k, 'a, 'id) t\nval keysToArray : ('k, _, _) t -> 'k array\nval valuesToArray : (_, 'a, _) t -> 'a array\nval minKey : ('k, _, _) t -> 'k option\nval minKeyUndefined : ('k, _, _) t -> 'k Js.undefined\nval maxKey : ('k, _, _) t -> 'k option\nval maxKeyUndefined : ('k, _, _) t -> 'k Js.undefined\nval minimum : ('k, 'a, _) t -> ('k * 'a) option\nval minUndefined : ('k, 'a, _) t -> ('k * 'a) Js.undefined\nval maximum : ('k, 'a, _) t -> ('k * 'a) option\nval maxUndefined : ('k, 'a, _) t -> ('k * 'a) Js.undefined\nval get : ('k, 'a, 'id) t -> 'k -> 'a option\nval getUndefined : ('k, 'a, 'id) t -> 'k -> 'a Js.undefined\nval getWithDefault : ('k, 'a, 'id) t -> 'k -> 'a -> 'a\nval getExn : ('k, 'a, 'id) t -> 'k -> 'a\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\n(****************************************************************************)\n\n(*TODO: add functional [merge, partition, keep, split]*)\n\nval remove : ('k, 'a, 'id) t -> 'k -> unit\n(** [remove m x] do the in-place modification, *)\n\nval removeMany : ('k, 'a, 'id) t -> 'k array -> unit\n\nval set : ('k, 'a, 'id) t -> 'k -> 'a -> unit\n(** [set m x y ] do the in-place modification *)\n\nval updateU : ('k, 'a, 'id) t -> 'k -> (('a option -> 'a option)[@u]) -> unit\nval update : ('k, 'a, 'id) t -> 'k -> ('a option -> 'a option) -> unit\nval mergeMany : ('k, 'a, 'id) t -> ('k * 'a) array -> unit\nval mapU : ('k, 'a, 'id) t -> (('a -> 'b)[@u]) -> ('k, 'b, 'id) t\n\nval map : ('k, 'a, 'id) t -> ('a -> 'b) -> ('k, 'b, 'id) t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : ('k, 'a, 'id) t -> (('k -> 'a -> 'b)[@u]) -> ('k, 'b, 'id) t\nval mapWithKey : ('k, 'a, 'id) t -> ('k -> 'a -> 'b) -> ('k, 'b, 'id) t\n"
},
{
"path": "packages/Belt/src/Belt_MutableMapInt.ml",
"content": "module I = Belt_internalMapInt\n\ntype key = int\n\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\n\ninclude (\n struct\n type 'a t = { mutable data : 'a I.t }\n\n let t : data:'a I.t -> 'a t = fun ~data -> { data }\n let dataSet : 'a t -> 'a I.t -> unit = fun o v -> o.data <- v\n let data : 'a t -> 'a I.t = fun o -> o.data\n end :\n sig\n type 'a t\n\n val t : data:'a I.t -> 'a t\n val dataSet : 'a t -> 'a I.t -> unit\n val data : 'a t -> 'a I.t\n end)\n\nlet make () = t ~data:N.empty\nlet isEmpty m = N.isEmpty (data m)\nlet clear m = dataSet m N.empty\nlet singleton k v = t ~data:(N.singleton k v)\nlet minKeyUndefined m = N.minKeyUndefined (data m)\nlet minKey m = N.minKey (data m)\nlet maxKeyUndefined m = N.maxKeyUndefined (data m)\nlet maxKey m = N.maxKey (data m)\nlet minimum m = N.minimum (data m)\nlet minUndefined m = N.minUndefined (data m)\nlet maximum m = N.maximum (data m)\nlet maxUndefined m = N.maxUndefined (data m)\n\nlet set (m : _ t) k v =\n let old_data = data m in\n let v = I.addMutate old_data k v in\n if v != old_data then dataSet m v\n\nlet forEachU d f = N.forEachU (data d) f\nlet forEach d f = forEachU d (fun a b -> f a b)\nlet mapU d f = t ~data:(N.mapU (data d) f)\nlet map d f = mapU d (fun a -> f a)\nlet mapWithKeyU d f = t ~data:(N.mapWithKeyU (data d) f)\nlet mapWithKey d f = mapWithKeyU d (fun a b -> f a b)\nlet reduceU d acc f = N.reduceU (data d) acc f\nlet reduce d acc f = reduceU d acc (fun a b c -> f a b c)\nlet everyU d f = N.everyU (data d) f\nlet every d f = everyU d (fun a b -> f a b)\nlet someU d f = N.someU (data d) f\nlet some d f = someU d (fun a b -> f a b)\nlet size d = N.size (data d)\nlet toList d = N.toList (data d)\nlet toArray d = N.toArray (data d)\nlet keysToArray d = N.keysToArray (data d)\nlet valuesToArray d = N.valuesToArray (data d)\nlet checkInvariantInternal d = N.checkInvariantInternal (data d)\nlet has d v = I.has (data d) v\n\nlet rec removeMutateAux nt (x : key) =\n let k = N.key nt in\n if x = k then (\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if x < k then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (removeMutateAux l x);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (removeMutateAux r x);\n N.return (N.balMutate nt)\n\nlet remove d v =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some root ->\n let newRoot = removeMutateAux root v in\n if newRoot != oldRoot then dataSet d newRoot\n\nlet rec updateDone t (x : key) f =\n match N.toOpt t with\n | None -> ( match f None with Some data -> N.singleton x data | None -> t)\n | Some nt ->\n let k = N.key nt in\n if k = x then (\n match f (Some (N.value nt)) with\n | None -> (\n let l, r = (N.left nt, N.right nt) in\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n | Some data ->\n N.valueSet nt data;\n N.return nt)\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < k then\n let ll = updateDone l x f in\n N.leftSet nt ll\n else N.rightSet nt (updateDone r x f);\n N.return (N.balMutate nt)\n\nlet updateU t x f =\n let oldRoot = data t in\n let newRoot = updateDone oldRoot x f in\n if newRoot != oldRoot then dataSet t newRoot\n\nlet update t x f = updateU t x (fun a -> f a)\n\nlet rec removeArrayMutateAux t xs i len =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = removeMutateAux t ele in\n match N.toOpt u with None -> N.empty | Some t -> removeArrayMutateAux t xs (i + 1) len\n else N.return t\n\nlet removeMany (type key id) (d : _ t) xs =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some nt ->\n let len = A.length xs in\n let newRoot = removeArrayMutateAux nt xs 0 len in\n if newRoot != oldRoot then dataSet d newRoot\n\nlet fromArray xs = t ~data:(I.fromArray xs)\nlet cmpU d0 d1 f = I.cmpU (data d0) (data d1) f\nlet cmp d0 d1 f = cmpU d0 d1 (fun a b -> f a b)\nlet eqU d0 d1 f = I.eqU (data d0) (data d1) f\nlet eq d0 d1 f = eqU d0 d1 (fun a b -> f a b)\nlet get d x = I.get (data d) x\nlet getUndefined d x = I.getUndefined (data d) x\nlet getWithDefault d x def = I.getWithDefault (data d) x def\nlet getExn d x = I.getExn (data d) x\n"
},
{
"path": "packages/Belt/src/Belt_MutableMapInt.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\ntype key = int\ntype 'a t\n\nval make : unit -> 'a t\nval clear : 'a t -> unit\nval isEmpty : 'a t -> bool\nval has : 'a t -> key -> bool\nval cmpU : 'a t -> 'a t -> (('a -> 'a -> int)[@u]) -> int\n\nval cmp : 'a t -> 'a t -> ('a -> 'a -> int) -> int\n(** [cmp m1 m2 cmp] First compare by size, if size is the same, compare by key, value pair *)\n\nval eqU : 'a t -> 'a t -> (('a -> 'a -> bool)[@u]) -> bool\n\nval eq : 'a t -> 'a t -> ('a -> 'a -> bool) -> bool\n(** [eq m1 m2 cmp] *)\n\nval forEachU : 'a t -> ((key -> 'a -> unit)[@u]) -> unit\n\nval forEach : 'a t -> (key -> 'a -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated\n value as second argument. The application order of [f] is in increasing order. *)\n\nval reduceU : 'a t -> 'b -> (('b -> key -> 'a -> 'b)[@u]) -> 'b\n\nval reduce : 'a t -> 'b -> ('b -> key -> 'a -> 'b) -> 'b\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data. *)\n\nval everyU : 'a t -> ((key -> 'a -> bool)[@u]) -> bool\n\nval every : 'a t -> (key -> 'a -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. The application order of [p] is\n unspecified. *)\n\nval someU : 'a t -> ((key -> 'a -> bool)[@u]) -> bool\n\nval some : 'a t -> (key -> 'a -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. The application order of [p] is\n unspecified. *)\n\nval size : 'a t -> int\n\nval toList : 'a t -> (key * 'a) list\n(** In increasing order *)\n\nval toArray : 'a t -> (key * 'a) array\n(** In increasing order *)\n\nval fromArray : (key * 'a) array -> 'a t\nval keysToArray : 'a t -> key array\nval valuesToArray : 'a t -> 'a array\nval minKey : _ t -> key option\nval minKeyUndefined : _ t -> key Js.undefined\nval maxKey : _ t -> key option\nval maxKeyUndefined : _ t -> key Js.undefined\nval minimum : 'a t -> (key * 'a) option\nval minUndefined : 'a t -> (key * 'a) Js.undefined\nval maximum : 'a t -> (key * 'a) option\nval maxUndefined : 'a t -> (key * 'a) Js.undefined\nval get : 'a t -> key -> 'a option\nval getUndefined : 'a t -> key -> 'a Js.undefined\nval getWithDefault : 'a t -> key -> 'a -> 'a\nval getExn : 'a t -> key -> 'a\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\n(****************************************************************************)\n\n(*TODO: add functional [merge, partition, keep, split]*)\n\nval remove : 'a t -> key -> unit\n(** [remove m x] do the in-place modification *)\n\nval removeMany : 'a t -> key array -> unit\n\nval set : 'a t -> key -> 'a -> unit\n(** [set m x y] do the in-place modification, return [m] for chaining. If [x] was already bound in [m], its previous\n binding disappears. *)\n\nval updateU : 'a t -> key -> (('a option -> 'a option)[@u]) -> unit\nval update : 'a t -> key -> ('a option -> 'a option) -> unit\nval mapU : 'a t -> (('a -> 'b)[@u]) -> 'b t\n\nval map : 'a t -> ('a -> 'b) -> 'b t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : 'a t -> ((key -> 'a -> 'b)[@u]) -> 'b t\nval mapWithKey : 'a t -> (key -> 'a -> 'b) -> 'b t\n"
},
{
"path": "packages/Belt/src/Belt_MutableMapString.ml",
"content": "module I = Belt_internalMapString\n\ntype key = string\n\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\n\ninclude (\n struct\n type 'a t = { mutable data : 'a I.t }\n\n let t : data:'a I.t -> 'a t = fun ~data -> { data }\n let dataSet : 'a t -> 'a I.t -> unit = fun o v -> o.data <- v\n let data : 'a t -> 'a I.t = fun o -> o.data\n end :\n sig\n type 'a t\n\n val t : data:'a I.t -> 'a t\n val dataSet : 'a t -> 'a I.t -> unit\n val data : 'a t -> 'a I.t\n end)\n\nlet make () = t ~data:N.empty\nlet isEmpty m = N.isEmpty (data m)\nlet clear m = dataSet m N.empty\nlet singleton k v = t ~data:(N.singleton k v)\nlet minKeyUndefined m = N.minKeyUndefined (data m)\nlet minKey m = N.minKey (data m)\nlet maxKeyUndefined m = N.maxKeyUndefined (data m)\nlet maxKey m = N.maxKey (data m)\nlet minimum m = N.minimum (data m)\nlet minUndefined m = N.minUndefined (data m)\nlet maximum m = N.maximum (data m)\nlet maxUndefined m = N.maxUndefined (data m)\n\nlet set (m : _ t) k v =\n let old_data = data m in\n let v = I.addMutate old_data k v in\n if v != old_data then dataSet m v\n\nlet forEachU d f = N.forEachU (data d) f\nlet forEach d f = forEachU d (fun a b -> f a b)\nlet mapU d f = t ~data:(N.mapU (data d) f)\nlet map d f = mapU d (fun a -> f a)\nlet mapWithKeyU d f = t ~data:(N.mapWithKeyU (data d) f)\nlet mapWithKey d f = mapWithKeyU d (fun a b -> f a b)\nlet reduceU d acc f = N.reduceU (data d) acc f\nlet reduce d acc f = reduceU d acc (fun a b c -> f a b c)\nlet everyU d f = N.everyU (data d) f\nlet every d f = everyU d (fun a b -> f a b)\nlet someU d f = N.someU (data d) f\nlet some d f = someU d (fun a b -> f a b)\nlet size d = N.size (data d)\nlet toList d = N.toList (data d)\nlet toArray d = N.toArray (data d)\nlet keysToArray d = N.keysToArray (data d)\nlet valuesToArray d = N.valuesToArray (data d)\nlet checkInvariantInternal d = N.checkInvariantInternal (data d)\nlet has d v = I.has (data d) v\n\nlet rec removeMutateAux nt (x : key) =\n let k = N.key nt in\n if x = k then (\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if x < k then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (removeMutateAux l x);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (removeMutateAux r x);\n N.return (N.balMutate nt)\n\nlet remove d v =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some root ->\n let newRoot = removeMutateAux root v in\n if newRoot != oldRoot then dataSet d newRoot\n\nlet rec updateDone t (x : key) f =\n match N.toOpt t with\n | None -> ( match f None with Some data -> N.singleton x data | None -> t)\n | Some nt ->\n let k = N.key nt in\n if k = x then (\n match f (Some (N.value nt)) with\n | None -> (\n let l, r = (N.left nt, N.right nt) in\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n | Some data ->\n N.valueSet nt data;\n N.return nt)\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < k then\n let ll = updateDone l x f in\n N.leftSet nt ll\n else N.rightSet nt (updateDone r x f);\n N.return (N.balMutate nt)\n\nlet updateU t x f =\n let oldRoot = data t in\n let newRoot = updateDone oldRoot x f in\n if newRoot != oldRoot then dataSet t newRoot\n\nlet update t x f = updateU t x (fun a -> f a)\n\nlet rec removeArrayMutateAux t xs i len =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = removeMutateAux t ele in\n match N.toOpt u with None -> N.empty | Some t -> removeArrayMutateAux t xs (i + 1) len\n else N.return t\n\nlet removeMany (type key id) (d : _ t) xs =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some nt ->\n let len = A.length xs in\n let newRoot = removeArrayMutateAux nt xs 0 len in\n if newRoot != oldRoot then dataSet d newRoot\n\nlet fromArray xs = t ~data:(I.fromArray xs)\nlet cmpU d0 d1 f = I.cmpU (data d0) (data d1) f\nlet cmp d0 d1 f = cmpU d0 d1 (fun a b -> f a b)\nlet eqU d0 d1 f = I.eqU (data d0) (data d1) f\nlet eq d0 d1 f = eqU d0 d1 (fun a b -> f a b)\nlet get d x = I.get (data d) x\nlet getUndefined d x = I.getUndefined (data d) x\nlet getWithDefault d x def = I.getWithDefault (data d) x def\nlet getExn d x = I.getExn (data d) x\n"
},
{
"path": "packages/Belt/src/Belt_MutableMapString.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\ntype key = string\ntype 'a t\n\nval make : unit -> 'a t\nval clear : 'a t -> unit\nval isEmpty : 'a t -> bool\nval has : 'a t -> key -> bool\nval cmpU : 'a t -> 'a t -> (('a -> 'a -> int)[@u]) -> int\n\nval cmp : 'a t -> 'a t -> ('a -> 'a -> int) -> int\n(** [cmp m1 m2 cmp] First compare by size, if size is the same, compare by key, value pair *)\n\nval eqU : 'a t -> 'a t -> (('a -> 'a -> bool)[@u]) -> bool\n\nval eq : 'a t -> 'a t -> ('a -> 'a -> bool) -> bool\n(** [eq m1 m2 cmp] *)\n\nval forEachU : 'a t -> ((key -> 'a -> unit)[@u]) -> unit\n\nval forEach : 'a t -> (key -> 'a -> unit) -> unit\n(** [forEach m f] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated\n value as second argument. The application order of [f] is in increasing order. *)\n\nval reduceU : 'a t -> 'b -> (('b -> key -> 'a -> 'b)[@u]) -> 'b\n\nval reduce : 'a t -> 'b -> ('b -> key -> 'a -> 'b) -> 'b\n(** [reduce m a f] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in\n increasing order), and [d1 ... dN] are the associated data. *)\n\nval everyU : 'a t -> ((key -> 'a -> bool)[@u]) -> bool\n\nval every : 'a t -> (key -> 'a -> bool) -> bool\n(** [every m p] checks if all the bindings of the map satisfy the predicate [p]. The application order of [p] is\n unspecified. *)\n\nval someU : 'a t -> ((key -> 'a -> bool)[@u]) -> bool\n\nval some : 'a t -> (key -> 'a -> bool) -> bool\n(** [some m p] checks if at least one binding of the map satisfy the predicate [p]. The application order of [p] is\n unspecified. *)\n\nval size : 'a t -> int\n\nval toList : 'a t -> (key * 'a) list\n(** In increasing order *)\n\nval toArray : 'a t -> (key * 'a) array\n(** In increasing order *)\n\nval fromArray : (key * 'a) array -> 'a t\nval keysToArray : 'a t -> key array\nval valuesToArray : 'a t -> 'a array\nval minKey : _ t -> key option\nval minKeyUndefined : _ t -> key Js.undefined\nval maxKey : _ t -> key option\nval maxKeyUndefined : _ t -> key Js.undefined\nval minimum : 'a t -> (key * 'a) option\nval minUndefined : 'a t -> (key * 'a) Js.undefined\nval maximum : 'a t -> (key * 'a) option\nval maxUndefined : 'a t -> (key * 'a) Js.undefined\nval get : 'a t -> key -> 'a option\nval getUndefined : 'a t -> key -> 'a Js.undefined\nval getWithDefault : 'a t -> key -> 'a -> 'a\nval getExn : 'a t -> key -> 'a\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\n(****************************************************************************)\n\n(*TODO: add functional [merge, partition, keep, split]*)\n\nval remove : 'a t -> key -> unit\n(** [remove m x] do the in-place modification *)\n\nval removeMany : 'a t -> key array -> unit\n\nval set : 'a t -> key -> 'a -> unit\n(** [set m x y] do the in-place modification, return [m] for chaining. If [x] was already bound in [m], its previous\n binding disappears. *)\n\nval updateU : 'a t -> key -> (('a option -> 'a option)[@u]) -> unit\nval update : 'a t -> key -> ('a option -> 'a option) -> unit\nval mapU : 'a t -> (('a -> 'b)[@u]) -> 'b t\n\nval map : 'a t -> ('a -> 'b) -> 'b t\n(** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been\n replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with\n respect to the ordering over the type of the keys. *)\n\nval mapWithKeyU : 'a t -> ((key -> 'a -> 'b)[@u]) -> 'b t\nval mapWithKey : 'a t -> (key -> 'a -> 'b) -> 'b t\n"
},
{
"path": "packages/Belt/src/Belt_MutableQueue.ml",
"content": "module A = Belt_Array\n\ninclude (\n struct\n type 'a node = { content : 'a; mutable next : 'a cell }\n and 'a cell = 'a node Js.null\n and 'a t = { mutable length : int; mutable first : 'a cell; mutable last : 'a cell }\n\n let node : content:'a -> next:'a cell -> 'a node = fun ~content ~next -> { content; next }\n let content : 'a node -> 'a = fun o -> o.content\n let nextSet : 'a node -> 'a cell -> unit = fun o v -> o.next <- v\n let next : 'a node -> 'a cell = fun o -> o.next\n let t : length:int -> first:'a cell -> last:'a cell -> 'a t = fun ~length ~first ~last -> { length; first; last }\n let lengthSet : 'a t -> int -> unit = fun o v -> o.length <- v\n let length : 'a t -> int = fun o -> o.length\n let firstSet : 'a t -> 'a cell -> unit = fun o v -> o.first <- v\n let first : 'a t -> 'a cell = fun o -> o.first\n let lastSet : 'a t -> 'a cell -> unit = fun o v -> o.last <- v\n let last : 'a t -> 'a cell = fun o -> o.last\n end :\n sig\n type 'a node\n and 'a cell = 'a node Js.null\n and 'a t\n\n val node : content:'a -> next:'a cell -> 'a node\n val content : 'a node -> 'a\n val nextSet : 'a node -> 'a cell -> unit\n val next : 'a node -> 'a cell\n val t : length:int -> first:'a cell -> last:'a cell -> 'a t\n val lengthSet : 'a t -> int -> unit\n val length : 'a t -> int\n val firstSet : 'a t -> 'a cell -> unit\n val first : 'a t -> 'a cell\n val lastSet : 'a t -> 'a cell -> unit\n val last : 'a t -> 'a cell\n end)\n\nlet null = Js.null\nlet return = Js.Null.return\nlet make () = t ~length:0 ~first:null ~last:null\n\nlet clear q =\n lengthSet q 0;\n firstSet q null;\n lastSet q null\n\nlet add q x =\n let cell = return @@ node ~content:x ~next:null in\n match Js.nullToOption (last q) with\n | None ->\n lengthSet q 1;\n firstSet q cell;\n lastSet q cell\n | Some last ->\n lengthSet q (length q + 1);\n nextSet last cell;\n lastSet q cell\n\nlet peek q = match Js.nullToOption (first q) with None -> None | Some v -> Some (content v)\n\nlet peekUndefined q =\n match Js.nullToOption (first q) with None -> Js.undefined | Some v -> Js.Undefined.return (content v)\n\nlet peekExn q =\n match Js.nullToOption (first q) with\n | None ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n | Some v -> content v\n\nlet pop q =\n match Js.nullToOption (first q) with\n | None -> None\n | Some x ->\n let next = next x in\n if next = Js.null then (\n clear q;\n Some (content x))\n else (\n lengthSet q (length q - 1);\n firstSet q next;\n Some (content x))\n\nlet popExn q =\n match Js.nullToOption (first q) with\n | None ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n | Some x ->\n let next = next x in\n if next = Js.null then (\n clear q;\n content x)\n else (\n lengthSet q (length q - 1);\n firstSet q next;\n content x)\n\nlet popUndefined q =\n match Js.nullToOption (first q) with\n | None -> Js.undefined\n | Some x ->\n let next = next x in\n if next = Js.null then (\n clear q;\n Js.Undefined.return (content x))\n else (\n lengthSet q (length q - 1);\n firstSet q next;\n Js.Undefined.return (content x))\n\nlet rec copyAux qRes prev cell =\n match Js.nullToOption cell with\n | None ->\n lastSet qRes prev;\n qRes\n | Some x ->\n let content = content x in\n let res = return @@ node ~content ~next:null in\n (match Js.nullToOption prev with None -> firstSet qRes res | Some p -> nextSet p res);\n copyAux qRes res (next x)\n\nlet copy q = copyAux (t ~length:(length q) ~first:null ~last:null) null (first q)\n\nlet rec copyMapAux qRes prev cell f =\n match Js.nullToOption cell with\n | None ->\n lastSet qRes prev;\n qRes\n | Some x ->\n let content = f (content x) in\n let res = return @@ node ~content ~next:null in\n (match Js.nullToOption prev with None -> firstSet qRes res | Some p -> nextSet p res);\n copyMapAux qRes res (next x) f\n\nlet mapU q f = copyMapAux (t ~length:(length q) ~first:null ~last:null) null (first q) f\nlet map q f = mapU q (fun a -> f a)\nlet isEmpty q = length q = 0\nlet size q = length q\n\nlet rec iterAux cell f =\n match Js.nullToOption cell with\n | None -> ()\n | Some x ->\n f (content x);\n iterAux (next x) f\n\nlet forEachU q f = iterAux (first q) f\nlet forEach q f = forEachU q (fun a -> f a)\n\nlet rec foldAux f accu cell =\n match Js.nullToOption cell with\n | None -> accu\n | Some x ->\n let accu = f accu (content x) in\n foldAux f accu (next x)\n\nlet reduceU q accu f = foldAux f accu (first q)\nlet reduce q accu f = reduceU q accu (fun a b -> f a b)\n\nlet transfer q1 q2 =\n if length q1 > 0 then\n match Js.nullToOption (last q2) with\n | None ->\n lengthSet q2 (length q1);\n firstSet q2 (first q1);\n lastSet q2 (last q1);\n clear q1\n | Some l ->\n lengthSet q2 (length q2 + length q1);\n nextSet l (first q1);\n lastSet q2 (last q1);\n clear q1\n\nlet rec fillAux i arr cell =\n match Js.nullToOption cell with\n | None -> ()\n | Some x ->\n A.setUnsafe arr i (content x);\n fillAux (i + 1) arr (next x)\n\nlet toArray x =\n let v =\n match Js.Null.toOption (first x) with None -> [||] | Some y -> A.makeUninitializedUnsafe (length x) (content y)\n in\n fillAux 0 v (first x);\n v\n\nlet fromArray arr =\n let q = make () in\n for i = 0 to A.length arr - 1 do\n add q (A.getUnsafe arr i)\n done;\n q\n"
},
{
"path": "packages/Belt/src/Belt_MutableQueue.mli",
"content": "(**************************************************************************)\n(* *)\n(* OCaml *)\n(* *)\n(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)\n(* *)\n(* Copyright 1996 Institut National de Recherche en Informatique et *)\n(* en Automatique. *)\n(* *)\n(* All rights reserved. This file is distributed under the terms of *)\n(* the GNU Lesser General Public License version 2.1, with the *)\n(* special exception on linking described in the file LICENSE. *)\n(* *)\n(**************************************************************************)\n(* Adapted significantly by ReScript Authors *)\n(** First-in first-out queues.\n\n This module implements queues (FIFOs), with in-place modification. *)\n\ntype 'a t\n(** The type of queues containing elements of type ['a]. *)\n\nval make : unit -> 'a t\n(** @return a new queue, initially empty. *)\n\nval clear : 'a t -> unit\n(** Discard all elements from the queue. *)\n\nval isEmpty : 'a t -> bool\n(** @return [true] if the given queue is empty, [false] otherwise. *)\n\nval fromArray : 'a array -> 'a t\n(** [fromArray a] is equivalent to [Array.forEach a (add q a)] *)\n\nval add : 'a t -> 'a -> unit\n(** [add q x] adds the element [x] at the end of the queue [q]. *)\n\nval peek : 'a t -> 'a option\n(** [peekOpt q] returns the first element in queue [q], without removing it from the queue. *)\n\nval peekUndefined : 'a t -> 'a Js.undefined\n(** [peekUndefined q] returns [undefined] if not found *)\n\nval peekExn : 'a t -> 'a\n(** [peekExn q]\n\n {b raise} an exception if [q] is empty *)\n\nval pop : 'a t -> 'a option\n(** [pop q] removes and returns the first element in queue [q].*)\n\nval popUndefined : 'a t -> 'a Js.undefined\n(** [popUndefined q] removes and returns the first element in queue [q]. it will return undefined if it is already empty\n*)\n\nval popExn : 'a t -> 'a\n(** [popExn q]\n\n {b raise} an exception if [q] is empty *)\n\nval copy : 'a t -> 'a t\n(** [copy q]\n\n @return a fresh queue *)\n\nval size : 'a t -> int\n(** @return the number of elements in a queue. *)\n\nval mapU : 'a t -> (('a -> 'b)[@u]) -> 'b t\nval map : 'a t -> ('a -> 'b) -> 'b t\nval forEachU : 'a t -> (('a -> unit)[@u]) -> unit\n\nval forEach : 'a t -> ('a -> unit) -> unit\n(** [forEach q f] applies [f] in turn to all elements of [q], from the least recently entered to the most recently\n entered. The queue itself is unchanged. *)\n\nval reduceU : 'a t -> 'b -> (('b -> 'a -> 'b)[@u]) -> 'b\n\nval reduce : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b\n(** [reduce q accu f] is equivalent to [List.reduce l accu f], where [l] is the list of [q]'s elements. The queue\n remains unchanged. *)\n\nval transfer : 'a t -> 'a t -> unit\n(** [transfer q1 q2] adds all of [q1]'s elements at the end of the queue [q2], then clears [q1]. It is equivalent to the\n sequence [forEach (fun x -> add x q2) q1; clear q1], but runs in constant time. *)\n\nval toArray : 'a t -> 'a array\n(** First added will be in the beginning of the array *)\n"
},
{
"path": "packages/Belt/src/Belt_MutableSet.ml",
"content": "module Int = Belt_MutableSetInt\nmodule String = Belt_MutableSetString\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\nmodule Sort = Belt_SortArray\n\ntype ('k, 'id) id = ('k, 'id) Belt_Id.comparable\ntype ('key, 'id) cmp = ('key, 'id) Belt_Id.cmp\n\nmodule S = struct\n include (\n struct\n type ('value, 'id) t = { cmp : ('value, 'id) cmp; mutable data : 'value N.t }\n\n let t : cmp:('value, 'id) cmp -> data:'value N.t -> ('value, 'id) t = fun ~cmp ~data -> { cmp; data }\n let cmp : ('value, 'id) t -> ('value, 'id) cmp = fun o -> o.cmp\n let dataSet : ('value, 'id) t -> 'value N.t -> unit = fun o v -> o.data <- v\n let data : ('value, 'id) t -> 'value N.t = fun o -> o.data\n end :\n sig\n type ('value, 'id) t\n\n val t : cmp:('value, 'id) cmp -> data:'value N.t -> ('value, 'id) t\n val cmp : ('value, 'id) t -> ('value, 'id) cmp\n val dataSet : ('value, 'id) t -> 'value N.t -> unit\n val data : ('value, 'id) t -> 'value N.t\n end)\nend\n\ntype ('k, 'id) t = ('k, 'id) S.t\n\nlet rec remove0 nt x ~cmp =\n let k = N.value nt in\n let c = cmp x k in\n if c = 0 then (\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if c < 0 then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (remove0 ~cmp l x);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (remove0 ~cmp r x);\n N.return (N.balMutate nt)\n\nlet remove d v =\n let oldRoot = S.data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some oldRoot2 ->\n let newRoot = remove0 ~cmp:(Belt_Id.getCmpInternal (S.cmp d)) oldRoot2 v in\n if newRoot != oldRoot then S.dataSet d newRoot\n\nlet rec removeMany0 t xs i len ~cmp =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = remove0 t ele ~cmp in\n match N.toOpt u with None -> N.empty | Some t -> removeMany0 t xs (i + 1) len ~cmp\n else N.return t\n\nlet removeMany d xs =\n let oldRoot = S.data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some nt ->\n let len = A.length xs in\n S.dataSet d (removeMany0 nt xs 0 len ~cmp:(Belt_Id.getCmpInternal (S.cmp d)))\n\nlet rec removeCheck0 nt x removed ~cmp =\n let k = N.value nt in\n let c = (Belt_Id.getCmpInternal cmp) x k in\n if c = 0 then (\n let () = removed := true in\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if c < 0 then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (removeCheck0 ~cmp l x removed);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (removeCheck0 ~cmp r x removed);\n N.return (N.balMutate nt)\n\nlet removeCheck d v =\n let oldRoot = S.data d in\n match N.toOpt oldRoot with\n | None -> false\n | Some oldRoot2 ->\n let removed = ref false in\n let newRoot = removeCheck0 ~cmp:(S.cmp d) oldRoot2 v removed in\n if newRoot != oldRoot then S.dataSet d newRoot;\n !removed\n\nlet rec addCheck0 t x added ~cmp =\n match N.toOpt t with\n | None ->\n added := true;\n N.singleton x\n | Some nt ->\n let k = N.value nt in\n let c = cmp x k in\n if c = 0 then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if c < 0 then\n let ll = addCheck0 ~cmp l x added in\n N.leftSet nt ll\n else N.rightSet nt (addCheck0 ~cmp r x added);\n N.return (N.balMutate nt)\n\nlet addCheck m e =\n let oldRoot = S.data m in\n let added = ref false in\n let newRoot = addCheck0 ~cmp:(Belt_Id.getCmpInternal (S.cmp m)) oldRoot e added in\n if newRoot != oldRoot then S.dataSet m newRoot;\n !added\n\nlet add m e =\n let oldRoot = S.data m in\n let newRoot = N.addMutate ~cmp:(S.cmp m) oldRoot e in\n if newRoot != oldRoot then S.dataSet m newRoot\n\nlet addArrayMutate t xs ~cmp =\n let v = ref t in\n for i = 0 to A.length xs - 1 do\n v := N.addMutate !v (A.getUnsafe xs i) ~cmp\n done;\n !v\n\nlet mergeMany d xs = S.dataSet d (addArrayMutate (S.data d) xs ~cmp:(S.cmp d))\n\nlet make (type value identity) ~(id : (value, identity) id) =\n let module M = (val id) in\n S.t ~cmp:M.cmp ~data:N.empty\n\nlet isEmpty d = N.isEmpty (S.data d)\nlet minimum d = N.minimum (S.data d)\nlet minUndefined d = N.minUndefined (S.data d)\nlet maximum d = N.maximum (S.data d)\nlet maxUndefined d = N.maxUndefined (S.data d)\nlet forEachU d f = N.forEachU (S.data d) f\nlet forEach d f = forEachU d (fun a -> f a)\nlet reduceU d acc cb = N.reduceU (S.data d) acc cb\nlet reduce d acc cb = reduceU d acc (fun a b -> cb a b)\nlet everyU d p = N.everyU (S.data d) p\nlet every d p = everyU d (fun a -> p a)\nlet someU d p = N.someU (S.data d) p\nlet some d p = someU d (fun a -> p a)\nlet size d = N.size (S.data d)\nlet toList d = N.toList (S.data d)\nlet toArray d = N.toArray (S.data d)\n\nlet fromSortedArrayUnsafe (type value identity) xs ~(id : (value, identity) id) : _ t =\n let module M = (val id) in\n S.t ~data:(N.fromSortedArrayUnsafe xs) ~cmp:M.cmp\n\nlet checkInvariantInternal d = N.checkInvariantInternal (S.data d)\n\nlet fromArray (type value identity) data ~(id : (value, identity) id) =\n let module M = (val id) in\n let cmp = M.cmp in\n S.t ~cmp ~data:(N.fromArray ~cmp data)\n\nlet cmp d0 d1 = N.cmp ~cmp:(S.cmp d0) (S.data d0) (S.data d1)\nlet eq d0 d1 = N.eq ~cmp:(S.cmp d0) (S.data d0) (S.data d1)\nlet get d x = N.get ~cmp:(S.cmp d) (S.data d) x\nlet getUndefined d x = N.getUndefined ~cmp:(S.cmp d) (S.data d) x\nlet getExn d x = N.getExn ~cmp:(S.cmp d) (S.data d) x\n\nlet split d key =\n let arr = N.toArray (S.data d) in\n let cmp = S.cmp d in\n let i = Sort.binarySearchByU arr key (Belt_Id.getCmpInternal cmp) in\n let len = A.length arr in\n if i < 0 then\n let next = -i - 1 in\n ( (S.t ~data:(N.fromSortedArrayAux arr 0 next) ~cmp, S.t ~data:(N.fromSortedArrayAux arr next (len - next)) ~cmp),\n false )\n else\n ( (S.t ~data:(N.fromSortedArrayAux arr 0 i) ~cmp, S.t ~data:(N.fromSortedArrayAux arr (i + 1) (len - i - 1)) ~cmp),\n true )\n\nlet keepU d p = S.t ~data:(N.keepCopyU (S.data d) p) ~cmp:(S.cmp d)\nlet keep d p = keepU d (fun a -> p a)\n\nlet partitionU d p =\n let cmp = S.cmp d in\n let a, b = N.partitionCopyU (S.data d) p in\n (S.t ~data:a ~cmp, S.t ~data:b ~cmp)\n\nlet partition d p = partitionU d (fun a -> p a)\nlet subset a b = N.subset ~cmp:(S.cmp a) (S.data a) (S.data b)\n\nlet intersect a b : _ t =\n let cmp = S.cmp a in\n match (N.toOpt (S.data a), N.toOpt (S.data b)) with\n | None, _ -> S.t ~cmp ~data:N.empty\n | _, None -> S.t ~cmp ~data:N.empty\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n let p = Belt_Id.getCmpInternal cmp in\n if\n p (A.getUnsafe tmp (sizea - 1)) (A.getUnsafe tmp sizea) < 0\n || p (A.getUnsafe tmp (totalSize - 1)) (A.getUnsafe tmp 0) < 0\n then S.t ~cmp ~data:N.empty\n else\n let tmp2 = A.makeUninitializedUnsafe (min sizea sizeb) (N.value dataa0) in\n let k = Sort.intersectU tmp 0 sizea tmp sizea sizeb tmp2 0 p in\n S.t ~data:(N.fromSortedArrayAux tmp2 0 k) ~cmp\n\nlet diff a b : _ t =\n let cmp = S.cmp a in\n let dataa = S.data a in\n match (N.toOpt dataa, N.toOpt (S.data b)) with\n | None, _ -> S.t ~cmp ~data:N.empty\n | _, None -> S.t ~data:(N.copy dataa) ~cmp\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n let p = Belt_Id.getCmpInternal cmp in\n if\n p (A.getUnsafe tmp (sizea - 1)) (A.getUnsafe tmp sizea) < 0\n || p (A.getUnsafe tmp (totalSize - 1)) (A.getUnsafe tmp 0) < 0\n then S.t ~data:(N.copy dataa) ~cmp\n else\n let tmp2 = A.makeUninitializedUnsafe sizea (N.value dataa0) in\n let k = Sort.diffU tmp 0 sizea tmp sizea sizeb tmp2 0 p in\n S.t ~data:(N.fromSortedArrayAux tmp2 0 k) ~cmp\n\nlet union a b =\n let cmp = S.cmp a in\n let dataa, datab = (S.data a, S.data b) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> S.t ~data:(N.copy datab) ~cmp\n | _, None -> S.t ~data:(N.copy dataa) ~cmp\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n let p = Belt_Id.getCmpInternal cmp in\n if p (A.getUnsafe tmp (sizea - 1)) (A.getUnsafe tmp sizea) < 0 then\n S.t ~data:(N.fromSortedArrayAux tmp 0 totalSize) ~cmp\n else\n let tmp2 = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n let k = Sort.unionU tmp 0 sizea tmp sizea sizeb tmp2 0 p in\n S.t ~data:(N.fromSortedArrayAux tmp2 0 k) ~cmp\n\nlet has d x = N.has ~cmp:(S.cmp d) (S.data d) x\nlet copy d = S.t ~data:(N.copy (S.data d)) ~cmp:(S.cmp d)\n"
},
{
"path": "packages/Belt/src/Belt_MutableSet.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** A {i mutable} sorted set module which allows customize {i compare} behavior.\n\n Same as Belt.Set, but mutable. *)\n\nmodule Int = Belt_MutableSetInt\n(** Specalized when key type is [int], more efficient than the generic type *)\n\nmodule String = Belt_MutableSetString\n(** Specalized when key type is [string], more efficient than the generic type *)\n\ntype ('k, 'id) t\ntype ('k, 'id) id = ('k, 'id) Belt_Id.comparable\n\nval make : id:('value, 'id) id -> ('value, 'id) t\nval fromArray : 'k array -> id:('k, 'id) id -> ('k, 'id) t\nval fromSortedArrayUnsafe : 'value array -> id:('value, 'id) id -> ('value, 'id) t\nval copy : ('k, 'id) t -> ('k, 'id) t\nval isEmpty : _ t -> bool\nval has : ('value, _) t -> 'value -> bool\nval add : ('value, 'id) t -> 'value -> unit\nval addCheck : ('value, 'id) t -> 'value -> bool\nval mergeMany : ('value, 'id) t -> 'value array -> unit\nval remove : ('value, 'id) t -> 'value -> unit\nval removeCheck : ('value, 'id) t -> 'value -> bool\n(* [b = removeCheck s e] [b] is true means one element removed *)\n\nval removeMany : ('value, 'id) t -> 'value array -> unit\nval union : ('value, 'id) t -> ('value, 'id) t -> ('value, 'id) t\nval intersect : ('value, 'id) t -> ('value, 'id) t -> ('value, 'id) t\nval diff : ('value, 'id) t -> ('value, 'id) t -> ('value, 'id) t\nval subset : ('value, 'id) t -> ('value, 'id) t -> bool\nval cmp : ('value, 'id) t -> ('value, 'id) t -> int\nval eq : ('value, 'id) t -> ('value, 'id) t -> bool\nval forEachU : ('value, 'id) t -> (('value -> unit)[@u]) -> unit\n\nval forEach : ('value, 'id) t -> ('value -> unit) -> unit\n(** [forEach m f] applies [f] in turn to all elements of [m]. In increasing order *)\n\nval reduceU : ('value, 'id) t -> 'a -> (('a -> 'value -> 'a)[@u]) -> 'a\n\nval reduce : ('value, 'id) t -> 'a -> ('a -> 'value -> 'a) -> 'a\n(** In increasing order. *)\n\nval everyU : ('value, 'id) t -> (('value -> bool)[@u]) -> bool\n\nval every : ('value, 'id) t -> ('value -> bool) -> bool\n(** [every s p] checks if all elements of the set satisfy the predicate [p]. Order unspecified *)\n\nval someU : ('value, 'id) t -> (('value -> bool)[@u]) -> bool\n\nval some : ('value, 'id) t -> ('value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. *)\n\nval keepU : ('value, 'id) t -> (('value -> bool)[@u]) -> ('value, 'id) t\n\nval keep : ('value, 'id) t -> ('value -> bool) -> ('value, 'id) t\n(** [keep s p] returns the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : ('value, 'id) t -> (('value -> bool)[@u]) -> ('value, 'id) t * ('value, 'id) t\n\nval partition : ('value, 'id) t -> ('value -> bool) -> ('value, 'id) t * ('value, 'id) t\n(** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the\n predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : ('value, 'id) t -> int\n\nval toList : ('value, 'id) t -> 'value list\n(** In increasing order*)\n\nval toArray : ('value, 'id) t -> 'value array\n(** In increasing order*)\n\nval minimum : ('value, 'id) t -> 'value option\nval minUndefined : ('value, 'id) t -> 'value Js.undefined\nval maximum : ('value, 'id) t -> 'value option\nval maxUndefined : ('value, 'id) t -> 'value Js.undefined\nval get : ('value, 'id) t -> 'value -> 'value option\nval getUndefined : ('value, 'id) t -> 'value -> 'value Js.undefined\nval getExn : ('value, 'id) t -> 'value -> 'value\n\nval split : ('value, 'id) t -> 'value -> (('value, 'id) t * ('value, 'id) t) * bool\n(** [split s x] returns a triple [((l, r), present)], where [l] is the set of elements of [s] that are strictly less\n than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains\n no element equal to [x], or [true] if [s] contains an element equal to [x]. [l,r] are freshly made, no sharing with\n [s] *)\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\n(*\n [add0] was not exposed for various reasons:\n 1. such api is dangerious\n [ cmp: ('value,'id) Belt_Cmp.cmp ->\n ('value, 'id) t0 -> 'value ->\n ('value, 'id) t0]\n 2. It is not really significantly more *)\n"
},
{
"path": "packages/Belt/src/Belt_MutableSetInt.ml",
"content": "[@@@ocaml.text\n\" This module is {!Belt.MutableSet} specialized with key type to be a primitive type.\\n\\\n\\ It is more efficient in general, the API is the same with {!Belt.MutableSet} except its key type is fixed,\\n\\\n\\ and identity is not needed(using the built-in one) \\n\"]\n\nmodule I = Belt_internalSetInt\nmodule S = Belt_SortArrayInt\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype value = I.value [@@ocaml.doc \" The type of the set elements. \"]\n\ninclude (\n struct\n type t = { mutable data : I.t }\n\n let t : data:I.t -> t = fun ~data -> { data }\n let dataSet : t -> I.t -> unit = fun o v -> o.data <- v\n let data : t -> I.t = fun o -> o.data\n end :\n sig\n type t\n\n val t : data:I.t -> t\n val dataSet : t -> I.t -> unit\n val data : t -> I.t\n end)\n\nlet rec remove0 nt (x : value) =\n let k = N.value nt in\n if x = k then (\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if x < k then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (remove0 l x);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (remove0 r x);\n N.return (N.balMutate nt)\n\nlet remove d v =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some oldRoot2 ->\n let newRoot = remove0 oldRoot2 v in\n if newRoot != oldRoot then dataSet d newRoot\n\nlet rec removeMany0 t xs i len =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = remove0 t ele in\n match N.toOpt u with None -> N.empty | Some t -> removeMany0 t xs (i + 1) len\n else N.return t\n\nlet removeMany (d : t) xs =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some nt ->\n let len = A.length xs in\n dataSet d (removeMany0 nt xs 0 len)\n\nlet rec removeCheck0 nt (x : value) removed =\n let k = N.value nt in\n if x = k then (\n let () = removed := true in\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if x < k then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (removeCheck0 l x removed);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (removeCheck0 r x removed);\n N.return (N.balMutate nt)\n\nlet removeCheck (d : t) v =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> false\n | Some oldRoot2 ->\n let removed = ref false in\n let newRoot = removeCheck0 oldRoot2 v removed in\n if newRoot != oldRoot then dataSet d newRoot;\n !removed\n\nlet rec addCheck0 t (x : value) added =\n match N.toOpt t with\n | None ->\n added := true;\n N.singleton x\n | Some nt ->\n let k = N.value nt in\n if x = k then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < k then\n let ll = addCheck0 l x added in\n N.leftSet nt ll\n else N.rightSet nt (addCheck0 r x added);\n N.return (N.balMutate nt)\n\nlet addCheck (m : t) e =\n let oldRoot = data m in\n let added = ref false in\n let newRoot = addCheck0 oldRoot e added in\n if newRoot != oldRoot then dataSet m newRoot;\n !added\n\nlet add d k =\n let oldRoot = data d in\n let v = I.addMutate oldRoot k in\n if v != oldRoot then dataSet d v\n\nlet addArrayMutate t xs =\n let v = ref t in\n for i = 0 to A.length xs - 1 do\n v := I.addMutate !v (A.getUnsafe xs i)\n done;\n !v\n\nlet mergeMany d arr = dataSet d (addArrayMutate (data d) arr)\nlet make () = t ~data:N.empty\nlet isEmpty d = N.isEmpty (data d)\nlet minimum d = N.minimum (data d)\nlet minUndefined d = N.minUndefined (data d)\nlet maximum d = N.maximum (data d)\nlet maxUndefined d = N.maxUndefined (data d)\nlet forEachU d f = N.forEachU (data d) f\nlet forEach d f = forEachU d (fun a -> f a)\nlet reduceU d acc cb = N.reduceU (data d) acc cb\nlet reduce d acc cb = reduceU d acc (fun a b -> cb a b)\nlet everyU d p = N.everyU (data d) p\nlet every d p = everyU d (fun a -> p a)\nlet someU d p = N.someU (data d) p\nlet some d p = someU d (fun a -> p a)\nlet size d = N.size (data d)\nlet toList d = N.toList (data d)\nlet toArray d = N.toArray (data d)\nlet fromSortedArrayUnsafe xs = t ~data:(N.fromSortedArrayUnsafe xs)\nlet checkInvariantInternal d = N.checkInvariantInternal (data d)\nlet fromArray xs = t ~data:(I.fromArray xs)\nlet cmp d0 d1 = I.cmp (data d0) (data d1)\nlet eq d0 d1 = I.eq (data d0) (data d1)\nlet get d x = I.get (data d) x\nlet getUndefined d x = I.getUndefined (data d) x\nlet getExn d x = I.getExn (data d) x\n\nlet split d key =\n let arr = N.toArray (data d) in\n let i = S.binarySearch arr key in\n let len = A.length arr in\n if i < 0 then\n let next = -i - 1 in\n ((t ~data:(N.fromSortedArrayAux arr 0 next), t ~data:(N.fromSortedArrayAux arr next (len - next))), false)\n else ((t ~data:(N.fromSortedArrayAux arr 0 i), t ~data:(N.fromSortedArrayAux arr (i + 1) (len - i - 1))), true)\n\nlet keepU d p = t ~data:(N.keepCopyU (data d) p)\nlet keep d p = keepU d (fun a -> p a)\n\nlet partitionU d p =\n let a, b = N.partitionCopyU (data d) p in\n (t ~data:a, t ~data:b)\n\nlet partition d p = partitionU d (fun a -> p a)\nlet subset a b = I.subset (data a) (data b)\n\nlet intersect dataa datab =\n let dataa, datab = (data dataa, data datab) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> make ()\n | _, None -> make ()\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n if A.getUnsafe tmp (sizea - 1) < A.getUnsafe tmp sizea || A.getUnsafe tmp (totalSize - 1) < A.getUnsafe tmp 0 then\n make ()\n else\n let tmp2 = A.makeUninitializedUnsafe (min sizea sizeb) (N.value dataa0) in\n let k = S.intersect tmp 0 sizea tmp sizea sizeb tmp2 0 in\n t ~data:(N.fromSortedArrayAux tmp2 0 k)\n\nlet diff dataa datab : t =\n let dataa, datab = (data dataa, data datab) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> make ()\n | _, None -> t ~data:(N.copy dataa)\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n if A.getUnsafe tmp (sizea - 1) < A.getUnsafe tmp sizea || A.getUnsafe tmp (totalSize - 1) < A.getUnsafe tmp 0 then\n t ~data:(N.copy dataa)\n else\n let tmp2 = A.makeUninitializedUnsafe sizea (N.value dataa0) in\n let k = S.diff tmp 0 sizea tmp sizea sizeb tmp2 0 in\n t ~data:(N.fromSortedArrayAux tmp2 0 k)\n\nlet union (dataa : t) (datab : t) : t =\n let dataa, datab = (data dataa, data datab) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> t ~data:(N.copy datab)\n | _, None -> t ~data:(N.copy dataa)\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n if A.getUnsafe tmp (sizea - 1) < A.getUnsafe tmp sizea then t ~data:(N.fromSortedArrayAux tmp 0 totalSize)\n else\n let tmp2 = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n let k = S.union tmp 0 sizea tmp sizea sizeb tmp2 0 in\n t ~data:(N.fromSortedArrayAux tmp2 0 k)\n\nlet has d x = I.has (data d) x\nlet copy d = t ~data:(N.copy (data d))\n"
},
{
"path": "packages/Belt/src/Belt_MutableSetInt.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This module is {!Belt.MutableSet} specialized with key type to be a primitive type.\n\n It is more efficient in general, the API is the same with {!Belt.MutableSet} except its key type is fixed, and\n identity is not needed(using the built-in one)\n\n {b See} {!Belt.MutableSet} *)\n\ntype value = int\n(** The type of the set elements. *)\n\ntype t\n(** The type of sets. *)\n\nval make : unit -> t\nval fromArray : value array -> t\nval fromSortedArrayUnsafe : value array -> t\nval copy : t -> t\nval isEmpty : t -> bool\nval has : t -> value -> bool\nval add : t -> value -> unit\nval addCheck : t -> value -> bool\nval mergeMany : t -> value array -> unit\nval remove : t -> value -> unit\nval removeCheck : t -> value -> bool\nval removeMany : t -> value array -> unit\nval union : t -> t -> t\nval intersect : t -> t -> t\nval diff : t -> t -> t\nval subset : t -> t -> bool\nval cmp : t -> t -> int\nval eq : t -> t -> bool\nval forEachU : t -> ((value -> unit)[@u]) -> unit\n\nval forEach : t -> (value -> unit) -> unit\n(** In increasing order*)\n\nval reduceU : t -> 'a -> (('a -> value -> 'a)[@u]) -> 'a\n\nval reduce : t -> 'a -> ('a -> value -> 'a) -> 'a\n(** Iterate in increasing order. *)\n\nval everyU : t -> ((value -> bool)[@u]) -> bool\n\nval every : t -> (value -> bool) -> bool\n(** [every p s] checks if all elements of the set satisfy the predicate [p]. Order unspecified. *)\n\nval someU : t -> ((value -> bool)[@u]) -> bool\n\nval some : t -> (value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. Oder unspecified. *)\n\nval keepU : t -> ((value -> bool)[@u]) -> t\n\nval keep : t -> (value -> bool) -> t\n(** [keep s p] returns a fresh copy of the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : t -> ((value -> bool)[@u]) -> t * t\n\nval partition : t -> (value -> bool) -> t * t\n(** [partition s p] returns a fresh copy pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that\n satisfy the predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : t -> int\n\nval toList : t -> value list\n(** In increasing order with respect *)\n\nval toArray : t -> value array\n(** In increasing order with respect *)\n\nval minimum : t -> value option\nval minUndefined : t -> value Js.undefined\nval maximum : t -> value option\nval maxUndefined : t -> value Js.undefined\nval get : t -> value -> value option\nval getUndefined : t -> value -> value Js.undefined\nval getExn : t -> value -> value\n\nval split : t -> value -> (t * t) * bool\n(** [split s key] return a fresh copy of each *)\n\nval checkInvariantInternal : t -> unit\n(** {b raise} when invariant is not held *)\n"
},
{
"path": "packages/Belt/src/Belt_MutableSetString.ml",
"content": "[@@@ocaml.text\n\" This module is {!Belt.MutableSet} specialized with key type to be a primitive type.\\n\\\n\\ It is more efficient in general, the API is the same with {!Belt.MutableSet} except its key type is fixed,\\n\\\n\\ and identity is not needed(using the built-in one) \\n\"]\n\nmodule I = Belt_internalSetString\nmodule S = Belt_SortArrayString\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype value = I.value [@@ocaml.doc \" The type of the set elements. \"]\n\ninclude (\n struct\n type t = { mutable data : I.t }\n\n let t : data:I.t -> t = fun ~data -> { data }\n let dataSet : t -> I.t -> unit = fun o v -> o.data <- v\n let data : t -> I.t = fun o -> o.data\n end :\n sig\n type t\n\n val t : data:I.t -> t\n val dataSet : t -> I.t -> unit\n val data : t -> I.t\n end)\n\nlet rec remove0 nt (x : value) =\n let k = N.value nt in\n if x = k then (\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if x < k then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (remove0 l x);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (remove0 r x);\n N.return (N.balMutate nt)\n\nlet remove d v =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some oldRoot2 ->\n let newRoot = remove0 oldRoot2 v in\n if newRoot != oldRoot then dataSet d newRoot\n\nlet rec removeMany0 t xs i len =\n if i < len then\n let ele = A.getUnsafe xs i in\n let u = remove0 t ele in\n match N.toOpt u with None -> N.empty | Some t -> removeMany0 t xs (i + 1) len\n else N.return t\n\nlet removeMany (d : t) xs =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> ()\n | Some nt ->\n let len = A.length xs in\n dataSet d (removeMany0 nt xs 0 len)\n\nlet rec removeCheck0 nt (x : value) removed =\n let k = N.value nt in\n if x = k then (\n let () = removed := true in\n let l, r =\n let open N in\n (left nt, right nt)\n in\n match\n let open N in\n (toOpt l, toOpt r)\n with\n | None, _ -> r\n | _, None -> l\n | Some _, Some nr ->\n N.rightSet nt (N.removeMinAuxWithRootMutate nt nr);\n N.return (N.balMutate nt))\n else if x < k then (\n match N.toOpt (N.left nt) with\n | None -> N.return nt\n | Some l ->\n N.leftSet nt (removeCheck0 l x removed);\n N.return (N.balMutate nt))\n else\n match N.toOpt (N.right nt) with\n | None -> N.return nt\n | Some r ->\n N.rightSet nt (removeCheck0 r x removed);\n N.return (N.balMutate nt)\n\nlet removeCheck (d : t) v =\n let oldRoot = data d in\n match N.toOpt oldRoot with\n | None -> false\n | Some oldRoot2 ->\n let removed = ref false in\n let newRoot = removeCheck0 oldRoot2 v removed in\n if newRoot != oldRoot then dataSet d newRoot;\n !removed\n\nlet rec addCheck0 t (x : value) added =\n match N.toOpt t with\n | None ->\n added := true;\n N.singleton x\n | Some nt ->\n let k = N.value nt in\n if x = k then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < k then\n let ll = addCheck0 l x added in\n N.leftSet nt ll\n else N.rightSet nt (addCheck0 r x added);\n N.return (N.balMutate nt)\n\nlet addCheck (m : t) e =\n let oldRoot = data m in\n let added = ref false in\n let newRoot = addCheck0 oldRoot e added in\n if newRoot != oldRoot then dataSet m newRoot;\n !added\n\nlet add d k =\n let oldRoot = data d in\n let v = I.addMutate oldRoot k in\n if v != oldRoot then dataSet d v\n\nlet addArrayMutate t xs =\n let v = ref t in\n for i = 0 to A.length xs - 1 do\n v := I.addMutate !v (A.getUnsafe xs i)\n done;\n !v\n\nlet mergeMany d arr = dataSet d (addArrayMutate (data d) arr)\nlet make () = t ~data:N.empty\nlet isEmpty d = N.isEmpty (data d)\nlet minimum d = N.minimum (data d)\nlet minUndefined d = N.minUndefined (data d)\nlet maximum d = N.maximum (data d)\nlet maxUndefined d = N.maxUndefined (data d)\nlet forEachU d f = N.forEachU (data d) f\nlet forEach d f = forEachU d (fun a -> f a)\nlet reduceU d acc cb = N.reduceU (data d) acc cb\nlet reduce d acc cb = reduceU d acc (fun a b -> cb a b)\nlet everyU d p = N.everyU (data d) p\nlet every d p = everyU d (fun a -> p a)\nlet someU d p = N.someU (data d) p\nlet some d p = someU d (fun a -> p a)\nlet size d = N.size (data d)\nlet toList d = N.toList (data d)\nlet toArray d = N.toArray (data d)\nlet fromSortedArrayUnsafe xs = t ~data:(N.fromSortedArrayUnsafe xs)\nlet checkInvariantInternal d = N.checkInvariantInternal (data d)\nlet fromArray xs = t ~data:(I.fromArray xs)\nlet cmp d0 d1 = I.cmp (data d0) (data d1)\nlet eq d0 d1 = I.eq (data d0) (data d1)\nlet get d x = I.get (data d) x\nlet getUndefined d x = I.getUndefined (data d) x\nlet getExn d x = I.getExn (data d) x\n\nlet split d key =\n let arr = N.toArray (data d) in\n let i = S.binarySearch arr key in\n let len = A.length arr in\n if i < 0 then\n let next = -i - 1 in\n ((t ~data:(N.fromSortedArrayAux arr 0 next), t ~data:(N.fromSortedArrayAux arr next (len - next))), false)\n else ((t ~data:(N.fromSortedArrayAux arr 0 i), t ~data:(N.fromSortedArrayAux arr (i + 1) (len - i - 1))), true)\n\nlet keepU d p = t ~data:(N.keepCopyU (data d) p)\nlet keep d p = keepU d (fun a -> p a)\n\nlet partitionU d p =\n let a, b = N.partitionCopyU (data d) p in\n (t ~data:a, t ~data:b)\n\nlet partition d p = partitionU d (fun a -> p a)\nlet subset a b = I.subset (data a) (data b)\n\nlet intersect dataa datab =\n let dataa, datab = (data dataa, data datab) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> make ()\n | _, None -> make ()\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n if A.getUnsafe tmp (sizea - 1) < A.getUnsafe tmp sizea || A.getUnsafe tmp (totalSize - 1) < A.getUnsafe tmp 0 then\n make ()\n else\n let tmp2 = A.makeUninitializedUnsafe (min sizea sizeb) (N.value dataa0) in\n let k = S.intersect tmp 0 sizea tmp sizea sizeb tmp2 0 in\n t ~data:(N.fromSortedArrayAux tmp2 0 k)\n\nlet diff dataa datab : t =\n let dataa, datab = (data dataa, data datab) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> make ()\n | _, None -> t ~data:(N.copy dataa)\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n if A.getUnsafe tmp (sizea - 1) < A.getUnsafe tmp sizea || A.getUnsafe tmp (totalSize - 1) < A.getUnsafe tmp 0 then\n t ~data:(N.copy dataa)\n else\n let tmp2 = A.makeUninitializedUnsafe sizea (N.value dataa0) in\n let k = S.diff tmp 0 sizea tmp sizea sizeb tmp2 0 in\n t ~data:(N.fromSortedArrayAux tmp2 0 k)\n\nlet union (dataa : t) (datab : t) : t =\n let dataa, datab = (data dataa, data datab) in\n match (N.toOpt dataa, N.toOpt datab) with\n | None, _ -> t ~data:(N.copy datab)\n | _, None -> t ~data:(N.copy dataa)\n | Some dataa0, Some datab0 ->\n let sizea, sizeb = (N.lengthNode dataa0, N.lengthNode datab0) in\n let totalSize = sizea + sizeb in\n let tmp = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n ignore @@ N.fillArray dataa0 0 tmp;\n ignore @@ N.fillArray datab0 sizea tmp;\n if A.getUnsafe tmp (sizea - 1) < A.getUnsafe tmp sizea then t ~data:(N.fromSortedArrayAux tmp 0 totalSize)\n else\n let tmp2 = A.makeUninitializedUnsafe totalSize (N.value dataa0) in\n let k = S.union tmp 0 sizea tmp sizea sizeb tmp2 0 in\n t ~data:(N.fromSortedArrayAux tmp2 0 k)\n\nlet has d x = I.has (data d) x\nlet copy d = t ~data:(N.copy (data d))\n"
},
{
"path": "packages/Belt/src/Belt_MutableSetString.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This module is {!Belt.MutableSet} specialized with key type to be a primitive type.\n\n It is more efficient in general, the API is the same with {!Belt.MutableSet} except its key type is fixed, and\n identity is not needed(using the built-in one)\n\n {b See} {!Belt.MutableSet} *)\n\ntype value = string\n(** The type of the set elements. *)\n\ntype t\n(** The type of sets. *)\n\nval make : unit -> t\nval fromArray : value array -> t\nval fromSortedArrayUnsafe : value array -> t\nval copy : t -> t\nval isEmpty : t -> bool\nval has : t -> value -> bool\nval add : t -> value -> unit\nval addCheck : t -> value -> bool\nval mergeMany : t -> value array -> unit\nval remove : t -> value -> unit\nval removeCheck : t -> value -> bool\nval removeMany : t -> value array -> unit\nval union : t -> t -> t\nval intersect : t -> t -> t\nval diff : t -> t -> t\nval subset : t -> t -> bool\nval cmp : t -> t -> int\nval eq : t -> t -> bool\nval forEachU : t -> ((value -> unit)[@u]) -> unit\n\nval forEach : t -> (value -> unit) -> unit\n(** In increasing order*)\n\nval reduceU : t -> 'a -> (('a -> value -> 'a)[@u]) -> 'a\n\nval reduce : t -> 'a -> ('a -> value -> 'a) -> 'a\n(** Iterate in increasing order. *)\n\nval everyU : t -> ((value -> bool)[@u]) -> bool\n\nval every : t -> (value -> bool) -> bool\n(** [every p s] checks if all elements of the set satisfy the predicate [p]. Order unspecified. *)\n\nval someU : t -> ((value -> bool)[@u]) -> bool\n\nval some : t -> (value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. Oder unspecified. *)\n\nval keepU : t -> ((value -> bool)[@u]) -> t\n\nval keep : t -> (value -> bool) -> t\n(** [keep s p] returns a fresh copy of the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : t -> ((value -> bool)[@u]) -> t * t\n\nval partition : t -> (value -> bool) -> t * t\n(** [partition s p] returns a fresh copy pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that\n satisfy the predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : t -> int\n\nval toList : t -> value list\n(** In increasing order with respect *)\n\nval toArray : t -> value array\n(** In increasing order with respect *)\n\nval minimum : t -> value option\nval minUndefined : t -> value Js.undefined\nval maximum : t -> value option\nval maxUndefined : t -> value Js.undefined\nval get : t -> value -> value option\nval getUndefined : t -> value -> value Js.undefined\nval getExn : t -> value -> value\n\nval split : t -> value -> (t * t) * bool\n(** [split s key] return a fresh copy of each *)\n\nval checkInvariantInternal : t -> unit\n(** {b raise} when invariant is not held *)\n"
},
{
"path": "packages/Belt/src/Belt_MutableStack.ml",
"content": "include (\n struct\n type 'a t = { mutable root : 'a opt_cell }\n and 'a opt_cell = 'a cell Js.null\n and 'a cell = { head : 'a; tail : 'a opt_cell }\n\n let t : root:'a opt_cell -> 'a t = fun ~root -> { root }\n let rootSet : 'a t -> 'a opt_cell -> unit = fun o v -> o.root <- v\n let root : 'a t -> 'a opt_cell = fun o -> o.root\n let cell : head:'a -> tail:'a opt_cell -> 'a cell = fun ~head ~tail -> { head; tail }\n let head : 'a cell -> 'a = fun o -> o.head\n let tail : 'a cell -> 'a opt_cell = fun o -> o.tail\n end :\n sig\n type 'a t\n and 'a opt_cell = 'a cell Js.null\n and 'a cell\n\n val t : root:'a opt_cell -> 'a t\n val rootSet : 'a t -> 'a opt_cell -> unit\n val root : 'a t -> 'a opt_cell\n val cell : head:'a -> tail:'a opt_cell -> 'a cell\n val head : 'a cell -> 'a\n val tail : 'a cell -> 'a opt_cell\n end)\n\nlet make () = t ~root:Js.null\nlet clear s = rootSet s Js.null\nlet copy (s : _ t) : _ t = t ~root:(root s)\nlet push s x = rootSet s (Js.Null.return @@ cell ~head:x ~tail:(root s))\n\nlet topUndefined (s : 'a t) =\n match Js.nullToOption (root s) with None -> Js.undefined | Some x -> Js.Undefined.return (head x)\n\nlet top s = match Js.nullToOption (root s) with None -> None | Some x -> Some (head x)\nlet isEmpty s = root s = Js.null\n\nlet popUndefined s =\n match Js.nullToOption (root s) with\n | None -> Js.undefined\n | Some x ->\n rootSet s (tail x);\n Js.Undefined.return (head x)\n\nlet pop s =\n match Js.nullToOption (root s) with\n | None -> None\n | Some x ->\n rootSet s (tail x);\n Some (head x)\n\nlet rec lengthAux (x : _ cell) acc =\n match Js.nullToOption (tail x) with None -> acc + 1 | Some x -> lengthAux x (acc + 1)\n\nlet size s = match Js.nullToOption (root s) with None -> 0 | Some x -> lengthAux x 0\n\nlet rec iterAux (s : _ opt_cell) f =\n match Js.nullToOption s with\n | None -> ()\n | Some x ->\n f (head x);\n iterAux (tail x) f\n\nlet forEachU s f = iterAux (root s) f\nlet forEach s f = forEachU s (fun x -> f x)\n\nlet dynamicPopIterU s f =\n let cursor = ref (root s) in\n while !cursor != Js.null do\n let v = Js.Null.getUnsafe !cursor in\n rootSet s (tail v);\n f (head v);\n cursor := root s\n done\n\nlet dynamicPopIter s f = dynamicPopIterU s (fun x -> f x)\n"
},
{
"path": "packages/Belt/src/Belt_MutableStack.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** First in last out stack.\n\n This module implements stacks, with in-place modification. *)\n\ntype 'a t\n\nval make : unit -> 'a t\n(** @return a new stack, initially empty. *)\n\nval clear : 'a t -> unit\n(** Discard all elements from the stack. *)\n\nval copy : 'a t -> 'a t\n(** [copy x] O(1) operation, return a new stack *)\n\nval push : 'a t -> 'a -> unit\nval popUndefined : 'a t -> 'a Js.undefined\nval pop : 'a t -> 'a option\nval topUndefined : 'a t -> 'a Js.undefined\nval top : 'a t -> 'a option\nval isEmpty : 'a t -> bool\nval size : 'a t -> int\nval forEachU : 'a t -> (('a -> unit)[@u]) -> unit\nval forEach : 'a t -> ('a -> unit) -> unit\nval dynamicPopIterU : 'a t -> (('a -> unit)[@u]) -> unit\n\nval dynamicPopIter : 'a t -> ('a -> unit) -> unit\n(** [dynamicPopIter s f ] apply [f] to each element of [s]. The item is poped before applying [f], [s] will be empty\n after this opeartion. This function is useful for worklist algorithm *)\n"
},
{
"path": "packages/Belt/src/Belt_Option.ml",
"content": "let getExn = function\n | Some x -> x\n | None ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n\nlet mapWithDefaultU opt default f = match opt with Some x -> f x | None -> default\nlet mapWithDefault opt default f = mapWithDefaultU opt default (fun x -> f x)\nlet mapU opt f = match opt with Some x -> Some (f x) | None -> None\nlet map opt f = mapU opt (fun x -> f x)\nlet flatMapU opt f = match opt with Some x -> f x | None -> None\nlet flatMap opt f = flatMapU opt (fun x -> f x)\nlet getWithDefault opt default = match opt with Some x -> x | None -> default\nlet orElse opt other = match opt with Some _ -> opt | None -> other\nlet isSome = function Some _ -> true | None -> false\nlet isNone = function Some _ -> false | None -> true\nlet eqU a b f = match (a, b) with Some a, Some b -> f a b | None, Some _ | Some _, None -> false | None, None -> true\nlet eq a b f = eqU a b (fun x y -> f x y)\nlet cmpU a b f = match (a, b) with Some a, Some b -> f a b | None, Some _ -> -1 | Some _, None -> 1 | None, None -> 0\nlet cmp a b f = cmpU a b (fun x y -> f x y)\nlet keepU opt f = match opt with Some x when f x -> opt | Some _ | None -> None\nlet keep opt f = keepU opt (fun x -> f x)\nlet forEachU opt f = match opt with Some x -> f x | None -> ()\nlet forEach opt f = forEachU opt (fun x -> f x)\n\nexternal getUnsafe : 'a option -> 'a = \"%identity\"\n"
},
{
"path": "packages/Belt/src/Belt_Option.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** {!Belt.Option}\n\n Utilities for option data type *)\n\nval keepU : 'a option -> (('a -> bool)[@u]) -> 'a option\n(** Uncurried version of [keep] *)\n\nval keep : 'a option -> ('a -> bool) -> 'a option\n(** [keep optionValue p]\n\n If [optionValue] is [Some value] and [p value = true], it returns [Some value]; otherwise returns [None]\n\n {[\n keep (Some 10) (fun x -> x > 5);;\n\n (* returns [Some 10] *)\n keep (Some 4) (fun x -> x > 5);;\n\n (* returns [None] *)\n keep None (fun x -> x > 5) (* returns [None] *)\n ]} *)\n\nval forEachU : 'a option -> (('a -> unit)[@u]) -> unit\n(** Uncurried version of [forEach] *)\n\nval forEach : 'a option -> ('a -> unit) -> unit\n(** [forEach optionValue f]\n\n If [optionValue] is [Some value], it calls [f value]; otherwise returns [()]\n\n {[\n forEach (Some \"thing\") (fun x -> Js.log x);;\n\n (* logs \"thing\" *)\n forEach None (fun x -> Js.log x) (* returns () *)\n ]} *)\n\nval getExn : 'a option -> 'a\n(** [getExn optionalValue] Returns [value] if [optionalValue] is [Some value], otherwise raises [getExn]\n\n {[\n getExn (Some 3) = 3;;\n getExn None (* Raises getExn error *)\n ]} *)\n\nexternal getUnsafe : 'a option -> 'a = \"%identity\"\n(** [getUnsafe x] returns x This is an unsafe operation, it assumes x is neither not None or (Some (None .. )) *)\n\nval mapWithDefaultU : 'a option -> 'b -> (('a -> 'b)[@u]) -> 'b\n(** Uncurried version of [mapWithDefault] *)\n\nval mapWithDefault : 'a option -> 'b -> ('a -> 'b) -> 'b\n(** [mapWithDefault optionValue default f]\n\n If [optionValue] is [Some value], returns [f value]; otherwise returns [default]\n\n {[\n mapWithDefault (Some 3) 0 (fun x -> x + 5) = 8;;\n mapWithDefault None 0 (fun x -> x + 5) = 0\n ]} *)\n\nval mapU : 'a option -> (('a -> 'b)[@u]) -> 'b option\n(** Uncurried version of [map] *)\n\nval map : 'a option -> ('a -> 'b) -> 'b option\n(** [map optionValue f]\n\n If [optionValue] is [Some value], returns [Some (f value)]; otherwise returns [None]\n\n {[\n map (Some 3) (fun x -> x * x) = Some 9;;\n map None (fun x -> x * x) = None\n ]} *)\n\nval flatMapU : 'a option -> (('a -> 'b option)[@u]) -> 'b option\n(** Uncurried version of [flatMap] *)\n\nval flatMap : 'a option -> ('a -> 'b option) -> 'b option\n(** [flatMap optionValue f]\n\n If [optionValue] is [Some value], returns [f value]; otherwise returns [None] The function [f] must have a return\n type of ['a option]\n\n {[\n let f (x : float) = if x >= 0.0 then Some (sqrt x) else None;;\n\n flatMap (Some 4.0) f = Some 2.0;;\n flatMap (Some (-4.0)) f = None;;\n flatMap None f = None\n ]} *)\n\nval getWithDefault : 'a option -> 'a -> 'a\n(** [getWithDefault optionalValue default]\n\n If [optionalValue] is [Some value], returns [value], otherwise [default]\n\n {[\n getWithDefault (Some 1812) 1066 = 1812;;\n getWithDefault None 1066 = 1066\n ]} *)\n\nval orElse : 'a option -> 'a option -> 'a option\n(** [orElse optionalValue otherOptional]\n\n If [optionalValue] is [Some value], returns [Some value], otherwise [otherOptional]\n\n {[\n orElse (Some 1812) (Some 1066) = Some 1812;;\n orElse None (Some 1066) = Some 1066;;\n orElse None None = None\n ]} *)\n\nval isSome : 'a option -> bool\n(** Returns [true] if the argument is [Some value], [false] otherwise *)\n\nval isNone : 'a option -> bool\n(** Returns [true] if the argument is [None], [false] otherwise *)\n\nval eqU : 'a option -> 'b option -> (('a -> 'b -> bool)[@u]) -> bool\n(** Uncurried version of [eq] *)\n\nval eq : 'a option -> 'b option -> ('a -> 'b -> bool) -> bool\n(** [eq optValue1 optvalue2 predicate]\n\n Evaluates two optional values for equality with respect to a predicate function.\n\n If both [optValue1] and [optValue2] are [None], returns [true].\n\n If one of the arguments is [Some value] and the other is [None], returns [false]\n\n If arguments are [Some value1] and [Some value2], returns the result of [predicate value1 value2]; the [predicate]\n function must return a [bool]\n\n {[\n let clockEqual = fun a b -> a mod 12 = b mod 12;;\n\n eq (Some 3) (Some 15) clockEqual = true;;\n eq (Some 3) None clockEqual = false;;\n eq None (Some 3) clockEqual = false;;\n eq None None clockEqual = true\n ]} *)\n\nval cmpU : 'a option -> 'b option -> (('a -> 'b -> int)[@u]) -> int\n(** Uncurried version of [cmp] *)\n\nval cmp : 'a option -> 'b option -> ('a -> 'b -> int) -> int\n(** [cmp optValue1 optvalue2 comparisonFcn]\n\n Compares two optional values with respect to a comparison function\n\n If both [optValue1] and [optValue2] are [None], returns 0.\n\n If the first argument is [Some value1] and the second is [None], returns 1 (something is greater than nothing)\n\n If the first argument is [None] and the second is [Some value2], returns -1 (nothing is less than something)\n\n If the arguments are [Some value1] and [Some value2], returns the result of [comparisonFcn value1 value2];\n [comparisonFcn] takes two arguments and returns -1 if the first argument is less than the second, 0 if the arguments\n are equal, and 1 if the first argument is greater than the second.\n\n {[\n let clockCompare = fun a b -> compare (a mod 12) (b mod 12);;\n\n cmp (Some 3) (Some 15) clockCompare = 0;;\n cmp (Some 3) (Some 14) clockCompare = 1;;\n cmp (Some 2) (Some 15) clockCompare = -1;;\n cmp None (Some 15) clockCompare = -1;;\n cmp (Some 14) None clockCompare = 1;;\n cmp None None clockCompare = 0\n ]} *)\n"
},
{
"path": "packages/Belt/src/Belt_Range.ml",
"content": "let forEachU s f action =\n for i = s to f do\n (action i : unit)\n done\n\nlet forEach s f action = forEachU s f (fun a -> action a)\nlet rec everyU s f p = if s > f then true else p s && everyU (s + 1) f p\nlet every s f p = everyU s f (fun a -> p a)\nlet rec everyByAux s f ~step p = if s > f then true else p s && everyByAux (s + step) f ~step p\nlet everyByU s f ~step p = if step > 0 then everyByAux s f ~step p else true\nlet everyBy s f ~step p = everyByU s f ~step (fun a -> p a)\nlet rec someU s f p = if s > f then false else p s || someU (s + 1) f p\nlet some s f p = someU s f (fun a -> p a)\nlet rec someByAux s f ~step p = if s > f then false else p s || someByAux (s + step) f ~step p\nlet someByU s f ~step p = if step > 0 then someByAux s f ~step p else false\nlet someBy s f ~step p = someByU s f ~step (fun a -> p a)\n"
},
{
"path": "packages/Belt/src/Belt_Range.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** A small module to provide a inclusive range operations [[start, finsish]], it use a for-loop internally instead of\n creating an array *)\n\nval forEachU : int -> int -> ((int -> unit)[@u]) -> unit\n\nval forEach : int -> int -> (int -> unit) -> unit\n(** [forEach start finish action]\n\n equivalent to [Belt.Array.(forEach (range start finish) action)] *)\n\nval everyU : int -> int -> ((int -> bool)[@u]) -> bool\n\nval every : int -> int -> (int -> bool) -> bool\n(** [every start finish p]\n\n equivalent to [Belt.Array.(every (range start finish) p )] *)\n\nval everyByU : int -> int -> step:int -> ((int -> bool)[@u]) -> bool\n\nval everyBy : int -> int -> step:int -> (int -> bool) -> bool\n(** [everyBy start finish ~step p]\n\n {b See} {!Belt.Array.rangeBy}\n\n equivalent to [Belt.Array.(every (rangeBy start finish ~step) p)] *)\n\nval someU : int -> int -> ((int -> bool)[@u]) -> bool\n\nval some : int -> int -> (int -> bool) -> bool\n(** [some start finish p]\n\n equivalent to [Belt.Array.(some (range start finish) p)] *)\n\nval someByU : int -> int -> step:int -> ((int -> bool)[@u]) -> bool\n\nval someBy : int -> int -> step:int -> (int -> bool) -> bool\n(** [someBy start finish ~step p]\n\n {b See} {!Belt.Array.rangeBy}\n\n equivalent to [Belt.Array.(some (rangeBy start finish ~step) p)] *)\n"
},
{
"path": "packages/Belt/src/Belt_Result.ml",
"content": "type ('a, 'b) t = ('a, 'b) result = Ok of 'a | Error of 'b\n\nlet getExn = function\n | Ok x -> x\n | Error _ ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n\nlet mapWithDefaultU opt default f = match opt with Ok x -> f x | Error _ -> default\nlet mapWithDefault opt default f = mapWithDefaultU opt default (fun x -> f x)\nlet mapU opt f = match opt with Ok x -> Ok (f x) | Error y -> Error y\nlet map opt f = mapU opt (fun x -> f x)\nlet flatMapU opt f = match opt with Ok x -> f x | Error y -> Error y\nlet flatMap opt f = flatMapU opt (fun x -> f x)\nlet getWithDefault opt default = match opt with Ok x -> x | Error _ -> default\nlet isOk = function Ok _ -> true | Error _ -> false\nlet isError = function Ok _ -> false | Error _ -> true\n\nlet eqU a b f =\n match (a, b) with Ok a, Ok b -> f a b | Error _, Ok _ | Ok _, Error _ -> false | Error _, Error _ -> true\n\nlet eq a b f = eqU a b (fun x y -> f x y)\n\nlet cmpU a b f =\n match (a, b) with Ok a, Ok b -> f a b | Error _, Ok _ -> -1 | Ok _, Error _ -> 1 | Error _, Error _ -> 0\n\nlet cmp a b f = cmpU a b (fun x y -> f x y)\n"
},
{
"path": "packages/Belt/src/Belt_Result.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** {!Belt.Result}\n\n Utilities for result data type. *)\n\n(** [Belt.Result] is a data type with two variants: [Ok] and [Error]. Each of these variants can contain data, and those\n two pieces of data need not have the same data type. [Belt.Result] is useful when you need to not only determine\n whether some data is valid or not (use [Belt.Option] for that), but also keep information about the invalid data.\n\n In the examples, we presume the existence of two variables:\n\n {[\n let good = Ok 42\n let bad = Error \"Invalid data\"\n ]} *)\n\ntype ('a, 'b) t = ('a, 'b) Stdlib.result = Ok of 'a | Error of 'b\n\nval getExn : ('a, 'b) t -> 'a\n(** [getExn res]\n\n when [res] is [Ok n], returns [n] when [res] is [Error m], {b raise} an exception\n\n {[\n getExn good = 42;;\n getExn bad (* raises exception *)\n ]} *)\n\nval mapWithDefaultU : ('a, 'c) t -> 'b -> (('a -> 'b)[@u]) -> 'b\n\nval mapWithDefault : ('a, 'c) t -> 'b -> ('a -> 'b) -> 'b\n(** [mapWithDefault res default f]\n\n When [res] is [Ok n], returns [f n], otherwise [default].\n\n {[\n mapWithDefault good 0 (fun x -> x / 2) = 21 mapWithDefault bad 0 (fun x -> x / 2) = 0\n ]} *)\n\nval mapU : ('a, 'c) t -> (('a -> 'b)[@u]) -> ('b, 'c) t\n\nval map : ('a, 'c) t -> ('a -> 'b) -> ('b, 'c) t\n(** [map res f]\n\n When [res] is [Ok n], returns [Ok (f n)]. Otherwise returns [res] unchanged. Function [f] takes a value of the same\n type as [n] and returns an ordinary value.\n\n {[\n let f x = sqrt (float_of_int x)\n map (Ok 64) f = Ok 8.0\n map (Error \"Invalid data\") f = Error \"Invalid data\"\n ]} *)\n\nval flatMapU : ('a, 'c) t -> (('a -> ('b, 'c) t)[@u]) -> ('b, 'c) t\n\nval flatMap : ('a, 'c) t -> ('a -> ('b, 'c) t) -> ('b, 'c) t\n(** [flatMap res f]\n\n When [res] is [Ok n], returns [f n]. Otherwise, returns [res] unchanged. Function [f] takes a value of the same type\n as [n] and returns a [Belt.Result].\n\n {[\n let recip x =\n if x != 0.0\n then\n Ok (1.0 /. x)\n else\n Error \"Divide by zero\"\n\n flatMap (Ok 2.0) recip = Ok 0.5\n flatMap (Ok 0.0) recip = Error \"Divide by zero\"\n flatMap (Error \"Already bad\") recip = Error \"Already bad\"\n ]} *)\n\nval getWithDefault : ('a, 'b) t -> 'a -> 'a\n(** [getWithDefault res defaultValue]\n\n if [res] is [Ok n], returns [n], otherwise [default]\n\n {[\n getWithDefault (Ok 42) 0 = 42 getWithDefault (Error \"Invalid Data\") = 0\n ]} *)\n\nval isOk : ('a, 'b) t -> bool\n(** [isOk res]\n\n Returns [true] if [res] is of the form [Ok n], [false] if it is the [Error e] variant. *)\n\nval isError : ('a, 'b) t -> bool\n(** [isError res]\n\n Returns [true] if [res] is of the form [Error e], [false] if it is the [Ok n] variant. *)\n\nval eqU : ('a, 'c) t -> ('b, 'd) t -> (('a -> 'b -> bool)[@u]) -> bool\n\nval eq : ('a, 'c) t -> ('b, 'd) t -> ('a -> 'b -> bool) -> bool\n(** [eq res1 res2 f]\n\n Determine if two [Belt.Result] variables are equal with respect to an equality function. If [res1] and [res2] are of\n the form [Ok n] and [Ok m], return the result of [f n m]. If one of [res1] and [res2] are of the form [Error e],\n return false If both [res1] and [res2] are of the form [Error e], return true\n\n {[\n let good1 = Ok 42\n let good2 = Ok 32\n let bad1 = Error \"invalid\"\n let bad2 = Error \"really invalid\"\n\n let mod10equal a b =\n a mod 10 == b mod 10\n\n eq good1 good2 mod10equal = true\n eq good1 bad1 mod10equal = false\n eq bad2 good2 mod10equal = false\n eq bad1 bad2 mod10equal = true\n ]} *)\n\nval cmpU : ('a, 'c) t -> ('b, 'd) t -> (('a -> 'b -> int)[@u]) -> int\n\nval cmp : ('a, 'c) t -> ('b, 'd) t -> ('a -> 'b -> int) -> int\n(** [cmp res1 res2 f]\n\n Compare two [Belt.Result] variables with respect to a comparison function. The comparison function returns -1 if the\n first variable is \"less than\" the second, 0 if the two variables are equal, and 1 if the first is \"greater than\" the\n second.\n\n If [res1] and [res2] are of the form [Ok n] and [Ok m], return the result of [f n m]. If [res1] is of the form\n [Error e] and [res2] of the form [Ok n], return -1 (nothing is less than something) If [res1] is of the form [Ok n]\n and [res2] of the form [Error e], return 1 (something is greater than nothing) If both [res1] and [res2] are of the\n form [Error e], return 0 (equal)\n\n {[\n let good1 = Ok 59\n let good2 = Ok 37\n let bad1 = Error \"invalid\"\n let bad2 = Error \"really invalid\"\n\n let mod10cmp a b =\n Pervasives.compare (a mod 10) (b mod 10) cmp (Ok 39) (Ok 57) mod10cmp\n = 1 cmp (Ok 57) (Ok 39) mod10cmp\n = -1 cmp (Ok 39) (Error \"y\") mod10cmp\n = 1 cmp (Error \"x\") (Ok 57) mod10cmp\n = -1 cmp (Error \"x\") (Error \"y\") mod10cmp\n = 0\n ]} *)\n"
},
{
"path": "packages/Belt/src/Belt_Set.ml",
"content": "(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\nmodule Int = Belt_SetInt\nmodule String = Belt_SetString\nmodule Dict = Belt_SetDict\n\ntype ('value, 'id) id = ('value, 'id) Belt_Id.comparable\ntype ('value, 'id) cmp = ('value, 'id) Belt_Id.cmp\ntype ('value, 'id) t = { cmp : ('value, 'id) cmp; data : ('value, 'id) Dict.t }\n\nlet fromArray (type value identity) data ~(id : (value, identity) id) =\n let module M = (val id) in\n let cmp = M.cmp in\n { cmp; data = Dict.fromArray ~cmp data }\n\nlet remove m e =\n let { cmp; data } = m in\n let newData = Dict.remove ~cmp data e in\n if newData == data then m else { cmp; data = newData }\n\nlet add m e =\n let { cmp; data } = m in\n let newData = Dict.add ~cmp data e in\n if newData == data then m else { cmp; data = newData }\n\nlet mergeMany ({ cmp; _ } as m) e = { cmp; data = Dict.mergeMany ~cmp m.data e }\nlet removeMany ({ cmp; _ } as m) e = { cmp; data = Dict.removeMany ~cmp m.data e }\nlet union ({ cmp; _ } as m) n = { data = Dict.union ~cmp m.data n.data; cmp }\n\nlet intersect m n =\n let cmp = m.cmp in\n { data = Dict.intersect ~cmp m.data n.data; cmp }\n\nlet diff m n =\n let cmp = m.cmp in\n { cmp; data = Dict.diff ~cmp m.data n.data }\n\nlet subset m n =\n let cmp = m.cmp in\n Dict.subset ~cmp m.data n.data\n\nlet split m e =\n let cmp = m.cmp in\n let (l, r), b = Dict.split ~cmp m.data e in\n (({ cmp; data = l }, { cmp; data = r }), b)\n\nlet make (type value identity) ~(id : (value, identity) id) =\n let module M = (val id) in\n { cmp = M.cmp; data = Dict.empty }\n\nlet isEmpty m = Dict.isEmpty m.data\n\nlet cmp m n =\n let cmp = m.cmp in\n Dict.cmp ~cmp m.data n.data\n\nlet eq m n = Dict.eq ~cmp:m.cmp m.data n.data\nlet forEachU m f = Dict.forEachU m.data f\nlet forEach m f = forEachU m (fun[@u] a -> f a)\nlet reduceU m acc f = Dict.reduceU m.data acc f\nlet reduce m acc f = reduceU m acc (fun[@u] a b -> f a b)\nlet everyU m f = Dict.everyU m.data f\nlet every m f = everyU m (fun[@u] a -> f a)\nlet someU m f = Dict.someU m.data f\nlet some m f = someU m (fun[@u] a -> f a)\nlet keepU m f = { cmp = m.cmp; data = Dict.keepU m.data f }\nlet keep m f = keepU m (fun[@u] a -> f a)\n\nlet partitionU m f =\n let l, r = Dict.partitionU m.data f in\n let cmp = m.cmp in\n ({ data = l; cmp }, { data = r; cmp })\n\nlet partition m f = partitionU m (fun[@u] a -> f a)\nlet size m = Dict.size m.data\nlet toList m = Dict.toList m.data\nlet toArray m = Dict.toArray m.data\nlet minimum m = Dict.minimum m.data\nlet minUndefined m = Dict.minUndefined m.data\nlet maximum m = Dict.maximum m.data\nlet maxUndefined m = Dict.maxUndefined m.data\nlet get m e = Dict.get ~cmp:m.cmp m.data e\nlet getUndefined m e = Dict.getUndefined ~cmp:m.cmp m.data e\nlet getExn m e = Dict.getExn ~cmp:m.cmp m.data e\nlet has m e = Dict.has ~cmp:m.cmp m.data e\n\nlet fromSortedArrayUnsafe (type value identity) xs ~(id : (value, identity) id) =\n let module M = (val id) in\n { cmp = M.cmp; data = Dict.fromSortedArrayUnsafe xs }\n\nlet getData m = m.data\n\nlet getId (type value identity) (m : (value, identity) t) : (value, identity) id =\n let module T = struct\n type nonrec identity = identity\n type nonrec t = value\n\n let cmp = m.cmp\n end in\n (module T)\n\nlet packIdData (type value identity) ~(id : (value, identity) id) ~data =\n let module M = (val id) in\n { cmp = M.cmp; data }\n\nlet checkInvariantInternal d = Dict.checkInvariantInternal d.data\n"
},
{
"path": "packages/Belt/src/Belt_Set.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** A {i immutable} sorted set module which allows customize {i compare} behavior.\n\n The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the\n size of the map.\n\n For more info on this module's usage of identity, `make` and others, please see the top level documentation of Belt,\n {b A special encoding for collection safety}.\n\n Example usage:\n\n {[\n module PairComparator = Belt.Id.MakeComparable (struct\n type t = int * int\n\n let cmp (a0, a1) (b0, b1) = match Pervasives.compare a0 b0 with 0 -> Pervasives.compare a1 b1 | c -> c\n end)\n\n let mySet = Belt.Set.make ~id:(module PairComparator)\n let mySet2 = Belt.Set.add mySet (1, 2)\n ]}\n\n The API documentation below will assume a predeclared comparator module for integers, IntCmp *)\n\nmodule Int = Belt_SetInt\n(** Specalized when value type is [int], more efficient than the generic type, its compare behavior is fixed using the\n built-in comparison *)\n\nmodule String = Belt_SetString\n(** Specalized when value type is [string], more efficient than the generic type, its compare behavior is fixed using\n the built-in comparison *)\n\nmodule Dict = Belt_SetDict\n(** This module seprate identity from data, it is a bit more verboe but slightly more efficient due to the fact that\n there is no need to pack identity and data back after each operation *)\n\ntype ('value, 'identity) t\n(** [('value, 'identity) t]\n\n ['value] is the element type\n\n ['identity] the identity of the collection *)\n\ntype ('value, 'id) id = ('value, 'id) Belt_Id.comparable\n(** The identity needed for making a set from scratch *)\n\nval make : id:('value, 'id) id -> ('value, 'id) t\n(** [make ~id] creates a new set by taking in the comparator\n {[\n let s = make ~id:(module IntCmp)\n ]} *)\n\nval fromArray : 'value array -> id:('value, 'id) id -> ('value, 'id) t\n(** [fromArray xs ~id]\n\n {[\n toArray (fromArray [ 1; 3; 2; 4 ] (module IntCmp)) = [ 1; 2; 3; 4 ]\n ]} *)\n\nval fromSortedArrayUnsafe : 'value array -> id:('value, 'id) id -> ('value, 'id) t\n(** [fromSortedArrayUnsafe xs ~id]\n\n The same as {!fromArray} except it is after assuming the input array [x] is already sorted\n\n {b Unsafe} *)\n\nval isEmpty : _ t -> bool\n(** {[\n isEmpty (fromArray [||] ~id:(module IntCmp)) = true;;\n isEmpty (fromArray [| 1 |] ~id:(module IntCmp)) = true\n ]} *)\n\nval has : ('value, 'id) t -> 'value -> bool\n(** {[\n let v = fromArray [| 1; 4; 2; 5 |] ~id:(module IntCmp);;\n\n has v 3 = false;;\n has v 1 = true\n ]} *)\n\nval add : ('value, 'id) t -> 'value -> ('value, 'id) t\n(** [add s x] If [x] was already in [s], [s] is returned unchanged.\n\n {[\n let s0 = make ~id:(module IntCmp)\n let s1 = add s0 1\n let s2 = add s1 2\n let s3 = add s2 2;;\n\n toArray s0 = [||];;\n toArray s1 = [| 1 |];;\n toArray s2 = [| 1; 2 |];;\n toArray s3 = [| 1; 2 |];;\n s2 == s3\n ]} *)\n\nval mergeMany : ('value, 'id) t -> 'value array -> ('value, 'id) t\n(** [mergeMany s xs]\n\n Adding each of [xs] to [s], note unlike {!add}, the reference of return value might be changed even if all values in\n [xs] exist [s] *)\n\nval remove : ('value, 'id) t -> 'value -> ('value, 'id) t\n(** [remove m x] If [x] was not in [m], [m] is returned reference unchanged.\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [| 2; 3; 1; 4; 5 |]\n let s1 = remove s0 1\n let s2 = remove s1 3\n let s3 = remove s2 3;;\n\n toArray s1 = [| 2; 3; 4; 5 |];;\n toArray s2 = [| 2; 4; 5 |];;\n s2 == s3\n ]} *)\n\nval removeMany : ('value, 'id) t -> 'value array -> ('value, 'id) t\n(** [removeMany s xs]\n\n Removing each of [xs] to [s], note unlike {!remove}, the reference of return value might be changed even if none in\n [xs] exists [s] *)\n\nval union : ('value, 'id) t -> ('value, 'id) t -> ('value, 'id) t\n(** [union s0 s1]\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n let s1 = fromArray ~id:(module IntCmp) [|5;2;3;1;5;4;|];;\n toArray (union s0 s1) = [|1;2;3;4;5;6|]\n ]} *)\n\nval intersect : ('value, 'id) t -> ('value, 'id) t -> ('value, 'id) t\n(** [intersect s0 s1]\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n let s1 = fromArray ~id:(module IntCmp) [|5;2;3;1;5;4;|];;\n toArray (intersect s0 s1) = [|2;3;5|]\n ]} *)\n\nval diff : ('value, 'id) t -> ('value, 'id) t -> ('value, 'id) t\n(** [diff s0 s1]\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n let s1 = fromArray ~id:(module IntCmp) [|5;2;3;1;5;4;|];;\n toArray (diff s0 s1) = [|6|];;\n toArray (diff s1 s0) = [|1;4|];;\n ]} *)\n\nval subset : ('value, 'id) t -> ('value, 'id) t -> bool\n(** [subset s0 s1]\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n let s1 = fromArray ~id:(module IntCmp) [|5;2;3;1;5;4;|];;\n let s2 = intersect s0 s1;;\n subset s2 s0 = true;;\n subset s2 s1 = true;;\n subset s1 s0 = false;;\n ]} *)\n\nval cmp : ('value, 'id) t -> ('value, 'id) t -> int\n(** Total ordering between sets. Can be used as the ordering function for doing sets of sets. It compare [size] first\n and then iterate over each element following the order of elements *)\n\nval eq : ('value, 'id) t -> ('value, 'id) t -> bool\n(** [eq s0 s1]\n\n @return true if [toArray s0 = toArray s1] *)\n\nval forEachU : ('value, 'id) t -> (('value -> unit)[@u]) -> unit\n\nval forEach : ('value, 'id) t -> ('value -> unit) -> unit\n(** [forEach s f] applies [f] in turn to all elements of [s]. In increasing order\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n let acc = ref [] ;;\n forEach s0 (fun x -> acc := x !acc);;\n !acc = [6;5;3;2];;\n ]} *)\n\nval reduceU : ('value, 'id) t -> 'a -> (('a -> 'value -> 'a)[@u]) -> 'a\n\nval reduce : ('value, 'id) t -> 'a -> ('a -> 'value -> 'a) -> 'a\n(** In increasing order.\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n reduce s0 [] Belt.List.add = [6;5;3;2];;\n ]} *)\n\nval everyU : ('value, 'id) t -> (('value -> bool)[@u]) -> bool\n\nval every : ('value, 'id) t -> ('value -> bool) -> bool\n(** [every p s] checks if all elements of the set satisfy the predicate [p]. Order unspecified. *)\n\nval someU : ('value, 'id) t -> (('value -> bool)[@u]) -> bool\n\nval some : ('value, 'id) t -> ('value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. *)\n\nval keepU : ('value, 'id) t -> (('value -> bool)[@u]) -> ('value, 'id) t\n\nval keep : ('value, 'id) t -> ('value -> bool) -> ('value, 'id) t\n(** [keep m p] returns the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : ('value, 'id) t -> (('value -> bool)[@u]) -> ('value, 'id) t * ('value, 'id) t\n\nval partition : ('value, 'id) t -> ('value -> bool) -> ('value, 'id) t * ('value, 'id) t\n(** [partition m p] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the\n predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : ('value, 'id) t -> int\n(** [size s]\n\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n size s0 = 4;;\n ]} *)\n\nval toArray : ('value, 'id) t -> 'value array\n(** [toArray s0]\n {[\n let s0 = fromArray ~id:(module IntCmp) [|5;2;3;5;6|]];;\n toArray s0 = [|2;3;5;6|];;\n ]}*)\n\nval toList : ('value, 'id) t -> 'value list\n(** In increasing order\n\n {b See} {!toArray} *)\n\nval minimum : ('value, 'id) t -> 'value option\n(** [minimum s0]\n\n @return the minimum element of the collection, [None] if it is empty *)\n\nval minUndefined : ('value, 'id) t -> 'value Js.undefined\n(** [minUndefined s0]\n\n @return the minimum element of the collection, [undefined] if it is empty *)\n\nval maximum : ('value, 'id) t -> 'value option\n(** [maximum s0]\n\n @return the maximum element of the collection, [None] if it is empty *)\n\nval maxUndefined : ('value, 'id) t -> 'value Js.undefined\n(** [maxUndefined s0]\n\n @return the maximum element of the collection, [undefined] if it is empty *)\n\nval get : ('value, 'id) t -> 'value -> 'value option\n(** [get s0 k]\n\n @return\n the reference of the value [k'] which is equivalent to [k] using the comparator specifiecd by this collection,\n [None] if it does not exist *)\n\nval getUndefined : ('value, 'id) t -> 'value -> 'value Js.undefined\n(** {b See} {!get} *)\n\nval getExn : ('value, 'id) t -> 'value -> 'value\n(** {b See} {!get}\n\n {b raise} if not exist *)\n\nval split : ('value, 'id) t -> 'value -> (('value, 'id) t * ('value, 'id) t) * bool\n(** [split set ele]\n\n @return a tuple [((smaller, larger), present)], [present] is true when [ele] exist in [set] *)\n\n(**/**)\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n\n(**/**)\n\n(****************************************************************************)\n(** Below are operations only when better performance needed, it is still safe API but more verbose. More API will be\n exposed by needs *)\n\nval getData : ('value, 'id) t -> ('value, 'id) Belt_SetDict.t\n(** [getData s0]\n\n {b Advanced usage only}\n\n @return\n the raw data (detached from comparator), but its type is still manifested, so that user can pass identity directly\n without boxing *)\n\nval getId : ('value, 'id) t -> ('value, 'id) id\n(** [getId s0]\n\n {b Advanced usage only}\n\n @return the identity of [s0] *)\n\nval packIdData : id:('value, 'id) id -> data:('value, 'id) Belt_SetDict.t -> ('value, 'id) t\n(** [packIdData ~id ~data]\n\n {b Advanced usage only}\n\n @return the packed collection *)\n"
},
{
"path": "packages/Belt/src/Belt_SetDict.ml",
"content": "(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype ('k, 'id) t = 'k N.t\ntype ('key, 'id) cmp = ('key, 'id) Belt_Id.cmp\n\n(* here we relies on reference transparence\n address equality means everything equal across time\n no need to call [bal] again\n*)\nlet rec add (t : _ t) x ~cmp : _ t =\n match t with\n | None -> N.singleton x\n | Some nt ->\n let k = nt.value in\n let c = ((Belt_Id.getCmpInternal cmp) x k [@u]) in\n if c = 0 then t\n else\n let { N.left = l; right = r; _ } = nt in\n if c < 0 then\n let ll = add ~cmp l x in\n if ll == l then t else N.bal ll k r\n else\n let rr = add ~cmp r x in\n if rr == r then t else N.bal l k rr\n\nlet rec remove (t : _ t) x ~cmp : _ t =\n match t with\n | None -> t\n | Some n ->\n let { N.left = l; value = v; right = r; _ } = n in\n let c = ((Belt_Id.getCmpInternal cmp) x v [@u]) in\n if c = 0 then\n match (l, r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let v = ref rn.value in\n let r = N.removeMinAuxWithRef rn v in\n N.bal l v.contents r\n else if c < 0 then\n let ll = remove ~cmp l x in\n if ll == l then t else N.bal ll v r\n else\n let rr = remove ~cmp r x in\n if rr == r then t else N.bal l v rr\n\nlet mergeMany h arr ~cmp =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key = A.getUnsafe arr i in\n v.contents <- add v.contents ~cmp key\n done;\n v.contents\n\nlet removeMany h arr ~cmp =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key = A.getUnsafe arr i in\n v.contents <- remove v.contents ~cmp key\n done;\n v.contents\n\nlet rec splitAuxNoPivot ~cmp (n : _ N.node) x : _ * _ =\n let { N.left = l; value = v; right = r; _ } = n in\n let c = ((Belt_Id.getCmpInternal cmp) x v [@u]) in\n if c = 0 then (l, r)\n else if c < 0 then\n match l with\n | None -> (None, Some n)\n | Some l ->\n let ll, rl = splitAuxNoPivot ~cmp l x in\n (ll, N.joinShared rl v r)\n else\n match r with\n | None -> (Some n, None)\n | Some r ->\n let lr, rr = splitAuxNoPivot ~cmp r x in\n (N.joinShared l v lr, rr)\n\nlet rec splitAuxPivot ~cmp (n : _ N.node) x pres : _ * _ =\n let { N.left = l; value = v; right = r; _ } = n in\n let c = ((Belt_Id.getCmpInternal cmp) x v [@u]) in\n if c = 0 then (\n pres.contents <- true;\n (l, r))\n else if c < 0 then\n match l with\n | None -> (None, Some n)\n | Some l ->\n let ll, rl = splitAuxPivot ~cmp l x pres in\n (ll, N.joinShared rl v r)\n else\n match r with\n | None -> (Some n, None)\n | Some r ->\n let lr, rr = splitAuxPivot ~cmp r x pres in\n (N.joinShared l v lr, rr)\n\nlet split (t : _ t) x ~cmp =\n match t with\n | None -> ((None, None), false)\n | Some n ->\n let pres = ref false in\n let v = splitAuxPivot ~cmp n x pres in\n (v, pres.contents)\n\n(* [union s1 s2]\n Use the pivot to split the smaller collection\n*)\nlet rec union (s1 : _ t) (s2 : _ t) ~cmp : _ t =\n match (s1, s2) with\n | None, _ -> s2\n | _, None -> s1\n | Some n1, Some n2 ->\n let h1, h2 = (n1.height, n2.height) in\n if h1 >= h2 then\n if h2 = 1 then add ~cmp s1 n2.value\n else\n let { N.left = l1; value = v1; right = r1; _ } = n1 in\n let l2, r2 = splitAuxNoPivot ~cmp n2 v1 in\n N.joinShared (union ~cmp l1 l2) v1 (union ~cmp r1 r2)\n else if h1 = 1 then add s2 ~cmp n1.value\n else\n let { N.left = l2; value = v2; right = r2; _ } = n2 in\n let l1, r1 = splitAuxNoPivot ~cmp n1 v2 in\n N.joinShared (union ~cmp l1 l2) v2 (union ~cmp r1 r2)\n\nlet rec intersect (s1 : _ t) (s2 : _ t) ~cmp =\n match (s1, s2) with\n | None, _ | _, None -> None\n | Some n1, Some n2 ->\n let { N.left = l1; value = v1; right = r1; _ } = n1 in\n let pres = ref false in\n let l2, r2 = splitAuxPivot ~cmp n2 v1 pres in\n let ll = intersect ~cmp l1 l2 in\n let rr = intersect ~cmp r1 r2 in\n if pres.contents then N.joinShared ll v1 rr else N.concatShared ll rr\n\nlet rec diff s1 s2 ~cmp =\n match (s1, s2) with\n | None, _ | _, None -> s1\n | Some n1, Some n2 ->\n let { N.left = l1; value = v1; right = r1; _ } = n1 in\n let pres = ref false in\n let l2, r2 = splitAuxPivot ~cmp n2 v1 pres in\n let ll = diff ~cmp l1 l2 in\n let rr = diff ~cmp r1 r2 in\n if pres.contents then N.concatShared ll rr else N.joinShared ll v1 rr\n\nlet empty = None\nlet fromArray = N.fromArray\nlet isEmpty = N.isEmpty\nlet cmp = N.cmp\nlet eq = N.eq\nlet has = N.has\nlet forEachU = N.forEachU\nlet forEach = N.forEach\nlet reduceU = N.reduceU\nlet reduce = N.reduce\nlet everyU = N.everyU\nlet every = N.every\nlet someU = N.someU\nlet some = N.some\nlet size = N.size\nlet toList = N.toList\nlet toArray = N.toArray\nlet minimum = N.minimum\nlet maximum = N.maximum\nlet maxUndefined = N.maxUndefined\nlet minUndefined = N.minUndefined\nlet get = N.get\nlet getExn = N.getExn\nlet getUndefined = N.getUndefined\nlet fromSortedArrayUnsafe = N.fromSortedArrayUnsafe\nlet subset = N.subset\nlet keep = N.keepShared\nlet keepU = N.keepSharedU\nlet partitionU = N.partitionSharedU\nlet partition = N.partitionShared\nlet checkInvariantInternal = N.checkInvariantInternal\n"
},
{
"path": "packages/Belt/src/Belt_SetDict.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\ntype ('value, 'identity) t\ntype ('value, 'id) cmp = ('value, 'id) Belt_Id.cmp\n\nval empty : ('value, 'id) t\nval fromArray : 'value array -> cmp:('value, 'id) cmp -> ('value, 'id) t\nval fromSortedArrayUnsafe : 'value array -> ('value, 'id) t\nval isEmpty : _ t -> bool\nval has : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> bool\n\nval add : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> ('value, 'id) t\n(** [add s x] If [x] was already in [s], [s] is returned unchanged. *)\n\nval mergeMany : ('value, 'id) t -> 'value array -> cmp:('value, 'id) cmp -> ('value, 'id) t\n\nval remove : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> ('value, 'id) t\n(** [remove m x] If [x] was not in [m], [m] is returned reference unchanged. *)\n\nval removeMany : ('value, 'id) t -> 'value array -> cmp:('value, 'id) cmp -> ('value, 'id) t\nval union : ('value, 'id) t -> ('value, 'id) t -> cmp:('value, 'id) cmp -> ('value, 'id) t\nval intersect : ('value, 'id) t -> ('value, 'id) t -> cmp:('value, 'id) cmp -> ('value, 'id) t\nval diff : ('value, 'id) t -> ('value, 'id) t -> cmp:('value, 'id) cmp -> ('value, 'id) t\n\nval subset : ('value, 'id) t -> ('value, 'id) t -> cmp:('value, 'id) cmp -> bool\n(** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *)\n\nval cmp : ('value, 'id) t -> ('value, 'id) t -> cmp:('value, 'id) cmp -> int\n(** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *)\n\nval eq : ('value, 'id) t -> ('value, 'id) t -> cmp:('value, 'id) cmp -> bool\n(** [eq s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *)\n\nval forEachU : ('value, 'id) t -> (('value -> unit)[@u]) -> unit\n\nval forEach : ('value, 'id) t -> ('value -> unit) -> unit\n(** [forEach s f] applies [f] in turn to all elements of [s]. In increasing order *)\n\nval reduceU : ('value, 'id) t -> 'a -> (('a -> 'value -> 'a)[@u]) -> 'a\n\nval reduce : ('value, 'id) t -> 'a -> ('a -> 'value -> 'a) -> 'a\n(** Iterate in increasing order. *)\n\nval everyU : ('value, 'id) t -> (('value -> bool)[@u]) -> bool\n\nval every : ('value, 'id) t -> ('value -> bool) -> bool\n(** [every p s] checks if all elements of the set satisfy the predicate [p]. Order unspecified. *)\n\nval someU : ('value, 'id) t -> (('value -> bool)[@u]) -> bool\n\nval some : ('value, 'id) t -> ('value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. Oder unspecified. *)\n\nval keepU : ('value, 'id) t -> (('value -> bool)[@u]) -> ('value, 'id) t\n\nval keep : ('value, 'id) t -> ('value -> bool) -> ('value, 'id) t\n(** [keep p s] returns the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : ('value, 'id) t -> (('value -> bool)[@u]) -> ('value, 'id) t * ('value, 'id) t\n\nval partition : ('value, 'id) t -> ('value -> bool) -> ('value, 'id) t * ('value, 'id) t\n(** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the\n predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : ('value, 'id) t -> int\n\nval toList : ('value, 'id) t -> 'value list\n(** In increasing order *)\n\nval toArray : ('value, 'id) t -> 'value array\nval minimum : ('value, 'id) t -> 'value option\nval minUndefined : ('value, 'id) t -> 'value Js.undefined\nval maximum : ('value, 'id) t -> 'value option\nval maxUndefined : ('value, 'id) t -> 'value Js.undefined\nval get : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> 'value option\nval getUndefined : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> 'value Js.undefined\nval getExn : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> 'value\n\nval split : ('value, 'id) t -> 'value -> cmp:('value, 'id) cmp -> (('value, 'id) t * ('value, 'id) t) * bool\n(** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than\n [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no\n element equal to [x], or [true] if [s] contains an element equal to [x]. *)\n\nval checkInvariantInternal : _ t -> unit\n(** {b raise} when invariant is not held *)\n"
},
{
"path": "packages/Belt/src/Belt_SetInt.ml",
"content": "module I = Belt_internalSetInt\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype value = I.value\ntype t = I.t\n\nlet empty = N.empty\nlet isEmpty = N.isEmpty\nlet minimum = N.minimum\nlet minUndefined = N.minUndefined\nlet maximum = N.maximum\nlet maxUndefined = N.maxUndefined\nlet forEach = N.forEach\nlet forEachU = N.forEachU\nlet reduce = N.reduce\nlet reduceU = N.reduceU\nlet every = N.every\nlet everyU = N.everyU\nlet some = N.some\nlet someU = N.someU\nlet keep = N.keepShared\nlet keepU = N.keepSharedU\nlet partition = N.partitionShared\nlet partitionU = N.partitionSharedU\nlet size = N.size\nlet toList = N.toList\nlet toArray = N.toArray\nlet fromSortedArrayUnsafe = N.fromSortedArrayUnsafe\nlet checkInvariantInternal = N.checkInvariantInternal\n\nlet rec add (t : t) (x : value) : t =\n match N.toOpt t with\n | None -> N.singleton x\n | Some nt ->\n let v = N.value nt in\n if x = v then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < v then\n let ll = add l x in\n if ll == l then t else N.bal ll v r\n else\n let rr = add r x in\n if rr == r then t else N.bal l v rr\n\nlet mergeMany h arr =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key = A.getUnsafe arr i in\n v := add !v key\n done;\n !v\n\nlet rec remove (t : t) (x : value) : t =\n match N.toOpt t with\n | None -> t\n | Some n ->\n let l, v, r =\n let open N in\n (left n, value n, right n)\n in\n if x = v then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let v = ref (N.value rn) in\n let r = N.removeMinAuxWithRef rn v in\n N.bal l !v r\n else if x < v then\n let ll = remove l x in\n if ll == l then t else N.bal ll v r\n else\n let rr = remove r x in\n if rr == r then t else N.bal l v rr\n\nlet removeMany h arr =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key = A.getUnsafe arr i in\n v := remove !v key\n done;\n !v\n\nlet fromArray = I.fromArray\nlet cmp = I.cmp\nlet eq = I.eq\nlet get = I.get\nlet getUndefined = I.getUndefined\nlet getExn = I.getExn\nlet subset = I.subset\nlet has = I.has\n\nlet rec splitAuxNoPivot (n : _ N.node) (x : value) : t * t =\n let l, v, r =\n let open N in\n (left n, value n, right n)\n in\n if x = v then (l, r)\n else if x < v then\n match N.toOpt l with\n | None -> (N.empty, N.return n)\n | Some l ->\n let ll, rl = splitAuxNoPivot l x in\n (ll, N.joinShared rl v r)\n else\n match N.toOpt r with\n | None -> (N.return n, N.empty)\n | Some r ->\n let lr, rr = splitAuxNoPivot r x in\n (N.joinShared l v lr, rr)\n\nlet rec splitAuxPivot (n : _ N.node) (x : value) pres : t * t =\n let l, v, r =\n let open N in\n (left n, value n, right n)\n in\n if x = v then (\n pres := true;\n (l, r))\n else if x < v then\n match N.toOpt l with\n | None -> (N.empty, N.return n)\n | Some l ->\n let ll, rl = splitAuxPivot l x pres in\n (ll, N.joinShared rl v r)\n else\n match N.toOpt r with\n | None -> (N.return n, N.empty)\n | Some r ->\n let lr, rr = splitAuxPivot r x pres in\n (N.joinShared l v lr, rr)\n\nlet split (t : t) (x : value) =\n match N.toOpt t with\n | None -> ((N.empty, N.empty), false)\n | Some n ->\n let pres = ref false in\n let v = splitAuxPivot n x pres in\n (v, !pres)\n\nlet rec union (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ -> s2\n | _, None -> s1\n | Some n1, Some n2 ->\n let h1, h2 =\n let open N in\n (height n1, height n2)\n in\n if h1 >= h2 then\n if h2 = 1 then add s1 (N.value n2)\n else\n let l1, v1, r1 =\n let open N in\n (left n1, value n1, right n1)\n in\n let l2, r2 = splitAuxNoPivot n2 v1 in\n N.joinShared (union l1 l2) v1 (union r1 r2)\n else if h1 = 1 then add s2 (N.value n1)\n else\n let l2, v2, r2 =\n let open N in\n (left n2, value n2, right n2)\n in\n let l1, r1 = splitAuxNoPivot n1 v2 in\n N.joinShared (union l1 l2) v2 (union r1 r2)\n\nlet rec intersect (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ | _, None -> N.empty\n | Some n1, Some n2 ->\n let l1, v1, r1 =\n let open N in\n (left n1, value n1, right n1)\n in\n let pres = ref false in\n let l2, r2 = splitAuxPivot n2 v1 pres in\n let ll = intersect l1 l2 in\n let rr = intersect r1 r2 in\n if !pres then N.joinShared ll v1 rr else N.concatShared ll rr\n\nlet rec diff (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ | _, None -> s1\n | Some n1, Some n2 ->\n let l1, v1, r1 =\n let open N in\n (left n1, value n1, right n1)\n in\n let pres = ref false in\n let l2, r2 = splitAuxPivot n2 v1 pres in\n let ll = diff l1 l2 in\n let rr = diff r1 r2 in\n if !pres then N.concatShared ll rr else N.joinShared ll v1 rr\n"
},
{
"path": "packages/Belt/src/Belt_SetInt.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This module is {!Belt.Set} specialized with value type to be a primitive type. It is more efficient in general, the\n API is the same with {!Belt.Set} except its value type is fixed, and identity is not needed(using the built-in one)\n\n {b See} {!Belt.Set} *)\n\ntype value = int\n(** The type of the set elements. *)\n\ntype t\n(** The type of sets. *)\n\nval empty : t\nval fromArray : value array -> t\nval fromSortedArrayUnsafe : value array -> t\nval isEmpty : t -> bool\nval has : t -> value -> bool\n\nval add : t -> value -> t\n(** [add s x] If [x] was already in [s], [s] is returned unchanged. *)\n\nval mergeMany : t -> value array -> t\n\nval remove : t -> value -> t\n(** [remove m x] If [x] was not in [m], [m] is returned reference unchanged. *)\n\nval removeMany : t -> value array -> t\nval union : t -> t -> t\nval intersect : t -> t -> t\nval diff : t -> t -> t\n\nval subset : t -> t -> bool\n(** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *)\n\nval cmp : t -> t -> int\n(** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *)\n\nval eq : t -> t -> bool\n(** [eq s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *)\n\nval forEachU : t -> ((value -> unit)[@u]) -> unit\n\nval forEach : t -> (value -> unit) -> unit\n(** [forEach s f] applies [f] in turn to all elements of [s]. In increasing order *)\n\nval reduceU : t -> 'a -> (('a -> value -> 'a)[@u]) -> 'a\n\nval reduce : t -> 'a -> ('a -> value -> 'a) -> 'a\n(** Iterate in increasing order. *)\n\nval everyU : t -> ((value -> bool)[@u]) -> bool\n\nval every : t -> (value -> bool) -> bool\n(** [every p s] checks if all elements of the set satisfy the predicate [p]. Order unspecified. *)\n\nval someU : t -> ((value -> bool)[@u]) -> bool\n\nval some : t -> (value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. Oder unspecified. *)\n\nval keepU : t -> ((value -> bool)[@u]) -> t\n\nval keep : t -> (value -> bool) -> t\n(** [keep p s] returns the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : t -> ((value -> bool)[@u]) -> t * t\n\nval partition : t -> (value -> bool) -> t * t\n(** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the\n predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : t -> int\n\nval toList : t -> value list\n(** In increasing order *)\n\nval toArray : t -> value array\nval minimum : t -> value option\nval minUndefined : t -> value Js.undefined\nval maximum : t -> value option\nval maxUndefined : t -> value Js.undefined\nval get : t -> value -> value option\nval getUndefined : t -> value -> value Js.undefined\nval getExn : t -> value -> value\n\nval split : t -> value -> (t * t) * bool\n(** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than\n [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no\n element equal to [x], or [true] if [s] contains an element equal to [x]. *)\n\nval checkInvariantInternal : t -> unit\n(** {b raise} when invariant is not held *)\n"
},
{
"path": "packages/Belt/src/Belt_SetString.ml",
"content": "module I = Belt_internalSetString\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype value = I.value\ntype t = I.t\n\nlet empty = N.empty\nlet isEmpty = N.isEmpty\nlet minimum = N.minimum\nlet minUndefined = N.minUndefined\nlet maximum = N.maximum\nlet maxUndefined = N.maxUndefined\nlet forEach = N.forEach\nlet forEachU = N.forEachU\nlet reduce = N.reduce\nlet reduceU = N.reduceU\nlet every = N.every\nlet everyU = N.everyU\nlet some = N.some\nlet someU = N.someU\nlet keep = N.keepShared\nlet keepU = N.keepSharedU\nlet partition = N.partitionShared\nlet partitionU = N.partitionSharedU\nlet size = N.size\nlet toList = N.toList\nlet toArray = N.toArray\nlet fromSortedArrayUnsafe = N.fromSortedArrayUnsafe\nlet checkInvariantInternal = N.checkInvariantInternal\n\nlet rec add (t : t) (x : value) : t =\n match N.toOpt t with\n | None -> N.singleton x\n | Some nt ->\n let v = N.value nt in\n if x = v then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < v then\n let ll = add l x in\n if ll == l then t else N.bal ll v r\n else\n let rr = add r x in\n if rr == r then t else N.bal l v rr\n\nlet mergeMany h arr =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key = A.getUnsafe arr i in\n v := add !v key\n done;\n !v\n\nlet rec remove (t : t) (x : value) : t =\n match N.toOpt t with\n | None -> t\n | Some n ->\n let l, v, r =\n let open N in\n (left n, value n, right n)\n in\n if x = v then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let v = ref (N.value rn) in\n let r = N.removeMinAuxWithRef rn v in\n N.bal l !v r\n else if x < v then\n let ll = remove l x in\n if ll == l then t else N.bal ll v r\n else\n let rr = remove r x in\n if rr == r then t else N.bal l v rr\n\nlet removeMany h arr =\n let len = A.length arr in\n let v = ref h in\n for i = 0 to len - 1 do\n let key = A.getUnsafe arr i in\n v := remove !v key\n done;\n !v\n\nlet fromArray = I.fromArray\nlet cmp = I.cmp\nlet eq = I.eq\nlet get = I.get\nlet getUndefined = I.getUndefined\nlet getExn = I.getExn\nlet subset = I.subset\nlet has = I.has\n\nlet rec splitAuxNoPivot (n : _ N.node) (x : value) : t * t =\n let l, v, r =\n let open N in\n (left n, value n, right n)\n in\n if x = v then (l, r)\n else if x < v then\n match N.toOpt l with\n | None -> (N.empty, N.return n)\n | Some l ->\n let ll, rl = splitAuxNoPivot l x in\n (ll, N.joinShared rl v r)\n else\n match N.toOpt r with\n | None -> (N.return n, N.empty)\n | Some r ->\n let lr, rr = splitAuxNoPivot r x in\n (N.joinShared l v lr, rr)\n\nlet rec splitAuxPivot (n : _ N.node) (x : value) pres : t * t =\n let l, v, r =\n let open N in\n (left n, value n, right n)\n in\n if x = v then (\n pres := true;\n (l, r))\n else if x < v then\n match N.toOpt l with\n | None -> (N.empty, N.return n)\n | Some l ->\n let ll, rl = splitAuxPivot l x pres in\n (ll, N.joinShared rl v r)\n else\n match N.toOpt r with\n | None -> (N.return n, N.empty)\n | Some r ->\n let lr, rr = splitAuxPivot r x pres in\n (N.joinShared l v lr, rr)\n\nlet split (t : t) (x : value) =\n match N.toOpt t with\n | None -> ((N.empty, N.empty), false)\n | Some n ->\n let pres = ref false in\n let v = splitAuxPivot n x pres in\n (v, !pres)\n\nlet rec union (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ -> s2\n | _, None -> s1\n | Some n1, Some n2 ->\n let h1, h2 =\n let open N in\n (height n1, height n2)\n in\n if h1 >= h2 then\n if h2 = 1 then add s1 (N.value n2)\n else\n let l1, v1, r1 =\n let open N in\n (left n1, value n1, right n1)\n in\n let l2, r2 = splitAuxNoPivot n2 v1 in\n N.joinShared (union l1 l2) v1 (union r1 r2)\n else if h1 = 1 then add s2 (N.value n1)\n else\n let l2, v2, r2 =\n let open N in\n (left n2, value n2, right n2)\n in\n let l1, r1 = splitAuxNoPivot n1 v2 in\n N.joinShared (union l1 l2) v2 (union r1 r2)\n\nlet rec intersect (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ | _, None -> N.empty\n | Some n1, Some n2 ->\n let l1, v1, r1 =\n let open N in\n (left n1, value n1, right n1)\n in\n let pres = ref false in\n let l2, r2 = splitAuxPivot n2 v1 pres in\n let ll = intersect l1 l2 in\n let rr = intersect r1 r2 in\n if !pres then N.joinShared ll v1 rr else N.concatShared ll rr\n\nlet rec diff (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ | _, None -> s1\n | Some n1, Some n2 ->\n let l1, v1, r1 =\n let open N in\n (left n1, value n1, right n1)\n in\n let pres = ref false in\n let l2, r2 = splitAuxPivot n2 v1 pres in\n let ll = diff l1 l2 in\n let rr = diff r1 r2 in\n if !pres then N.concatShared ll rr else N.joinShared ll v1 rr\n"
},
{
"path": "packages/Belt/src/Belt_SetString.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This module is {!Belt.Set} specialized with value type to be a primitive type. It is more efficient in general, the\n API is the same with {!Belt.Set} except its value type is fixed, and identity is not needed(using the built-in one)\n\n {b See} {!Belt.Set} *)\n\ntype value = string\n(** The type of the set elements. *)\n\ntype t\n(** The type of sets. *)\n\nval empty : t\nval fromArray : value array -> t\nval fromSortedArrayUnsafe : value array -> t\nval isEmpty : t -> bool\nval has : t -> value -> bool\n\nval add : t -> value -> t\n(** [add s x] If [x] was already in [s], [s] is returned unchanged. *)\n\nval mergeMany : t -> value array -> t\n\nval remove : t -> value -> t\n(** [remove m x] If [x] was not in [m], [m] is returned reference unchanged. *)\n\nval removeMany : t -> value array -> t\nval union : t -> t -> t\nval intersect : t -> t -> t\nval diff : t -> t -> t\n\nval subset : t -> t -> bool\n(** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *)\n\nval cmp : t -> t -> int\n(** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *)\n\nval eq : t -> t -> bool\n(** [eq s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *)\n\nval forEachU : t -> ((value -> unit)[@u]) -> unit\n\nval forEach : t -> (value -> unit) -> unit\n(** [forEach s f] applies [f] in turn to all elements of [s]. In increasing order *)\n\nval reduceU : t -> 'a -> (('a -> value -> 'a)[@u]) -> 'a\n\nval reduce : t -> 'a -> ('a -> value -> 'a) -> 'a\n(** Iterate in increasing order. *)\n\nval everyU : t -> ((value -> bool)[@u]) -> bool\n\nval every : t -> (value -> bool) -> bool\n(** [every p s] checks if all elements of the set satisfy the predicate [p]. Order unspecified. *)\n\nval someU : t -> ((value -> bool)[@u]) -> bool\n\nval some : t -> (value -> bool) -> bool\n(** [some p s] checks if at least one element of the set satisfies the predicate [p]. Oder unspecified. *)\n\nval keepU : t -> ((value -> bool)[@u]) -> t\n\nval keep : t -> (value -> bool) -> t\n(** [keep p s] returns the set of all elements in [s] that satisfy predicate [p]. *)\n\nval partitionU : t -> ((value -> bool)[@u]) -> t * t\n\nval partition : t -> (value -> bool) -> t * t\n(** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the\n predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *)\n\nval size : t -> int\n\nval toList : t -> value list\n(** In increasing order *)\n\nval toArray : t -> value array\nval minimum : t -> value option\nval minUndefined : t -> value Js.undefined\nval maximum : t -> value option\nval maxUndefined : t -> value Js.undefined\nval get : t -> value -> value option\nval getUndefined : t -> value -> value Js.undefined\nval getExn : t -> value -> value\n\nval split : t -> value -> (t * t) * bool\n(** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than\n [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no\n element equal to [x], or [true] if [s] contains an element equal to [x]. *)\n\nval checkInvariantInternal : t -> unit\n(** {b raise} when invariant is not held *)\n"
},
{
"path": "packages/Belt/src/Belt_SortArray.ml",
"content": "module Int = Belt_SortArrayInt\nmodule String = Belt_SortArrayString\nmodule A = Belt_Array\n\nlet rec sortedLengthAuxMore xs prec acc len lt =\n if acc >= len then acc\n else\n let v = A.getUnsafe xs acc in\n if lt v prec then sortedLengthAuxMore xs v (acc + 1) len lt else acc\n\nlet rec sortedLengthAuxLess xs prec acc len lt =\n if acc >= len then acc\n else\n let v = A.getUnsafe xs acc in\n if lt prec v then sortedLengthAuxLess xs v (acc + 1) len lt else acc\n\nlet strictlySortedLengthU xs lt =\n let len = A.length xs in\n match len with\n | 0 | 1 -> len\n | _ ->\n let x0, x1 = (A.getUnsafe xs 0, A.getUnsafe xs 1) in\n if lt x0 x1 then sortedLengthAuxLess xs x1 2 len lt\n else if lt x1 x0 then -sortedLengthAuxMore xs x1 2 len lt\n else 1\n\nlet strictlySortedLength xs lt = strictlySortedLengthU xs (fun x y -> lt x y)\n\nlet rec isSortedAux a i cmp last_bound =\n if i = last_bound then true\n else if cmp (A.getUnsafe a i) (A.getUnsafe a (i + 1)) <= 0 then isSortedAux a (i + 1) cmp last_bound\n else false\n\nlet isSortedU a cmp =\n let len = A.length a in\n if len = 0 then true else isSortedAux a 0 cmp (len - 1)\n\nlet isSorted a cmp = isSortedU a (fun x y -> cmp x y)\nlet cutoff = 5\n\nlet merge src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n let src1r = src1ofs + src1len and src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if cmp s1 s2 <= 0 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 (d + 1) else A.blitUnsafe src2 i2 dst (d + 1) (src2r - i2))\n else (\n A.setUnsafe dst d s2;\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) (d + 1) else A.blitUnsafe src i1 dst (d + 1) (src1r - i1))\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet unionU src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n let c = cmp s1 s2 in\n if c < 0 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let d = d + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d\n else (\n A.blitUnsafe src2 i2 dst d (src2r - i2);\n d + src2r - i2))\n else if c = 0 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d\n else if i1 = src1r then (\n A.blitUnsafe src2 i2 dst d (src2r - i2);\n d + src2r - i2)\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1))\n else (\n A.setUnsafe dst d s2;\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1))\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n unionU src src1ofs src1len src2 src2ofs src2len dst dstofs (fun x y -> cmp x y)\n\nlet intersectU src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n let c = cmp s1 s2 in\n if c < 0 then\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d else d\n else if c = 0 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d else d)\n else\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d else d\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet intersect src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n intersectU src src1ofs src1len src2 src2ofs src2len dst dstofs (fun x y -> cmp x y)\n\nlet diffU src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n let c = cmp s1 s2 in\n if c < 0 then (\n A.setUnsafe dst d s1;\n let d = d + 1 in\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d else d)\n else if c = 0 then\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d\n else if i1 = src1r then d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1)\n else\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1)\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet diff src src1ofs src1len src2 src2ofs src2len dst dstofs cmp =\n diffU src src1ofs src1len src2 src2ofs src2len dst dstofs (fun x y -> cmp x y)\n\nlet insertionSort src srcofs dst dstofs len cmp =\n for i = 0 to len - 1 do\n let e = A.getUnsafe src (srcofs + i) in\n let j = ref (dstofs + i - 1) in\n while !j >= dstofs && cmp (A.getUnsafe dst !j) e > 0 do\n A.setUnsafe dst (!j + 1) (A.getUnsafe dst !j);\n decr j\n done;\n A.setUnsafe dst (!j + 1) e\n done\n\nlet rec sortTo src srcofs dst dstofs len cmp =\n if len <= cutoff then insertionSort src srcofs dst dstofs len cmp\n else\n let l1 = len / 2 in\n let l2 = len - l1 in\n sortTo src (srcofs + l1) dst (dstofs + l1) l2 cmp;\n sortTo src srcofs src (srcofs + l2) l1 cmp;\n merge src (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs cmp\n\nlet stableSortInPlaceByU a cmp =\n let l = A.length a in\n if l <= cutoff then insertionSort a 0 a 0 l cmp\n else\n let l1 = l / 2 in\n let l2 = l - l1 in\n let t = Belt_Array.makeUninitializedUnsafe l2 (Belt_Array.getUnsafe a 0) in\n sortTo a l1 t 0 l2 cmp;\n sortTo a 0 a l2 l1 cmp;\n merge a l2 l1 t 0 l2 a 0 cmp\n\nlet stableSortInPlaceBy a cmp = stableSortInPlaceByU a (fun x y -> cmp x y)\n\nlet stableSortByU a cmp =\n let b = A.copy a in\n stableSortInPlaceByU b cmp;\n b\n\nlet stableSortBy a cmp = stableSortByU a (fun x y -> cmp x y)\n\nlet rec binarySearchAux arr lo hi key cmp =\n let mid = (lo + hi) / 2 in\n let midVal = A.getUnsafe arr mid in\n let c = cmp key midVal in\n if c = 0 then mid\n else if c < 0 then\n if hi = mid then if cmp (A.getUnsafe arr lo) key = 0 then lo else -(hi + 1) else binarySearchAux arr lo mid key cmp\n else if lo = mid then if cmp (A.getUnsafe arr hi) key = 0 then hi else -(hi + 1)\n else binarySearchAux arr mid hi key cmp\n\nlet binarySearchByU sorted key cmp : int =\n let len = A.length sorted in\n if len = 0 then -1\n else\n let lo = A.getUnsafe sorted 0 in\n let c = cmp key lo in\n if c < 0 then -1\n else\n let hi = A.getUnsafe sorted (len - 1) in\n let c2 = cmp key hi in\n if c2 > 0 then -(len + 1) else binarySearchAux sorted 0 (len - 1) key cmp\n\nlet binarySearchBy sorted key cmp = binarySearchByU sorted key (fun x y -> cmp x y)\n"
},
{
"path": "packages/Belt/src/Belt_SortArray.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** A module for Array sort relevant utiliites *)\n\nmodule Int = Belt_SortArrayInt\n(** Specalized when key type is [int], more efficient than the generic type *)\n\nmodule String = Belt_SortArrayString\n(** Specalized when key type is [string], more efficient than the generic type *)\n\nval strictlySortedLengthU : 'a array -> (('a -> 'a -> bool)[@u]) -> int\n\nval strictlySortedLength : 'a array -> ('a -> 'a -> bool) -> int\n(** [strictlySortedLenght xs cmp] return [+n] means increasing order [-n] means negative order\n\n {[\n strictlySortedLength [| 1; 2; 3; 4; 3 |] (fun x y -> x < y) = 4;;\n strictlySortedLength [||] (fun x y -> x < y) = 0;;\n strictlySortedLength [| 1 |] (fun x y -> x < y) = 1;;\n strictlySortedLength [| 4; 3; 2; 1 |] (fun x y -> x < y) = -4\n ]} *)\n\nval isSortedU : 'a array -> (('a -> 'a -> int)[@u]) -> bool\n\nval isSorted : 'a array -> ('a -> 'a -> int) -> bool\n(** [isSorted arr cmp]\n @return\n true if array is increasingly sorted (equal is okay )\n {[\n isSorted [| 1; 1; 2; 3; 4 |] (fun x y -> compare x y) = true\n ]} *)\n\nval stableSortInPlaceByU : 'a array -> (('a -> 'a -> int)[@u]) -> unit\n\nval stableSortInPlaceBy : 'a array -> ('a -> 'a -> int) -> unit\n(** [stableSortBy xs cmp]\n\n Sort xs in place using comparator [cmp], the stable means if the elements are equal, their order will be preserved\n*)\n\nval stableSortByU : 'a array -> (('a -> 'a -> int)[@u]) -> 'a array\n\nval stableSortBy : 'a array -> ('a -> 'a -> int) -> 'a array\n(** [stableSort xs cmp]\n @return a fresh array\n\n The same as {!stableSortInPlaceBy} except that [xs] is not modified *)\n\nval binarySearchByU : 'a array -> 'a -> (('a -> 'a -> int)[@u]) -> int\n\nval binarySearchBy : 'a array -> 'a -> ('a -> 'a -> int) -> int\n(** If value is not found and value is less than one or more elements in array, the negative number returned is the\n bitwise complement of the index of the first element that is larger than value.\n\n If value is not found and value is greater than all elements in array, the negative number returned is the bitwise\n complement of (the index of the last element plus 1)\n\n for example, if [key] is smaller than all elements return [-1] since [lnot (-1) = 0] if [key] is larger than all\n elements return [- (len + 1)] since [lnot (-(len+1)) = len]\n\n {[\n binarySearchBy [| 1; 2; 3; 4; 33; 35; 36 |] 33 = 4;;\n lnot (binarySearchBy [| 1; 3; 5; 7 |] 4) = 2\n ]} *)\n\n(**/**)\n\nval unionU : 'a array -> int -> int -> 'a array -> int -> int -> 'a array -> int -> (('a -> 'a -> int)[@u]) -> int\n\nval union : 'a array -> int -> int -> 'a array -> int -> int -> 'a array -> int -> ('a -> 'a -> int) -> int\n(** [union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp] assume [src] and [src2] is strictly sorted. for\n equivalent elements, it is picked from [src] also assume that [dst] is large enough to store all elements *)\n\nval intersectU : 'a array -> int -> int -> 'a array -> int -> int -> 'a array -> int -> (('a -> 'a -> int)[@u]) -> int\n\nval intersect : 'a array -> int -> int -> 'a array -> int -> int -> 'a array -> int -> ('a -> 'a -> int) -> int\n(** [union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp] return the [offset] in the output array *)\n\nval diffU : 'a array -> int -> int -> 'a array -> int -> int -> 'a array -> int -> (('a -> 'a -> int)[@u]) -> int\nval diff : 'a array -> int -> int -> 'a array -> int -> int -> 'a array -> int -> ('a -> 'a -> int) -> int\n\n(**/**)\n"
},
{
"path": "packages/Belt/src/Belt_SortArrayInt.ml",
"content": "type element = int\n\nmodule A = Belt_Array\n\nlet rec sortedLengthAuxMore (xs : element array) prec acc len =\n if acc >= len then acc\n else\n let v = A.getUnsafe xs acc in\n if prec > v then sortedLengthAuxMore xs v (acc + 1) len else acc\n\nlet rec sortedLengthAuxLess (xs : element array) prec acc len =\n if acc >= len then acc\n else\n let v = A.getUnsafe xs acc in\n if prec < v then sortedLengthAuxLess xs v (acc + 1) len else acc\n\nlet strictlySortedLength (xs : element array) =\n let len = A.length xs in\n match len with\n | 0 | 1 -> len\n | _ ->\n let x0, x1 = (A.getUnsafe xs 0, A.getUnsafe xs 1) in\n if x0 < x1 then sortedLengthAuxLess xs x1 2 len else if x0 > x1 then -sortedLengthAuxMore xs x1 2 len else 1\n\nlet rec isSortedAux (a : element array) i last_bound =\n if i = last_bound then true\n else if A.getUnsafe a i <= A.getUnsafe a (i + 1) then isSortedAux a (i + 1) last_bound\n else false\n\nlet isSorted a =\n let len = A.length a in\n if len = 0 then true else isSortedAux a 0 (len - 1)\n\nlet cutoff = 5\n\nlet merge (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len and src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 <= s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 (d + 1) else A.blitUnsafe src2 i2 dst (d + 1) (src2r - i2))\n else (\n A.setUnsafe dst d s2;\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) (d + 1) else A.blitUnsafe src i1 dst (d + 1) (src1r - i1))\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet union (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 < s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let d = d + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d\n else (\n A.blitUnsafe src2 i2 dst d (src2r - i2);\n d + src2r - i2))\n else if s1 = s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d\n else if i1 = src1r then (\n A.blitUnsafe src2 i2 dst d (src2r - i2);\n d + src2r - i2)\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1))\n else (\n A.setUnsafe dst d s2;\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1))\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet intersect (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 < s2 then\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d else d\n else if s1 = s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d else d)\n else\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d else d\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet diff (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 < s2 then (\n A.setUnsafe dst d s1;\n let d = d + 1 in\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d else d)\n else if s1 = s2 then\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d\n else if i1 = src1r then d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1)\n else\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1)\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet insertionSort (src : element array) srcofs dst dstofs len =\n for i = 0 to len - 1 do\n let e = A.getUnsafe src (srcofs + i) in\n let j = ref (dstofs + i - 1) in\n while !j >= dstofs && A.getUnsafe dst !j > e do\n A.setUnsafe dst (!j + 1) (A.getUnsafe dst !j);\n decr j\n done;\n A.setUnsafe dst (!j + 1) e\n done\n\nlet rec sortTo (src : element array) srcofs dst dstofs len =\n if len <= cutoff then insertionSort src srcofs dst dstofs len\n else\n let l1 = len / 2 in\n let l2 = len - l1 in\n sortTo src (srcofs + l1) dst (dstofs + l1) l2;\n sortTo src srcofs src (srcofs + l2) l1;\n merge src (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs\n\nlet stableSortInPlace (a : element array) =\n let l = A.length a in\n if l <= cutoff then insertionSort a 0 a 0 l\n else\n let l1 = l / 2 in\n let l2 = l - l1 in\n let t = Belt_Array.makeUninitializedUnsafe l2 (Belt_Array.getUnsafe a 0) in\n sortTo a l1 t 0 l2;\n sortTo a 0 a l2 l1;\n merge a l2 l1 t 0 l2 a 0\n\nlet stableSort a =\n let b = A.copy a in\n stableSortInPlace b;\n b\n\nlet rec binarySearchAux (arr : element array) lo hi key =\n let mid = (lo + hi) / 2 in\n let midVal = A.getUnsafe arr mid in\n if key = midVal then mid\n else if key < midVal then\n if hi = mid then if A.getUnsafe arr lo = key then lo else -(hi + 1) else binarySearchAux arr lo mid key\n else if lo = mid then if A.getUnsafe arr hi = key then hi else -(hi + 1)\n else binarySearchAux arr mid hi key\n\nlet binarySearch (sorted : element array) key : int =\n let len = A.length sorted in\n if len = 0 then -1\n else\n let lo = A.getUnsafe sorted 0 in\n if key < lo then -1\n else\n let hi = A.getUnsafe sorted (len - 1) in\n if key > hi then -(len + 1) else binarySearchAux sorted 0 (len - 1) key\n"
},
{
"path": "packages/Belt/src/Belt_SortArrayInt.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This is a specialized module for {!Belt.SortArray}, the docs in that module also applies here, except the comparator\n is fixed and inlined *)\n\ntype element = int\n\nval strictlySortedLength : element array -> int\n(** The same as {!Belt.SortArray.strictlySortedLength } except the comparator is fixed\n @return [+n] means increasing order [-n] means negative order *)\n\nval isSorted : element array -> bool\n(** [sorted xs] return true if [xs] is in non strict increasing order *)\n\nval stableSortInPlace : element array -> unit\n(** The same as {!Belt.SortArray.stableSortInPlaceBy} except the comparator is fixed *)\n\nval stableSort : element array -> element array\n(** The same as {!Belt.SortArray.stableSortBy} except the comparator is fixed *)\n\nval binarySearch : element array -> element -> int\n(** If value is not found and value is less than one or more elements in array, the negative number returned is the\n bitwise complement of the index of the first element that is larger than value.\n\n If value is not found and value is greater than all elements in array, the negative number returned is the bitwise\n complement of (the index of the last element plus 1)\n\n for example, if [key] is smaller than all elements return [-1] since [lnot (-1) = 0] if [key] is larger than all\n elements return [- (len + 1)] since [lnot (-(len+1)) = len] *)\n\n(**/**)\n\nval union : element array -> int -> int -> element array -> int -> int -> element array -> int -> int\n(** [union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp] assume [src] and [src2] is strictly sorted. for\n equivalent elements, it is picked from [src] also assume that [dst] is large enough to store all elements *)\n\nval intersect : element array -> int -> int -> element array -> int -> int -> element array -> int -> int\nval diff : element array -> int -> int -> element array -> int -> int -> element array -> int -> int\n\n(**/**)\n"
},
{
"path": "packages/Belt/src/Belt_SortArrayString.ml",
"content": "type element = string\n\nmodule A = Belt_Array\n\nlet rec sortedLengthAuxMore (xs : element array) prec acc len =\n if acc >= len then acc\n else\n let v = A.getUnsafe xs acc in\n if prec > v then sortedLengthAuxMore xs v (acc + 1) len else acc\n\nlet rec sortedLengthAuxLess (xs : element array) prec acc len =\n if acc >= len then acc\n else\n let v = A.getUnsafe xs acc in\n if prec < v then sortedLengthAuxLess xs v (acc + 1) len else acc\n\nlet strictlySortedLength (xs : element array) =\n let len = A.length xs in\n match len with\n | 0 | 1 -> len\n | _ ->\n let x0, x1 = (A.getUnsafe xs 0, A.getUnsafe xs 1) in\n if x0 < x1 then sortedLengthAuxLess xs x1 2 len else if x0 > x1 then -sortedLengthAuxMore xs x1 2 len else 1\n\nlet rec isSortedAux (a : element array) i last_bound =\n if i = last_bound then true\n else if A.getUnsafe a i <= A.getUnsafe a (i + 1) then isSortedAux a (i + 1) last_bound\n else false\n\nlet isSorted a =\n let len = A.length a in\n if len = 0 then true else isSortedAux a 0 (len - 1)\n\nlet cutoff = 5\n\nlet merge (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len and src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 <= s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 (d + 1) else A.blitUnsafe src2 i2 dst (d + 1) (src2r - i2))\n else (\n A.setUnsafe dst d s2;\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) (d + 1) else A.blitUnsafe src i1 dst (d + 1) (src1r - i1))\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet union (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 < s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let d = d + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d\n else (\n A.blitUnsafe src2 i2 dst d (src2r - i2);\n d + src2r - i2))\n else if s1 = s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d\n else if i1 = src1r then (\n A.blitUnsafe src2 i2 dst d (src2r - i2);\n d + src2r - i2)\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1))\n else (\n A.setUnsafe dst d s2;\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1))\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet intersect (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 < s2 then\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d else d\n else if s1 = s2 then (\n A.setUnsafe dst d s1;\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n let d = d + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d else d)\n else\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d else d\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet diff (src : element array) src1ofs src1len src2 src2ofs src2len dst dstofs =\n let src1r = src1ofs + src1len in\n let src2r = src2ofs + src2len in\n let rec loop i1 s1 i2 s2 d =\n if s1 < s2 then (\n A.setUnsafe dst d s1;\n let d = d + 1 in\n let i1 = i1 + 1 in\n if i1 < src1r then loop i1 (A.getUnsafe src i1) i2 s2 d else d)\n else if s1 = s2 then\n let i1 = i1 + 1 in\n let i2 = i2 + 1 in\n if i1 < src1r && i2 < src2r then loop i1 (A.getUnsafe src i1) i2 (A.getUnsafe src2 i2) d\n else if i1 = src1r then d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1)\n else\n let i2 = i2 + 1 in\n if i2 < src2r then loop i1 s1 i2 (A.getUnsafe src2 i2) d\n else (\n A.blitUnsafe src i1 dst d (src1r - i1);\n d + src1r - i1)\n in\n loop src1ofs (A.getUnsafe src src1ofs) src2ofs (A.getUnsafe src2 src2ofs) dstofs\n\nlet insertionSort (src : element array) srcofs dst dstofs len =\n for i = 0 to len - 1 do\n let e = A.getUnsafe src (srcofs + i) in\n let j = ref (dstofs + i - 1) in\n while !j >= dstofs && A.getUnsafe dst !j > e do\n A.setUnsafe dst (!j + 1) (A.getUnsafe dst !j);\n decr j\n done;\n A.setUnsafe dst (!j + 1) e\n done\n\nlet rec sortTo (src : element array) srcofs dst dstofs len =\n if len <= cutoff then insertionSort src srcofs dst dstofs len\n else\n let l1 = len / 2 in\n let l2 = len - l1 in\n sortTo src (srcofs + l1) dst (dstofs + l1) l2;\n sortTo src srcofs src (srcofs + l2) l1;\n merge src (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs\n\nlet stableSortInPlace (a : element array) =\n let l = A.length a in\n if l <= cutoff then insertionSort a 0 a 0 l\n else\n let l1 = l / 2 in\n let l2 = l - l1 in\n let t = Belt_Array.makeUninitializedUnsafe l2 (Belt_Array.getUnsafe a 0) in\n sortTo a l1 t 0 l2;\n sortTo a 0 a l2 l1;\n merge a l2 l1 t 0 l2 a 0\n\nlet stableSort a =\n let b = A.copy a in\n stableSortInPlace b;\n b\n\nlet rec binarySearchAux (arr : element array) lo hi key =\n let mid = (lo + hi) / 2 in\n let midVal = A.getUnsafe arr mid in\n if key = midVal then mid\n else if key < midVal then\n if hi = mid then if A.getUnsafe arr lo = key then lo else -(hi + 1) else binarySearchAux arr lo mid key\n else if lo = mid then if A.getUnsafe arr hi = key then hi else -(hi + 1)\n else binarySearchAux arr mid hi key\n\nlet binarySearch (sorted : element array) key : int =\n let len = A.length sorted in\n if len = 0 then -1\n else\n let lo = A.getUnsafe sorted 0 in\n if key < lo then -1\n else\n let hi = A.getUnsafe sorted (len - 1) in\n if key > hi then -(len + 1) else binarySearchAux sorted 0 (len - 1) key\n"
},
{
"path": "packages/Belt/src/Belt_SortArrayString.mli",
"content": "(* Copyright (C) 2017 Authors of ReScript\n *\n * This program is free software: you can redistribute it and/or modify\n * it under the terms of the GNU Lesser General Public License as published by\n * the Free Software Foundation, either version 3 of the License, or\n * (at your option) any later version.\n *\n * In addition to the permissions granted to you by the LGPL, you may combine\n * or link a \"work that uses the Library\" with a publicly distributed version\n * of this file to produce a combined library or application, then distribute\n * that combined work under the terms of your choosing, with no requirement\n * to comply with the obligations normally placed on you by section 4 of the\n * LGPL version 3 (or the corresponding section of a later version of the LGPL\n * should you choose to use a later version).\n *\n * This program is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU Lesser General Public License for more details.\n *\n * You should have received a copy of the GNU Lesser General Public License\n * along with this program; if not, write to the Free Software\n * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)\n\n(** This is a specialized module for {!Belt.SortArray}, the docs in that module also applies here, except the comparator\n is fixed and inlined *)\n\ntype element = string\n\nval strictlySortedLength : element array -> int\n(** The same as {!Belt.SortArray.strictlySortedLength } except the comparator is fixed\n @return [+n] means increasing order [-n] means negative order *)\n\nval isSorted : element array -> bool\n(** [sorted xs] return true if [xs] is in non strict increasing order *)\n\nval stableSortInPlace : element array -> unit\n(** The same as {!Belt.SortArray.stableSortInPlaceBy} except the comparator is fixed *)\n\nval stableSort : element array -> element array\n(** The same as {!Belt.SortArray.stableSortBy} except the comparator is fixed *)\n\nval binarySearch : element array -> element -> int\n(** If value is not found and value is less than one or more elements in array, the negative number returned is the\n bitwise complement of the index of the first element that is larger than value.\n\n If value is not found and value is greater than all elements in array, the negative number returned is the bitwise\n complement of (the index of the last element plus 1)\n\n for example, if [key] is smaller than all elements return [-1] since [lnot (-1) = 0] if [key] is larger than all\n elements return [- (len + 1)] since [lnot (-(len+1)) = len] *)\n\n(**/**)\n\nval union : element array -> int -> int -> element array -> int -> int -> element array -> int -> int\n(** [union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp] assume [src] and [src2] is strictly sorted. for\n equivalent elements, it is picked from [src] also assume that [dst] is large enough to store all elements *)\n\nval intersect : element array -> int -> int -> element array -> int -> int -> element array -> int -> int\nval diff : element array -> int -> int -> element array -> int -> int -> element array -> int -> int\n\n(**/**)\n"
},
{
"path": "packages/Belt/src/Belt_internalAVLset.ml",
"content": "type 'value node = {\n mutable value : 'value; [@mel.as \"v\"]\n mutable height : int; [@mel.as \"h\"]\n mutable left : 'value t; [@mel.as \"l\"]\n mutable right : 'value t; [@mel.as \"r\"]\n}\n\nand 'value t = 'value node option\n\nlet node : value:'value -> height:int -> left:'value t -> right:'value t -> 'value node =\n fun ~value ~height ~left ~right -> { value; height; left; right }\n\nlet valueSet : 'value node -> 'value -> unit = fun o v -> o.value <- v\nlet value : 'value node -> 'value = fun o -> o.value\nlet heightSet : 'value node -> int -> unit = fun o v -> o.height <- v\nlet height : 'value node -> int = fun o -> o.height\nlet leftSet : 'value node -> 'value t -> unit = fun o v -> o.left <- v\nlet left : 'value node -> 'value t = fun o -> o.left\nlet rightSet : 'value node -> 'value t -> unit = fun o v -> o.right <- v\nlet right : 'value node -> 'value t = fun o -> o.right\n\nmodule A = Belt_Array\nmodule S = Belt_SortArray\n\nlet toOpt = Js.toOption\nlet return : 'a -> 'a Js.null = Js.Null.return\nlet empty = Js.empty\nlet unsafeCoerce : 'a Js.null -> 'a = Js.Null.getUnsafe\n\ntype ('a, 'b) cmp = ('a, 'b) Belt_Id.cmp\n\nlet treeHeight (n : _ t) = match toOpt n with None -> 0 | Some n -> height n\n\nlet rec copy n =\n match toOpt n with\n | None -> n\n | Some n ->\n let l, r = (left n, right n) in\n return @@ node ~left:(copy l) ~right:(copy r) ~value:(value n) ~height:(height n)\n\nlet create (l : _ t) v (r : _ t) =\n let hl = match toOpt l with None -> 0 | Some n -> height n in\n let hr = match toOpt r with None -> 0 | Some n -> height n in\n return @@ node ~left:l ~value:v ~right:r ~height:(if hl >= hr then hl + 1 else hr + 1)\n\nlet singleton x = return @@ node ~left:empty ~value:x ~right:empty ~height:1\n\nlet heightGe l r =\n match (toOpt l, toOpt r) with _, None -> true | Some hl, Some hr -> height hl >= height hr | None, Some _ -> false\n\nlet bal l v r =\n let hl = match toOpt l with None -> 0 | Some n -> height n in\n let hr = match toOpt r with None -> 0 | Some n -> height n in\n if hl > hr + 2 then\n let ll, lv, lr =\n let __ocaml_internal_obj = unsafeCoerce l in\n (left __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n if heightGe ll lr then create ll lv (create lr v r)\n else\n let lrl, lrv, lrr =\n let __ocaml_internal_obj = unsafeCoerce lr in\n (left __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n create (create ll lv lrl) lrv (create lrr v r)\n else if hr > hl + 2 then\n let rl, rv, rr =\n let __ocaml_internal_obj = unsafeCoerce r in\n (left __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n if heightGe rr rl then create (create l v rl) rv rr\n else\n let rll, rlv, rlr =\n let __ocaml_internal_obj = unsafeCoerce rl in\n (left __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n create (create l v rll) rlv (create rlr rv rr)\n else return @@ node ~left:l ~value:v ~right:r ~height:(if hl >= hr then hl + 1 else hr + 1)\n\nlet rec min0Aux n = match toOpt (left n) with None -> value n | Some n -> min0Aux n\nlet minimum n = match toOpt n with None -> None | Some n -> Some (min0Aux n)\nlet minUndefined n = match toOpt n with None -> Js.undefined | Some n -> Js.Undefined.return (min0Aux n)\nlet rec max0Aux n = match toOpt (right n) with None -> value n | Some n -> max0Aux n\nlet maximum n = match toOpt n with None -> None | Some n -> Some (max0Aux n)\nlet maxUndefined n = match toOpt n with None -> Js.undefined | Some n -> Js.Undefined.return (max0Aux n)\n\nlet rec removeMinAuxWithRef n v =\n let ln, rn, kn = (left n, right n, value n) in\n match toOpt ln with\n | None ->\n v := kn;\n rn\n | Some ln -> bal (removeMinAuxWithRef ln v) kn rn\n\nlet isEmpty n = match toOpt n with Some _ -> false | None -> true\nlet rec stackAllLeft v s = match toOpt v with None -> s | Some x -> stackAllLeft (left x) (x :: s)\n\nlet rec forEachU n f =\n match toOpt n with\n | None -> ()\n | Some n ->\n forEachU (left n) f;\n f (value n);\n forEachU (right n) f\n\nlet forEach n f = forEachU n (fun a -> f a)\n\nlet rec reduceU s accu f =\n match toOpt s with\n | None -> accu\n | Some n ->\n let l, k, r = (left n, value n, right n) in\n reduceU r (f (reduceU l accu f) k) f\n\nlet reduce s accu f = reduceU s accu (fun a b -> f a b)\n\nlet rec everyU n p =\n match toOpt n with None -> true | Some n -> p (value n) && everyU (left n) p && everyU (right n) p\n\nlet every n p = everyU n (fun a -> p a)\nlet rec someU n p = match toOpt n with None -> false | Some n -> p (value n) || someU (left n) p || someU (right n) p\nlet some n p = someU n (fun a -> p a)\n\nlet rec addMinElement n v =\n match toOpt n with None -> singleton v | Some n -> bal (addMinElement (left n) v) (value n) (right n)\n\nlet rec addMaxElement n v =\n match toOpt n with None -> singleton v | Some n -> bal (left n) (value n) (addMaxElement (right n) v)\n\nlet rec joinShared ln v rn =\n match (toOpt ln, toOpt rn) with\n | None, _ -> addMinElement rn v\n | _, None -> addMaxElement ln v\n | Some l, Some r ->\n let lh = height l in\n let rh = height r in\n if lh > rh + 2 then bal (left l) (value l) (joinShared (right l) v rn)\n else if rh > lh + 2 then bal (joinShared ln v (left r)) (value r) (right r)\n else create ln v rn\n\nlet concatShared t1 t2 =\n match (toOpt t1, toOpt t2) with\n | None, _ -> t2\n | _, None -> t1\n | _, Some t2n ->\n let v = ref (value t2n) in\n let t2r = removeMinAuxWithRef t2n v in\n joinShared t1 !v t2r\n\nlet rec partitionSharedU n p =\n match toOpt n with\n | None -> (empty, empty)\n | Some n ->\n let value = value n in\n let lt, lf = partitionSharedU (left n) p in\n let pv = p value in\n let rt, rf = partitionSharedU (right n) p in\n if pv then (joinShared lt value rt, concatShared lf rf) else (concatShared lt rt, joinShared lf value rf)\n\nlet partitionShared n p = partitionSharedU n (fun a -> p a)\n\nlet rec lengthNode n =\n let l, r = (left n, right n) in\n let sizeL = match toOpt l with None -> 0 | Some l -> lengthNode l in\n let sizeR = match toOpt r with None -> 0 | Some r -> lengthNode r in\n 1 + sizeL + sizeR\n\nlet size n = match toOpt n with None -> 0 | Some n -> lengthNode n\n\nlet rec toListAux n accu =\n match toOpt n with None -> accu | Some n -> toListAux (left n) (value n :: toListAux (right n) accu)\n\nlet toList s = toListAux s []\n\nlet rec checkInvariantInternal (v : _ t) =\n match toOpt v with\n | None -> ()\n | Some n ->\n let l, r = (left n, right n) in\n let diff = treeHeight l - treeHeight r in\n if Stdlib.not (diff <= 2 && diff >= -2) then\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n else (\n checkInvariantInternal l;\n checkInvariantInternal r)\n\nlet rec fillArray n i arr =\n let l, v, r = (left n, value n, right n) in\n let next = match toOpt l with None -> i | Some l -> fillArray l i arr in\n A.setUnsafe arr next v;\n let rnext = next + 1 in\n match toOpt r with None -> rnext | Some r -> fillArray r rnext arr\n\ninclude (\n struct\n type cursor = { mutable forward : int; mutable backward : int }\n\n let cursor : forward:int -> backward:int -> cursor = fun ~forward ~backward -> { forward; backward }\n let forwardSet : cursor -> int -> unit = fun o v -> o.forward <- v\n let forward : cursor -> int = fun o -> o.forward\n let backwardSet : cursor -> int -> unit = fun o v -> o.backward <- v\n let backward : cursor -> int = fun o -> o.backward\n end :\n sig\n type cursor\n\n val cursor : forward:int -> backward:int -> cursor\n val forwardSet : cursor -> int -> unit\n val forward : cursor -> int\n val backwardSet : cursor -> int -> unit\n val backward : cursor -> int\n end)\n\nlet rec fillArrayWithPartition n cursor arr p =\n let l, v, r = (left n, value n, right n) in\n (match toOpt l with None -> () | Some l -> fillArrayWithPartition l cursor arr p);\n (if p v then (\n let c = forward cursor in\n A.setUnsafe arr c v;\n forwardSet cursor (c + 1))\n else\n let c = backward cursor in\n A.setUnsafe arr c v;\n backwardSet cursor (c - 1));\n match toOpt r with None -> () | Some r -> fillArrayWithPartition r cursor arr p\n\nlet rec fillArrayWithFilter n i arr p =\n let l, v, r = (left n, value n, right n) in\n let next = match toOpt l with None -> i | Some l -> fillArrayWithFilter l i arr p in\n let rnext =\n if p v then (\n A.setUnsafe arr next v;\n next + 1)\n else next\n in\n match toOpt r with None -> rnext | Some r -> fillArrayWithFilter r rnext arr p\n\nlet toArray n =\n match toOpt n with\n | None -> [||]\n | Some n ->\n let size = lengthNode n in\n let v = A.makeUninitializedUnsafe size (value n) in\n ignore (fillArray n 0 v : int);\n v\n\nlet rec fromSortedArrayRevAux arr off len =\n match len with\n | 0 -> empty\n | 1 -> singleton (A.getUnsafe arr off)\n | 2 ->\n let x0, x1 =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off - 1))\n in\n return @@ node ~left:(singleton x0) ~value:x1 ~height:2 ~right:empty\n | 3 ->\n let x0, x1, x2 =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off - 1), getUnsafe arr (off - 2))\n in\n return @@ node ~left:(singleton x0) ~right:(singleton x2) ~value:x1 ~height:2\n | _ ->\n let nl = len / 2 in\n let left = fromSortedArrayRevAux arr off nl in\n let mid = A.getUnsafe arr (off - nl) in\n let right = fromSortedArrayRevAux arr (off - nl - 1) (len - nl - 1) in\n create left mid right\n\nlet rec fromSortedArrayAux arr off len =\n match len with\n | 0 -> empty\n | 1 -> singleton (A.getUnsafe arr off)\n | 2 ->\n let x0, x1 =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off + 1))\n in\n return @@ node ~left:(singleton x0) ~value:x1 ~height:2 ~right:empty\n | 3 ->\n let x0, x1, x2 =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off + 1), getUnsafe arr (off + 2))\n in\n return @@ node ~left:(singleton x0) ~right:(singleton x2) ~value:x1 ~height:2\n | _ ->\n let nl = len / 2 in\n let left = fromSortedArrayAux arr off nl in\n let mid = A.getUnsafe arr (off + nl) in\n let right = fromSortedArrayAux arr (off + nl + 1) (len - nl - 1) in\n create left mid right\n\nlet fromSortedArrayUnsafe arr = fromSortedArrayAux arr 0 (A.length arr)\n\nlet rec keepSharedU n p =\n match toOpt n with\n | None -> empty\n | Some n ->\n let l, v, r = (left n, value n, right n) in\n let newL = keepSharedU l p in\n let pv = p v in\n let newR = keepSharedU r p in\n if pv then if l == newL && r == newR then return n else joinShared newL v newR else concatShared newL newR\n\nlet keepShared n p = keepSharedU n (fun a -> p a)\n\nlet keepCopyU n p : _ t =\n match toOpt n with\n | None -> empty\n | Some n ->\n let size = lengthNode n in\n let v = A.makeUninitializedUnsafe size (value n) in\n let last = fillArrayWithFilter n 0 v p in\n fromSortedArrayAux v 0 last\n\nlet keepCopy n p = keepCopyU n (fun x -> p x)\n\nlet partitionCopyU n p =\n match toOpt n with\n | None -> (empty, empty)\n | Some n ->\n let size = lengthNode n in\n let v = A.makeUninitializedUnsafe size (value n) in\n let backward = size - 1 in\n let cursor = cursor ~forward:0 ~backward in\n fillArrayWithPartition n cursor v p;\n let forwardLen = forward cursor in\n (fromSortedArrayAux v 0 forwardLen, fromSortedArrayRevAux v backward (size - forwardLen))\n\nlet partitionCopy n p = partitionCopyU n (fun a -> p a)\n\nlet rec has (t : _ t) x ~cmp =\n match toOpt t with\n | None -> false\n | Some n ->\n let v = value n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n c = 0 || has ~cmp (if c < 0 then left n else right n) x\n\nlet rec compareAux e1 e2 ~cmp =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n let c = (Belt_Id.getCmpInternal cmp) (value h1) (value h2) in\n if c = 0 then compareAux ~cmp (stackAllLeft (right h1) t1) (stackAllLeft (right h2) t2) else c\n | _, _ -> 0\n\nlet cmp s1 s2 ~cmp =\n let len1, len2 = (size s1, size s2) in\n if len1 = len2 then compareAux ~cmp (stackAllLeft s1 []) (stackAllLeft s2 []) else if len1 < len2 then -1 else 1\n\nlet eq s1 s2 ~cmp:c = cmp ~cmp:c s1 s2 = 0\n\nlet rec subset (s1 : _ t) (s2 : _ t) ~cmp =\n match (toOpt s1, toOpt s2) with\n | None, _ -> true\n | _, None -> false\n | Some t1, Some t2 ->\n let l1, v1, r1 = (left t1, value t1, right t1) in\n let l2, v2, r2 = (left t2, value t2, right t2) in\n let c = (Belt_Id.getCmpInternal cmp) v1 v2 in\n if c = 0 then subset ~cmp l1 l2 && subset ~cmp r1 r2\n else if c < 0 then subset ~cmp (create l1 v1 empty) l2 && subset ~cmp r1 s2\n else subset ~cmp (create empty v1 r1) r2 && subset ~cmp l1 s2\n\nlet rec get (n : _ t) x ~cmp =\n match toOpt n with\n | None -> None\n | Some t ->\n let v = value t in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then Some v else get ~cmp (if c < 0 then left t else right t) x\n\nlet rec getUndefined (n : _ t) x ~cmp =\n match toOpt n with\n | None -> Js.Undefined.empty\n | Some t ->\n let v = value t in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then Js.Undefined.return v else getUndefined ~cmp (if c < 0 then left t else right t) x\n\nlet rec getExn (n : _ t) x ~cmp =\n match toOpt n with\n | None ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n | Some t ->\n let v = value t in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then v else getExn ~cmp (if c < 0 then left t else right t) x\n\nlet rotateWithLeftChild k2 =\n let k1 = unsafeCoerce (left k2) in\n leftSet k2 (right k1);\n rightSet k1 (return k2);\n let hlk2, hrk2 = (treeHeight (left k2), treeHeight (right k2)) in\n heightSet k2 (Stdlib.max hlk2 hrk2 + 1);\n let hlk1, hk2 = (treeHeight (left k1), height k2) in\n heightSet k1 (Stdlib.max hlk1 hk2 + 1);\n k1\n\nlet rotateWithRightChild k1 =\n let k2 = unsafeCoerce (right k1) in\n rightSet k1 (left k2);\n leftSet k2 (return k1);\n let hlk1, hrk1 = (treeHeight (left k1), treeHeight (right k1)) in\n heightSet k1 (Stdlib.max hlk1 hrk1 + 1);\n let hrk2, hk1 = (treeHeight (right k2), height k1) in\n heightSet k2 (Stdlib.max hrk2 hk1 + 1);\n k2\n\nlet doubleWithLeftChild k3 =\n let v = return (rotateWithRightChild (unsafeCoerce (left k3))) in\n leftSet k3 v;\n rotateWithLeftChild k3\n[@@ocaml.doc \" \"]\n\nlet doubleWithRightChild k2 =\n let v = return (rotateWithLeftChild (unsafeCoerce (right k2))) in\n rightSet k2 v;\n rotateWithRightChild k2\n\nlet heightUpdateMutate t =\n let hlt, hrt = (treeHeight (left t), treeHeight (right t)) in\n heightSet t (Stdlib.max hlt hrt + 1);\n t\n\nlet balMutate nt =\n let l, r = (left nt, right nt) in\n let hl, hr = (treeHeight l, treeHeight r) in\n if hl > 2 + hr then\n let ll, lr =\n let __ocaml_internal_obj = unsafeCoerce l in\n (left __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n if heightGe ll lr then heightUpdateMutate (rotateWithLeftChild nt) else heightUpdateMutate (doubleWithLeftChild nt)\n else if hr > 2 + hl then\n let rl, rr =\n let __ocaml_internal_obj = unsafeCoerce r in\n (left __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n if heightGe rr rl then heightUpdateMutate (rotateWithRightChild nt)\n else heightUpdateMutate (doubleWithRightChild nt)\n else (\n heightSet nt (max hl hr + 1);\n nt)\n\nlet rec addMutate ~cmp (t : _ t) x =\n match toOpt t with\n | None -> singleton x\n | Some nt ->\n let k = value nt in\n let c = (Belt_Id.getCmpInternal cmp) x k in\n if c = 0 then t\n else\n let l, r = (left nt, right nt) in\n if c < 0 then\n let ll = addMutate ~cmp l x in\n leftSet nt ll\n else rightSet nt (addMutate ~cmp r x);\n return (balMutate nt)\n\nlet fromArray (xs : _ array) ~cmp =\n let len = A.length xs in\n if len = 0 then empty\n else\n let next = ref (S.strictlySortedLengthU xs (fun x y -> (Belt_Id.getCmpInternal cmp) x y < 0)) in\n let result =\n ref\n (if !next >= 0 then fromSortedArrayAux xs 0 !next\n else (\n next := - !next;\n fromSortedArrayRevAux xs (!next - 1) !next))\n in\n for i = !next to len - 1 do\n result := addMutate ~cmp !result (A.getUnsafe xs i)\n done;\n !result\n\nlet rec removeMinAuxWithRootMutate nt n =\n let rn, ln = (right n, left n) in\n match toOpt ln with\n | None ->\n valueSet nt (value n);\n rn\n | Some ln ->\n leftSet n (removeMinAuxWithRootMutate nt ln);\n return (balMutate n)\n"
},
{
"path": "packages/Belt/src/Belt_internalAVLset.mli",
"content": "type 'value node = { mutable value : 'value; mutable height : int; mutable left : 'value t; mutable right : 'value t }\nand 'value t = 'value node option\n\nval node : value:'value -> height:int -> left:'value t -> right:'value t -> 'value node\nval valueSet : 'value node -> 'value -> unit\nval value : 'value node -> 'value\nval heightSet : 'value node -> int -> unit\nval height : 'value node -> int\nval leftSet : 'value node -> 'value t -> unit\nval left : 'value node -> 'value t\nval rightSet : 'value node -> 'value t -> unit\nval right : 'value node -> 'value t\n\nmodule A = Belt_Array\nmodule S = Belt_SortArray\n\nval toOpt : 'a option -> 'a option\nval return : 'a -> 'a option\nval empty : 'a option\nval unsafeCoerce : 'a option -> 'a\n\ntype ('a, 'b) cmp = ('a, 'b) Belt_Id.cmp\n\nval treeHeight : 'a t -> int\nval copy : 'a node option -> 'a node option\nval create : 'a t -> 'a -> 'a t -> 'a node option\nval singleton : 'a -> 'a node option\nval heightGe : 'a node option -> 'b node option -> bool\nval bal : 'a node option -> 'a -> 'a node option -> 'a node option\nval min0Aux : 'a node -> 'a\nval minimum : 'a node option -> 'a option\nval minUndefined : 'a node option -> 'a option\nval max0Aux : 'a node -> 'a\nval maximum : 'a node option -> 'a option\nval maxUndefined : 'a node option -> 'a option\nval removeMinAuxWithRef : 'a node -> 'a ref -> 'a t\nval isEmpty : 'a option -> bool\nval stackAllLeft : 'a node option -> 'a node list -> 'a node list\nval forEachU : 'a node option -> ('a -> unit) -> unit\nval forEach : 'a node option -> ('a -> unit) -> unit\nval reduceU : 'a node option -> 'b -> ('b -> 'a -> 'b) -> 'b\nval reduce : 'a node option -> 'b -> ('b -> 'a -> 'b) -> 'b\nval everyU : 'a node option -> ('a -> bool) -> bool\nval every : 'a node option -> ('a -> bool) -> bool\nval someU : 'a node option -> ('a -> bool) -> bool\nval some : 'a node option -> ('a -> bool) -> bool\nval addMinElement : 'a node option -> 'a -> 'a node option\nval addMaxElement : 'a node option -> 'a -> 'a node option\nval joinShared : 'a node option -> 'a -> 'a node option -> 'a node option\nval concatShared : 'a node option -> 'a node option -> 'a node option\nval partitionSharedU : 'a node option -> ('a -> bool) -> 'a node option * 'a node option\nval partitionShared : 'a node option -> ('a -> bool) -> 'a node option * 'a node option\nval lengthNode : 'a node -> int\nval size : 'a node option -> int\nval toListAux : 'a node option -> 'a list -> 'a list\nval toList : 'a node option -> 'a list\nval checkInvariantInternal : 'a t -> unit\nval fillArray : 'a node -> int -> 'a A.t -> int\n\ntype cursor\n\nval cursor : forward:int -> backward:int -> cursor\nval forwardSet : cursor -> int -> unit\nval forward : cursor -> int\nval backwardSet : cursor -> int -> unit\nval backward : cursor -> int\nval fillArrayWithPartition : 'a node -> cursor -> 'a A.t -> ('a -> bool) -> unit\nval fillArrayWithFilter : 'a node -> int -> 'a A.t -> ('a -> bool) -> int\nval toArray : 'a node option -> 'a array\nval fromSortedArrayRevAux : 'a A.t -> int -> int -> 'a node option\nval fromSortedArrayAux : 'a A.t -> int -> int -> 'a node option\nval fromSortedArrayUnsafe : 'a A.t -> 'a node option\nval keepSharedU : 'a node option -> ('a -> bool) -> 'a t\nval keepShared : 'a node option -> ('a -> bool) -> 'a t\nval keepCopyU : 'a node option -> ('a -> bool) -> 'a t\nval keepCopy : 'a node option -> ('a -> bool) -> 'a t\nval partitionCopyU : 'a node option -> ('a -> bool) -> 'a node option * 'a node option\nval partitionCopy : 'a node option -> ('a -> bool) -> 'a node option * 'a node option\nval has : 'a t -> 'a -> cmp:('a -> 'a -> int) -> bool\nval compareAux : 'a node list -> 'a node list -> cmp:('a -> 'a -> int) -> int\nval cmp : 'a node option -> 'a node option -> cmp:('a -> 'a -> int) -> int\nval eq : 'a node option -> 'a node option -> cmp:('a -> 'a -> int) -> bool\nval subset : 'a t -> 'a t -> cmp:('a -> 'a -> int) -> bool\nval get : 'a t -> 'a -> cmp:('a -> 'a -> int) -> 'a option\nval getUndefined : 'a t -> 'a -> cmp:('a -> 'a -> int) -> 'a option\nval getExn : 'a t -> 'a -> cmp:('a -> 'a -> int) -> 'a\nval rotateWithLeftChild : 'a node -> 'a node\nval rotateWithRightChild : 'a node -> 'a node\nval doubleWithLeftChild : 'a node -> 'a node\nval doubleWithRightChild : 'a node -> 'a node\nval heightUpdateMutate : 'a node -> 'a node\nval balMutate : 'a node -> 'a node\nval addMutate : cmp:('a -> 'a -> int) -> 'a t -> 'a -> 'a node option\nval fromArray : 'a array -> cmp:('a -> 'a -> int) -> 'a node option\nval removeMinAuxWithRootMutate : 'a node -> 'a node -> 'a t\n"
},
{
"path": "packages/Belt/src/Belt_internalAVLtree.ml",
"content": "[@@@ocaml.text \" Almost rewritten by authors of BuckleScript \"]\n\ntype ('k, 'v) node = {\n mutable key : 'k;\n mutable value : 'v;\n mutable height : int;\n mutable left : ('k, 'v) t;\n mutable right : ('k, 'v) t;\n}\n\nand ('key, 'a) t = ('key, 'a) node Js.null\n\nlet node : key:'k -> value:'v -> height:int -> left:('k, 'v) t -> right:('k, 'v) t -> ('k, 'v) node =\n fun ~key ~value ~height ~left ~right -> { key; value; height; left; right }\n\nlet keySet : ('k, 'v) node -> 'k -> unit = fun o v -> o.key <- v\nlet key : ('k, 'v) node -> 'k = fun o -> o.key\nlet valueSet : ('k, 'v) node -> 'v -> unit = fun o v -> o.value <- v\nlet value : ('k, 'v) node -> 'v = fun o -> o.value\nlet heightSet : ('k, 'v) node -> int -> unit = fun o v -> o.height <- v\nlet height : ('k, 'v) node -> int = fun o -> o.height\nlet leftSet : ('k, 'v) node -> ('k, 'v) t -> unit = fun o v -> o.left <- v\nlet left : ('k, 'v) node -> ('k, 'v) t = fun o -> o.left\nlet rightSet : ('k, 'v) node -> ('k, 'v) t -> unit = fun o v -> o.right <- v\nlet right : ('k, 'v) node -> ('k, 'v) t = fun o -> o.right\n\ntype ('k, 'id) cmp = ('k, 'id) Belt_Id.cmp\n\nmodule A = Belt_Array\nmodule S = Belt_SortArray\n\nlet toOpt : 'a Js.null -> 'a option = Js.toOption\nlet return a = Js.Null.return a\nlet empty : 'a Js.null = Js.empty\nlet unsafeCoerce a = Js.Null.getUnsafe a\nlet treeHeight (n : _ t) = match toOpt n with None -> 0 | Some n -> height n\n\nlet rec copy n =\n match toOpt n with\n | None -> n\n | Some n ->\n let l, r = (left n, right n) in\n return @@ node ~left:(copy l) ~right:(copy r) ~value:(value n) ~key:(key n) ~height:(height n)\n\nlet create l x d r =\n let hl, hr = (treeHeight l, treeHeight r) in\n return @@ node ~left:l ~key:x ~value:d ~right:r ~height:(if hl >= hr then hl + 1 else hr + 1)\n\nlet singleton x d = return @@ node ~left:empty ~key:x ~value:d ~right:empty ~height:1\n\nlet heightGe l r =\n match (toOpt l, toOpt r) with _, None -> true | Some hl, Some hr -> height hl >= height hr | None, Some _ -> false\n\nlet updateValue n newValue =\n if value n == newValue then n\n else node ~left:(left n) ~right:(right n) ~key:(key n) ~value:newValue ~height:(height n)\n\nlet bal l x d r =\n let hl = match toOpt l with None -> 0 | Some n -> height n in\n let hr = match toOpt r with None -> 0 | Some n -> height n in\n if hl > hr + 2 then\n let ll, lv, ld, lr =\n let __ocaml_internal_obj = unsafeCoerce l in\n (left __ocaml_internal_obj, key __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n if treeHeight ll >= treeHeight lr then create ll lv ld (create lr x d r)\n else\n let lrl, lrv, lrd, lrr =\n let __ocaml_internal_obj = unsafeCoerce lr in\n (left __ocaml_internal_obj, key __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n create (create ll lv ld lrl) lrv lrd (create lrr x d r)\n else if hr > hl + 2 then\n let rl, rv, rd, rr =\n let __ocaml_internal_obj = unsafeCoerce r in\n (left __ocaml_internal_obj, key __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n if treeHeight rr >= treeHeight rl then create (create l x d rl) rv rd rr\n else\n let rll, rlv, rld, rlr =\n let __ocaml_internal_obj = unsafeCoerce rl in\n (left __ocaml_internal_obj, key __ocaml_internal_obj, value __ocaml_internal_obj, right __ocaml_internal_obj)\n in\n create (create l x d rll) rlv rld (create rlr rv rd rr)\n else return @@ node ~left:l ~key:x ~value:d ~right:r ~height:(if hl >= hr then hl + 1 else hr + 1)\n\nlet rec minKey0Aux n = match toOpt (left n) with None -> key n | Some n -> minKey0Aux n\nlet minKey n = match toOpt n with None -> None | Some n -> Some (minKey0Aux n)\nlet minKeyUndefined n = match toOpt n with None -> Js.undefined | Some n -> Js.Undefined.return (minKey0Aux n)\nlet rec maxKey0Aux n = match toOpt (right n) with None -> key n | Some n -> maxKey0Aux n\nlet maxKey n = match toOpt n with None -> None | Some n -> Some (maxKey0Aux n)\nlet maxKeyUndefined n = match toOpt n with None -> Js.undefined | Some n -> Js.Undefined.return (maxKey0Aux n)\nlet rec minKV0Aux n = match toOpt (left n) with None -> (key n, value n) | Some n -> minKV0Aux n\nlet minimum n = match toOpt n with None -> None | Some n -> Some (minKV0Aux n)\nlet minUndefined n = match toOpt n with None -> Js.undefined | Some n -> Js.Undefined.return (minKV0Aux n)\nlet rec maxKV0Aux n = match toOpt (right n) with None -> (key n, value n) | Some n -> maxKV0Aux n\nlet maximum n = match toOpt n with None -> None | Some n -> Some (maxKV0Aux n)\nlet maxUndefined n = match toOpt n with None -> Js.undefined | Some n -> Js.Undefined.return (maxKV0Aux n)\n\nlet rec removeMinAuxWithRef n kr vr =\n let ln, rn, kn, vn = (left n, right n, key n, value n) in\n match toOpt ln with\n | None ->\n kr := kn;\n vr := vn;\n rn\n | Some ln -> bal (removeMinAuxWithRef ln kr vr) kn vn rn\n\nlet isEmpty x = match toOpt x with None -> true | Some _ -> false\nlet rec stackAllLeft v s = match toOpt v with None -> s | Some x -> stackAllLeft (left x) (x :: s)\n\nlet rec forEachU n f =\n match toOpt n with\n | None -> ()\n | Some n ->\n forEachU (left n) f;\n f (key n) (value n);\n forEachU (right n) f\n\nlet forEach n f = forEachU n (fun a b -> f a b)\n\nlet rec mapU n f =\n match toOpt n with\n | None -> empty\n | Some n ->\n let newLeft = mapU (left n) f in\n let newD = f (value n) in\n let newRight = mapU (right n) f in\n return @@ node ~left:newLeft ~key:(key n) ~value:newD ~right:newRight ~height:(height n)\n\nlet map n f = mapU n (fun a -> f a)\n\nlet rec mapWithKeyU n f =\n match toOpt n with\n | None -> empty\n | Some n ->\n let key = key n in\n let newLeft = mapWithKeyU (left n) f in\n let newD = f key (value n) in\n let newRight = mapWithKeyU (right n) f in\n return @@ node ~left:newLeft ~key ~value:newD ~right:newRight ~height:(height n)\n\nlet mapWithKey n f = mapWithKeyU n (fun a b -> f a b)\n\nlet rec reduceU m accu f =\n match toOpt m with\n | None -> accu\n | Some n ->\n let l, v, d, r = (left n, key n, value n, right n) in\n reduceU r (f (reduceU l accu f) v d) f\n\nlet reduce m accu f = reduceU m accu (fun a b c -> f a b c)\n\nlet rec everyU n p =\n match toOpt n with None -> true | Some n -> p (key n) (value n) && everyU (left n) p && everyU (right n) p\n\nlet every n p = everyU n (fun a b -> p a b)\n\nlet rec someU n p =\n match toOpt n with None -> false | Some n -> p (key n) (value n) || someU (left n) p || someU (right n) p\n\nlet some n p = someU n (fun a b -> p a b)\n\nlet rec addMinElement n k v =\n match toOpt n with None -> singleton k v | Some n -> bal (addMinElement (left n) k v) (key n) (value n) (right n)\n\nlet rec addMaxElement n k v =\n match toOpt n with None -> singleton k v | Some n -> bal (left n) (key n) (value n) (addMaxElement (right n) k v)\n\nlet rec join ln v d rn =\n match (toOpt ln, toOpt rn) with\n | None, _ -> addMinElement rn v d\n | _, None -> addMaxElement ln v d\n | Some l, Some r ->\n let ll, lv, ld, lr, lh = (left l, key l, value l, right l, height l) in\n let rl, rv, rd, rr, rh = (left r, key r, value r, right r, height r) in\n if lh > rh + 2 then bal ll lv ld (join lr v d rn)\n else if rh > lh + 2 then bal (join ln v d rl) rv rd rr\n else create ln v d rn\n\nlet concat t1 t2 =\n match (toOpt t1, toOpt t2) with\n | None, _ -> t2\n | _, None -> t1\n | _, Some t2n ->\n let kr, vr = (ref (key t2n), ref (value t2n)) in\n let t2r = removeMinAuxWithRef t2n kr vr in\n join t1 !kr !vr t2r\n\nlet concatOrJoin t1 v d t2 = match d with Some d -> join t1 v d t2 | None -> concat t1 t2\n\nlet rec keepSharedU n p =\n match toOpt n with\n | None -> empty\n | Some n ->\n let v, d = (key n, value n) in\n let newLeft = keepSharedU (left n) p in\n let pvd = p v d in\n let newRight = keepSharedU (right n) p in\n if pvd then join newLeft v d newRight else concat newLeft newRight\n\nlet keepShared n p = keepSharedU n (fun a b -> p a b)\n\nlet rec keepMapU n p =\n match toOpt n with\n | None -> empty\n | Some n -> (\n let v, d = (key n, value n) in\n let newLeft = keepMapU (left n) p in\n let pvd = p v d in\n let newRight = keepMapU (right n) p in\n match pvd with None -> concat newLeft newRight | Some d -> join newLeft v d newRight)\n\nlet keepMap n p = keepMapU n (fun a b -> p a b)\n\nlet rec partitionSharedU n p =\n match toOpt n with\n | None -> (empty, empty)\n | Some n ->\n let key, value = (key n, value n) in\n let lt, lf = partitionSharedU (left n) p in\n let pvd = p key value in\n let rt, rf = partitionSharedU (right n) p in\n if pvd then (join lt key value rt, concat lf rf) else (concat lt rt, join lf key value rf)\n\nlet partitionShared n p = partitionSharedU n (fun a b -> p a b)\n\nlet rec lengthNode n =\n let l, r = (left n, right n) in\n let sizeL = match toOpt l with None -> 0 | Some l -> lengthNode l in\n let sizeR = match toOpt r with None -> 0 | Some r -> lengthNode r in\n 1 + sizeL + sizeR\n\nlet size n = match toOpt n with None -> 0 | Some n -> lengthNode n\n\nlet rec toListAux n accu =\n match toOpt n with\n | None -> accu\n | Some n ->\n let l, r, k, v = (left n, right n, key n, value n) in\n toListAux l ((k, v) :: toListAux r accu)\n\nlet toList s = toListAux s []\n\nlet rec checkInvariantInternal (v : _ t) =\n match toOpt v with\n | None -> ()\n | Some n ->\n let l, r = (left n, right n) in\n let diff = treeHeight l - treeHeight r in\n if Stdlib.not (diff <= 2 && diff >= -2) then\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n else (\n checkInvariantInternal l;\n checkInvariantInternal r)\n\nlet rec fillArrayKey n i arr =\n let l, v, r = (left n, key n, right n) in\n let next = match toOpt l with None -> i | Some l -> fillArrayKey l i arr in\n A.setUnsafe arr next v;\n let rnext = next + 1 in\n match toOpt r with None -> rnext | Some r -> fillArrayKey r rnext arr\n\nlet rec fillArrayValue n i arr =\n let l, r = (left n, right n) in\n let next = match toOpt l with None -> i | Some l -> fillArrayValue l i arr in\n A.setUnsafe arr next (value n);\n let rnext = next + 1 in\n match toOpt r with None -> rnext | Some r -> fillArrayValue r rnext arr\n\nlet rec fillArray n i arr =\n let l, v, r = (left n, key n, right n) in\n let next = match toOpt l with None -> i | Some l -> fillArray l i arr in\n A.setUnsafe arr next (v, value n);\n let rnext = next + 1 in\n match toOpt r with None -> rnext | Some r -> fillArray r rnext arr\n\ninclude (\n struct\n type cursor = { mutable forward : int; mutable backward : int }\n\n let cursor : forward:int -> backward:int -> cursor = fun ~forward ~backward -> { forward; backward }\n let forwardSet : cursor -> int -> unit = fun o v -> o.forward <- v\n let forward : cursor -> int = fun o -> o.forward\n let backwardSet : cursor -> int -> unit = fun o v -> o.backward <- v\n let backward : cursor -> int = fun o -> o.backward\n end :\n sig\n type cursor\n\n val cursor : forward:int -> backward:int -> cursor\n val forwardSet : cursor -> int -> unit\n val forward : cursor -> int\n val backwardSet : cursor -> int -> unit\n val backward : cursor -> int\n end)\n\nlet rec fillArrayWithPartition n cursor arr p =\n let l, v, r = (left n, key n, right n) in\n (match toOpt l with None -> () | Some l -> fillArrayWithPartition l cursor arr p);\n (if p v then (\n let c = forward cursor in\n A.setUnsafe arr c (v, value n);\n forwardSet cursor (c + 1))\n else\n let c = backward cursor in\n A.setUnsafe arr c (v, value n);\n backwardSet cursor (c - 1));\n match toOpt r with None -> () | Some r -> fillArrayWithPartition r cursor arr p\n\nlet rec fillArrayWithFilter n i arr p =\n let l, v, r = (left n, key n, right n) in\n let next = match toOpt l with None -> i | Some l -> fillArrayWithFilter l i arr p in\n let rnext =\n if p v then (\n A.setUnsafe arr next (v, value n);\n next + 1)\n else next\n in\n match toOpt r with None -> rnext | Some r -> fillArrayWithFilter r rnext arr p\n\nlet toArray n =\n match toOpt n with\n | None -> [||]\n | Some n ->\n let size = lengthNode n in\n let v = A.makeUninitializedUnsafe size (key n, value n) in\n ignore (fillArray n 0 v : int);\n v\n\nlet keysToArray n =\n match toOpt n with\n | None -> [||]\n | Some n ->\n let size = lengthNode n in\n let v = A.makeUninitializedUnsafe size (key n) in\n ignore (fillArrayKey n 0 v : int);\n v\n\nlet valuesToArray n =\n match toOpt n with\n | None -> [||]\n | Some n ->\n let size = lengthNode n in\n let v = A.makeUninitializedUnsafe size (value n) in\n ignore (fillArrayValue n 0 v : int);\n v\n\nlet rec fromSortedArrayRevAux arr off len =\n match len with\n | 0 -> empty\n | 1 ->\n let k, v = A.getUnsafe arr off in\n singleton k v\n | 2 ->\n let (x0, y0), (x1, y1) =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off - 1))\n in\n return @@ node ~left:(singleton x0 y0) ~key:x1 ~value:y1 ~height:2 ~right:empty\n | 3 ->\n let (x0, y0), (x1, y1), (x2, y2) =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off - 1), getUnsafe arr (off - 2))\n in\n return @@ node ~left:(singleton x0 y0) ~right:(singleton x2 y2) ~key:x1 ~value:y1 ~height:2\n | _ ->\n let nl = len / 2 in\n let left = fromSortedArrayRevAux arr off nl in\n let midK, midV = A.getUnsafe arr (off - nl) in\n let right = fromSortedArrayRevAux arr (off - nl - 1) (len - nl - 1) in\n create left midK midV right\n\nlet rec fromSortedArrayAux arr off len =\n match len with\n | 0 -> empty\n | 1 ->\n let k, v = A.getUnsafe arr off in\n singleton k v\n | 2 ->\n let (x0, y0), (x1, y1) =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off + 1))\n in\n return @@ node ~left:(singleton x0 y0) ~key:x1 ~value:y1 ~height:2 ~right:empty\n | 3 ->\n let (x0, y0), (x1, y1), (x2, y2) =\n let open A in\n (getUnsafe arr off, getUnsafe arr (off + 1), getUnsafe arr (off + 2))\n in\n return @@ node ~left:(singleton x0 y0) ~right:(singleton x2 y2) ~key:x1 ~value:y1 ~height:2\n | _ ->\n let nl = len / 2 in\n let left = fromSortedArrayAux arr off nl in\n let midK, midV = A.getUnsafe arr (off + nl) in\n let right = fromSortedArrayAux arr (off + nl + 1) (len - nl - 1) in\n create left midK midV right\n\nlet fromSortedArrayUnsafe arr = fromSortedArrayAux arr 0 (A.length arr)\n\nlet rec compareAux e1 e2 ~kcmp ~vcmp =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n let c = (Belt_Id.getCmpInternal kcmp) (key h1) (key h2) in\n if c = 0 then\n let cx = vcmp (value h1) (value h2) in\n if cx = 0 then compareAux ~kcmp ~vcmp (stackAllLeft (right h1) t1) (stackAllLeft (right h2) t2) else cx\n else c\n | _, _ -> 0\n\nlet rec eqAux e1 e2 ~kcmp ~veq =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n if (Belt_Id.getCmpInternal kcmp) (key h1) (key h2) = 0 && veq (value h1) (value h2) then\n eqAux ~kcmp ~veq (stackAllLeft (right h1) t1) (stackAllLeft (right h2) t2)\n else false\n | _, _ -> true\n\nlet cmpU s1 s2 ~kcmp ~vcmp =\n let len1, len2 = (size s1, size s2) in\n if len1 = len2 then compareAux (stackAllLeft s1 []) (stackAllLeft s2 []) ~kcmp ~vcmp\n else if len1 < len2 then -1\n else 1\n\nlet cmp s1 s2 ~kcmp ~vcmp = cmpU s1 s2 ~kcmp ~vcmp:(fun a b -> vcmp a b)\n\nlet eqU s1 s2 ~kcmp ~veq =\n let len1, len2 = (size s1, size s2) in\n if len1 = len2 then eqAux (stackAllLeft s1 []) (stackAllLeft s2 []) ~kcmp ~veq else false\n\nlet eq s1 s2 ~kcmp ~veq = eqU s1 s2 ~kcmp ~veq:(fun a b -> veq a b)\n\nlet rec get n x ~cmp =\n match toOpt n with\n | None -> None\n | Some n ->\n let v = key n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then Some (value n) else get ~cmp (if c < 0 then left n else right n) x\n\nlet rec getUndefined n x ~cmp =\n match toOpt n with\n | None -> Js.undefined\n | Some n ->\n let v = key n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then Js.Undefined.return (value n) else getUndefined ~cmp (if c < 0 then left n else right n) x\n\nlet rec getExn n x ~cmp =\n match toOpt n with\n | None ->\n let error = Printf.sprintf \"File %s, line %d\" __FILE__ __LINE__ in\n Js.Exn.raiseError error\n | Some n ->\n let v = key n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then value n else getExn ~cmp (if c < 0 then left n else right n) x\n\nlet rec getWithDefault n x def ~cmp =\n match toOpt n with\n | None -> def\n | Some n ->\n let v = key n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n if c = 0 then value n else getWithDefault ~cmp (if c < 0 then left n else right n) x def\n\nlet rec has n x ~cmp =\n match toOpt n with\n | None -> false\n | Some n ->\n let v = key n in\n let c = (Belt_Id.getCmpInternal cmp) x v in\n c = 0 || has ~cmp (if c < 0 then left n else right n) x\n\nlet rotateWithLeftChild k2 =\n let k1 = unsafeCoerce (left k2) in\n leftSet k2 (right k1);\n rightSet k1 (return k2);\n let hlk2, hrk2 = (treeHeight (left k2), treeHeight (right k2)) in\n heightSet k2 (Stdlib.max hlk2 hrk2 + 1);\n let hlk1, hk2 = (treeHeight (left k1), height k2) in\n heightSet k1 (Stdlib.max hlk1 hk2 + 1);\n k1\n\nlet rotateWithRightChild k1 =\n let k2 = unsafeCoerce (right k1) in\n rightSet k1 (left k2);\n leftSet k2 (return k1);\n let hlk1, hrk1 = (treeHeight (left k1), treeHeight (right k1)) in\n heightSet k1 (Stdlib.max hlk1 hrk1 + 1);\n let hrk2, hk1 = (treeHeight (right k2), height k1) in\n heightSet k2 (Stdlib.max hrk2 hk1 + 1);\n k2\n\nlet doubleWithLeftChild k3 =\n let v = rotateWithRightChild (unsafeCoerce (left k3)) in\n leftSet k3 (return v);\n rotateWithLeftChild k3\n\nlet doubleWithRightChild k2 =\n let v = rotateWithLeftChild (unsafeCoerce (right k2)) in\n rightSet k2 (return v);\n rotateWithRightChild k2\n\nlet heightUpdateMutate t =\n let hlt, hrt = (treeHeight (left t), treeHeight (right t)) in\n heightSet t (Stdlib.max hlt hrt + 1);\n t\n\nlet balMutate nt =\n let l, r = (left nt, right nt) in\n let hl, hr = (treeHeight l, treeHeight r) in\n if hl > 2 + hr then\n let l = unsafeCoerce l in\n let ll, lr = (left l, right l) in\n if heightGe ll lr then heightUpdateMutate (rotateWithLeftChild nt) else heightUpdateMutate (doubleWithLeftChild nt)\n else if hr > 2 + hl then\n let r = unsafeCoerce r in\n let rl, rr = (left r, right r) in\n if heightGe rr rl then heightUpdateMutate (rotateWithRightChild nt)\n else heightUpdateMutate (doubleWithRightChild nt)\n else (\n heightSet nt (max hl hr + 1);\n nt)\n\nlet rec updateMutate (t : _ t) x data ~cmp =\n match toOpt t with\n | None -> singleton x data\n | Some nt ->\n let k = key nt in\n let c = (Belt_Id.getCmpInternal cmp) x k in\n if c = 0 then (\n valueSet nt data;\n return nt)\n else\n let l, r = (left nt, right nt) in\n if c < 0 then\n let ll = updateMutate ~cmp l x data in\n leftSet nt ll\n else rightSet nt (updateMutate ~cmp r x data);\n return (balMutate nt)\n\nlet fromArray (xs : _ array) ~cmp =\n let len = A.length xs in\n if len = 0 then empty\n else\n let next = ref (S.strictlySortedLengthU xs (fun (x0, _) (y0, _) -> (Belt_Id.getCmpInternal cmp) x0 y0 < 0)) in\n let result =\n ref\n (if !next >= 0 then fromSortedArrayAux xs 0 !next\n else (\n next := - !next;\n fromSortedArrayRevAux xs (!next - 1) !next))\n in\n for i = !next to len - 1 do\n let k, v = A.getUnsafe xs i in\n result := updateMutate ~cmp !result k v\n done;\n !result\n\nlet rec removeMinAuxWithRootMutate nt n =\n let rn, ln = (right n, left n) in\n match toOpt ln with\n | None ->\n keySet nt (key n);\n valueSet nt (value n);\n rn\n | Some ln ->\n leftSet n (removeMinAuxWithRootMutate nt ln);\n return (balMutate n)\n\nlet rec findFirstByU n p =\n match n with\n | None -> None\n | Some n ->\n let left = findFirstByU n.left p in\n if left <> None then left\n else\n let { key = v; value = d } = n in\n let pvd = (p v d [@bs]) in\n if pvd then Some (v, d)\n else\n let right = findFirstByU n.right p in\n if right <> None then right else None\n\nlet findFirstBy n p = findFirstByU n (fun[@bs] a b -> p a b)\n"
},
{
"path": "packages/Belt/src/Belt_internalAVLtree.mli",
"content": "type ('k, 'v) node = {\n mutable key : 'k;\n mutable value : 'v;\n mutable height : int;\n mutable left : ('k, 'v) t;\n mutable right : ('k, 'v) t;\n}\n\nand ('key, 'a) t = ('key, 'a) node option\n\nval node : key:'k -> value:'v -> height:int -> left:('k, 'v) t -> right:('k, 'v) t -> ('k, 'v) node\nval keySet : ('k, 'v) node -> 'k -> unit\nval key : ('k, 'v) node -> 'k\nval valueSet : ('k, 'v) node -> 'v -> unit\nval value : ('k, 'v) node -> 'v\nval heightSet : ('k, 'v) node -> int -> unit\nval height : ('k, 'v) node -> int\nval leftSet : ('k, 'v) node -> ('k, 'v) t -> unit\nval left : ('k, 'v) node -> ('k, 'v) t\nval rightSet : ('k, 'v) node -> ('k, 'v) t -> unit\nval right : ('k, 'v) node -> ('k, 'v) t\n\ntype ('k, 'id) cmp = ('k, 'id) Belt_Id.cmp\n\nmodule A = Belt_Array\nmodule S = Belt_SortArray\n\nval toOpt : 'a option -> 'a option\nval return : 'a -> 'a option\nval empty : 'a option\nval unsafeCoerce : 'a option -> 'a\nval treeHeight : ('a, 'b) t -> int\nval copy : ('a, 'b) node option -> ('a, 'b) node option\nval create : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) node option\nval singleton : 'a -> 'b -> ('a, 'b) node option\nval heightGe : ('a, 'b) node option -> ('c, 'd) node option -> bool\nval updateValue : ('a, 'b) node -> 'b -> ('a, 'b) node\nval bal : ('a, 'b) node option -> 'a -> 'b -> ('a, 'b) node option -> ('a, 'b) node option\nval minKey0Aux : ('a, 'b) node -> 'a\nval minKey : ('a, 'b) node option -> 'a option\nval minKeyUndefined : ('a, 'b) node option -> 'a option\nval maxKey0Aux : ('a, 'b) node -> 'a\nval maxKey : ('a, 'b) node option -> 'a option\nval maxKeyUndefined : ('a, 'b) node option -> 'a option\nval minKV0Aux : ('a, 'b) node -> 'a * 'b\nval minimum : ('a, 'b) node option -> ('a * 'b) option\nval minUndefined : ('a, 'b) node option -> ('a * 'b) option\nval maxKV0Aux : ('a, 'b) node -> 'a * 'b\nval maximum : ('a, 'b) node option -> ('a * 'b) option\nval maxUndefined : ('a, 'b) node option -> ('a * 'b) option\nval removeMinAuxWithRef : ('a, 'b) node -> 'a ref -> 'b ref -> ('a, 'b) t\nval isEmpty : 'a option -> bool\nval stackAllLeft : ('a, 'b) node option -> ('a, 'b) node list -> ('a, 'b) node list\nval forEachU : ('a, 'b) node option -> ('a -> 'b -> unit) -> unit\nval forEach : ('a, 'b) node option -> ('a -> 'b -> unit) -> unit\nval mapU : ('a, 'b) node option -> ('b -> 'c) -> ('a, 'c) node option\nval map : ('a, 'b) node option -> ('b -> 'c) -> ('a, 'c) node option\nval mapWithKeyU : ('a, 'b) node option -> ('a -> 'b -> 'c) -> ('a, 'c) node option\nval mapWithKey : ('a, 'b) node option -> ('a -> 'b -> 'c) -> ('a, 'c) node option\nval reduceU : ('a, 'b) node option -> 'c -> ('c -> 'a -> 'b -> 'c) -> 'c\nval reduce : ('a, 'b) node option -> 'c -> ('c -> 'a -> 'b -> 'c) -> 'c\nval everyU : ('a, 'b) node option -> ('a -> 'b -> bool) -> bool\nval every : ('a, 'b) node option -> ('a -> 'b -> bool) -> bool\nval someU : ('a, 'b) node option -> ('a -> 'b -> bool) -> bool\nval some : ('a, 'b) node option -> ('a -> 'b -> bool) -> bool\nval addMinElement : ('a, 'b) node option -> 'a -> 'b -> ('a, 'b) node option\nval addMaxElement : ('a, 'b) node option -> 'a -> 'b -> ('a, 'b) node option\nval join : ('a, 'b) node option -> 'a -> 'b -> ('a, 'b) node option -> ('a, 'b) node option\nval concat : ('a, 'b) node option -> ('a, 'b) node option -> ('a, 'b) node option\nval concatOrJoin : ('a, 'b) node option -> 'a -> 'b option -> ('a, 'b) node option -> ('a, 'b) node option\nval keepSharedU : ('a, 'b) node option -> ('a -> 'b -> bool) -> ('a, 'b) node option\nval keepShared : ('a, 'b) node option -> ('a -> 'b -> bool) -> ('a, 'b) node option\nval keepMapU : ('a, 'b) node option -> ('a -> 'b -> 'c option) -> ('a, 'c) node option\nval keepMap : ('a, 'b) node option -> ('a -> 'b -> 'c option) -> ('a, 'c) node option\nval partitionSharedU : ('a, 'b) node option -> ('a -> 'b -> bool) -> ('a, 'b) node option * ('a, 'b) node option\nval partitionShared : ('a, 'b) node option -> ('a -> 'b -> bool) -> ('a, 'b) node option * ('a, 'b) node option\nval lengthNode : ('a, 'b) node -> int\nval size : ('a, 'b) node option -> int\nval toListAux : ('a, 'b) node option -> ('a * 'b) list -> ('a * 'b) list\nval toList : ('a, 'b) node option -> ('a * 'b) list\nval checkInvariantInternal : ('a, 'b) t -> unit\nval fillArrayKey : ('a, 'b) node -> int -> 'a A.t -> int\nval fillArrayValue : ('a, 'b) node -> int -> 'b A.t -> int\nval fillArray : ('weak55, 'a) node -> int -> ('weak55 * 'a) A.t -> int\n\ntype cursor\n\nval cursor : forward:int -> backward:int -> cursor\nval forwardSet : cursor -> int -> unit\nval forward : cursor -> int\nval backwardSet : cursor -> int -> unit\nval backward : cursor -> int\nval fillArrayWithPartition : ('a, 'b) node -> cursor -> ('a * 'b) A.t -> ('a -> bool) -> unit\nval fillArrayWithFilter : ('a, 'b) node -> int -> ('a * 'b) A.t -> ('a -> bool) -> int\nval toArray : ('a, 'b) node option -> ('a * 'b) array\nval keysToArray : ('a, 'b) node option -> 'a array\nval valuesToArray : ('a, 'b) node option -> 'b array\nval fromSortedArrayRevAux : ('a * 'b) A.t -> int -> int -> ('a, 'b) node option\nval fromSortedArrayAux : ('a * 'b) A.t -> int -> int -> ('a, 'b) node option\nval fromSortedArrayUnsafe : ('a * 'b) A.t -> ('a, 'b) node option\nval compareAux : ('a, 'b) node list -> ('a, 'c) node list -> kcmp:('a -> 'a -> int) -> vcmp:('b -> 'c -> int) -> int\nval eqAux : ('a, 'b) node list -> ('a, 'c) node list -> kcmp:('a -> 'a -> int) -> veq:('b -> 'c -> bool) -> bool\nval cmpU : ('a, 'b) node option -> ('a, 'c) node option -> kcmp:('a -> 'a -> int) -> vcmp:('b -> 'c -> int) -> int\nval cmp : ('a, 'b) node option -> ('a, 'c) node option -> kcmp:('a -> 'a -> int) -> vcmp:('b -> 'c -> int) -> int\nval eqU : ('a, 'b) node option -> ('a, 'c) node option -> kcmp:('a -> 'a -> int) -> veq:('b -> 'c -> bool) -> bool\nval eq : ('a, 'b) node option -> ('a, 'c) node option -> kcmp:('a -> 'a -> int) -> veq:('b -> 'c -> bool) -> bool\nval get : ('a, 'b) node option -> 'a -> cmp:('a -> 'a -> int) -> 'b option\nval getUndefined : ('a, 'b) node option -> 'a -> cmp:('a -> 'a -> int) -> 'b option\nval getExn : ('a, 'b) node option -> 'a -> cmp:('a -> 'a -> int) -> 'b\nval getWithDefault : ('a, 'weak59) node option -> 'a -> 'weak59 -> cmp:('a -> 'a -> int) -> 'weak59\nval has : ('a, 'b) node option -> 'a -> cmp:('a -> 'a -> int) -> bool\nval rotateWithLeftChild : ('a, 'b) node -> ('a, 'b) node\nval rotateWithRightChild : ('a, 'b) node -> ('a, 'b) node\nval doubleWithLeftChild : ('a, 'b) node -> ('a, 'b) node\nval doubleWithRightChild : ('a, 'b) node -> ('a, 'b) node\nval heightUpdateMutate : ('a, 'b) node -> ('a, 'b) node\nval balMutate : ('a, 'b) node -> ('a, 'b) node\nval updateMutate : ('a, 'b) t -> 'a -> 'b -> cmp:('a -> 'a -> int) -> ('a, 'b) node option\nval fromArray : ('a * 'b) array -> cmp:('a -> 'a -> int) -> ('a, 'b) node option\nval removeMinAuxWithRootMutate : ('a, 'b) node -> ('a, 'b) node -> ('a, 'b) t\nval findFirstByU : ('a, 'b) t -> (('a -> 'b -> bool)[@bs]) -> ('a * 'b) option\nval findFirstBy : ('a, 'b) t -> ('a -> 'b -> bool) -> ('a * 'b) option\n"
},
{
"path": "packages/Belt/src/Belt_internalBuckets.ml",
"content": "[@@@ocaml.text \" Adapted by Authors of BuckleScript 2017 \"]\n\nmodule C = Belt_internalBucketsType\n\ntype ('a, 'b) bucket = { mutable key : 'a; mutable value : 'b; mutable next : ('a, 'b) bucket C.opt }\nand ('hash, 'eq, 'a, 'b) t = ('hash, 'eq, ('a, 'b) bucket) C.container\n\nlet bucket : key:'a -> value:'b -> next:('a, 'b) bucket C.opt -> ('a, 'b) bucket =\n fun ~key ~value ~next -> { key; value; next }\n\nlet keySet : ('a, 'b) bucket -> 'a -> unit = fun o v -> o.key <- v\nlet key : ('a, 'b) bucket -> 'a = fun o -> o.key\nlet valueSet : ('a, 'b) bucket -> 'b -> unit = fun o v -> o.value <- v\nlet value : ('a, 'b) bucket -> 'b = fun o -> o.value\nlet nextSet : ('a, 'b) bucket -> ('a, 'b) bucket C.opt -> unit = fun o v -> o.next <- v\nlet next : ('a, 'b) bucket -> ('a, 'b) bucket C.opt = fun o -> o.next\n\nmodule A = Belt_Array\n\nlet rec copy (x : _ t) : _ t =\n C.container ~hash:(C.hash x) ~eq:(C.eq x) ~size:(C.size x) ~buckets:(Stdlib.Array.map copyBucket (C.buckets x))\n\nand copyBucket c =\n match C.toOpt c with\n | None -> c\n | Some c ->\n let head = bucket ~key:(key c) ~value:(value c) ~next:C.emptyOpt in\n copyAuxCont (next c) head;\n C.return head\n\nand copyAuxCont c prec =\n match C.toOpt c with\n | None -> ()\n | Some nc ->\n let ncopy = bucket ~key:(key nc) ~value:(value nc) ~next:C.emptyOpt in\n nextSet prec (C.return ncopy);\n copyAuxCont (next nc) ncopy\n\nlet rec bucketLength accu buckets =\n match C.toOpt buckets with None -> accu | Some cell -> bucketLength (accu + 1) (next cell)\n\nlet rec do_bucket_iter ~f buckets =\n match C.toOpt buckets with\n | None -> ()\n | Some cell ->\n f (key cell) (value cell);\n do_bucket_iter ~f (next cell)\n\nlet forEachU h f =\n let d = C.buckets h in\n for i = 0 to A.length d - 1 do\n do_bucket_iter f (A.getUnsafe d i)\n done\n\nlet forEach h f = forEachU h (fun a b -> f a b)\n\nlet rec do_bucket_fold ~f b accu =\n match C.toOpt b with None -> accu | Some cell -> do_bucket_fold ~f (next cell) (f accu (key cell) (value cell))\n\nlet reduceU h init f =\n let d = C.buckets h in\n let accu = ref init in\n for i = 0 to A.length d - 1 do\n accu := do_bucket_fold ~f (A.getUnsafe d i) !accu\n done;\n !accu\n\nlet reduce h init f = reduceU h init (fun a b c -> f a b c)\n\nlet getMaxBucketLength h =\n A.reduceU (C.buckets h) 0 (fun m b ->\n let len = bucketLength 0 b in\n Stdlib.max m len)\n\nlet getBucketHistogram h =\n let mbl = getMaxBucketLength h in\n let histo = A.makeByU (mbl + 1) (fun _ -> 0) in\n A.forEachU (C.buckets h) (fun b ->\n let l = bucketLength 0 b in\n A.setUnsafe histo l (A.getUnsafe histo l + 1));\n histo\n\nlet logStats h =\n let histogram = getBucketHistogram h in\n Printf.printf \"{\\n\\tbindings: %d,\\n\\tbuckets: %d\\n\\thistogram: %s\\n}\" (C.size h)\n (A.length (C.buckets h))\n (A.reduceU histogram \"\" (fun acc x -> acc ^ string_of_int x))\n\nlet rec filterMapInplaceBucket f h i prec cell =\n let n = next cell in\n match f (key cell) (value cell) with\n | None -> (\n C.sizeSet h (C.size h - 1);\n match C.toOpt n with\n | Some nextCell -> filterMapInplaceBucket f h i prec nextCell\n | None -> ( match C.toOpt prec with None -> A.setUnsafe (C.buckets h) i prec | Some cell -> nextSet cell n))\n | Some data -> (\n let bucket = C.return cell in\n (match C.toOpt prec with None -> A.setUnsafe (C.buckets h) i bucket | Some c -> nextSet c bucket);\n valueSet cell data;\n match C.toOpt n with None -> nextSet cell n | Some nextCell -> filterMapInplaceBucket f h i bucket nextCell)\n[@@ocaml.doc \" iterate the Buckets, in place remove the elements \"]\n\nlet keepMapInPlaceU h f =\n let h_buckets = C.buckets h in\n for i = 0 to A.length h_buckets - 1 do\n let v = A.getUnsafe h_buckets i in\n match C.toOpt v with None -> () | Some v -> filterMapInplaceBucket f h i C.emptyOpt v\n done\n\nlet keepMapInPlace h f = keepMapInPlaceU h (fun a b -> f a b)\n\nlet rec fillArray i arr cell =\n A.setUnsafe arr i (key cell, value cell);\n match C.toOpt (next cell) with None -> i + 1 | Some v -> fillArray (i + 1) arr v\n\nlet toArray h =\n let d = C.buckets h in\n let current = ref 0 in\n let arr = ref None in\n for i = 0 to A.length d - 1 do\n let cell = A.getUnsafe d i in\n match C.toOpt cell with\n | None -> ()\n | Some cell ->\n let arr =\n match !arr with\n | None ->\n let a = A.makeUninitializedUnsafe (C.size h) (key cell, value cell) in\n arr := Some a;\n a\n | Some arr -> arr\n in\n current := fillArray !current arr cell\n done;\n match !arr with None -> [||] | Some arr -> arr\n\nlet rec fillArrayMap i arr cell f =\n A.setUnsafe arr i (f cell);\n match C.toOpt (next cell) with None -> i + 1 | Some v -> fillArrayMap (i + 1) arr v f\n\nlet linear h f =\n let d = C.buckets h in\n let current = ref 0 in\n let arr = ref None in\n for i = 0 to A.length d - 1 do\n let cell = A.getUnsafe d i in\n match C.toOpt cell with\n | None -> ()\n | Some cell ->\n let arr =\n match !arr with\n | None ->\n let a = A.makeUninitializedUnsafe (C.size h) (f cell) in\n arr := Some a;\n a\n | Some arr -> arr\n in\n current := fillArrayMap !current arr cell f\n done;\n match !arr with None -> [||] | Some arr -> arr\n\nlet keysToArray h = linear h (fun x -> key x)\nlet valuesToArray h = linear h (fun x -> value x)\nlet toArray h = linear h (fun x -> (key x, value x))\n"
},
{
"path": "packages/Belt/src/Belt_internalBuckets.mli",
"content": "module C = Belt_internalBucketsType\n\ntype ('a, 'b) bucket = { mutable key : 'a; mutable value : 'b; mutable next : ('a, 'b) bucket option }\nand ('hash, 'eq, 'a, 'b) t = ('hash, 'eq, ('a, 'b) bucket) C.container\n\nval bucket : key:'a -> value:'b -> next:('a, 'b) bucket C.opt -> ('a, 'b) bucket\nval keySet : ('a, 'b) bucket -> 'a -> unit\nval key : ('a, 'b) bucket -> 'a\nval valueSet : ('a, 'b) bucket -> 'b -> unit\nval value : ('a, 'b) bucket -> 'b\nval nextSet : ('a, 'b) bucket -> ('a, 'b) bucket C.opt -> unit\nval next : ('a, 'b) bucket -> ('a, 'b) bucket C.opt\n\nmodule A = Belt_Array\n\nval copy : ('a, 'b, 'c, 'd) t -> ('a, 'b, 'c, 'd) t\nval copyBucket : ('a, 'b) bucket C.opt -> ('a, 'b) bucket C.opt\nval copyAuxCont : ('a, 'b) bucket C.opt -> ('a, 'b) bucket -> unit\nval bucketLength : int -> ('a, 'b) bucket C.opt -> int\nval do_bucket_iter : f:('a -> 'b -> unit) -> ('a, 'b) bucket C.opt -> unit\nval forEachU : ('a, 'b, ('c, 'd) bucket) C.container -> ('c -> 'd -> unit) -> unit\nval forEach : ('a, 'b, ('c, 'd) bucket) C.container -> ('c -> 'd -> unit) -> unit\nval do_bucket_fold : f:('a -> 'b -> 'c -> 'a) -> ('b, 'c) bucket C.opt -> 'a -> 'a\nval reduceU : ('a, 'b, ('c, 'd) bucket) C.container -> 'e -> ('e -> 'c -> 'd -> 'e) -> 'e\nval reduce : ('a, 'b, ('c, 'd) bucket) C.container -> 'e -> ('e -> 'c -> 'd -> 'e) -> 'e\nval getMaxBucketLength : ('a, 'b, ('c, 'd) bucket) C.container -> int\nval getBucketHistogram : ('a, 'b, ('c, 'd) bucket) C.container -> int A.t\nval logStats : ('a, 'b, ('c, 'd) bucket) C.container -> unit\n\nval filterMapInplaceBucket :\n ('a -> 'b -> 'b option) ->\n ('c, 'd, ('a, 'b) bucket) C.container ->\n int ->\n ('a, 'b) bucket C.opt ->\n ('a, 'b) bucket ->\n unit\n\nval keepMapInPlaceU : ('a, 'b, ('c, 'd) bucket) C.container -> ('c -> 'd -> 'd option) -> unit\nval keepMapInPlace : ('a, 'b, ('c, 'd) bucket) C.container -> ('c -> 'd -> 'd option) -> unit\nval fillArray : int -> ('a * 'b) A.t -> ('a, 'b) bucket -> int\nval toArray : ('a, 'b, ('c, 'd) bucket) C.container -> ('c * 'd) A.t\nval fillArrayMap : int -> 'a A.t -> ('b, 'c) bucket -> (('b, 'c) bucket -> 'a) -> int\nval linear : ('a, 'b, ('c, 'd) bucket) C.container -> (('c, 'd) bucket -> 'e) -> 'e A.t\nval keysToArray : ('a, 'b, ('c, 'd) bucket) C.container -> 'c A.t\nval valuesToArray : ('a, 'b, ('c, 'd) bucket) C.container -> 'd A.t\nval toArray : ('a, 'b, ('c, 'd) bucket) C.container -> ('c * 'd) A.t\n"
},
{
"path": "packages/Belt/src/Belt_internalBucketsType.ml",
"content": "type 'a opt = 'a Js.undefined\n\ninclude (\n struct\n type ('hash, 'eq, 'c) container = { mutable size : int; mutable buckets : 'c opt array; hash : 'hash; eq : 'eq }\n\n let container : size:int -> buckets:'c opt array -> hash:'hash -> eq:'eq -> ('hash, 'eq, 'c) container =\n fun ~size ~buckets ~hash ~eq -> { size; buckets; hash; eq }\n\n let sizeSet : ('hash, 'eq, 'c) container -> int -> unit = fun o v -> o.size <- v\n let size : ('hash, 'eq, 'c) container -> int = fun o -> o.size\n let bucketsSet : ('hash, 'eq, 'c) container -> 'c opt array -> unit = fun o v -> o.buckets <- v\n let buckets : ('hash, 'eq, 'c) container -> 'c opt array = fun o -> o.buckets\n let hash : ('hash, 'eq, 'c) container -> 'hash = fun o -> o.hash\n let eq : ('hash, 'eq, 'c) container -> 'eq = fun o -> o.eq\n end :\n sig\n type ('hash, 'eq, 'c) container\n\n val container : size:int -> buckets:'c opt array -> hash:'hash -> eq:'eq -> ('hash, 'eq, 'c) container\n val sizeSet : ('hash, 'eq, 'c) container -> int -> unit\n val size : ('hash, 'eq, 'c) container -> int\n val bucketsSet : ('hash, 'eq, 'c) container -> 'c opt array -> unit\n val buckets : ('hash, 'eq, 'c) container -> 'c opt array\n val hash : ('hash, 'eq, 'c) container -> 'hash\n val eq : ('hash, 'eq, 'c) container -> 'eq\n end)\n\nmodule A = Belt_Array\n\nlet toOpt = Js.undefinedToOption\nlet return = Js.Undefined.return\nlet emptyOpt = Js.undefined\nlet rec power_2_above x n = if x >= n then x else if x * 2 < x then x else power_2_above (x * 2) n\n\nlet make ~hash ~eq ~hintSize =\n let s = power_2_above 16 hintSize in\n container ~size:0 ~buckets:(A.makeUninitialized s) ~hash ~eq\n\nlet clear h =\n sizeSet h 0;\n let h_buckets = buckets h in\n let len = A.length h_buckets in\n for i = 0 to len - 1 do\n A.setUnsafe h_buckets i emptyOpt\n done\n\nlet isEmpty h = size h = 0\n"
},
{
"path": "packages/Belt/src/Belt_internalBucketsType.mli",
"content": "type 'a opt = 'a option\ntype ('hash, 'eq, 'c) container\n\nval container : size:int -> buckets:'c opt array -> hash:'hash -> eq:'eq -> ('hash, 'eq, 'c) container\nval sizeSet : ('hash, 'eq, 'c) container -> int -> unit\nval size : ('hash, 'eq, 'c) container -> int\nval bucketsSet : ('hash, 'eq, 'c) container -> 'c opt array -> unit\nval buckets : ('hash, 'eq, 'c) container -> 'c opt array\nval hash : ('hash, 'eq, 'c) container -> 'hash\nval eq : ('hash, 'eq, 'c) container -> 'eq\n\nmodule A = Belt_Array\n\nval toOpt : 'a option -> 'a option\nval return : 'a -> 'a option\nval emptyOpt : 'a option\nval power_2_above : int -> int -> int\nval make : hash:'a -> eq:'b -> hintSize:int -> ('a, 'b, 'c) container\nval clear : ('a, 'b, 'c) container -> unit\nval isEmpty : ('a, 'b, 'c) container -> bool\n"
},
{
"path": "packages/Belt/src/Belt_internalMapInt.ml",
"content": "type key = int\n\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\nmodule S = Belt_SortArray\n\ntype 'a t = (key, 'a) N.t\n\nlet rec add t (x : key) (data : _) =\n match N.toOpt t with\n | None -> N.singleton x data\n | Some n ->\n let k = N.key n in\n if x = k then N.return (N.updateValue n data)\n else\n let v = N.value n in\n if x < k then N.bal (add (N.left n) x data) k v (N.right n) else N.bal (N.left n) k v (add (N.right n) x data)\n\nlet rec get n (x : key) =\n match N.toOpt n with\n | None -> None\n | Some n ->\n let v = N.key n in\n if x = v then Some (N.value n) else get (if x < v then N.left n else N.right n) x\n\nlet rec getUndefined n (x : key) =\n match N.toOpt n with\n | None -> Js.undefined\n | Some n ->\n let v = N.key n in\n if x = v then Js.Undefined.return (N.value n) else getUndefined (if x < v then N.left n else N.right n) x\n\nlet rec getExn n (x : key) =\n match N.toOpt n with\n | None -> Js.Exn.raiseError \"File \\\"../others/internal_map.cppo.ml\\\", line 51, characters 14-20\"\n | Some n ->\n let v = N.key n in\n if x = v then N.value n else getExn (if x < v then N.left n else N.right n) x\n\nlet rec getWithDefault n (x : key) def =\n match N.toOpt n with\n | None -> def\n | Some n ->\n let v = N.key n in\n if x = v then N.value n else getWithDefault (if x < v then N.left n else N.right n) x def\n\nlet rec has n (x : key) =\n match N.toOpt n with\n | None -> false\n | Some n ->\n let v = N.key n in\n x = v || has (if x < v then N.left n else N.right n) x\n\nlet rec remove n (x : key) =\n match N.toOpt n with\n | None -> n\n | Some n ->\n let l, v, r =\n let open N in\n (left n, key n, right n)\n in\n if x = v then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r\n else if x < v then\n let open N in\n bal (remove l x) v (value n) r\n else\n let open N in\n bal l v (value n) (remove r x)\n\nlet rec splitAux (x : key) (n : _ N.node) : _ t * _ option * _ t =\n let l, v, d, r =\n let open N in\n (left n, key n, value n, right n)\n in\n if x = v then (l, Some d, r)\n else if x < v then\n match N.toOpt l with\n | None ->\n let open N in\n (empty, None, return n)\n | Some l ->\n let ll, pres, rl = splitAux x l in\n (ll, pres, N.join rl v d r)\n else\n match N.toOpt r with\n | None ->\n let open N in\n (return n, None, empty)\n | Some r ->\n let lr, pres, rr = splitAux x r in\n (N.join l v d lr, pres, rr)\n\nlet rec split (x : key) n =\n match N.toOpt n with\n | None ->\n let open N in\n (empty, None, empty)\n | Some n -> splitAux x n\n\nlet rec mergeU s1 s2 f =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, None -> N.empty\n | Some n, _\n when let open N in\n height n >= match N.toOpt s2 with None -> 0 | Some n -> N.height n ->\n let l1, v1, d1, r1 =\n let open N in\n (left n, key n, value n, right n)\n in\n let l2, d2, r2 = split v1 s2 in\n N.concatOrJoin (mergeU l1 l2 f) v1 (f v1 (Some d1) d2) (mergeU r1 r2 f)\n | _, Some n ->\n let l2, v2, d2, r2 =\n let open N in\n (left n, key n, value n, right n)\n in\n let l1, d1, r1 = split v2 s1 in\n N.concatOrJoin (mergeU l1 l2 f) v2 (f v2 d1 (Some d2)) (mergeU r1 r2 f)\n | _ -> assert false\n\nlet merge s1 s2 f = mergeU s1 s2 (fun a b c -> f a b c)\n\nlet rec compareAux e1 e2 vcmp =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n let c = Stdlib.compare (N.key h1 : key) (N.key h2) in\n if c = 0 then\n let cx = vcmp (N.value h1) (N.value h2) in\n if cx = 0 then compareAux (N.stackAllLeft (N.right h1) t1) (N.stackAllLeft (N.right h2) t2) vcmp else cx\n else c\n | _, _ -> 0\n\nlet cmpU s1 s2 cmp =\n let len1, len2 = (N.size s1, N.size s2) in\n if len1 = len2 then compareAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) cmp else if len1 < len2 then -1 else 1\n\nlet cmp s1 s2 f = cmpU s1 s2 (fun a b -> f a b)\n\nlet rec eqAux e1 e2 eq =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n if (N.key h1 : key) = N.key h2 && eq (N.value h1) (N.value h2) then\n eqAux (N.stackAllLeft (N.right h1) t1) (N.stackAllLeft (N.right h2) t2) eq\n else false\n | _, _ -> true\n\nlet eqU s1 s2 eq =\n let len1, len2 = (N.size s1, N.size s2) in\n if len1 = len2 then eqAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) eq else false\n\nlet eq s1 s2 f = eqU s1 s2 (fun a b -> f a b)\n\nlet rec addMutate (t : _ t) x data : _ t =\n match N.toOpt t with\n | None -> N.singleton x data\n | Some nt ->\n let k = N.key nt in\n if x = k then (\n N.keySet nt x;\n N.valueSet nt data;\n N.return nt)\n else\n let l, r = (N.left nt, N.right nt) in\n if x < k then\n let ll = addMutate l x data in\n N.leftSet nt ll\n else N.rightSet nt (addMutate r x data);\n N.return (N.balMutate nt)\n\nlet fromArray (xs : (key * _) array) =\n let len = A.length xs in\n if len = 0 then N.empty\n else\n let next = ref (S.strictlySortedLengthU xs (fun (x0, _) (y0, _) -> x0 < y0)) in\n let result =\n ref\n (if !next >= 0 then N.fromSortedArrayAux xs 0 !next\n else (\n next := - !next;\n N.fromSortedArrayRevAux xs (!next - 1) !next))\n in\n for i = !next to len - 1 do\n let k, v = A.getUnsafe xs i in\n result := addMutate !result k v\n done;\n !result\n"
},
{
"path": "packages/Belt/src/Belt_internalMapString.ml",
"content": "type key = string\n\nmodule N = Belt_internalAVLtree\nmodule A = Belt_Array\nmodule S = Belt_SortArray\n\ntype 'a t = (key, 'a) N.t\n\nlet rec add t (x : key) (data : _) =\n match N.toOpt t with\n | None -> N.singleton x data\n | Some n ->\n let k = N.key n in\n if x = k then N.return (N.updateValue n data)\n else\n let v = N.value n in\n if x < k then N.bal (add (N.left n) x data) k v (N.right n) else N.bal (N.left n) k v (add (N.right n) x data)\n\nlet rec get n (x : key) =\n match N.toOpt n with\n | None -> None\n | Some n ->\n let v = N.key n in\n if x = v then Some (N.value n) else get (if x < v then N.left n else N.right n) x\n\nlet rec getUndefined n (x : key) =\n match N.toOpt n with\n | None -> Js.undefined\n | Some n ->\n let v = N.key n in\n if x = v then Js.Undefined.return (N.value n) else getUndefined (if x < v then N.left n else N.right n) x\n\nlet rec getExn n (x : key) =\n match N.toOpt n with\n | None -> Js.Exn.raiseError \"File \\\"../others/internal_map.cppo.ml\\\", line 51, characters 14-20\"\n | Some n ->\n let v = N.key n in\n if x = v then N.value n else getExn (if x < v then N.left n else N.right n) x\n\nlet rec getWithDefault n (x : key) def =\n match N.toOpt n with\n | None -> def\n | Some n ->\n let v = N.key n in\n if x = v then N.value n else getWithDefault (if x < v then N.left n else N.right n) x def\n\nlet rec has n (x : key) =\n match N.toOpt n with\n | None -> false\n | Some n ->\n let v = N.key n in\n x = v || has (if x < v then N.left n else N.right n) x\n\nlet rec remove n (x : key) =\n match N.toOpt n with\n | None -> n\n | Some n ->\n let l, v, r =\n let open N in\n (left n, key n, right n)\n in\n if x = v then\n match (N.toOpt l, N.toOpt r) with\n | None, _ -> r\n | _, None -> l\n | _, Some rn ->\n let kr, vr = (ref (N.key rn), ref (N.value rn)) in\n let r = N.removeMinAuxWithRef rn kr vr in\n N.bal l !kr !vr r\n else if x < v then\n let open N in\n bal (remove l x) v (value n) r\n else\n let open N in\n bal l v (value n) (remove r x)\n\nlet rec splitAux (x : key) (n : _ N.node) : _ t * _ option * _ t =\n let l, v, d, r =\n let open N in\n (left n, key n, value n, right n)\n in\n if x = v then (l, Some d, r)\n else if x < v then\n match N.toOpt l with\n | None ->\n let open N in\n (empty, None, return n)\n | Some l ->\n let ll, pres, rl = splitAux x l in\n (ll, pres, N.join rl v d r)\n else\n match N.toOpt r with\n | None ->\n let open N in\n (return n, None, empty)\n | Some r ->\n let lr, pres, rr = splitAux x r in\n (N.join l v d lr, pres, rr)\n\nlet rec split (x : key) n =\n match N.toOpt n with\n | None ->\n let open N in\n (empty, None, empty)\n | Some n -> splitAux x n\n\nlet rec mergeU s1 s2 f =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, None -> N.empty\n | Some n, _\n when let open N in\n height n >= match N.toOpt s2 with None -> 0 | Some n -> N.height n ->\n let l1, v1, d1, r1 =\n let open N in\n (left n, key n, value n, right n)\n in\n let l2, d2, r2 = split v1 s2 in\n N.concatOrJoin (mergeU l1 l2 f) v1 (f v1 (Some d1) d2) (mergeU r1 r2 f)\n | _, Some n ->\n let l2, v2, d2, r2 =\n let open N in\n (left n, key n, value n, right n)\n in\n let l1, d1, r1 = split v2 s1 in\n N.concatOrJoin (mergeU l1 l2 f) v2 (f v2 d1 (Some d2)) (mergeU r1 r2 f)\n | _ -> assert false\n\nlet merge s1 s2 f = mergeU s1 s2 (fun a b c -> f a b c)\n\nlet rec compareAux e1 e2 vcmp =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n let c = Stdlib.compare (N.key h1 : key) (N.key h2) in\n if c = 0 then\n let cx = vcmp (N.value h1) (N.value h2) in\n if cx = 0 then compareAux (N.stackAllLeft (N.right h1) t1) (N.stackAllLeft (N.right h2) t2) vcmp else cx\n else c\n | _, _ -> 0\n\nlet cmpU s1 s2 cmp =\n let len1, len2 = (N.size s1, N.size s2) in\n if len1 = len2 then compareAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) cmp else if len1 < len2 then -1 else 1\n\nlet cmp s1 s2 f = cmpU s1 s2 (fun a b -> f a b)\n\nlet rec eqAux e1 e2 eq =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n if (N.key h1 : key) = N.key h2 && eq (N.value h1) (N.value h2) then\n eqAux (N.stackAllLeft (N.right h1) t1) (N.stackAllLeft (N.right h2) t2) eq\n else false\n | _, _ -> true\n\nlet eqU s1 s2 eq =\n let len1, len2 = (N.size s1, N.size s2) in\n if len1 = len2 then eqAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) eq else false\n\nlet eq s1 s2 f = eqU s1 s2 (fun a b -> f a b)\n\nlet rec addMutate (t : _ t) x data : _ t =\n match N.toOpt t with\n | None -> N.singleton x data\n | Some nt ->\n let k = N.key nt in\n if x = k then (\n N.keySet nt x;\n N.valueSet nt data;\n N.return nt)\n else\n let l, r = (N.left nt, N.right nt) in\n if x < k then\n let ll = addMutate l x data in\n N.leftSet nt ll\n else N.rightSet nt (addMutate r x data);\n N.return (N.balMutate nt)\n\nlet fromArray (xs : (key * _) array) =\n let len = A.length xs in\n if len = 0 then N.empty\n else\n let next = ref (S.strictlySortedLengthU xs (fun (x0, _) (y0, _) -> x0 < y0)) in\n let result =\n ref\n (if !next >= 0 then N.fromSortedArrayAux xs 0 !next\n else (\n next := - !next;\n N.fromSortedArrayRevAux xs (!next - 1) !next))\n in\n for i = !next to len - 1 do\n let k, v = A.getUnsafe xs i in\n result := addMutate !result k v\n done;\n !result\n"
},
{
"path": "packages/Belt/src/Belt_internalSetBuckets.ml",
"content": "module C = Belt_internalBucketsType\n\ninclude (\n struct\n type 'a bucket = { mutable key : 'a; mutable next : 'a bucket C.opt }\n and ('hash, 'eq, 'a) t = ('hash, 'eq, 'a bucket) C.container\n\n let bucket : key:'a -> next:'a bucket C.opt -> 'a bucket = fun ~key ~next -> { key; next }\n let keySet : 'a bucket -> 'a -> unit = fun o v -> o.key <- v\n let key : 'a bucket -> 'a = fun o -> o.key\n let nextSet : 'a bucket -> 'a bucket C.opt -> unit = fun o v -> o.next <- v\n let next : 'a bucket -> 'a bucket C.opt = fun o -> o.next\n end :\n sig\n type 'a bucket\n and ('hash, 'eq, 'a) t = ('hash, 'eq, 'a bucket) C.container\n\n val bucket : key:'a -> next:'a bucket C.opt -> 'a bucket\n val keySet : 'a bucket -> 'a -> unit\n val key : 'a bucket -> 'a\n val nextSet : 'a bucket -> 'a bucket C.opt -> unit\n val next : 'a bucket -> 'a bucket C.opt\n end)\n\nmodule A = Belt_Array\n\nlet rec copy (x : _ t) : _ t =\n C.container ~hash:(C.hash x) ~eq:(C.eq x) ~size:(C.size x) ~buckets:(Stdlib.Array.map copyBucket (C.buckets x))\n\nand copyBucket c =\n match C.toOpt c with\n | None -> c\n | Some c ->\n let head = bucket ~key:(key c) ~next:C.emptyOpt in\n copyAuxCont (next c) head;\n C.return head\n\nand copyAuxCont c prec =\n match C.toOpt c with\n | None -> ()\n | Some nc ->\n let ncopy = bucket ~key:(key nc) ~next:C.emptyOpt in\n nextSet prec (C.return ncopy);\n copyAuxCont (next nc) ncopy\n\nlet rec bucketLength accu buckets =\n match C.toOpt buckets with None -> accu | Some cell -> bucketLength (accu + 1) (next cell)\n\nlet rec doBucketIter ~f buckets =\n match C.toOpt buckets with\n | None -> ()\n | Some cell ->\n f (key cell);\n doBucketIter ~f (next cell)\n\nlet forEachU h f =\n let d = C.buckets h in\n for i = 0 to A.length d - 1 do\n doBucketIter f (A.getUnsafe d i)\n done\n\nlet forEach h f = forEachU h (fun a -> f a)\n\nlet rec fillArray i arr cell =\n A.setUnsafe arr i (key cell);\n match C.toOpt (next cell) with None -> i + 1 | Some v -> fillArray (i + 1) arr v\n\nlet toArray h =\n let d = C.buckets h in\n let current = ref 0 in\n let arr = ref None in\n for i = 0 to A.length d - 1 do\n let cell = A.getUnsafe d i in\n match C.toOpt cell with\n | None -> ()\n | Some cell ->\n let arr =\n match !arr with\n | None ->\n let a = A.makeUninitializedUnsafe (C.size h) (key cell) in\n arr := Some a;\n a\n | Some arr -> arr\n in\n current := fillArray !current arr cell\n done;\n match !arr with None -> [||] | Some arr -> arr\n\nlet rec doBucketFold ~f b accu =\n match C.toOpt b with None -> accu | Some cell -> doBucketFold ~f (next cell) (f accu (key cell))\n\nlet reduceU h init f =\n let d = C.buckets h in\n let accu = ref init in\n for i = 0 to A.length d - 1 do\n accu := doBucketFold ~f (A.getUnsafe d i) !accu\n done;\n !accu\n\nlet reduce h init f = reduceU h init (fun a b -> f a b)\n\nlet getMaxBucketLength h =\n A.reduceU (C.buckets h) 0 (fun m b ->\n let len = bucketLength 0 b in\n Stdlib.max m len)\n\nlet getBucketHistogram h =\n let mbl = getMaxBucketLength h in\n let histo = A.makeByU (mbl + 1) (fun _ -> 0) in\n A.forEachU (C.buckets h) (fun b ->\n let l = bucketLength 0 b in\n A.setUnsafe histo l (A.getUnsafe histo l + 1));\n histo\n\nlet logStats h =\n let histogram = getBucketHistogram h in\n Printf.printf \"{\\n\\tbindings: %d,\\n\\tbuckets: %d\\n\\thistogram: %s\\n}\" (C.size h)\n (A.length (C.buckets h))\n (A.reduceU histogram \"\" (fun acc x -> acc ^ string_of_int x))\n"
},
{
"path": "packages/Belt/src/Belt_internalSetBuckets.mli",
"content": "module C = Belt_internalBucketsType\n\ntype 'a bucket\nand ('hash, 'eq, 'a) t = ('hash, 'eq, 'a bucket) C.container\n\nval bucket : key:'a -> next:'a bucket C.opt -> 'a bucket\nval keySet : 'a bucket -> 'a -> unit\nval key : 'a bucket -> 'a\nval nextSet : 'a bucket -> 'a bucket C.opt -> unit\nval next : 'a bucket -> 'a bucket C.opt\n\nmodule A = Belt_Array\n\nval copy : ('a, 'b, 'c) t -> ('a, 'b, 'c) t\nval copyBucket : 'a bucket C.opt -> 'a bucket C.opt\nval copyAuxCont : 'a bucket C.opt -> 'a bucket -> unit\nval bucketLength : int -> 'a bucket C.opt -> int\nval doBucketIter : f:('a -> unit) -> 'a bucket C.opt -> unit\nval forEachU : ('a, 'b, 'c bucket) C.container -> ('c -> unit) -> unit\nval forEach : ('a, 'b, 'c bucket) C.container -> ('c -> unit) -> unit\nval fillArray : int -> 'a A.t -> 'a bucket -> int\nval toArray : ('a, 'b, 'c bucket) C.container -> 'c A.t\nval doBucketFold : f:('a -> 'b -> 'a) -> 'b bucket C.opt -> 'a -> 'a\nval reduceU : ('a, 'b, 'c bucket) C.container -> 'd -> ('d -> 'c -> 'd) -> 'd\nval reduce : ('a, 'b, 'c bucket) C.container -> 'd -> ('d -> 'c -> 'd) -> 'd\nval getMaxBucketLength : ('a, 'b, 'c bucket) C.container -> int\nval getBucketHistogram : ('a, 'b, 'c bucket) C.container -> int A.t\nval logStats : ('a, 'b, 'c bucket) C.container -> unit\n"
},
{
"path": "packages/Belt/src/Belt_internalSetInt.ml",
"content": "type value = int\n\nmodule S = Belt_SortArrayInt\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype t = value N.t\n\nlet rec has (t : t) (x : value) =\n match N.toOpt t with\n | None -> false\n | Some n ->\n let v = N.value n in\n x = v || has (if x < v then N.left n else N.right n) x\n\nlet rec compareAux e1 e2 =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n let (k1 : value), k2 = (N.value h1, N.value h2) in\n if k1 = k2 then compareAux (N.stackAllLeft (N.right h1) t1) (N.stackAllLeft (N.right h2) t2)\n else if k1 < k2 then -1\n else 1\n | _, _ -> 0\n\nlet cmp s1 s2 =\n let len1, len2 = (N.size s1, N.size s2) in\n if len1 = len2 then compareAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) else if len1 < len2 then -1 else 1\n\nlet eq (s1 : t) s2 = cmp s1 s2 = 0\n\nlet rec subset (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ -> true\n | _, None -> false\n | Some t1, Some t2 ->\n let l1, v1, r1 =\n let open N in\n (left t1, value t1, right t1)\n in\n let l2, v2, r2 =\n let open N in\n (left t2, value t2, right t2)\n in\n if v1 = v2 then subset l1 l2 && subset r1 r2\n else if v1 < v2 then\n subset\n (let open N in\n create l1 v1 empty)\n l2\n && subset r1 s2\n else\n subset\n (let open N in\n create empty v1 r1)\n r2\n && subset l1 s2\n\nlet rec get (n : t) (x : value) =\n match N.toOpt n with\n | None -> None\n | Some t ->\n let v = N.value t in\n if x = v then Some v else get (if x < v then N.left t else N.right t) x\n\nlet rec getUndefined (n : t) (x : value) =\n match N.toOpt n with\n | None -> Js.undefined\n | Some t ->\n let v = N.value t in\n if x = v then Js.Undefined.return v else getUndefined (if x < v then N.left t else N.right t) x\n\nlet rec getExn (n : t) (x : value) =\n match N.toOpt n with\n | None -> Js.Exn.raiseError \"File \\\"../others/internal_set.cppo.ml\\\", line 90, characters 14-20\"\n | Some t ->\n let v = N.value t in\n if x = v then v else getExn (if x < v then N.left t else N.right t) x\n\nlet rec addMutate t (x : value) =\n match N.toOpt t with\n | None -> N.singleton x\n | Some nt ->\n let k = N.value nt in\n if x = k then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < k then N.leftSet nt (addMutate l x) else N.rightSet nt (addMutate r x);\n N.return (N.balMutate nt)\n\nlet fromArray (xs : value array) =\n let len = A.length xs in\n if len = 0 then N.empty\n else\n let next = ref (S.strictlySortedLength xs) in\n let result =\n ref\n (if !next >= 0 then N.fromSortedArrayAux xs 0 !next\n else (\n next := - !next;\n N.fromSortedArrayRevAux xs (!next - 1) !next))\n in\n for i = !next to len - 1 do\n result := addMutate !result (A.getUnsafe xs i)\n done;\n !result\n"
},
{
"path": "packages/Belt/src/Belt_internalSetString.ml",
"content": "type value = string\n\nmodule S = Belt_SortArrayString\nmodule N = Belt_internalAVLset\nmodule A = Belt_Array\n\ntype t = value N.t\n\nlet rec has (t : t) (x : value) =\n match N.toOpt t with\n | None -> false\n | Some n ->\n let v = N.value n in\n x = v || has (if x < v then N.left n else N.right n) x\n\nlet rec compareAux e1 e2 =\n match (e1, e2) with\n | h1 :: t1, h2 :: t2 ->\n let (k1 : value), k2 = (N.value h1, N.value h2) in\n if k1 = k2 then compareAux (N.stackAllLeft (N.right h1) t1) (N.stackAllLeft (N.right h2) t2)\n else if k1 < k2 then -1\n else 1\n | _, _ -> 0\n\nlet cmp s1 s2 =\n let len1, len2 = (N.size s1, N.size s2) in\n if len1 = len2 then compareAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) else if len1 < len2 then -1 else 1\n\nlet eq (s1 : t) s2 = cmp s1 s2 = 0\n\nlet rec subset (s1 : t) (s2 : t) =\n match\n let open N in\n (toOpt s1, toOpt s2)\n with\n | None, _ -> true\n | _, None -> false\n | Some t1, Some t2 ->\n let l1, v1, r1 =\n let open N in\n (left t1, value t1, right t1)\n in\n let l2, v2, r2 =\n let open N in\n (left t2, value t2, right t2)\n in\n if v1 = v2 then subset l1 l2 && subset r1 r2\n else if v1 < v2 then\n subset\n (let open N in\n create l1 v1 empty)\n l2\n && subset r1 s2\n else\n subset\n (let open N in\n create empty v1 r1)\n r2\n && subset l1 s2\n\nlet rec get (n : t) (x : value) =\n match N.toOpt n with\n | None -> None\n | Some t ->\n let v = N.value t in\n if x = v then Some v else get (if x < v then N.left t else N.right t) x\n\nlet rec getUndefined (n : t) (x : value) =\n match N.toOpt n with\n | None -> Js.undefined\n | Some t ->\n let v = N.value t in\n if x = v then Js.Undefined.return v else getUndefined (if x < v then N.left t else N.right t) x\n\nlet rec getExn (n : t) (x : value) =\n match N.toOpt n with\n | None -> Js.Exn.raiseError \"File \\\"../others/internal_set.cppo.ml\\\", line 90, characters 14-20\"\n | Some t ->\n let v = N.value t in\n if x = v then v else getExn (if x < v then N.left t else N.right t) x\n\nlet rec addMutate t (x : value) =\n match N.toOpt t with\n | None -> N.singleton x\n | Some nt ->\n let k = N.value nt in\n if x = k then t\n else\n let l, r =\n let open N in\n (left nt, right nt)\n in\n if x < k then N.leftSet nt (addMutate l x) else N.rightSet nt (addMutate r x);\n N.return (N.balMutate nt)\n\nlet fromArray (xs : value array) =\n let len = A.length xs in\n if len = 0 then N.empty\n else\n let next = ref (S.strictlySortedLength xs) in\n let result =\n ref\n (if !next >= 0 then N.fromSortedArrayAux xs 0 !next\n else (\n next := - !next;\n N.fromSortedArrayRevAux xs (!next - 1) !next))\n in\n for i = !next to len - 1 do\n result := addMutate !result (A.getUnsafe xs i)\n done;\n !result\n"
},
{
"path": "packages/Belt/src/caml_hash.ml",
"content": "[@@@ocaml.text \" \"]\n\nlet ( << ) = Nativeint.shift_left [@@ocaml.text \" \"]\n\nlet ( >>> ) = Nativeint.shift_right_logical\nlet ( |~ ) = Nativeint.logor\nlet ( ^ ) = Nativeint.logxor\n\nexternal ( *~ ) : nativeint -> nativeint -> nativeint = \"caml_int32_mul\"\nexternal ( +~ ) : nativeint -> nativeint -> nativeint = \"caml_int32_add\"\n\nlet rotl32 (x : nativeint) n = x << n |~ (x >>> 32 - n)\n\nlet caml_hash_mix_int h d =\n let d = ref d in\n d := !d *~ 3432918353n;\n d := rotl32 !d 15;\n d := !d *~ 461845907n;\n let h = ref (h ^ !d) in\n h := rotl32 !h 13;\n !h +~ (!h << 2) +~ 3864292196n\n\nlet caml_hash_final_mix h =\n let h = ref (h ^ (h >>> 16)) in\n h := !h *~ 2246822507n;\n h := !h ^ (!h >>> 13);\n h := !h *~ 3266489909n;\n !h ^ (!h >>> 16)\n\nlet caml_hash_mix_string h s =\n let len = String.length s in\n let block = (len / 4) - 1 in\n let hash = ref h in\n for i = 0 to block do\n let j = 4 * i in\n let w =\n Char.code s.[j] lor (Char.code s.[j + 1] lsl 8) lor (Char.code s.[j + 2] lsl 16) lor (Char.code s.[j + 3] lsl 24)\n in\n hash := caml_hash_mix_int !hash (Nativeint.of_int w)\n done;\n let modulo = len land 3 in\n (if modulo <> 0 then\n let w =\n if modulo = 3 then (Char.code s.[len - 1] lsl 16) lor (Char.code s.[len - 2] lsl 8) lor Char.code s.[len - 3]\n else if modulo = 2 then (Char.code s.[len - 1] lsl 8) lor Char.code s.[len - 2]\n else Char.code s.[len - 1]\n in\n hash := caml_hash_mix_int !hash (Nativeint.of_int w));\n hash := !hash ^ Nativeint.of_int len;\n !hash\n"
},
{
"path": "packages/Belt/src/dune",
"content": "(library\n (name belt)\n (foreign_stubs\n (language c)\n (names stubs))\n (flags :standard -w -A)\n (public_name server-reason-react.belt)\n (libraries server-reason-react.js))\n"
},
{
"path": "packages/Belt/src/stubs.c",
"content": "#include \n#include \n#include \n\nCAMLprim value belt_makemutablelist(value a, value l) {\n CAMLparam2(a, l);\n CAMLlocal1(box);\n box = caml_alloc_small(2, 0);\n Field(box, 0) = a;\n Field(box, 1) = l;\n CAMLreturn(box);\n}\n"
},
{
"path": "packages/Belt/test/Test_Belt_Array.ml",
"content": "let suites =\n [\n ( \"Array\",\n [\n test \"get and set bounds\" (fun () ->\n let values = [| 1; 2 |] in\n assert_option Alcotest.int (Some 1) (Belt.Array.get values 0);\n assert_option Alcotest.int (Some 2) (Belt.Array.get values 1);\n assert_option Alcotest.int None (Belt.Array.get values 2);\n assert_option Alcotest.int None (Belt.Array.get values 3);\n assert_option Alcotest.int None (Belt.Array.get values (-1));\n assert_option Alcotest.int (Some 1) (Js.Undefined.toOption (Belt.Array.getUndefined values 0));\n assert_option Alcotest.int None (Js.Undefined.toOption (Belt.Array.getUndefined values 2));\n assert_raises_any (fun () -> ignore (Belt.Array.getExn [| 0; 1 |] (-1)));\n assert_raises_any (fun () -> ignore (Belt.Array.getExn [| 0; 1 |] 2));\n assert_int 0 (Belt.Array.getExn [| 0; 1 |] 0);\n assert_int 1 (Belt.Array.getExn [| 0; 1 |] 1);\n assert_raises_any (fun () -> Belt.Array.setExn [| 0; 1 |] (-1) 0);\n assert_raises_any (fun () -> Belt.Array.setExn [| 0; 1 |] 2 0);\n assert_bool false (Belt.Array.set [| 1; 2 |] 2 0);\n let left = [| 1; 2 |] in\n assert_bool true (Belt.Array.set left 0 0);\n assert_int 0 (Belt.Array.getExn left 0);\n let right = [| 1; 2 |] in\n assert_bool true (Belt.Array.set right 1 0);\n assert_int 0 (Belt.Array.getExn right 1);\n let exn_left = [| 1; 2 |] in\n Belt.Array.setExn exn_left 0 0;\n assert_int 0 (Belt.Array.getExn exn_left 0);\n let exn_right = [| 1; 2 |] in\n Belt.Array.setExn exn_right 1 0;\n assert_int 0 (Belt.Array.getExn exn_right 1));\n test \"shuffle preserves contents\" (fun () ->\n let original = Belt.Array.makeBy 3000 (fun i -> i) in\n let shuffled = Belt.Array.shuffle original in\n assert_bool false (original = shuffled);\n assert_int (Belt.Array.reduce original 0 ( + )) (Belt.Array.reduce shuffled 0 ( + )));\n test \"range helpers\" (fun () ->\n assert_array Alcotest.int [| 0; 1; 2; 3 |] (Belt.Array.range 0 3);\n assert_array Alcotest.int [||] (Belt.Array.range 3 0);\n assert_array Alcotest.int [| 3 |] (Belt.Array.range 3 3);\n assert_array Alcotest.int [| 0; 3; 6; 9 |] (Belt.Array.rangeBy 0 10 ~step:3);\n assert_array Alcotest.int [| 0; 3; 6; 9; 12 |] (Belt.Array.rangeBy 0 12 ~step:3);\n assert_array Alcotest.int [||] (Belt.Array.rangeBy 33 0 ~step:1);\n assert_array Alcotest.int [||] (Belt.Array.rangeBy 33 0 ~step:(-1));\n assert_array Alcotest.int [||] (Belt.Array.rangeBy 3 12 ~step:(-1));\n assert_array Alcotest.int [||] (Belt.Array.rangeBy 3 3 ~step:0);\n assert_array Alcotest.int [| 3 |] (Belt.Array.rangeBy 3 3 ~step:1));\n test \"reductions\" (fun () ->\n assert_int 100 (Belt.Array.reduceReverse [||] 100 ( - ));\n assert_int 97 (Belt.Array.reduceReverse [| 1; 2 |] 100 ( - ));\n assert_int 90 (Belt.Array.reduceReverse [| 1; 2; 3; 4 |] 100 ( - ));\n assert_int 16 (Belt.Array.reduceWithIndex [| 1; 2; 3; 4 |] 0 (fun acc value index -> acc + value + index));\n assert_int 6\n (Belt.Array.reduceReverse2 [| 1; 2; 3 |] [| 1; 2 |] 0 (fun acc left right -> acc + left + right)));\n test \"construction copy and conversions\" (fun () ->\n let make_matrix width height value =\n let outer = Belt.Array.makeUninitializedUnsafe width [||] in\n for x = 0 to width - 1 do\n let inner = Belt.Array.makeUninitializedUnsafe height value in\n for y = 0 to height - 1 do\n Belt.Array.setUnsafe inner y value\n done;\n Belt.Array.setUnsafe outer x inner\n done;\n outer\n in\n let undefined_array : int Js.undefined array = Belt.Array.makeUninitialized 1 in\n assert_int 1 (Belt.Array.length undefined_array);\n assert_array (Alcotest.option Alcotest.int) [| None |]\n (Belt.Array.mapU undefined_array Js.Undefined.toOption);\n assert_array Alcotest.int [||] (Belt.Array.makeBy 0 (fun _ -> 1));\n assert_array Alcotest.int [| 0; 1; 2 |] (Belt.Array.makeBy 3 (fun i -> i));\n assert_array (Alcotest.array Alcotest.int)\n [| [| 1; 1; 1; 1 |]; [| 1; 1; 1; 1 |]; [| 1; 1; 1; 1 |] |]\n (make_matrix 3 4 1);\n assert_array (Alcotest.array Alcotest.int) [| [||]; [||]; [||] |] (make_matrix 3 0 0);\n assert_array (Alcotest.array Alcotest.int) [||] (make_matrix 0 3 1);\n assert_array (Alcotest.array Alcotest.int) [| [| 1 |] |] (make_matrix 1 1 1);\n assert_array Alcotest.int [||] (Belt.Array.copy [||]);\n assert_array Alcotest.int [||] (Belt.Array.map [||] succ);\n assert_array Alcotest.int [||] (Belt.Array.mapWithIndex [||] ( + ));\n assert_array Alcotest.int [| 1; 3; 5 |] (Belt.Array.mapWithIndex [| 1; 2; 3 |] ( + ));\n assert_list Alcotest.int [] (Belt.List.fromArray [||]);\n assert_list Alcotest.int [ 1 ] (Belt.List.fromArray [| 1 |]);\n assert_list Alcotest.int [ 1; 2; 3 ] (Belt.List.fromArray [| 1; 2; 3 |]);\n assert_array Alcotest.int [| 2; 3; 4 |] (Belt.Array.map [| 1; 2; 3 |] succ);\n assert_array Alcotest.int [||] (Belt.List.toArray []);\n assert_array Alcotest.int [| 1 |] (Belt.List.toArray [ 1 ]);\n assert_array Alcotest.int [| 1; 2 |] (Belt.List.toArray [ 1; 2 ]);\n assert_array Alcotest.int [| 1; 2; 3 |] (Belt.List.toArray [ 1; 2; 3 ]));\n test \"callback once regressions\" (fun () ->\n let seen_make = ref [] in\n let made =\n Belt.Array.makeByU 3 (fun i ->\n seen_make := i :: !seen_make;\n i * 2)\n in\n assert_array Alcotest.int [| 0; 2; 4 |] made;\n assert_list Alcotest.int [ 0; 1; 2 ] (List.rev !seen_make);\n let seen_map = ref [] in\n let mapped =\n Belt.Array.mapU [| 1; 2; 3 |] (fun value ->\n seen_map := value :: !seen_map;\n value + 10)\n in\n assert_array Alcotest.int [| 11; 12; 13 |] mapped;\n assert_list Alcotest.int [ 1; 2; 3 ] (List.rev !seen_map);\n let seen_map_with_index = ref [] in\n let mapped_with_index =\n Belt.Array.mapWithIndexU [| \"a\"; \"b\"; \"c\" |] (fun index value ->\n seen_map_with_index := (index, value) :: !seen_map_with_index;\n index)\n in\n assert_array Alcotest.int [| 0; 1; 2 |] mapped_with_index;\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (0, \"a\"); (1, \"b\"); (2, \"c\") ]\n (List.rev !seen_map_with_index);\n let seen_zip = ref [] in\n let zipped =\n Belt.Array.zipByU [| 1; 2; 3 |] [| 10; 20 |] (fun left right ->\n seen_zip := (left, right) :: !seen_zip;\n left + right)\n in\n assert_array Alcotest.int [| 11; 22 |] zipped;\n assert_list (Alcotest.pair Alcotest.int Alcotest.int) [ (1, 10); (2, 20) ] (List.rev !seen_zip));\n test \"keep keepMap and partition\" (fun () ->\n let values = Belt.Array.makeBy 10 (fun i -> i) in\n assert_array Alcotest.int [| 0; 2; 4; 6; 8 |] (Belt.Array.keep values (fun value -> value mod 2 = 0));\n assert_array Alcotest.int [| 0; 3; 6; 9 |] (Belt.Array.keep values (fun value -> value mod 3 = 0));\n assert_array Alcotest.int [| 1; 3; 5; 7; 9 |]\n (Belt.Array.keepMap values (fun value -> if value mod 2 = 0 then Some (value + 1) else None));\n let evens, odds = Belt.Array.partition [| 1; 2; 3; 4; 5 |] (fun value -> value mod 2 = 0) in\n assert_array Alcotest.int [| 2; 4 |] evens;\n assert_array Alcotest.int [| 1; 3; 5 |] odds;\n let twos, rest = Belt.Array.partition [| 1; 2; 3; 4; 5 |] (fun value -> value = 2) in\n assert_array Alcotest.int [| 2 |] twos;\n assert_array Alcotest.int [| 1; 3; 4; 5 |] rest;\n let yes, no = Belt.Array.partition [||] (fun _ -> false) in\n assert_array Alcotest.int [||] yes;\n assert_array Alcotest.int [||] no);\n test \"slice\" (fun () ->\n let values = [| 1; 2; 3; 4; 5 |] in\n assert_array Alcotest.int [| 1; 2 |] (Belt.Array.slice values ~offset:0 ~len:2);\n assert_array Alcotest.int [| 1; 2; 3; 4; 5 |] (Belt.Array.slice values ~offset:0 ~len:5);\n assert_array Alcotest.int [| 1; 2; 3; 4; 5 |] (Belt.Array.slice values ~offset:0 ~len:15);\n assert_array Alcotest.int [||] (Belt.Array.slice values ~offset:5 ~len:1);\n assert_array Alcotest.int [| 5 |] (Belt.Array.slice values ~offset:4 ~len:1);\n assert_array Alcotest.int [| 5 |] (Belt.Array.slice values ~offset:(-1) ~len:1);\n assert_array Alcotest.int [| 5 |] (Belt.Array.slice values ~offset:(-1) ~len:2);\n assert_array Alcotest.int [| 4 |] (Belt.Array.slice values ~offset:(-2) ~len:1);\n assert_array Alcotest.int [| 4; 5 |] (Belt.Array.slice values ~offset:(-2) ~len:2);\n assert_array Alcotest.int [| 4; 5 |] (Belt.Array.slice values ~offset:(-2) ~len:3);\n assert_array Alcotest.int [| 1; 2; 3 |] (Belt.Array.slice values ~offset:(-10) ~len:3);\n assert_array Alcotest.int [| 1; 2; 3; 4 |] (Belt.Array.slice values ~offset:(-10) ~len:4);\n assert_array Alcotest.int [| 1; 2; 3; 4; 5 |] (Belt.Array.slice values ~offset:(-10) ~len:5);\n assert_array Alcotest.int [| 1; 2; 3; 4; 5 |] (Belt.Array.slice values ~offset:(-10) ~len:6);\n assert_array Alcotest.int [||] (Belt.Array.slice values ~offset:0 ~len:0);\n assert_array Alcotest.int [||] (Belt.Array.slice values ~offset:0 ~len:(-1)));\n test \"sliceToEnd\" (fun () ->\n let values = [| 1; 2; 3; 4; 5 |] in\n assert_array Alcotest.int [| 1; 2; 3; 4; 5 |] (Belt.Array.sliceToEnd values 0);\n assert_array Alcotest.int [||] (Belt.Array.sliceToEnd values 5);\n assert_array Alcotest.int [| 5 |] (Belt.Array.sliceToEnd values 4);\n assert_array Alcotest.int [| 5 |] (Belt.Array.sliceToEnd values (-1));\n assert_array Alcotest.int [| 4; 5 |] (Belt.Array.sliceToEnd values (-2));\n assert_array Alcotest.int [| 1; 2; 3; 4; 5 |] (Belt.Array.sliceToEnd values (-10));\n assert_array Alcotest.int [||] (Belt.Array.sliceToEnd values 6));\n test \"fill\" (fun () ->\n let values = Belt.Array.makeBy 10 (fun value -> value) in\n Belt.Array.fill values ~offset:0 ~len:3 0;\n assert_array Alcotest.int [| 0; 0; 0; 3; 4; 5; 6; 7; 8; 9 |] values;\n Belt.Array.fill values ~offset:2 ~len:8 1;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 1; 1; 1 |] values;\n Belt.Array.fill values ~offset:8 ~len:1 9;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 1; 9; 1 |] values;\n Belt.Array.fill values ~offset:8 ~len:2 9;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 1; 9; 9 |] values;\n Belt.Array.fill values ~offset:8 ~len:3 12;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 1; 12; 12 |] values;\n Belt.Array.fill values ~offset:(-2) ~len:3 11;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 1; 11; 11 |] values;\n Belt.Array.fill values ~offset:(-3) ~len:3 10;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 10; 10; 10 |] values;\n Belt.Array.fill values ~offset:(-3) ~len:1 7;\n assert_array Alcotest.int [| 0; 0; 1; 1; 1; 1; 1; 7; 10; 10 |] values;\n Belt.Array.fill values ~offset:(-13) ~len:1 7;\n assert_array Alcotest.int [| 7; 0; 1; 1; 1; 1; 1; 7; 10; 10 |] values;\n Belt.Array.fill values ~offset:(-13) ~len:12 7;\n assert_array Alcotest.int (Array.make 10 7) values;\n Belt.Array.fill values ~offset:0 ~len:(-1) 2;\n assert_array Alcotest.int (Array.make 10 7) values;\n let small = [| 1; 2; 3 |] in\n Belt.Array.fill small ~offset:0 ~len:0 0;\n assert_array Alcotest.int [| 1; 2; 3 |] small;\n Belt.Array.fill small ~offset:4 ~len:1 0;\n assert_array Alcotest.int [| 1; 2; 3 |] small);\n test \"blit\" (fun () ->\n let src = Belt.Array.makeBy 10 (fun value -> value) in\n let dst = Belt.Array.make 10 3 in\n Belt.Array.blit ~src ~srcOffset:1 ~dst ~dstOffset:2 ~len:5;\n assert_array Alcotest.int [| 3; 3; 1; 2; 3; 4; 5; 3; 3; 3 |] dst;\n Belt.Array.blit ~src ~srcOffset:(-1) ~dst ~dstOffset:2 ~len:5;\n assert_array Alcotest.int [| 3; 3; 9; 2; 3; 4; 5; 3; 3; 3 |] dst;\n Belt.Array.blit ~src ~srcOffset:(-1) ~dst ~dstOffset:(-2) ~len:5;\n assert_array Alcotest.int [| 3; 3; 9; 2; 3; 4; 5; 3; 9; 3 |] dst;\n Belt.Array.blit ~src ~srcOffset:(-2) ~dst ~dstOffset:(-2) ~len:2;\n assert_array Alcotest.int [| 3; 3; 9; 2; 3; 4; 5; 3; 8; 9 |] dst;\n Belt.Array.blit ~src ~srcOffset:(-11) ~dst ~dstOffset:(-11) ~len:100;\n assert_array Alcotest.int src dst;\n Belt.Array.blit ~src ~srcOffset:(-11) ~dst ~dstOffset:(-11) ~len:2;\n assert_array Alcotest.int src dst;\n let overlap = Belt.Array.makeBy 10 (fun value -> value) in\n Belt.Array.blit ~src:overlap ~srcOffset:(-1) ~dst:overlap ~dstOffset:1 ~len:2;\n assert_array Alcotest.int [| 0; 9; 2; 3; 4; 5; 6; 7; 8; 9 |] overlap;\n Belt.Array.blit ~src:overlap ~srcOffset:(-2) ~dst:overlap ~dstOffset:1 ~len:2;\n assert_array Alcotest.int [| 0; 8; 9; 3; 4; 5; 6; 7; 8; 9 |] overlap;\n Belt.Array.blit ~src:overlap ~srcOffset:(-5) ~dst:overlap ~dstOffset:4 ~len:3;\n assert_array Alcotest.int [| 0; 8; 9; 3; 5; 6; 7; 7; 8; 9 |] overlap;\n Belt.Array.blit ~src:overlap ~srcOffset:4 ~dst:overlap ~dstOffset:5 ~len:3;\n assert_array Alcotest.int [| 0; 8; 9; 3; 5; 5; 6; 7; 8; 9 |] overlap;\n assert_array Alcotest.int [||] (Belt.Array.make 0 3);\n assert_array Alcotest.int [||] (Belt.Array.make (-1) 3);\n let untouched = [| 0; 1; 2 |] in\n Belt.Array.blit ~src:untouched ~srcOffset:4 ~dst:untouched ~dstOffset:1 ~len:1;\n assert_array Alcotest.int [| 0; 1; 2 |] untouched);\n test \"zip and unzip\" (fun () ->\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.int)\n [| (1, 2); (2, 3); (3, 4) |]\n (Belt.Array.zip [| 1; 2; 3 |] [| 2; 3; 4; 1 |]);\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.int)\n [| (2, 1); (3, 2); (4, 3) |]\n (Belt.Array.zip [| 2; 3; 4; 1 |] [| 1; 2; 3 |]);\n assert_array Alcotest.int [| 1; 1; 1 |] (Belt.Array.zipBy [| 2; 3; 4; 1 |] [| 1; 2; 3 |] ( - ));\n assert_array Alcotest.int [| -1; -1; -1 |] (Belt.Array.zipBy [| 1; 2; 3 |] [| 2; 3; 4; 1 |] ( - ));\n let left, right = Belt.Array.unzip [| (1, 2); (2, 3); (3, 4) |] in\n assert_array Alcotest.int [| 1; 2; 3 |] left;\n assert_array Alcotest.int [| 2; 3; 4 |] right);\n test \"iteration predicates and reverse\" (fun () ->\n let sum = ref 0 in\n Belt.Array.forEach [| 0; 1; 2; 3; 4 |] (fun value -> sum := !sum + value);\n assert_int 10 !sum;\n assert_bool false (Belt.Array.every [| 0; 1; 2; 3; 4 |] (fun value -> value > 2));\n assert_bool true (Belt.Array.some [| 1; 3; 7; 8 |] (fun value -> value mod 2 = 0));\n assert_bool false (Belt.Array.some [| 1; 3; 7 |] (fun value -> value mod 2 = 0));\n assert_bool false (Belt.Array.eq [| 0; 1 |] [| 1 |] ( = ));\n let indexed_sum = ref 0 in\n Belt.Array.forEachWithIndex [| 1; 1; 1 |] (fun index value -> indexed_sum := !indexed_sum + index + value);\n assert_int 6 !indexed_sum;\n List.iter\n (fun values ->\n let reversed = Belt.Array.reverse values in\n let in_place = Belt.Array.copy values in\n Belt.Array.reverseInPlace in_place;\n assert_array Alcotest.int reversed in_place)\n [ [||]; [| 1 |]; [| 1; 2 |]; [| 1; 2; 3 |]; [| 1; 2; 3; 4 |] ]);\n test \"every2 and some2\" (fun () ->\n assert_bool true (Belt.Array.every2 [||] [| 1 |] (fun left right -> left > right));\n assert_bool true (Belt.Array.every2 [| 2; 3 |] [| 1 |] (fun left right -> left > right));\n assert_bool true (Belt.Array.every2 [| 2 |] [| 1 |] (fun left right -> left > right));\n assert_bool false (Belt.Array.every2 [| 2; 3 |] [| 1; 4 |] (fun left right -> left > right));\n assert_bool true (Belt.Array.every2 [| 2; 3 |] [| 1; 0 |] (fun left right -> left > right));\n assert_bool false (Belt.Array.some2 [||] [| 1 |] (fun left right -> left > right));\n assert_bool true (Belt.Array.some2 [| 2; 3 |] [| 1 |] (fun left right -> left > right));\n assert_bool true (Belt.Array.some2 [| 2; 3 |] [| 1; 4 |] (fun left right -> left > right));\n assert_bool false (Belt.Array.some2 [| 0; 3 |] [| 1; 4 |] (fun left right -> left > right));\n assert_bool true (Belt.Array.some2 [| 0; 3 |] [| 3; 2 |] (fun left right -> left > right)));\n test \"concat and concatMany\" (fun () ->\n let left = [| 3; 4 |] in\n let right = [| 1; 2 |] in\n let empty_left = Belt.Array.concat [||] right in\n let empty_right = Belt.Array.concat left [||] in\n assert_array Alcotest.int [| 1; 2; 3 |] (Belt.Array.concat [||] [| 1; 2; 3 |]);\n assert_array Alcotest.int [||] (Belt.Array.concat [||] [||]);\n assert_array Alcotest.int [| 3; 2; 1; 2; 3 |] (Belt.Array.concat [| 3; 2 |] [| 1; 2; 3 |]);\n assert_array Alcotest.int [| 3; 2; 1; 2; 3 |] (Belt.Array.concatMany [| [| 3; 2 |]; [| 1; 2; 3 |] |]);\n assert_array Alcotest.int [| 3; 2; 1; 2; 3; 0 |]\n (Belt.Array.concatMany [| [| 3; 2 |]; [| 1; 2; 3 |]; [||]; [| 0 |] |]);\n assert_array Alcotest.int [| 3; 2; 1; 2; 3; 0 |]\n (Belt.Array.concatMany [| [||]; [| 3; 2 |]; [| 1; 2; 3 |]; [||]; [| 0 |] |]);\n assert_array Alcotest.int [||] (Belt.Array.concatMany [| [||]; [||] |]);\n assert_array Alcotest.int [| 1; 2 |] empty_left;\n assert_array Alcotest.int [| 3; 4 |] empty_right;\n Belt.Array.setExn empty_left 0 99;\n Belt.Array.setExn empty_right 0 42;\n assert_array Alcotest.int [| 1; 2 |] right;\n assert_array Alcotest.int [| 3; 4 |] left);\n test \"cmp and find helpers\" (fun () ->\n assert_bool true (Belt.Array.cmp [| 1; 2; 3 |] [| 0; 1; 2; 3 |] compare < 0);\n assert_bool true (Belt.Array.cmp [| 0; 1; 2; 3 |] [| 1; 2; 3 |] compare > 0);\n assert_bool true (Belt.Array.cmp [| 1; 2; 3 |] [| 0; 1; 2 |] compare > 0);\n assert_bool true (Belt.Array.cmp [| 1; 2; 3 |] [| 1; 2; 3 |] compare = 0);\n assert_bool true (Belt.Array.cmp [| 1; 2; 4 |] [| 1; 2; 3 |] compare > 0);\n assert_option Alcotest.int (Some 2) (Belt.Array.getBy [| 1; 2; 3 |] (fun value -> value > 1));\n assert_option Alcotest.int None (Belt.Array.getBy [| 1; 2; 3 |] (fun value -> value > 3));\n assert_option Alcotest.int (Some 1) (Belt.Array.getIndexBy [| 1; 2; 3 |] (fun value -> value > 1));\n assert_option Alcotest.int None (Belt.Array.getIndexBy [| 1; 2; 3 |] (fun value -> value > 3)));\n test \"unsafe allocation helpers\" (fun () ->\n let values = Belt.Array.makeUninitializedUnsafe 5 \"lola\" in\n assert_string \"lola\" (Belt.Array.getUnsafe values 0);\n assert_string \"lola\" (Belt.Array.getUnsafe values 1);\n assert_string \"lola\" (Belt.Array.getUnsafe values 2);\n assert_string \"lola\" (Belt.Array.getUnsafe values 3);\n assert_string \"lola\" (Belt.Array.getUnsafe values 4);\n let truncated = Belt.Array.truncateToLengthUnsafe values 3 in\n assert_string \"lola\" (Belt.Array.getUnsafe truncated 0));\n test \"push unsupported in native\" (fun () ->\n let values = [||] in\n assert_bool true\n (match (Belt.Array.push [@alert \"-not_implemented\"]) values 3 with\n | `Do_not_use_Array_push_in_native -> true);\n assert_bool true\n (match (Belt.Array.push [@alert \"-not_implemented\"]) values 2 with\n | `Do_not_use_Array_push_in_native -> true);\n assert_bool true\n (match (Belt.Array.push [@alert \"-not_implemented\"]) values 1 with\n | `Do_not_use_Array_push_in_native -> true);\n assert_array Alcotest.int [||] values);\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Float.ml",
"content": "let suites =\n [\n ( \"Float\",\n [\n test \"fromInt\" (fun () ->\n assert_float 1. (Belt.Float.fromInt 1);\n assert_float (-1.) (Belt.Float.fromInt (-1)));\n test \"toInt\" (fun () ->\n assert_int 1 (Belt.Float.toInt 1.);\n assert_int 1 (Belt.Float.toInt 1.3);\n assert_int 1 (Belt.Float.toInt 1.7);\n assert_int (-1) (Belt.Float.toInt (-1.));\n assert_int (-1) (Belt.Float.toInt (-1.5));\n assert_int (-1) (Belt.Float.toInt (-1.7)));\n test \"fromString\" (fun () ->\n assert_option float (Some 1.) (Belt.Float.fromString \"1\");\n assert_option float (Some (-1.)) (Belt.Float.fromString \"-1\");\n assert_option float (Some 1.7) (Belt.Float.fromString \"1.7\");\n assert_option float (Some (-1.)) (Belt.Float.fromString \"-1.0\");\n assert_option float (Some (-1.5)) (Belt.Float.fromString \"-1.5\");\n assert_option float (Some (-1.7)) (Belt.Float.fromString \"-1.7\");\n assert_option float None (Belt.Float.fromString \"not a float\"));\n test \"toString and operators\" (fun () ->\n assert_string \"1\" (Belt.Float.toString 1.);\n assert_string \"-1\" (Belt.Float.toString (-1.));\n assert_string \"-1.5\" (Belt.Float.toString (-1.5));\n let open Belt.Float in\n assert_float 5. (2. + 3.);\n assert_float (-1.) (2. - 3.);\n assert_float 6. (2. * 3.);\n assert_float 1.5 (3. / 2.));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_HashMap.ml",
"content": "let collision_hashmap () =\n let values = Belt.HashMap.make ~hintSize:16 ~id:(module CollidingIntHash) in\n Belt.HashMap.set values 0 \"zero\";\n Belt.HashMap.set values 11 \"eleven\";\n Belt.HashMap.set values 23 \"twenty-three\";\n values\n\nlet assert_hashmap_state expected values =\n assert_int (Array.length expected) (Belt.HashMap.size values);\n let count = ref 0 in\n Belt.HashMap.forEach values (fun _ _ -> incr count);\n assert_int (Array.length expected) !count;\n assert_array_unordered (Alcotest.pair Alcotest.int Alcotest.string) expected (Belt.HashMap.toArray values);\n assert_array_unordered Alcotest.int (Array.map fst expected) (Belt.HashMap.keysToArray values);\n assert_array_unordered Alcotest.string (Array.map snd expected) (Belt.HashMap.valuesToArray values)\n\nlet suites =\n [\n ( \"HashMap\",\n [\n test \"mergeMany overwrites duplicates\" (fun () ->\n let values = Belt.HashMap.make ~id:(module IntHash) ~hintSize:30 in\n Belt.HashMap.mergeMany values [| (1, 1); (2, 3); (3, 3); (2, 2) |];\n assert_option Alcotest.int (Some 2) (Belt.HashMap.get values 2);\n assert_int 3 (Belt.HashMap.size values));\n test \"fromArray dedupes overlapping keys\" (fun () ->\n let input =\n Array.map (fun value -> (value, value)) (Array.append (shuffled_range 30 100) (shuffled_range 40 120))\n in\n let values = Belt.HashMap.fromArray input ~id:(module IntHash) in\n assert_int 91 (Belt.HashMap.size values);\n let keys = Belt.HashMap.keysToArray values in\n Belt.SortArray.Int.stableSortInPlace keys;\n assert_array Alcotest.int (inclusive_range 30 120) keys);\n test \"remove stress\" (fun () ->\n let input =\n Array.map (fun value -> (value, value)) (Array.append (shuffled_range 0 10_000) (shuffled_range 0 100))\n in\n let values = Belt.HashMap.make ~id:(module IntHash) ~hintSize:40 in\n Belt.HashMap.mergeMany values input;\n assert_int 10_001 (Belt.HashMap.size values);\n for key = 0 to 1000 do\n Belt.HashMap.remove values key\n done;\n assert_int 9_000 (Belt.HashMap.size values);\n for key = 0 to 2000 do\n Belt.HashMap.remove values key\n done;\n assert_int 8_000 (Belt.HashMap.size values);\n for key = 2001 to 10_000 do\n assert_bool true (Belt.HashMap.has values key)\n done);\n test \"keepMapInPlace middle remove\" (fun () ->\n let values = collision_hashmap () in\n Belt.HashMap.keepMapInPlace values (fun key value -> if key <> 11 then Some (value ^ \"!\") else None);\n assert_option Alcotest.string (Some \"zero!\") (Belt.HashMap.get values 0);\n assert_option Alcotest.string None (Belt.HashMap.get values 11);\n assert_option Alcotest.string (Some \"twenty-three!\") (Belt.HashMap.get values 23);\n assert_hashmap_state [| (0, \"zero!\"); (23, \"twenty-three!\") |] values);\n test \"keepMapInPlace head remove\" (fun () ->\n let values = collision_hashmap () in\n Belt.HashMap.keepMapInPlace values (fun key value -> if key <> 23 then Some value else None);\n assert_option Alcotest.string None (Belt.HashMap.get values 23);\n assert_hashmap_state [| (0, \"zero\"); (11, \"eleven\") |] values);\n test \"keepMapInPlace tail remove\" (fun () ->\n let values = collision_hashmap () in\n Belt.HashMap.keepMapInPlace values (fun key value -> if key <> 0 then Some value else None);\n assert_option Alcotest.string None (Belt.HashMap.get values 0);\n assert_hashmap_state [| (11, \"eleven\"); (23, \"twenty-three\") |] values);\n test \"keepMapInPlace consecutive remove\" (fun () ->\n let values = collision_hashmap () in\n Belt.HashMap.keepMapInPlace values (fun key value -> if key = 0 then Some (value ^ \"!\") else None);\n assert_hashmap_state [| (0, \"zero!\") |] values);\n test \"keepMapInPlace remove all\" (fun () ->\n let values = collision_hashmap () in\n Belt.HashMap.keepMapInPlace values (fun _ _ -> None);\n assert_hashmap_state [||] values);\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_HashMap_Int.ml",
"content": "let suites =\n [\n ( \"HashMap.Int\",\n [\n test \"smoke\" (fun () ->\n let values = Belt.HashMap.Int.make ~hintSize:4 in\n Belt.HashMap.Int.set values 1 \"one\";\n assert_int 1 (Belt.HashMap.Int.size values);\n assert_array_unordered\n (Alcotest.pair Alcotest.int Alcotest.string)\n [| (1, \"one\") |]\n (Belt.HashMap.Int.toArray values));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_HashMap_String.ml",
"content": "let suites =\n [\n ( \"HashMap.String\",\n [\n test \"smoke\" (fun () ->\n let values = Belt.HashMap.String.make ~hintSize:4 in\n Belt.HashMap.String.set values \"one\" 1;\n assert_int 1 (Belt.HashMap.String.size values);\n assert_array_unordered\n (Alcotest.pair Alcotest.string Alcotest.int)\n [| (\"one\", 1) |]\n (Belt.HashMap.String.toArray values));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_HashSet_Int.ml",
"content": "let suites =\n [\n ( \"HashSet.Int\",\n [\n test \"dedupe reduce and forEach\" (fun () ->\n let values = Belt.HashSet.Int.fromArray (Array.append (shuffled_range 30 100) (shuffled_range 40 120)) in\n assert_int 91 (Belt.HashSet.Int.size values);\n let sorted = Belt.Set.Int.toArray (Belt.Set.Int.fromArray (Belt.HashSet.Int.toArray values)) in\n assert_array Alcotest.int (inclusive_range 30 120) sorted;\n let expected_sum = arithmetic_sum 30 120 in\n assert_int expected_sum (Belt.HashSet.Int.reduce values 0 (fun acc value -> acc + value));\n let total = ref 0 in\n Belt.HashSet.Int.forEach values (fun value -> total := !total + value);\n assert_int expected_sum !total);\n test \"size stress\" (fun () ->\n let values = Belt.HashSet.Int.make ~hintSize:40 in\n Belt.HashSet.Int.mergeMany values (Array.append (shuffled_range 0 10_000) (shuffled_range 0 100));\n assert_int 10_001 (Belt.HashSet.Int.size values);\n for key = 0 to 1000 do\n Belt.HashSet.Int.remove values key\n done;\n assert_int 9_000 (Belt.HashSet.Int.size values);\n for key = 0 to 2000 do\n Belt.HashSet.Int.remove values key\n done;\n assert_int 8_000 (Belt.HashSet.Int.size values));\n test \"copy independence\" (fun () ->\n let original = Belt.HashSet.Int.fromArray (shuffled_range 0 10_000) in\n let copy = Belt.HashSet.Int.copy original in\n assert_array_unordered Alcotest.int (Belt.HashSet.Int.toArray original) (Belt.HashSet.Int.toArray copy);\n for key = 0 to 2000 do\n Belt.HashSet.Int.remove copy key\n done;\n for key = 0 to 1000 do\n Belt.HashSet.Int.remove original key\n done;\n let left = Array.append (inclusive_range 0 1000) (Belt.HashSet.Int.toArray original) in\n let right = Array.append (inclusive_range 0 2000) (Belt.HashSet.Int.toArray copy) in\n Belt.SortArray.Int.stableSortInPlace left;\n Belt.SortArray.Int.stableSortInPlace right;\n assert_array Alcotest.int left right);\n test \"bucket histogram sanity\" (fun () ->\n let values = Belt.HashSet.Int.fromArray (shuffled_range 0 10_000) in\n assert_bool true (Array.length (Belt.HashSet.Int.getBucketHistogram values) <= 10));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_HashSet_String.ml",
"content": "let suites =\n [\n ( \"HashSet.String\",\n [\n test \"smoke\" (fun () ->\n let values = Belt.HashSet.String.make ~hintSize:4 in\n Belt.HashSet.String.add values \"a\";\n assert_int 1 (Belt.HashSet.String.size values);\n assert_array_unordered Alcotest.string [| \"a\" |] (Belt.HashSet.String.toArray values));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Int.ml",
"content": "let suites =\n [\n ( \"Int\",\n [\n test \"toFloat\" (fun () ->\n assert_float 1. (Belt.Int.toFloat 1);\n assert_float (-1.) (Belt.Int.toFloat (-1)));\n test \"fromFloat\" (fun () ->\n assert_int 1 (Belt.Int.fromFloat 1.);\n assert_int 1 (Belt.Int.fromFloat 1.3);\n assert_int 1 (Belt.Int.fromFloat 1.7);\n assert_int (-1) (Belt.Int.fromFloat (-1.));\n assert_int (-1) (Belt.Int.fromFloat (-1.5));\n assert_int (-1) (Belt.Int.fromFloat (-1.7)));\n test \"fromString\" (fun () ->\n assert_option Alcotest.int (Some 1) (Belt.Int.fromString \"1\");\n assert_option Alcotest.int (Some (-1)) (Belt.Int.fromString \"-1\");\n assert_option Alcotest.int (Some 1) (Belt.Int.fromString \"1.7\");\n assert_option Alcotest.int (Some (-1)) (Belt.Int.fromString \"-1.0\");\n assert_option Alcotest.int (Some (-1)) (Belt.Int.fromString \"-1.5\");\n assert_option Alcotest.int (Some (-1)) (Belt.Int.fromString \"-1.7\");\n assert_option Alcotest.int None (Belt.Int.fromString \"not an int\"));\n test \"toString and operators\" (fun () ->\n assert_string \"1\" (Belt.Int.toString 1);\n assert_string \"-1\" (Belt.Int.toString (-1));\n let open Belt.Int in\n assert_int 5 (2 + 3);\n assert_int (-1) (2 - 3);\n assert_int 6 (2 * 3);\n assert_int 0 (2 / 3));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_List.ml",
"content": "let sum values =\n let total = ref 0 in\n Belt.List.forEach values (fun value -> total := !total + value);\n !total\n\nlet sum2 left right =\n let total = ref 0 in\n Belt.List.forEach2 left right (fun x y -> total := !total + x + y);\n !total\n\nlet mod2 value = value mod 2 = 0\nlet even_index _ index = index mod 2 = 0\nlet id value = value\nlet add left right = left + right\nlet succ value = value + 1\nlet length_10_id = Belt.List.makeBy 10 id\nlet length_8_id = Belt.List.makeBy 8 id\n\nlet suites =\n [\n ( \"List\",\n [\n test \"makeBy get and map\" (fun () ->\n let values = Belt.List.makeBy 5 (fun index -> index * index) in\n for index = 0 to 4 do\n assert_int (index * index) (Belt.List.getExn values index)\n done;\n assert_list Alcotest.int [ 1; 2; 5; 10; 17 ] (Belt.List.map values (fun value -> value + 1));\n assert_option Alcotest.int (Some 4) (Belt.List.getBy [ 1; 4; 3; 2 ] (fun value -> value mod 2 = 0));\n assert_option Alcotest.int None (Belt.List.getBy [ 1; 4; 3; 2 ] (fun value -> value mod 5 = 0)));\n test \"flatten\" (fun () ->\n assert_list Alcotest.int [ 1; 2; 3; 0; 1; 2; 3 ]\n (Belt.List.flatten [ [ 1 ]; [ 2 ]; [ 3 ]; []; Belt.List.makeBy 4 (fun index -> index) ]);\n assert_list Alcotest.int [] (Belt.List.flatten []);\n assert_list Alcotest.int [ 2; 1; 2 ] (Belt.List.flatten [ []; []; [ 2 ]; [ 1 ]; [ 2 ]; [] ]));\n test \"concatMany\" (fun () ->\n assert_list Alcotest.int [ 1; 2; 3; 0; 1; 2; 3 ]\n (Belt.List.concatMany [| [ 1 ]; [ 2 ]; [ 3 ]; []; Belt.List.makeBy 4 (fun index -> index) |]);\n assert_list Alcotest.int [] (Belt.List.concatMany [||]);\n assert_list Alcotest.int [ 2; 1; 2 ] (Belt.List.concatMany [| []; []; [ 2 ]; [ 1 ]; [ 2 ]; [] |]);\n assert_list Alcotest.int [ 2; 3; 1; 2 ] (Belt.List.concatMany [| []; []; [ 2; 3 ]; [ 1 ]; [ 2 ]; [] |]);\n assert_list Alcotest.int [ 1; 2; 3 ] (Belt.List.concatMany [| [ 1; 2; 3 ] |]));\n test \"concat\" (fun () ->\n assert_list Alcotest.int\n (Array.to_list (Array.append (inclusive_range 0 99) (inclusive_range 0 99)))\n (Belt.List.toArray\n (Belt.List.concat\n (Belt.List.makeBy 100 (fun index -> index))\n (Belt.List.makeBy 100 (fun index -> index)))\n |> Array.to_list);\n assert_list Alcotest.int [ 1 ] (Belt.List.concat [ 1 ] []);\n assert_list Alcotest.int [ 1 ] (Belt.List.concat [] [ 1 ]));\n test \"zip and zipBy\" (fun () ->\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.int)\n [ (1, 3); (2, 4) ]\n (Belt.List.zip [ 1; 2; 3 ] [ 3; 4 ]);\n assert_list (Alcotest.pair Alcotest.int Alcotest.int) [] (Belt.List.zip [] [ 1 ]);\n assert_list (Alcotest.pair Alcotest.int Alcotest.int) [] (Belt.List.zip [] []);\n assert_list (Alcotest.pair Alcotest.int Alcotest.int) [] (Belt.List.zip [ 1; 2; 3 ] []);\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.int)\n [ (1, 2); (2, 3); (3, 4) ]\n (Belt.List.zip [ 1; 2; 3 ] [ 2; 3; 4 ]);\n let zip_by_add left right = Belt.List.zipBy left right add in\n let doubled = Belt.List.makeBy 10 (fun index -> index * 2) in\n assert_list Alcotest.int doubled (zip_by_add length_10_id length_10_id);\n assert_list Alcotest.int [] (zip_by_add [] [ 1 ]);\n assert_list Alcotest.int [] (zip_by_add [ 1 ] []);\n assert_list Alcotest.int [] (zip_by_add [] []);\n assert_list Alcotest.int\n (Belt.List.concat (Belt.List.map length_8_id (fun value -> value * 2)) [ 16; 18 ])\n (zip_by_add length_10_id length_10_id);\n assert_list Alcotest.int\n (Belt.List.mapWithIndex length_8_id (fun index value -> index + value))\n (zip_by_add length_10_id length_8_id);\n assert_list Alcotest.int\n (Belt.List.map length_10_id (fun value -> value * 2))\n (Belt.List.reverse (Belt.List.mapReverse2 length_10_id length_10_id add));\n let reversed = Belt.List.reverse (Belt.List.mapReverse2 length_8_id length_10_id add) in\n assert_int 8 (Belt.List.length reversed);\n assert_list Alcotest.int (Belt.List.zipBy length_10_id length_8_id add) reversed;\n assert_list Alcotest.int [ 4; 2 ]\n (Belt.List.mapReverse2 [ 1; 2; 3 ] [ 1; 2 ] (fun left right -> left + right)));\n test \"partition\" (fun () ->\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int)\n ([ 2; 2; 4 ], [ 1; 3; 3 ])\n (Belt.List.partition [ 1; 2; 3; 2; 3; 4 ] mod2);\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int)\n ([ 2; 2; 2; 4 ], [])\n (Belt.List.partition [ 2; 2; 2; 4 ] mod2);\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int)\n ([], [ 2; 2; 2; 4 ])\n (Belt.List.partition [ 2; 2; 2; 4 ] (fun value -> not (mod2 value)));\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int) ([], []) (Belt.List.partition [] mod2));\n test \"unzip\" (fun () ->\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int) ([], []) (Belt.List.unzip []);\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int) ([ 1 ], [ 2 ])\n (Belt.List.unzip [ (1, 2) ]);\n assert_pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int)\n ([ 1; 3 ], [ 2; 4 ])\n (Belt.List.unzip [ (1, 2); (3, 4) ]));\n test \"keep and keepWithIndex\" (fun () ->\n assert_list Alcotest.int [ 2; 4 ] (Belt.List.keep [ 1; 2; 3; 4 ] mod2);\n assert_list Alcotest.int [] (Belt.List.keep [ 1; 3; 41 ] mod2);\n assert_list Alcotest.int [] (Belt.List.keep [] mod2);\n assert_list Alcotest.int [ 2; 2; 2; 4; 6 ] (Belt.List.keep [ 2; 2; 2; 4; 6 ] mod2);\n assert_list Alcotest.int [] (Belt.List.keepWithIndex [] even_index);\n assert_list Alcotest.int [ 1; 3 ] (Belt.List.keepWithIndex [ 1; 2; 3; 4 ] even_index);\n assert_list Alcotest.int [ 0; 2; 4; 6 ] (Belt.List.keepWithIndex [ 0; 1; 2; 3; 4; 5; 6; 7 ] even_index));\n test \"map\" (fun () ->\n assert_list Alcotest.int [ 0; 2; 4; 6; 8 ] (Belt.List.map (Belt.List.makeBy 5 id) (fun value -> value * 2));\n assert_list Alcotest.int [] (Belt.List.map [] id);\n assert_list Alcotest.int [ -1 ] (Belt.List.map [ 1 ] (fun value -> -value)));\n test \"take drop and splitAt\" (fun () ->\n assert_option (Alcotest.list Alcotest.int) (Some [ 1; 2 ]) (Belt.List.take [ 1; 2; 3 ] 2);\n assert_option (Alcotest.list Alcotest.int) None (Belt.List.take [] 1);\n assert_option (Alcotest.list Alcotest.int) None (Belt.List.take [ 1; 2 ] 3);\n assert_option (Alcotest.list Alcotest.int) (Some [ 1; 2 ]) (Belt.List.take [ 1; 2 ] 2);\n assert_option (Alcotest.list Alcotest.int) (Some length_8_id) (Belt.List.take length_10_id 8);\n assert_option (Alcotest.list Alcotest.int) (Some []) (Belt.List.take length_10_id 0);\n assert_option (Alcotest.list Alcotest.int) None (Belt.List.take length_8_id (-2));\n assert_option (Alcotest.list Alcotest.int) (Some []) (Belt.List.drop length_10_id 10);\n assert_option (Alcotest.list Alcotest.int) (Some [ 8; 9 ]) (Belt.List.drop length_10_id 8);\n assert_option (Alcotest.list Alcotest.int) (Some length_10_id) (Belt.List.drop length_10_id 0);\n assert_option (Alcotest.list Alcotest.int) None (Belt.List.drop length_8_id (-1));\n let values = Belt.List.makeBy 5 id in\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n None (Belt.List.splitAt [] 1);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n None (Belt.List.splitAt values 6);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n (Some (values, []))\n (Belt.List.splitAt values 5);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n (Some ([ 0; 1; 2; 3 ], [ 4 ]))\n (Belt.List.splitAt values 4);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n (Some ([ 0; 1; 2 ], [ 3; 4 ]))\n (Belt.List.splitAt values 3);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n (Some ([ 0; 1 ], [ 2; 3; 4 ]))\n (Belt.List.splitAt values 2);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n (Some ([ 0 ], [ 1; 2; 3; 4 ]))\n (Belt.List.splitAt values 1);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n (Some ([], values))\n (Belt.List.splitAt values 0);\n assert_option\n (Alcotest.pair (Alcotest.list Alcotest.int) (Alcotest.list Alcotest.int))\n None (Belt.List.splitAt values (-1)));\n test \"association helpers\" (fun () ->\n let eq_int left right = (left : int) = right in\n assert_bool true (Belt.List.hasAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 2 ( = ));\n assert_bool false (Belt.List.hasAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 4 ( = ));\n assert_bool true\n (Belt.List.hasAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 4 (fun left right -> left + 1 = right));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"1\"); (2, \"2\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 3 ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (2, \"2\"); (3, \"3\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 1 ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"1\"); (3, \"3\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 2 ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"1\"); (2, \"2\"); (3, \"3\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 0 ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"1\"); (2, \"2\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 3 eq_int);\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (2, \"2\"); (3, \"3\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 1 eq_int);\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"1\"); (3, \"3\") ]\n (Belt.List.removeAssoc [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] 2 eq_int);\n assert_list (Alcotest.pair Alcotest.int Alcotest.string) [] (Belt.List.removeAssoc [] 2 eq_int);\n let values = [ (1, \"1\"); (2, \"2\"); (3, \"3\") ] in\n let untouched = Belt.List.removeAssoc values 0 eq_int in\n assert_same_physical values untouched;\n let updated = Belt.List.setAssoc values 2 \"22\" ( = ) in\n assert_list (Alcotest.pair Alcotest.int Alcotest.string) [ (1, \"1\"); (2, \"22\"); (3, \"3\") ] updated;\n let added = Belt.List.setAssoc updated 22 \"2\" ( = ) in\n assert_list (Alcotest.pair Alcotest.int Alcotest.string) ((22, \"2\") :: updated) added;\n assert_same_physical updated (Belt.List.tailExn added);\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"a\"); (2, \"x\"); (3, \"c\") ]\n (Belt.List.setAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 2 \"x\" ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (2, \"2\"); (1, \"a\"); (3, \"c\") ]\n (Belt.List.setAssoc [ (1, \"a\"); (3, \"c\") ] 2 \"2\" ( = ));\n assert_list (Alcotest.pair Alcotest.int Alcotest.string) [ (1, \"1\") ] (Belt.List.setAssoc [] 1 \"1\" ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (1, \"1\") ]\n (Belt.List.setAssoc [ (1, \"2\") ] 1 \"1\" ( = ));\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.string)\n [ (0, \"0\"); (1, \"1\") ]\n (Belt.List.setAssoc [ (0, \"0\"); (1, \"2\") ] 1 \"1\" ( = ));\n assert_option Alcotest.string (Some \"b\") (Belt.List.getAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 2 ( = ));\n assert_option Alcotest.string None (Belt.List.getAssoc [ (1, \"a\"); (2, \"b\"); (3, \"c\") ] 4 ( = )));\n test \"head tail and access\" (fun () ->\n assert_pair (Alcotest.option Alcotest.int)\n (Alcotest.option (Alcotest.list Alcotest.int))\n (Some 0, Belt.List.drop length_10_id 1)\n (Belt.List.head length_10_id, Belt.List.tail length_10_id);\n assert_option Alcotest.int None (Belt.List.head []);\n assert_raises_any (fun () -> ignore (Belt.List.headExn []));\n assert_raises_any (fun () -> ignore (Belt.List.tailExn []));\n assert_raises_any (fun () -> ignore (Belt.List.getExn [ 0; 1 ] (-1)));\n assert_raises_any (fun () -> ignore (Belt.List.getExn [ 0; 1 ] 2));\n assert_list Alcotest.int [ 0; 1 ] (Belt.List.map [ 0; 1 ] (fun index -> Belt.List.getExn [ 0; 1 ] index));\n assert_int 1 (Belt.List.headExn [ 1 ]);\n assert_list Alcotest.int [] (Belt.List.tailExn [ 1 ]);\n Belt.List.forEachWithIndex length_10_id (fun index value ->\n assert_option Alcotest.int (Some value) (Belt.List.get length_10_id index));\n assert_option (Alcotest.list Alcotest.int) None (Belt.List.tail []);\n assert_option (Alcotest.list Alcotest.int) None (Belt.List.drop [] 3);\n assert_list Alcotest.int [] (Belt.List.mapWithIndex [] (fun index value -> index + value));\n assert_option Alcotest.int None (Belt.List.get length_10_id (-1));\n assert_option Alcotest.int None (Belt.List.get length_10_id 12);\n assert_int 0 (sum []);\n assert_int 45 (sum length_10_id);\n assert_list Alcotest.int [] (Belt.List.makeBy 0 id);\n assert_list Alcotest.int length_10_id (Belt.List.reverse (Belt.List.reverse length_10_id));\n assert_list Alcotest.int length_8_id (Belt.List.reverse (Belt.List.reverse length_8_id));\n assert_list Alcotest.int [] (Belt.List.reverse []);\n assert_list Alcotest.int (Belt.List.map length_10_id succ)\n (Belt.List.reverse (Belt.List.mapReverse length_10_id succ)));\n test \"reductions\" (fun () ->\n assert_int 45 (Belt.List.reduce length_10_id 0 add);\n assert_int 45 (Belt.List.reduceReverse length_10_id 0 add);\n assert_int (9999 * 5000) (Belt.List.reduceReverse (Belt.List.makeBy 10_000 (fun index -> index)) 0 ( + ));\n assert_int 90 (sum2 length_10_id length_10_id);\n assert_int 56 (sum2 length_8_id length_10_id);\n assert_int 56 (sum2 length_10_id length_8_id);\n assert_int 56 (Belt.List.reduce2 length_10_id length_8_id 0 (fun acc left right -> acc + left + right));\n assert_int 18 (Belt.List.reduce2 [ 1; 2; 3 ] [ 2; 4; 6 ] 0 (fun acc left right -> acc + left + right));\n assert_int 56\n (Belt.List.reduceReverse2 length_10_id length_8_id 0 (fun acc left right -> acc + left + right));\n assert_int 90\n (Belt.List.reduceReverse2 length_10_id length_10_id 0 (fun acc left right -> acc + left + right));\n assert_int 6 (Belt.List.reduceReverse2 [ 1; 2; 3 ] [ 1; 2 ] 0 (fun acc left right -> acc + left + right));\n assert_int 10 (Belt.List.reduceReverse [ 1; 2; 3; 4 ] 0 ( + ));\n assert_int 0 (Belt.List.reduceReverse [ 1; 2; 3; 4 ] 10 ( - ));\n assert_list Alcotest.int [ 1; 2; 3; 4 ] (Belt.List.reduceReverse [ 1; 2; 3; 4 ] [] Belt.List.add);\n assert_int 10 (Belt.List.reduce [ 1; 2; 3; 4 ] 0 ( + ));\n assert_int 0 (Belt.List.reduce [ 1; 2; 3; 4 ] 10 ( - ));\n assert_list Alcotest.int [ 4; 3; 2; 1 ] (Belt.List.reduce [ 1; 2; 3; 4 ] [] Belt.List.add);\n assert_int 16 (Belt.List.reduceWithIndex [ 1; 2; 3; 4 ] 0 (fun acc value index -> acc + value + index));\n assert_int 6 (Belt.List.reduceReverse2 [ 1; 2; 3 ] [ 1; 2 ] 0 (fun acc left right -> acc + left + right));\n let values = Belt.List.makeBy 10_000 (fun index -> index) in\n assert_int\n ((9999 * 10_000) - 9999)\n (Belt.List.reduceReverse2 values (0 :: values) 0 (fun acc left right -> acc + left + right)));\n test \"predicates and comparison\" (fun () ->\n assert_bool true (Belt.List.every [ 2; 4; 6 ] mod2);\n assert_bool false (Belt.List.every [ 1 ] mod2);\n assert_bool true (Belt.List.every [] mod2);\n assert_bool true (Belt.List.some [ 1; 2; 5 ] mod2);\n assert_bool false (Belt.List.some [ 1; 3; 5 ] mod2);\n assert_bool false (Belt.List.some [] mod2);\n assert_bool true (Belt.List.has [ 1; 2; 3 ] \"2\" (fun value text -> string_of_int value = text));\n assert_bool false (Belt.List.has [ 1; 2; 3 ] \"0\" (fun value text -> string_of_int value = text));\n assert_bool true (Belt.List.every2 [] [ 1 ] (fun left right -> left > right));\n assert_bool true (Belt.List.every2 [ 2; 3 ] [ 1 ] (fun left right -> left > right));\n assert_bool true (Belt.List.every2 [ 2 ] [ 1 ] (fun left right -> left > right));\n assert_bool false (Belt.List.every2 [ 2; 3 ] [ 1; 4 ] (fun left right -> left > right));\n assert_bool true (Belt.List.every2 [ 2; 3 ] [ 1; 0 ] (fun left right -> left > right));\n assert_bool false (Belt.List.some2 [] [ 1 ] (fun left right -> left > right));\n assert_bool true (Belt.List.some2 [ 2; 3 ] [ 1 ] (fun left right -> left > right));\n assert_bool true (Belt.List.some2 [ 2; 3 ] [ 1; 4 ] (fun left right -> left > right));\n assert_bool false (Belt.List.some2 [ 0; 3 ] [ 1; 4 ] (fun left right -> left > right));\n assert_bool true (Belt.List.some2 [ 0; 3 ] [ 3; 2 ] (fun left right -> left > right));\n assert_bool false (Belt.List.some2 [ 1; 2; 3 ] [ -1; -2 ] (fun left right -> left = right));\n assert_list Alcotest.int [ 2; 3 ] (Belt.List.add (Belt.List.add [] 3) 2);\n assert_bool true (Belt.List.cmp [ 1; 2; 3 ] [ 0; 1; 2; 3 ] compare > 0);\n assert_bool true (Belt.List.cmp [ 1; 2; 3; 4 ] [ 1; 2; 3 ] compare > 0);\n assert_bool true (Belt.List.cmp [ 1; 2; 3 ] [ 1; 2; 3; 4 ] compare < 0);\n assert_bool true (Belt.List.cmp [ 1; 2; 3 ] [ 0; 1; 2 ] compare > 0);\n assert_bool true (Belt.List.cmp [ 1; 2; 3 ] [ 1; 2; 3 ] compare = 0);\n assert_bool true (Belt.List.cmp [ 1; 2; 4 ] [ 1; 2; 3 ] compare > 0);\n assert_bool true (Belt.List.cmpByLength [] [] = 0);\n assert_bool true (Belt.List.cmpByLength [ 1 ] [] > 0);\n assert_bool true (Belt.List.cmpByLength [] [ 1 ] < 0);\n assert_bool true (Belt.List.cmpByLength [ 1; 2 ] [ 1 ] > 0);\n assert_bool true (Belt.List.cmpByLength [ 1 ] [ 1; 2 ] < 0);\n assert_bool true (Belt.List.cmpByLength [ 1; 3 ] [ 1; 2 ] = 0));\n test \"make sort eq and keepMap\" (fun () ->\n List.iter\n (fun length -> assert_list Alcotest.int (Belt.List.makeBy length (fun _ -> 3)) (Belt.List.make length 3))\n [ 0; 1; 2; 3 ];\n let cmp left right = left - right in\n assert_list Alcotest.int [ 2; 3; 4; 5 ] (Belt.List.sort [ 5; 4; 3; 2 ] cmp);\n assert_list Alcotest.int [ 1; 3; 3; 9; 37 ] (Belt.List.sort [ 3; 9; 37; 3; 1 ] cmp);\n assert_bool true (not (Belt.List.eq [ 1; 2; 3 ] [ 1; 2 ] ( = )));\n assert_bool true (Belt.List.eq [ 1; 2; 3 ] [ 1; 2; 3 ] ( = ));\n assert_bool true (not (Belt.List.eq [ 1; 2; 3 ] [ 1; 2; 4 ] ( = )));\n assert_bool true (not (Belt.List.eq [ 1; 2; 3 ] [ 1; 2; 3; 4 ] ( = )));\n let values = Belt.List.makeBy 20 (fun index -> index) in\n assert_list Alcotest.int [ 1; 8; 15 ]\n (Belt.List.keepMap values (fun value -> if value mod 7 = 0 then Some (value + 1) else None));\n assert_list Alcotest.int [ -2; -4 ]\n (Belt.List.keepMap [ 1; 2; 3; 4 ] (fun value -> if value mod 2 = 0 then Some (-value) else None));\n assert_list Alcotest.int []\n (Belt.List.keepMap [ 1; 2; 3; 4 ] (fun value -> if value mod 5 = 0 then Some value else None)));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Map.ml",
"content": "let int_pairs start finish = Array.map (fun value -> (value, value)) (inclusive_range start finish)\nlet map_of_array values = Belt.Map.fromArray values ~id:(module IntCmp)\nlet set_of_keys values = Belt.Set.fromArray values ~id:(module IntCmp)\n\nlet merge_inter left right =\n set_of_keys\n (Belt.Map.keysToArray\n (Belt.Map.merge left right (fun _ left_value right_value ->\n match (left_value, right_value) with Some _, Some _ -> Some () | _ -> None)))\n\nlet merge_union left right =\n set_of_keys\n (Belt.Map.keysToArray\n (Belt.Map.merge left right (fun _ left_value right_value ->\n match (left_value, right_value) with None, None -> None | _ -> Some ())))\n\nlet merge_diff left right =\n set_of_keys\n (Belt.Map.keysToArray\n (Belt.Map.merge left right (fun _ left_value right_value ->\n match (left_value, right_value) with Some _, None -> Some () | _ -> None)))\n\nlet suites =\n [\n ( \"Map\",\n [\n test \"fromArray set get toArray and toList\" (fun () ->\n let values = map_of_array (Array.map (fun key -> (key, key)) (shuffled_range 0 39)) in\n let updated = Belt.Map.set values 39 120 in\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.int)\n (Array.map (fun key -> (key, key)) (inclusive_range 0 39))\n (Belt.Map.toArray values);\n assert_list\n (Alcotest.pair Alcotest.int Alcotest.int)\n (Array.to_list (Array.map (fun key -> (key, key)) (inclusive_range 0 39)))\n (Belt.Map.toList values);\n assert_option Alcotest.int (Some 39) (Belt.Map.get values 39);\n assert_option Alcotest.int (Some 120) (Belt.Map.get updated 39));\n test \"large fromArray sorts output\" (fun () ->\n let values = map_of_array (Array.map (fun key -> (key, key)) (shuffled_range 0 1_000)) in\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.int)\n (Array.map (fun key -> (key, key)) (inclusive_range 0 1_000))\n (Belt.Map.toArray values));\n test \"merge variants\" (fun () ->\n let left = map_of_array (int_pairs 0 100) in\n let right = map_of_array (int_pairs 30 120) in\n assert_bool true (Belt.Set.eq (merge_inter left right) (set_of_keys (inclusive_range 30 100)));\n assert_bool true (Belt.Set.eq (merge_union left right) (set_of_keys (inclusive_range 0 120)));\n assert_bool true (Belt.Set.eq (merge_diff left right) (set_of_keys (inclusive_range 0 29)));\n assert_bool true (Belt.Set.eq (merge_diff right left) (set_of_keys (inclusive_range 101 120))));\n test \"update removeMany and undefined access\" (fun () ->\n let base = map_of_array (int_pairs 0 10) in\n let overwritten = Belt.Map.set base 3 33 in\n let removed = Belt.Map.remove overwritten 3 in\n let inserted = Belt.Map.update removed 3 (function Some value -> Some (value + 1) | None -> Some 11) in\n let absent = Belt.Map.update removed 3 (function Some value -> Some (value + 1) | None -> None) in\n let removed_once = Belt.Map.remove base 3 in\n let removed_twice = Belt.Map.remove removed_once 3 in\n assert_same_physical removed_once removed_twice;\n assert_bool true (Belt.Map.has base 3);\n assert_bool false (Belt.Map.has removed_once 3);\n assert_undefined Alcotest.int (Some 3) (Belt.Map.getUndefined base 3);\n assert_undefined Alcotest.int (Some 33) (Belt.Map.getUndefined overwritten 3);\n assert_undefined Alcotest.int None (Belt.Map.getUndefined removed 3);\n assert_undefined Alcotest.int (Some 11) (Belt.Map.getUndefined inserted 3);\n assert_undefined Alcotest.int None (Belt.Map.getUndefined absent 3);\n let leftovers = Belt.Map.removeMany base [| 7; 8; 0; 1; 3; 2; 4; 922; 4; 5; 6 |] in\n assert_array Alcotest.int [| 9; 10 |] (Belt.Map.keysToArray leftovers);\n let empty = Belt.Map.removeMany leftovers (inclusive_range 0 100) in\n assert_bool true (Belt.Map.isEmpty empty));\n test \"set returns new map\" (fun () ->\n let values = map_of_array (int_pairs 0 100) in\n let updated = Belt.Map.set values 3 32 in\n assert_option Alcotest.int (Some 32) (Belt.Map.get updated 3);\n assert_option Alcotest.int (Some 3) (Belt.Map.get values 3));\n test \"repeated update accumulation\" (fun () ->\n let values = Belt.Map.make ~id:(module IntCmp) in\n let combined = Belt.Array.concat (shuffled_range 0 20) (shuffled_range 10 30) in\n let accumulated =\n Array.fold_left\n (fun map key -> Belt.Map.update map key (function None -> Some 1 | Some count -> Some (count + 1)))\n values combined\n in\n let expected = map_of_array (Array.init 31 (fun key -> (key, if key >= 10 && key <= 20 then 2 else 1))) in\n assert_bool true (Belt.Map.eq accumulated expected ( = )));\n test \"mergeMany split and empty removals\" (fun () ->\n let merged = Belt.Map.mergeMany (Belt.Map.make ~id:(module IntCmp)) (int_pairs 0 1_000) in\n let from_array = map_of_array (int_pairs 0 1_000) in\n assert_bool true (Belt.Map.eq merged from_array ( = ));\n let increment = function None -> Some 0 | Some value -> Some (value + 1) in\n let updated = Belt.Map.update merged 10 increment in\n let with_negative = Belt.Map.update updated (-10) increment in\n let (left, right), present = Belt.Map.split updated 500 in\n assert_option Alcotest.int (Some 11) (Belt.Map.get updated 10);\n assert_option Alcotest.int None (Belt.Map.get updated (-10));\n assert_option Alcotest.int (Some 0) (Belt.Map.get with_negative (-10));\n assert_bool true (Belt.Map.isEmpty (Belt.Map.remove (Belt.Map.make ~id:(module IntCmp)) 0));\n assert_bool true (Belt.Map.isEmpty (Belt.Map.removeMany (Belt.Map.make ~id:(module IntCmp)) [| 0 |]));\n assert_option Alcotest.int (Some 500) present;\n assert_array Alcotest.int (inclusive_range 0 499) (Belt.Map.keysToArray left);\n assert_array Alcotest.int (inclusive_range 501 1_000) (Belt.Map.keysToArray right);\n let removed = Belt.Map.remove updated 500 in\n let (left_missing, right_missing), present_missing = Belt.Map.split removed 500 in\n assert_option Alcotest.int None present_missing;\n assert_array Alcotest.int (inclusive_range 0 499) (Belt.Map.keysToArray left_missing);\n assert_array Alcotest.int (inclusive_range 501 1_000) (Belt.Map.keysToArray right_missing));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Map_Dict.ml",
"content": "let suites =\n [\n ( \"Map.Dict\",\n [\n test \"packIdData and first class comparator\" (fun () ->\n let module Comparable = (val Belt.Id.comparable ~cmp:(compare : int -> int -> int)) in\n let empty = Belt.Map.make ~id:(module Comparable) in\n let id = Belt.Map.getId empty in\n let module Cmp = (val id) in\n let data = Belt.Map.getData empty in\n let data = Belt.Map.Dict.set data 1 1 ~cmp:Cmp.cmp in\n let data = Belt.Map.Dict.set data 2 2 ~cmp:Cmp.cmp in\n let packed = Belt.Map.packIdData ~id ~data in\n assert_array (Alcotest.pair Alcotest.int Alcotest.int) [| (1, 1); (2, 2) |] (Belt.Map.toArray packed));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Map_Int.ml",
"content": "let suites =\n [\n ( \"Map.Int\",\n [\n test \"findFirstBy\" (fun () ->\n let values = Belt.Map.Int.fromArray [| (4, \"four\"); (1, \"one\"); (2, \"two\") |] in\n assert_option\n (Alcotest.pair Alcotest.int Alcotest.string)\n (Some (2, \"two\"))\n (Belt.Map.Int.findFirstBy values (fun key _ -> key mod 2 = 0 && key < 4));\n assert_option\n (Alcotest.pair Alcotest.int Alcotest.string)\n None\n (Belt.Map.Int.findFirstBy values (fun key _ -> key > 10)));\n test \"invariant after removals\" (fun () ->\n let shuffled = Array.map (fun key -> (key, key)) (shuffled_range 0 10_000) in\n let values = Belt.Map.Int.fromArray shuffled in\n Belt.Map.Int.checkInvariantInternal values;\n let removed = Array.sub shuffled 0 2000 in\n let reduced = Array.fold_left (fun map (key, _) -> Belt.Map.Int.remove map key) values removed in\n Belt.Map.Int.checkInvariantInternal values;\n Belt.Map.Int.checkInvariantInternal reduced;\n Array.iter (fun (key, _) -> assert_option Alcotest.int None (Belt.Map.Int.get reduced key)) removed);\n test \"set get remove stress\" (fun () ->\n let values = ref Belt.Map.Int.empty in\n let count = 10_000 in\n for key = 0 to count do\n values := Belt.Map.Int.set !values key key\n done;\n for key = 0 to count do\n assert_bool true (Belt.Map.Int.get !values key <> None)\n done;\n for key = 0 to count do\n values := Belt.Map.Int.remove !values key\n done;\n assert_bool true (Belt.Map.Int.isEmpty !values));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Map_String.ml",
"content": "let suites =\n [\n ( \"Map.String\",\n [\n test \"findFirstBy\" (fun () ->\n let values = Belt.Map.String.fromArray [| (\"cc\", 3); (\"b\", 1); (\"aa\", 2) |] in\n assert_option\n (Alcotest.pair Alcotest.string Alcotest.int)\n (Some (\"aa\", 2))\n (Belt.Map.String.findFirstBy values (fun key _ -> String.length key = 2));\n assert_option\n (Alcotest.pair Alcotest.string Alcotest.int)\n None\n (Belt.Map.String.findFirstBy values (fun key _ -> key = \"zzz\")));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableMap.ml",
"content": "let random_pairs start finish = Array.map (fun value -> (value, value)) (shuffled_range start finish)\nlet make_map () = Belt.MutableMap.make ~id:(module IntCmp)\n\nlet suites =\n [\n ( \"MutableMap\",\n [\n test \"remove preserves successor values\" (fun () ->\n let values = make_map () in\n Belt.MutableMap.set values 2 \"two\";\n Belt.MutableMap.set values 1 \"one\";\n Belt.MutableMap.set values 3 \"three\";\n Belt.MutableMap.remove values 2;\n assert_option Alcotest.string None (Belt.MutableMap.get values 2);\n assert_option Alcotest.string (Some \"one\") (Belt.MutableMap.get values 1);\n assert_option Alcotest.string (Some \"three\") (Belt.MutableMap.get values 3));\n test \"remove deep successor preserves values\" (fun () ->\n let values = make_map () in\n List.iter\n (fun (key, value) -> Belt.MutableMap.set values key value)\n [ (5, \"five\"); (2, \"two\"); (8, \"eight\"); (6, \"six\"); (9, \"nine\"); (7, \"seven\") ];\n Belt.MutableMap.remove values 5;\n Belt.MutableMap.checkInvariantInternal values;\n assert_option Alcotest.string None (Belt.MutableMap.get values 5);\n assert_option Alcotest.string (Some \"six\") (Belt.MutableMap.get values 6);\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.string)\n [| (2, \"two\"); (6, \"six\"); (7, \"seven\"); (8, \"eight\"); (9, \"nine\") |]\n (Belt.MutableMap.toArray values));\n test \"update remove preserves values\" (fun () ->\n let values = make_map () in\n List.iter\n (fun (key, value) -> Belt.MutableMap.set values key value)\n [ (5, \"five\"); (2, \"two\"); (8, \"eight\"); (6, \"six\"); (9, \"nine\") ];\n Belt.MutableMap.update values 5 (fun _ -> None);\n Belt.MutableMap.checkInvariantInternal values;\n assert_option Alcotest.string None (Belt.MutableMap.get values 5);\n assert_option Alcotest.string (Some \"six\") (Belt.MutableMap.get values 6);\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.string)\n [| (2, \"two\"); (6, \"six\"); (8, \"eight\"); (9, \"nine\") |]\n (Belt.MutableMap.toArray values));\n test \"removeMany exact keys\" (fun () ->\n let values = Belt.MutableMap.fromArray (random_pairs 0 10) ~id:(module IntCmp) in\n Belt.MutableMap.set values 3 33;\n assert_int 33 (Belt.MutableMap.getExn values 3);\n Belt.MutableMap.removeMany values [| 7; 8; 0; 1; 3; 2; 4; 922; 4; 5; 6 |];\n assert_array Alcotest.int [| 9; 10 |] (Belt.MutableMap.keysToArray values);\n Belt.MutableMap.removeMany values (inclusive_range 0 100);\n assert_bool true (Belt.MutableMap.isEmpty values));\n test \"trim to three entries\" (fun () ->\n let values = Belt.MutableMap.fromArray (random_pairs 0 10_000) ~id:(module IntCmp) in\n Belt.MutableMap.set values 2000 33;\n Belt.MutableMap.removeMany values (inclusive_range 0 1998);\n Belt.MutableMap.removeMany values (inclusive_range 2002 11_000);\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.int)\n [| (1999, 1999); (2000, 33); (2001, 2001) |]\n (Belt.MutableMap.toArray values));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableMap_Int.ml",
"content": "let suites =\n [\n ( \"MutableMap.Int\",\n [\n test \"smoke\" (fun () ->\n let values = Belt.MutableMap.Int.make () in\n Belt.MutableMap.Int.set values 1 \"one\";\n assert_option Alcotest.string (Some \"one\") (Belt.MutableMap.Int.get values 1));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableMap_String.ml",
"content": "let suites =\n [\n ( \"MutableMap.String\",\n [\n test \"smoke\" (fun () ->\n let values = Belt.MutableMap.String.make () in\n Belt.MutableMap.String.set values \"one\" 1;\n assert_option Alcotest.int (Some 1) (Belt.MutableMap.String.get values \"one\"));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableQueue.ml",
"content": "let does_raise operation queue = match operation queue with exception _ -> true | _ -> false\n\nlet suites =\n [\n ( \"MutableQueue\",\n [\n test \"push pop fifo\" (fun () ->\n let queue = Belt.MutableQueue.make () in\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray queue);\n assert_int 0 (Belt.MutableQueue.size queue);\n Belt.MutableQueue.add queue 1;\n assert_array Alcotest.int [| 1 |] (Belt.MutableQueue.toArray queue);\n assert_int 1 (Belt.MutableQueue.size queue);\n Belt.MutableQueue.add queue 2;\n Belt.MutableQueue.add queue 3;\n Belt.MutableQueue.add queue 4;\n assert_array Alcotest.int [| 1; 2; 3; 4 |] (Belt.MutableQueue.toArray queue);\n assert_int 1 (Belt.MutableQueue.popExn queue);\n assert_array Alcotest.int [| 2; 3; 4 |] (Belt.MutableQueue.toArray queue);\n assert_int 2 (Belt.MutableQueue.popExn queue);\n assert_array Alcotest.int [| 3; 4 |] (Belt.MutableQueue.toArray queue);\n assert_int 3 (Belt.MutableQueue.popExn queue);\n assert_array Alcotest.int [| 4 |] (Belt.MutableQueue.toArray queue);\n assert_int 4 (Belt.MutableQueue.popExn queue);\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray queue);\n assert_int 0 (Belt.MutableQueue.size queue);\n assert_bool true (does_raise Belt.MutableQueue.popExn queue));\n test \"reuse after empty\" (fun () ->\n let queue = Belt.MutableQueue.make () in\n Belt.MutableQueue.add queue 1;\n assert_int 1 (Belt.MutableQueue.popExn queue);\n assert_bool true (does_raise Belt.MutableQueue.popExn queue);\n Belt.MutableQueue.add queue 2;\n assert_int 2 (Belt.MutableQueue.popExn queue);\n assert_bool true (does_raise Belt.MutableQueue.popExn queue);\n assert_int 0 (Belt.MutableQueue.size queue));\n test \"peekExn\" (fun () ->\n let queue = Belt.MutableQueue.make () in\n Belt.MutableQueue.add queue 1;\n assert_int 1 (Belt.MutableQueue.peekExn queue);\n Belt.MutableQueue.add queue 2;\n assert_int 1 (Belt.MutableQueue.peekExn queue);\n Belt.MutableQueue.add queue 3;\n assert_int 1 (Belt.MutableQueue.peekExn queue);\n assert_int 1 (Belt.MutableQueue.popExn queue);\n assert_int 2 (Belt.MutableQueue.peekExn queue);\n assert_int 2 (Belt.MutableQueue.popExn queue);\n assert_int 3 (Belt.MutableQueue.peekExn queue);\n assert_int 3 (Belt.MutableQueue.popExn queue);\n assert_bool true (does_raise Belt.MutableQueue.peekExn queue);\n assert_bool true (does_raise Belt.MutableQueue.peekExn queue));\n test \"clear\" (fun () ->\n let queue = Belt.MutableQueue.make () in\n for value = 1 to 10 do\n Belt.MutableQueue.add queue value\n done;\n Belt.MutableQueue.clear queue;\n assert_int 0 (Belt.MutableQueue.size queue);\n assert_bool true (does_raise Belt.MutableQueue.popExn queue);\n assert_bool true (queue = Belt.MutableQueue.make ());\n Belt.MutableQueue.add queue 42;\n assert_int 42 (Belt.MutableQueue.popExn queue));\n test \"copy\" (fun () ->\n let source = Belt.MutableQueue.make () in\n for value = 1 to 10 do\n Belt.MutableQueue.add source value\n done;\n let copy = Belt.MutableQueue.copy source in\n assert_array Alcotest.int [| 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 |] (Belt.MutableQueue.toArray source);\n assert_array Alcotest.int [| 1; 2; 3; 4; 5; 6; 7; 8; 9; 10 |] (Belt.MutableQueue.toArray copy);\n assert_int 10 (Belt.MutableQueue.size source);\n assert_int 10 (Belt.MutableQueue.size copy);\n for value = 1 to 10 do\n assert_int value (Belt.MutableQueue.popExn source)\n done;\n for value = 1 to 10 do\n assert_int value (Belt.MutableQueue.popExn copy)\n done);\n test \"isEmpty and size\" (fun () ->\n let queue = Belt.MutableQueue.make () in\n assert_bool true (Belt.MutableQueue.isEmpty queue);\n for value = 1 to 10 do\n Belt.MutableQueue.add queue value;\n assert_int value (Belt.MutableQueue.size queue);\n assert_bool false (Belt.MutableQueue.isEmpty queue)\n done;\n for value = 10 downto 1 do\n assert_int value (Belt.MutableQueue.size queue);\n assert_bool false (Belt.MutableQueue.isEmpty queue);\n ignore (Belt.MutableQueue.popExn queue)\n done;\n assert_int 0 (Belt.MutableQueue.size queue);\n assert_bool true (Belt.MutableQueue.isEmpty queue));\n test \"forEach\" (fun () ->\n let queue = Belt.MutableQueue.make () in\n for value = 1 to 10 do\n Belt.MutableQueue.add queue value\n done;\n let expected = ref 1 in\n Belt.MutableQueue.forEach queue (fun value ->\n assert_int !expected value;\n incr expected));\n test \"transfer\" (fun () ->\n let left = Belt.MutableQueue.make () in\n let right = Belt.MutableQueue.make () in\n Belt.MutableQueue.transfer left right;\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray left);\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray right);\n for value = 1 to 4 do\n Belt.MutableQueue.add left value\n done;\n Belt.MutableQueue.transfer left right;\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray left);\n assert_array Alcotest.int [| 1; 2; 3; 4 |] (Belt.MutableQueue.toArray right);\n for value = 5 to 8 do\n Belt.MutableQueue.add right value\n done;\n Belt.MutableQueue.transfer left right;\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray left);\n assert_array Alcotest.int [| 1; 2; 3; 4; 5; 6; 7; 8 |] (Belt.MutableQueue.toArray right));\n test \"transfer appends to nonempty queue\" (fun () ->\n let left = Belt.MutableQueue.make () in\n let right = Belt.MutableQueue.make () in\n for value = 1 to 4 do\n Belt.MutableQueue.add left value\n done;\n for value = 5 to 8 do\n Belt.MutableQueue.add right value\n done;\n Belt.MutableQueue.transfer left right;\n let expected = [| 5; 6; 7; 8; 1; 2; 3; 4 |] in\n assert_array Alcotest.int [||] (Belt.MutableQueue.toArray left);\n assert_array Alcotest.int expected (Belt.MutableQueue.toArray right);\n assert_int\n (Belt.Array.reduce expected 0 (fun acc value -> acc - value))\n (Belt.MutableQueue.reduce right 0 (fun acc value -> acc - value)));\n test \"fromArray and map\" (fun () ->\n let queue = Belt.MutableQueue.fromArray [| 1; 2; 3; 4 |] in\n let mapped = Belt.MutableQueue.map queue (fun value -> value - 1) in\n assert_array Alcotest.int [| 0; 1; 2; 3 |] (Belt.MutableQueue.toArray mapped);\n assert_bool true (Belt.MutableQueue.isEmpty (Belt.MutableQueue.fromArray [||]));\n assert_bool true\n (Belt.MutableQueue.isEmpty\n (Belt.MutableQueue.map (Belt.MutableQueue.fromArray [||]) (fun value -> value + 1))));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableSet.ml",
"content": "let of_array values = Belt.MutableSet.fromArray values ~id:(module IntCmp)\n\nlet suites =\n [\n ( \"MutableSet\",\n [\n test \"remove add and split\" (fun () ->\n let values = of_array (inclusive_range 0 30) in\n assert_bool true (Belt.MutableSet.removeCheck values 0);\n assert_bool false (Belt.MutableSet.removeCheck values 0);\n assert_bool true (Belt.MutableSet.removeCheck values 30);\n assert_bool true (Belt.MutableSet.removeCheck values 20);\n assert_int 28 (Belt.MutableSet.size values);\n assert_undefined Alcotest.int (Some 29) (Belt.MutableSet.maxUndefined values);\n assert_undefined Alcotest.int (Some 1) (Belt.MutableSet.minUndefined values);\n Belt.MutableSet.add values 3;\n Array.iter (Belt.MutableSet.remove values) (shuffled_range 0 30);\n assert_bool true (Belt.MutableSet.isEmpty values);\n Belt.MutableSet.add values 0;\n Belt.MutableSet.add values 1;\n Belt.MutableSet.add values 2;\n Belt.MutableSet.add values 0;\n assert_int 3 (Belt.MutableSet.size values);\n Belt.MutableSet.mergeMany values (shuffled_range 0 20_000);\n Belt.MutableSet.mergeMany values (shuffled_range 0 200);\n assert_int 20_001 (Belt.MutableSet.size values);\n Belt.MutableSet.removeMany values (shuffled_range 0 200);\n assert_int 19_800 (Belt.MutableSet.size values);\n Belt.MutableSet.removeMany values (shuffled_range 0 1000);\n assert_int 19_000 (Belt.MutableSet.size values);\n let values = of_array (shuffled_range 1000 2000) in\n let (left, right), present = Belt.MutableSet.split values 1000 in\n assert_bool true present;\n assert_array Alcotest.int (inclusive_range 1000 2000) (Belt.MutableSet.toArray values);\n assert_array Alcotest.int (inclusive_range 1001 2000) (Belt.MutableSet.toArray right);\n assert_bool true (Belt.MutableSet.subset left values));\n test \"set algebra and partitions\" (fun () ->\n let left = of_array (shuffled_range 0 100) in\n let right = of_array (shuffled_range 40 120) in\n assert_bool true (Belt.MutableSet.eq (Belt.MutableSet.union left right) (of_array (inclusive_range 0 120)));\n assert_bool true\n (Belt.MutableSet.eq (Belt.MutableSet.intersect left right) (of_array (inclusive_range 40 100)));\n assert_bool true (Belt.MutableSet.eq (Belt.MutableSet.diff left right) (of_array (inclusive_range 0 39)));\n let values = of_array (shuffled_range 0 1000) in\n let evens = Belt.MutableSet.keep values (fun value -> value mod 2 = 0) in\n let odds = Belt.MutableSet.keep values (fun value -> value mod 2 <> 0) in\n let evens_part, odds_part = Belt.MutableSet.partition values (fun value -> value mod 2 = 0) in\n assert_bool true (Belt.MutableSet.eq evens evens_part);\n assert_bool true (Belt.MutableSet.eq odds odds_part);\n List.iter Belt.MutableSet.checkInvariantInternal [ values; evens; odds; evens_part; odds_part ]);\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableSet_Int.ml",
"content": "let of_array = Belt.MutableSet.Int.fromArray\n\nlet suites =\n [\n ( \"MutableSet.Int\",\n [\n test \"removeCheck addCheck mergeMany and removeMany\" (fun () ->\n let values = of_array (inclusive_range 0 30) in\n assert_bool true (Belt.MutableSet.Int.removeCheck values 0);\n assert_bool false (Belt.MutableSet.Int.removeCheck values 0);\n assert_bool true (Belt.MutableSet.Int.removeCheck values 30);\n assert_bool true (Belt.MutableSet.Int.removeCheck values 20);\n assert_int 28 (Belt.MutableSet.Int.size values);\n assert_undefined Alcotest.int (Some 29) (Belt.MutableSet.Int.maxUndefined values);\n assert_undefined Alcotest.int (Some 1) (Belt.MutableSet.Int.minUndefined values);\n Belt.MutableSet.Int.add values 3;\n Array.iter (Belt.MutableSet.Int.remove values) (shuffled_range 0 30);\n assert_bool true (Belt.MutableSet.Int.isEmpty values);\n Belt.MutableSet.Int.add values 0;\n Belt.MutableSet.Int.add values 1;\n Belt.MutableSet.Int.add values 2;\n Belt.MutableSet.Int.add values 0;\n assert_int 3 (Belt.MutableSet.Int.size values);\n assert_bool false (Belt.MutableSet.Int.isEmpty values);\n for key = 0 to 3 do\n Belt.MutableSet.Int.remove values key\n done;\n assert_bool true (Belt.MutableSet.Int.isEmpty values);\n Belt.MutableSet.Int.mergeMany values (shuffled_range 0 2_000);\n Belt.MutableSet.Int.mergeMany values (shuffled_range 0 200);\n assert_int 2_001 (Belt.MutableSet.Int.size values);\n Belt.MutableSet.Int.removeMany values (shuffled_range 0 200);\n assert_int 1_800 (Belt.MutableSet.Int.size values);\n Belt.MutableSet.Int.removeMany values (shuffled_range 0 1000);\n assert_int 1_000 (Belt.MutableSet.Int.size values);\n Belt.MutableSet.Int.removeMany values (shuffled_range 0 1000);\n assert_int 1_000 (Belt.MutableSet.Int.size values);\n Belt.MutableSet.Int.removeMany values (shuffled_range 1000 1_500);\n assert_int 500 (Belt.MutableSet.Int.size values);\n Belt.MutableSet.Int.removeMany values (shuffled_range 1_500 1_999);\n assert_int 1 (Belt.MutableSet.Int.size values);\n assert_bool true (Belt.MutableSet.Int.has values 2_000);\n Belt.MutableSet.Int.removeMany values (shuffled_range 1_500 3_000);\n assert_bool true (Belt.MutableSet.Int.isEmpty values));\n test \"stats split and subset\" (fun () ->\n let values = of_array (shuffled_range 1000 2000) in\n let removals =\n Array.map (fun key -> Belt.MutableSet.Int.removeCheck values key) (shuffled_range 500 1499)\n in\n let removed_count = Array.fold_left (fun acc removed -> if removed then acc + 1 else acc) 0 removals in\n assert_int 500 removed_count;\n assert_int 501 (Belt.MutableSet.Int.size values);\n let additions = Array.map (fun key -> Belt.MutableSet.Int.addCheck values key) (shuffled_range 500 2000) in\n let added_count = Array.fold_left (fun acc added -> if added then acc + 1 else acc) 0 additions in\n assert_int 1000 added_count;\n assert_int 1501 (Belt.MutableSet.Int.size values);\n assert_bool true (Belt.MutableSet.Int.isEmpty (Belt.MutableSet.Int.make ()));\n assert_option Alcotest.int (Some 500) (Belt.MutableSet.Int.minimum values);\n assert_option Alcotest.int (Some 2000) (Belt.MutableSet.Int.maximum values);\n assert_undefined Alcotest.int (Some 500) (Belt.MutableSet.Int.minUndefined values);\n assert_undefined Alcotest.int (Some 2000) (Belt.MutableSet.Int.maxUndefined values);\n assert_int ((500 + 2000) / 2 * 1501) (Belt.MutableSet.Int.reduce values 0 (fun acc value -> acc + value));\n assert_list Alcotest.int (Array.to_list (inclusive_range 500 2000)) (Belt.MutableSet.Int.toList values);\n assert_array Alcotest.int (inclusive_range 500 2000) (Belt.MutableSet.Int.toArray values);\n Belt.MutableSet.Int.checkInvariantInternal values;\n assert_option Alcotest.int None (Belt.MutableSet.Int.get values 3);\n assert_option Alcotest.int (Some 1200) (Belt.MutableSet.Int.get values 1200);\n let (left, right), present = Belt.MutableSet.Int.split values 1000 in\n assert_bool true present;\n assert_array Alcotest.int (inclusive_range 500 999) (Belt.MutableSet.Int.toArray left);\n assert_array Alcotest.int (inclusive_range 1001 2000) (Belt.MutableSet.Int.toArray right);\n assert_bool true (Belt.MutableSet.Int.subset left values);\n assert_bool true (Belt.MutableSet.Int.subset right values);\n assert_bool true (Belt.MutableSet.Int.isEmpty (Belt.MutableSet.Int.intersect left right));\n assert_bool true (Belt.MutableSet.Int.removeCheck values 1000);\n let (left_missing, right_missing), present_missing = Belt.MutableSet.Int.split values 1000 in\n assert_bool false present_missing;\n assert_array Alcotest.int (inclusive_range 500 999) (Belt.MutableSet.Int.toArray left_missing);\n assert_array Alcotest.int (inclusive_range 1001 2000) (Belt.MutableSet.Int.toArray right_missing));\n test \"set algebra and partitions\" (fun () ->\n let left = of_array (shuffled_range 0 100) in\n let right = of_array (shuffled_range 40 120) in\n assert_bool true\n (Belt.MutableSet.Int.eq (Belt.MutableSet.Int.union left right) (of_array (inclusive_range 0 120)));\n assert_bool true\n (Belt.MutableSet.Int.eq\n (Belt.MutableSet.Int.union (of_array (shuffled_range 0 20)) (of_array (shuffled_range 21 40)))\n (of_array (inclusive_range 0 40)));\n assert_bool true\n (Belt.MutableSet.Int.eq (Belt.MutableSet.Int.intersect left right) (of_array (inclusive_range 40 100)));\n assert_bool true\n (Belt.MutableSet.Int.eq\n (Belt.MutableSet.Int.intersect (of_array (shuffled_range 0 20)) (of_array (shuffled_range 21 40)))\n (Belt.MutableSet.Int.make ()));\n assert_bool true\n (Belt.MutableSet.Int.eq\n (Belt.MutableSet.Int.intersect (of_array [| 1; 3; 4; 5; 7; 9 |]) (of_array [| 2; 4; 5; 6; 8; 10 |]))\n (of_array [| 4; 5 |]));\n assert_bool true\n (Belt.MutableSet.Int.eq (Belt.MutableSet.Int.diff left right) (of_array (inclusive_range 0 39)));\n assert_bool true\n (Belt.MutableSet.Int.eq (Belt.MutableSet.Int.diff right left) (of_array (inclusive_range 101 120)));\n let values = of_array (shuffled_range 0 1000) in\n let evens = Belt.MutableSet.Int.keep values (fun value -> value mod 2 = 0) in\n let odds = Belt.MutableSet.Int.keep values (fun value -> value mod 2 <> 0) in\n let evens_part, odds_part = Belt.MutableSet.Int.partition values (fun value -> value mod 2 = 0) in\n assert_bool true (Belt.MutableSet.Int.eq evens evens_part);\n assert_bool true (Belt.MutableSet.Int.eq odds odds_part);\n List.iter Belt.MutableSet.Int.checkInvariantInternal [ values; evens; odds; evens_part; odds_part ]);\n test \"large add stress\" (fun () ->\n let values = Belt.MutableSet.Int.make () in\n for key = 0 to 10_000 do\n Belt.MutableSet.Int.add values key\n done;\n Belt.MutableSet.Int.checkInvariantInternal values;\n for key = 0 to 10_000 do\n assert_bool true (Belt.MutableSet.Int.has values key)\n done;\n assert_int 10_001 (Belt.MutableSet.Int.size values));\n test \"fromArray and removal stress\" (fun () ->\n let values = Belt.MutableSet.Int.make () in\n Belt.MutableSet.Int.mergeMany values (Array.append (shuffled_range 30 100) (shuffled_range 40 120));\n assert_int 91 (Belt.MutableSet.Int.size values);\n assert_array Alcotest.int (inclusive_range 30 120) (Belt.MutableSet.Int.toArray values);\n let values =\n Belt.MutableSet.Int.fromArray (Array.append (shuffled_range 0 10_000) (shuffled_range 0 100))\n in\n assert_int 10_001 (Belt.MutableSet.Int.size values);\n Array.iter (fun key -> Belt.MutableSet.Int.remove values key) (shuffled_range 5_000 8_000);\n assert_int 7_000 (Belt.MutableSet.Int.size values);\n Array.iter (fun key -> Belt.MutableSet.Int.remove values key) (shuffled_range 0 10_000);\n assert_int 0 (Belt.MutableSet.Int.size values);\n assert_bool true (Belt.MutableSet.Int.isEmpty values));\n test \"fromSortedArrayUnsafe and derived copies\" (fun () ->\n List.iter\n (fun values ->\n let set = Belt.MutableSet.Int.fromSortedArrayUnsafe values in\n Belt.MutableSet.Int.checkInvariantInternal set;\n assert_array Alcotest.int values (Belt.MutableSet.Int.toArray set))\n [\n [||];\n [| 0 |];\n [| 0; 1 |];\n [| 0; 1; 2 |];\n [| 0; 1; 2; 3 |];\n [| 0; 1; 2; 3; 4 |];\n [| 0; 1; 2; 3; 4; 5 |];\n [| 0; 1; 2; 3; 4; 6 |];\n [| 0; 1; 2; 3; 4; 6; 7 |];\n [| 0; 1; 2; 3; 4; 6; 7; 8 |];\n [| 0; 1; 2; 3; 4; 6; 7; 8; 9 |];\n inclusive_range 0 1000;\n ];\n let values = Belt.MutableSet.Int.fromArray (shuffled_range 0 1000) in\n let copy = Belt.MutableSet.Int.keep values (fun value -> value mod 8 = 0) in\n let keep_even, keep_odd = Belt.MutableSet.Int.partition values (fun value -> value mod 8 = 0) in\n let rest = Belt.MutableSet.Int.keep values (fun value -> value mod 8 <> 0) in\n for key = 0 to 200 do\n Belt.MutableSet.Int.remove values key\n done;\n assert_int 126 (Belt.MutableSet.Int.size copy);\n assert_array Alcotest.int (Array.init 126 (fun index -> index * 8)) (Belt.MutableSet.Int.toArray copy);\n assert_int 800 (Belt.MutableSet.Int.size values);\n assert_bool true (Belt.MutableSet.Int.eq copy keep_even);\n assert_bool true (Belt.MutableSet.Int.eq rest keep_odd);\n let values = Belt.MutableSet.Int.fromArray (shuffled_range 0 1000) in\n let (left, right), _ = Belt.MutableSet.Int.split values 400 in\n assert_bool true (Belt.MutableSet.Int.eq left (Belt.MutableSet.Int.fromArray (inclusive_range 0 399)));\n assert_bool true (Belt.MutableSet.Int.eq right (Belt.MutableSet.Int.fromArray (inclusive_range 401 1000))));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableSet_String.ml",
"content": "let suites =\n [\n ( \"MutableSet.String\",\n [\n test \"smoke\" (fun () ->\n let values = Belt.MutableSet.String.make () in\n assert_bool true (Belt.MutableSet.String.addCheck values \"a\");\n assert_bool false (Belt.MutableSet.String.addCheck values \"a\");\n assert_array Alcotest.string [| \"a\" |] (Belt.MutableSet.String.toArray values));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_MutableStack.ml",
"content": "type tree = { value : int; left : tree option; right : tree option }\n\nlet node ?left ?right value = { value; left; right }\nlet traversal_tree = node 1 ~left:(node 2 ~left:(node 4) ~right:(node 5)) ~right:(node 3)\n\nlet push_all_left start stack =\n let current = ref start in\n while Option.is_some !current do\n let value = Option.get !current in\n Belt.MutableStack.push stack value;\n current := value.left\n done\n\nlet in_order root =\n let stack = Belt.MutableStack.make () in\n let queue = Belt.MutableQueue.make () in\n push_all_left (Some root) stack;\n while not (Belt.MutableStack.isEmpty stack) do\n match Belt.MutableStack.pop stack with\n | None -> ()\n | Some value ->\n Belt.MutableQueue.add queue value.value;\n push_all_left value.right stack\n done;\n Belt.MutableQueue.toArray queue\n\nlet in_order_dynamic root =\n let stack = Belt.MutableStack.make () in\n let queue = Belt.MutableQueue.make () in\n push_all_left (Some root) stack;\n Belt.MutableStack.dynamicPopIter stack (fun popped ->\n Belt.MutableQueue.add queue popped.value;\n push_all_left popped.right stack);\n Belt.MutableQueue.toArray queue\n\nlet suites =\n [\n ( \"MutableStack\",\n [\n test \"inorder traversal\" (fun () -> assert_array Alcotest.int [| 4; 2; 5; 1; 3 |] (in_order traversal_tree));\n test \"dynamicPopIter traversal\" (fun () ->\n assert_array Alcotest.int [| 4; 2; 5; 1; 3 |] (in_order_dynamic traversal_tree));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Option.ml",
"content": "let suites =\n [\n ( \"Option\",\n [\n test \"keep\" (fun () ->\n assert_option Alcotest.int (Some 10) (Belt.Option.keep (Some 10) (fun x -> x > 5));\n assert_option Alcotest.int None (Belt.Option.keep (Some 4) (fun x -> x > 5));\n assert_option Alcotest.int None (Belt.Option.keep None (fun x -> x > 5)));\n test \"orElse\" (fun () ->\n assert_option Alcotest.int (Some 10) (Belt.Option.orElse (Some 10) (Some 20));\n assert_option Alcotest.int (Some 20) (Belt.Option.orElse None (Some 20));\n assert_option Alcotest.int None (Belt.Option.orElse None None));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Result.ml",
"content": "let _result_alias_one : (string, string) result = Belt.Result.map (Ok \"Test\") (fun r -> \"Value: \" ^ r)\n\nlet _result_alias_two : string =\n Belt.Result.getWithDefault (Belt.Result.map (Error \"error\") (fun r -> \"Value: \" ^ r)) \"success\"\n\nlet suites =\n [\n ( \"Result\",\n [\n test \"alias compatibility\" (fun () ->\n (match Belt.Result.map (Ok \"Test\") (fun r -> \"Value: \" ^ r) with\n | Ok value -> assert_string \"Value: Test\" value\n | Error _ -> Alcotest.fail \"Expected Ok\");\n assert_string \"success\"\n (Belt.Result.getWithDefault (Belt.Result.map (Error \"error\") (fun r -> \"Value: \" ^ r)) \"success\"));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Set.ml",
"content": "let of_array values = Belt.Set.fromArray values ~id:(module IntCmp)\n\nlet suites =\n [\n ( \"Set\",\n [\n test \"remove add and minmax behavior\" (fun () ->\n let original = of_array (inclusive_range 0 30) in\n let removed_zero = Belt.Set.remove original 0 in\n let removed_zero_again = Belt.Set.remove removed_zero 0 in\n let removed_tail = Belt.Set.remove removed_zero 30 in\n let removed_mid = Belt.Set.remove removed_tail 20 in\n let shuffled = shuffled_range 0 30 in\n let added_back = Belt.Set.add removed_mid 3 in\n let emptied = Belt.Set.removeMany added_back shuffled in\n let rebuilt = Belt.Set.mergeMany emptied [| 0; 1; 2; 0 |] in\n let emptied_again = Belt.Set.removeMany rebuilt [| 0; 1; 2; 3 |] in\n let merged = Belt.Set.mergeMany emptied_again (shuffled_range 0 2_000) in\n let merged_again = Belt.Set.mergeMany merged (shuffled_range 0 200) in\n let removed_small = Belt.Set.removeMany merged_again (shuffled_range 0 200) in\n let removed_medium = Belt.Set.removeMany removed_small (shuffled_range 0 1000) in\n let removed_medium_again = Belt.Set.removeMany removed_medium (shuffled_range 0 1000) in\n let removed_large = Belt.Set.removeMany removed_medium_again (shuffled_range 1000 1_500) in\n let only_last = Belt.Set.removeMany removed_large (shuffled_range 1_500 1_999) in\n let empty_final = Belt.Set.removeMany only_last (shuffled_range 2_000 2_100) in\n assert_not_same_physical original removed_zero;\n assert_same_physical removed_zero removed_zero_again;\n assert_int 28 (Belt.Set.size removed_mid);\n assert_undefined Alcotest.int (Some 29) (Belt.Set.maxUndefined removed_mid);\n assert_undefined Alcotest.int (Some 1) (Belt.Set.minUndefined removed_mid);\n assert_same_physical removed_mid added_back;\n assert_bool true (Belt.Set.isEmpty emptied);\n assert_int 3 (Belt.Set.size rebuilt);\n assert_bool false (Belt.Set.isEmpty rebuilt);\n assert_bool true (Belt.Set.isEmpty emptied_again);\n assert_bool true (Belt.Set.has merged_again 20);\n assert_bool true (Belt.Set.has merged_again 21);\n assert_int 2_001 (Belt.Set.size merged_again);\n assert_int 1_800 (Belt.Set.size removed_small);\n assert_int 1_000 (Belt.Set.size removed_medium);\n assert_int (Belt.Set.size removed_medium) (Belt.Set.size removed_medium_again);\n assert_int 500 (Belt.Set.size removed_large);\n assert_int 1 (Belt.Set.size only_last);\n assert_bool true (Belt.Set.has only_last 2_000);\n assert_bool false (Belt.Set.has only_last 500);\n assert_bool true (Belt.Set.isEmpty empty_final));\n test \"union intersect diff subset and undefined access\" (fun () ->\n let left = of_array (shuffled_range 0 100) in\n let right = of_array (shuffled_range 59 200) in\n let unioned = Belt.Set.union left right in\n let expected_union = of_array (inclusive_range 0 200) in\n let intersected = Belt.Set.intersect left right in\n let diff_left = Belt.Set.diff left right in\n let diff_right = Belt.Set.diff right left in\n let with_59 = Belt.Set.add diff_left 59 in\n let singleton = Belt.Set.add (Belt.Set.make ~id:(module IntCmp)) 3 in\n let even_values = of_array (Array.map (fun value -> value * 2) (shuffled_range 0 100)) in\n let union_singleton = Belt.Set.union even_values singleton in\n let expected_union_singleton =\n Array.append (Array.map (fun value -> value * 2) (inclusive_range 0 100)) [| 3 |]\n in\n Array.sort compare expected_union_singleton;\n assert_bool true (Belt.Set.eq unioned expected_union);\n assert_array Alcotest.int expected_union_singleton (Belt.Set.toArray union_singleton);\n assert_array Alcotest.int (inclusive_range 59 100) (Belt.Set.toArray intersected);\n assert_array Alcotest.int (inclusive_range 0 58) (Belt.Set.toArray diff_left);\n assert_bool true (Belt.Set.eq (Belt.Set.union right left) unioned);\n assert_array Alcotest.int (inclusive_range 101 200) (Belt.Set.toArray diff_right);\n assert_bool true (Belt.Set.subset diff_right right);\n assert_bool false (Belt.Set.subset right diff_right);\n assert_bool true (Belt.Set.subset diff_left left);\n assert_bool true (Belt.Set.subset intersected left && Belt.Set.subset intersected right);\n assert_undefined Alcotest.int (Some 47) (Belt.Set.getUndefined diff_left 47);\n assert_option Alcotest.int (Some 47) (Belt.Set.get diff_left 47);\n assert_undefined Alcotest.int None (Belt.Set.getUndefined diff_left 59);\n assert_option Alcotest.int None (Belt.Set.get diff_left 59);\n assert_int 60 (Belt.Set.size with_59);\n assert_option Alcotest.int None (Belt.Set.minimum (Belt.Set.make ~id:(module IntCmp)));\n assert_option Alcotest.int None (Belt.Set.maximum (Belt.Set.make ~id:(module IntCmp)));\n assert_undefined Alcotest.int None (Belt.Set.minUndefined (Belt.Set.make ~id:(module IntCmp)));\n assert_undefined Alcotest.int None (Belt.Set.maxUndefined (Belt.Set.make ~id:(module IntCmp))));\n test \"iteration every some cmp\" (fun () ->\n let values = of_array (shuffled_range 0 20) in\n let removed = Belt.Set.remove values 17 in\n let with_extra = Belt.Set.add removed 33 in\n let collected = ref [] in\n Belt.Set.forEach values (fun value -> collected := value :: !collected);\n assert_list Alcotest.int (Array.to_list (inclusive_range 0 20)) (List.rev !collected);\n assert_list Alcotest.int (Belt.Set.toList values) (Array.to_list (inclusive_range 0 20));\n assert_bool true (Belt.Set.some values (fun value -> value = 17));\n assert_bool false (Belt.Set.some removed (fun value -> value = 17));\n assert_bool true (Belt.Set.every values (fun value -> value < 24));\n assert_bool false (Belt.Set.every with_extra (fun value -> value < 24));\n assert_bool false (Belt.Set.every (of_array [| 1; 2; 3 |]) (fun value -> value = 2));\n assert_bool true (Belt.Set.cmp removed values < 0);\n assert_bool true (Belt.Set.cmp values removed > 0));\n test \"keep partition getExn and split\" (fun () ->\n let values = of_array (shuffled_range 0 1000) in\n let evens = Belt.Set.keep values (fun value -> value mod 2 = 0) in\n let odds = Belt.Set.keep values (fun value -> value mod 2 <> 0) in\n let evens_part, odds_part = Belt.Set.partition values (fun value -> value mod 2 = 0) in\n assert_bool true (Belt.Set.eq evens evens_part);\n assert_bool true (Belt.Set.eq odds odds_part);\n assert_int 3 (Belt.Set.getExn values 3);\n assert_int 4 (Belt.Set.getExn values 4);\n assert_raises_any (fun () -> ignore (Belt.Set.getExn values 1002));\n assert_raises_any (fun () -> ignore (Belt.Set.getExn values (-1)));\n assert_int 1001 (Belt.Set.size values);\n assert_bool false (Belt.Set.isEmpty values);\n let (left, right), present = Belt.Set.split values 200 in\n assert_bool true present;\n assert_array Alcotest.int (inclusive_range 0 199) (Belt.Set.toArray left);\n assert_list Alcotest.int (Array.to_list (inclusive_range 201 1000)) (Belt.Set.toList right);\n let removed_200 = Belt.Set.remove values 200 in\n let (left_missing, right_missing), present_missing = Belt.Set.split removed_200 200 in\n assert_bool false present_missing;\n assert_array Alcotest.int (inclusive_range 0 199) (Belt.Set.toArray left_missing);\n assert_list Alcotest.int (Array.to_list (inclusive_range 201 1000)) (Belt.Set.toList right_missing);\n assert_option Alcotest.int (Some 0) (Belt.Set.minimum left);\n assert_option Alcotest.int (Some 201) (Belt.Set.minimum right));\n test \"empty keep and empty split\" (fun () ->\n let empty = Belt.Set.fromArray [||] ~id:(module IntCmp) in\n assert_bool true (Belt.Set.isEmpty (Belt.Set.keep empty (fun value -> value mod 2 = 0)));\n let (left, right), present = Belt.Set.split (Belt.Set.make ~id:(module IntCmp)) 0 in\n assert_bool true (Belt.Set.isEmpty left);\n assert_bool true (Belt.Set.isEmpty right);\n assert_bool false present);\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Set_Dict.ml",
"content": "let suites =\n [\n ( \"Set.Dict\",\n [\n test \"forEach and every\" (fun () ->\n let values = Belt.Set.fromArray (shuffled_range 0 20) ~id:(module IntCmp) in\n let collected = ref [] in\n Belt.Set.Dict.forEach (Belt.Set.getData values) (fun value -> collected := value :: !collected);\n assert_list Alcotest.int (Array.to_list (inclusive_range 0 20)) (List.rev !collected);\n assert_bool true (Belt.Set.Dict.every (Belt.Set.getData values) (fun value -> value < 24)));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Set_Int.ml",
"content": "let of_array = Belt.Set.Int.fromArray\n\nlet suites =\n [\n ( \"Set.Int\",\n [\n test \"eq and partition\" (fun () ->\n assert_bool true (Belt.Set.Int.eq (of_array [| 1; 2; 3 |]) (of_array [| 3; 2; 1 |]));\n let values = of_array (Array.append (inclusive_range 100 1000) (reverse_inclusive_range 400 1500)) in\n assert_array Alcotest.int (inclusive_range 100 1500) (Belt.Set.Int.toArray values);\n let left, right = Belt.Set.Int.partition values (fun value -> value mod 3 = 0) in\n let expected_left = ref Belt.Set.Int.empty in\n let expected_right = ref Belt.Set.Int.empty in\n for value = 100 to 1500 do\n if value mod 3 = 0 then expected_left := Belt.Set.Int.add !expected_left value\n else expected_right := Belt.Set.Int.add !expected_right value\n done;\n assert_bool true (Belt.Set.Int.eq left !expected_left);\n assert_bool true (Belt.Set.Int.eq right !expected_right));\n test \"set algebra\" (fun () ->\n assert_array Alcotest.int (inclusive_range 50 100)\n (Belt.Set.Int.toArray\n (Belt.Set.Int.intersect (of_array (inclusive_range 1 100)) (of_array (inclusive_range 50 200))));\n assert_array Alcotest.int (inclusive_range 1 200)\n (Belt.Set.Int.toArray\n (Belt.Set.Int.union (of_array (inclusive_range 1 100)) (of_array (inclusive_range 50 200))));\n assert_array Alcotest.int (inclusive_range 1 49)\n (Belt.Set.Int.toArray\n (Belt.Set.Int.diff (of_array (inclusive_range 1 100)) (of_array (inclusive_range 50 200))));\n assert_array Alcotest.int (inclusive_range 50 100)\n (Belt.Set.Int.toArray\n (Belt.Set.Int.intersect\n (of_array (reverse_inclusive_range 1 100))\n (of_array (reverse_inclusive_range 50 200))));\n assert_array Alcotest.int (inclusive_range 1 200)\n (Belt.Set.Int.toArray\n (Belt.Set.Int.union\n (of_array (reverse_inclusive_range 1 100))\n (of_array (reverse_inclusive_range 50 200))));\n assert_array Alcotest.int (inclusive_range 1 49)\n (Belt.Set.Int.toArray\n (Belt.Set.Int.diff\n (of_array (reverse_inclusive_range 1 100))\n (of_array (reverse_inclusive_range 50 200)))));\n test \"min max reduce and emptiness\" (fun () ->\n let source = [| 1; 222; 3; 4; 2; 0; 33; -1 |] in\n let values = of_array source in\n assert_int (Array.fold_left ( + ) 0 source) (Belt.Set.Int.reduce values 0 (fun acc value -> acc + value));\n assert_undefined Alcotest.int (Some (-1)) (Belt.Set.Int.minUndefined values);\n assert_undefined Alcotest.int (Some 222) (Belt.Set.Int.maxUndefined values);\n let values = Belt.Set.Int.remove values 3 in\n assert_option Alcotest.int (Some (-1)) (Belt.Set.Int.minimum values);\n assert_option Alcotest.int (Some 222) (Belt.Set.Int.maximum values);\n let values = Belt.Set.Int.remove values 222 in\n assert_option Alcotest.int (Some (-1)) (Belt.Set.Int.minimum values);\n assert_option Alcotest.int (Some 33) (Belt.Set.Int.maximum values);\n let values = Belt.Set.Int.remove values (-1) in\n assert_option Alcotest.int (Some 0) (Belt.Set.Int.minimum values);\n assert_option Alcotest.int (Some 33) (Belt.Set.Int.maximum values);\n let values = Belt.Set.Int.remove values 0 in\n let values = Belt.Set.Int.remove values 33 in\n let values = Belt.Set.Int.remove values 2 in\n let values = Belt.Set.Int.remove values 3 in\n let values = Belt.Set.Int.remove values 4 in\n let values = Belt.Set.Int.remove values 1 in\n assert_bool true (Belt.Set.Int.isEmpty values));\n test \"invariant under large removals\" (fun () ->\n let shuffled = shuffled_range 0 10_000 in\n let values = Belt.Set.Int.fromArray shuffled in\n Belt.Set.Int.checkInvariantInternal values;\n let removed = Array.sub shuffled 0 2000 in\n let remaining = Array.fold_left (fun set value -> Belt.Set.Int.remove set value) values removed in\n Belt.Set.Int.checkInvariantInternal values;\n assert_bool true (Belt.Set.Int.eq (Belt.Set.Int.union (Belt.Set.Int.fromArray removed) remaining) values));\n test \"subset eq cmp get and add identity\" (fun () ->\n let base = Belt.Set.Int.fromArray (shuffled_range 0 100) in\n let superset = Belt.Set.Int.fromArray (shuffled_range 0 200) in\n let membership_set = Belt.Set.Int.fromArray (shuffled_range 0 500) in\n let right_only = Belt.Set.Int.fromArray (shuffled_range 120 200) in\n let unioned = Belt.Set.Int.union base right_only in\n let checks = Array.map (fun value -> Belt.Set.Int.has membership_set value) (shuffled_range 200 700) in\n let present_count = Array.fold_left (fun acc present -> if present then acc + 1 else acc) 0 checks in\n assert_int 301 present_count;\n assert_bool true (Belt.Set.Int.subset base superset);\n assert_bool true (Belt.Set.Int.subset unioned superset);\n assert_same_physical unioned (Belt.Set.Int.add unioned 200);\n assert_same_physical unioned (Belt.Set.Int.add unioned 0);\n assert_bool false (Belt.Set.Int.subset (Belt.Set.Int.add unioned 201) superset);\n let equal_left = Belt.Set.Int.fromArray (shuffled_range 0 100) in\n let equal_right = Belt.Set.Int.fromArray (shuffled_range 0 100) in\n let with_extra = Belt.Set.Int.add equal_right 101 in\n let removed = Belt.Set.Int.remove equal_right 99 in\n let changed = Belt.Set.Int.add removed 101 in\n assert_bool true (Belt.Set.Int.eq equal_left equal_right);\n assert_bool false (Belt.Set.Int.eq equal_left with_extra);\n assert_bool false (Belt.Set.Int.eq removed with_extra);\n assert_bool false (Belt.Set.Int.eq equal_right changed);\n assert_bool true (Belt.Set.Int.cmp equal_left equal_right = 0);\n assert_bool true (Belt.Set.Int.cmp equal_left with_extra < 0);\n assert_bool true\n (Belt.Set.Int.cmp\n (Belt.Set.Int.fromArray (shuffled_range 0 500))\n (Belt.Set.Int.fromArray (shuffled_range 3 502))\n > 0);\n assert_option Alcotest.int (Some 30) (Belt.Set.Int.get (Belt.Set.Int.fromArray (shuffled_range 0 500)) 30);\n assert_option Alcotest.int None (Belt.Set.Int.get (Belt.Set.Int.fromArray (shuffled_range 0 500)) 3000));\n test \"mergeMany removeMany and split\" (fun () ->\n let merged = Belt.Set.Int.mergeMany Belt.Set.Int.empty (shuffled_range 0 100) in\n let trimmed = Belt.Set.Int.removeMany merged (shuffled_range 40 100) in\n let expected_trimmed = Belt.Set.Int.fromArray (inclusive_range 0 39) in\n let (left, right), present = Belt.Set.Int.split merged 40 in\n assert_bool true (Belt.Set.Int.eq merged (Belt.Set.Int.fromArray (inclusive_range 0 100)));\n assert_bool true (Belt.Set.Int.eq trimmed expected_trimmed);\n assert_bool true present;\n assert_bool true (Belt.Set.Int.eq expected_trimmed left);\n let right_without_40 = Belt.Set.Int.remove (Belt.Set.Int.removeMany merged (inclusive_range 0 39)) 40 in\n assert_bool true (Belt.Set.Int.eq right right_without_40);\n let removed_40 = Belt.Set.Int.remove merged 40 in\n let (left_missing, right_missing), present_missing = Belt.Set.Int.split removed_40 40 in\n assert_bool false present_missing;\n assert_bool true (Belt.Set.Int.eq left left_missing);\n assert_bool true (Belt.Set.Int.eq right right_missing);\n let single = Belt.Set.Int.removeMany right (inclusive_range 42 2000) in\n assert_int 1 (Belt.Set.Int.size single);\n assert_bool true (Belt.Set.Int.isEmpty (Belt.Set.Int.removeMany right (inclusive_range 0 2000))));\n test \"empty split\" (fun () ->\n let (left, right), present = Belt.Set.Int.split Belt.Set.Int.empty 0 in\n assert_bool true (Belt.Set.Int.isEmpty left);\n assert_bool true (Belt.Set.Int.isEmpty right);\n assert_bool false present);\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Set_String.ml",
"content": "let suites =\n [\n ( \"Set.String\",\n [\n test \"smoke\" (fun () ->\n assert_array Alcotest.string [| \"a\"; \"b\"; \"c\" |]\n (Belt.Set.String.toArray (Belt.Set.String.fromArray [| \"c\"; \"a\"; \"b\"; \"b\" |])));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_SortArray.ml",
"content": "let int_cmp = compare\n\nlet union xs ys =\n let output = Belt.Array.makeUninitializedUnsafe (Array.length xs + Array.length ys) 0 in\n let written = Belt.SortArray.union xs 0 (Array.length xs) ys 0 (Array.length ys) output 0 int_cmp in\n Belt.Array.truncateToLengthUnsafe output written\n\nlet intersect xs ys =\n let output = Belt.Array.makeUninitializedUnsafe (Array.length xs) 0 in\n let written = Belt.SortArray.intersect xs 0 (Array.length xs) ys 0 (Array.length ys) output 0 int_cmp in\n Belt.Array.truncateToLengthUnsafe output written\n\nlet diff xs ys =\n let output = Belt.Array.makeUninitializedUnsafe (Array.length xs) 0 in\n let written = Belt.SortArray.diff xs 0 (Array.length xs) ys 0 (Array.length ys) output 0 int_cmp in\n Belt.Array.truncateToLengthUnsafe output written\n\nlet suites =\n [\n ( \"SortArray\",\n [\n test \"union\" (fun () ->\n assert_array Alcotest.int (inclusive_range 1 13) (union (inclusive_range 1 10) (inclusive_range 3 13));\n assert_array Alcotest.int (inclusive_range 1 13) (union (inclusive_range 1 10) (inclusive_range 9 13));\n assert_array Alcotest.int (inclusive_range 8 13) (union (inclusive_range 8 10) (inclusive_range 9 13));\n assert_array Alcotest.int [| 0; 1; 2; 4; 5; 6; 7 |] (union (inclusive_range 0 2) (inclusive_range 4 7)));\n test \"intersect\" (fun () ->\n assert_array Alcotest.int (inclusive_range 3 10) (intersect (inclusive_range 1 10) (inclusive_range 3 13));\n assert_array Alcotest.int (inclusive_range 9 10) (intersect (inclusive_range 1 10) (inclusive_range 9 13));\n assert_array Alcotest.int (inclusive_range 9 10) (intersect (inclusive_range 8 10) (inclusive_range 9 13));\n assert_array Alcotest.int [||] (intersect (inclusive_range 0 2) (inclusive_range 4 7)));\n test \"diff\" (fun () ->\n assert_array Alcotest.int [| 1; 2 |] (diff (inclusive_range 1 10) (inclusive_range 3 13));\n assert_array Alcotest.int (inclusive_range 1 8) (diff (inclusive_range 1 10) (inclusive_range 9 13));\n assert_array Alcotest.int [| 8 |] (diff (inclusive_range 8 10) (inclusive_range 9 13));\n assert_array Alcotest.int [| 0; 1; 2 |] (diff (inclusive_range 0 2) (inclusive_range 4 7)));\n test \"isSorted and stableSortInPlace\" (fun () ->\n for upper = 0 to 200 do\n let values = shuffled_range 0 upper in\n Belt.SortArray.stableSortInPlaceBy values int_cmp;\n assert_bool true (Belt.SortArray.isSorted values int_cmp)\n done;\n assert_bool true (Belt.SortArray.isSorted [||] int_cmp);\n assert_bool true (Belt.SortArray.isSorted [| 0 |] int_cmp);\n assert_bool true (Belt.SortArray.isSorted [| 0; 1 |] int_cmp);\n assert_bool false (Belt.SortArray.isSorted [| 1; 0 |] int_cmp));\n test \"specialized stable sorts\" (fun () ->\n let values = shuffled_range 0 10_000 in\n let copy1 = Array.copy values in\n let copy2 = Array.copy values in\n Belt.SortArray.stableSortInPlaceBy values int_cmp;\n assert_bool true (Belt.SortArray.isSorted values int_cmp);\n Belt.SortArray.Int.stableSortInPlace copy1;\n assert_bool true (Belt.SortArray.isSorted copy1 int_cmp);\n Belt.SortArray.stableSortInPlaceBy copy2 int_cmp;\n assert_bool true (Belt.SortArray.isSorted copy2 int_cmp));\n test \"stableSortBy\" (fun () ->\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.string)\n [| (1, \"a\"); (1, \"b\"); (2, \"a\") |]\n (Belt.SortArray.stableSortBy\n [| (1, \"a\"); (1, \"b\"); (2, \"a\") |]\n (fun (left, _) (right, _) -> left - right));\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.string)\n [| (1, \"b\"); (1, \"a\"); (1, \"b\"); (2, \"a\") |]\n (Belt.SortArray.stableSortBy\n [| (1, \"b\"); (1, \"a\"); (1, \"b\"); (2, \"a\") |]\n (fun (left, _) (right, _) -> left - right));\n assert_array\n (Alcotest.pair Alcotest.int Alcotest.string)\n [| (1, \"c\"); (1, \"b\"); (1, \"a\"); (1, \"b\"); (1, \"c\"); (2, \"a\") |]\n (Belt.SortArray.stableSortBy\n [| (1, \"c\"); (1, \"b\"); (1, \"a\"); (1, \"b\"); (1, \"c\"); (2, \"a\") |]\n (fun (left, _) (right, _) -> left - right)));\n test \"binarySearch\" (fun () ->\n assert_int 2 (lnot (Belt.SortArray.binarySearchBy [| 1; 3; 5; 7 |] 4 compare));\n assert_int 4 (Belt.SortArray.binarySearchBy [| 1; 2; 3; 4; 33; 35; 36 |] 33 int_cmp);\n assert_int 0 (Belt.SortArray.binarySearchBy [| 1; 2; 3; 4; 33; 35; 36 |] 1 int_cmp);\n assert_int 1 (Belt.SortArray.binarySearchBy [| 1; 2; 3; 4; 33; 35; 36 |] 2 int_cmp);\n assert_int 2 (Belt.SortArray.binarySearchBy [| 1; 2; 3; 4; 33; 35; 36 |] 3 int_cmp);\n assert_int 3 (Belt.SortArray.binarySearchBy [| 1; 2; 3; 4; 33; 35; 36 |] 4 int_cmp);\n let values = inclusive_range 0 1000 in\n for index = 0 to 1000 do\n assert_int index (Belt.SortArray.binarySearchBy values index int_cmp)\n done;\n let evens = Array.map (fun value -> value * 2) (inclusive_range 0 2000) in\n assert_int 2001 (lnot (Belt.SortArray.binarySearchBy evens 5000 int_cmp));\n assert_int 0 (lnot (Belt.SortArray.binarySearchBy evens (-1) int_cmp));\n assert_int 0 (Belt.SortArray.binarySearchBy evens 0 int_cmp);\n assert_int 1 (lnot (Belt.SortArray.binarySearchBy evens 1 int_cmp));\n for index = 0 to 1999 do\n assert_int (index + 1) (lnot (Belt.SortArray.binarySearchBy evens ((2 * index) + 1) int_cmp))\n done);\n test \"strictlySortedLength\" (fun () ->\n let less left right = left < right in\n assert_int 0 (Belt.SortArray.strictlySortedLength [||] less);\n assert_int 1 (Belt.SortArray.strictlySortedLength [| 1 |] less);\n assert_int 1 (Belt.SortArray.strictlySortedLength [| 1; 1 |] less);\n assert_int 1 (Belt.SortArray.strictlySortedLength [| 1; 1; 2 |] less);\n assert_int 2 (Belt.SortArray.strictlySortedLength [| 1; 2 |] less);\n assert_int 4 (Belt.SortArray.strictlySortedLength [| 1; 2; 3; 4; 3 |] less);\n assert_int 1 (Belt.SortArray.strictlySortedLength [| 4; 4; 3; 2; 1 |] less);\n assert_int (-4) (Belt.SortArray.strictlySortedLength [| 4; 3; 2; 1 |] less);\n assert_int (-5) (Belt.SortArray.strictlySortedLength [| 4; 3; 2; 1; 0 |] less));\n ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_SortArray_Int.ml",
"content": "let suites =\n [\n (\"SortArray.Int\", [ test \"binarySearch\" (fun () -> assert_int 1 (Belt.SortArray.Int.binarySearch [| 1; 3; 5 |] 3)) ]);\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_SortArray_String.ml",
"content": "let suites =\n [\n ( \"SortArray.String\",\n [ test \"binarySearch\" (fun () -> assert_int 1 (Belt.SortArray.String.binarySearch [| \"a\"; \"c\"; \"e\" |] \"c\")) ] );\n ]\n"
},
{
"path": "packages/Belt/test/Test_Belt_Support.ml",
"content": "let test title fn = Alcotest.test_case title `Quick fn\nlet slow_test title fn = Alcotest.test_case title `Slow fn\nlet float = Alcotest.float 0.\nlet assert_string expected actual = Alcotest.check Alcotest.string \"should be equal\" expected actual\nlet assert_int expected actual = Alcotest.check Alcotest.int \"should be equal\" expected actual\nlet assert_float expected actual = Alcotest.check float \"should be equal\" expected actual\nlet assert_bool expected actual = Alcotest.check Alcotest.bool \"should be equal\" expected actual\nlet assert_option ty expected actual = Alcotest.check (Alcotest.option ty) \"should be equal\" expected actual\nlet assert_array ty expected actual = Alcotest.check (Alcotest.array ty) \"should be equal\" expected actual\nlet assert_list ty expected actual = Alcotest.check (Alcotest.list ty) \"should be equal\" expected actual\n\nlet assert_pair left_ty right_ty expected actual =\n Alcotest.check (Alcotest.pair left_ty right_ty) \"should be equal\" expected actual\n\nlet assert_array_unordered ty expected actual =\n let expected = Array.copy expected in\n let actual = Array.copy actual in\n Array.sort compare expected;\n Array.sort compare actual;\n Alcotest.check (Alcotest.array ty) \"should be equal\" expected actual\n\nlet assert_same_physical left right = assert_bool true (left == right)\nlet assert_not_same_physical left right = assert_bool false (left == right)\nlet assert_undefined ty expected actual = assert_option ty expected (Js.Undefined.toOption actual)\nlet assert_raises_any f = match f () with exception _ -> () | _ -> Alcotest.fail \"Expected an exception\"\n\nlet assert_raises_js_error f =\n match f () with exception Js.Exn.Error _ -> () | _ -> Alcotest.fail \"Expected Js.Exn.Error\"\n\nlet inclusive_range start finish = if finish < start then [||] else Array.init (finish - start + 1) (fun i -> start + i)\nlet reverse_inclusive_range start finish = inclusive_range start finish |> Array.to_list |> List.rev |> Array.of_list\nlet arithmetic_sum start finish = if finish < start then 0 else (start + finish) * (finish - start + 1) / 2\n\nlet shuffled_copy values =\n let values = Array.copy values in\n let state = Random.State.make [| 0x5eed; Array.length values |] in\n for i = Array.length values - 1 downto 1 do\n let j = Random.State.int state (i + 1) in\n let tmp = values.(i) in\n values.(i) <- values.(j);\n values.(j) <- tmp\n done;\n values\n\nlet shuffled_range start finish = shuffled_copy (inclusive_range start finish)\nlet shuffled_pairs start finish = Array.map (fun i -> (i, i)) (shuffled_range start finish)\n\nmodule IntCmp = Belt.Id.MakeComparable (struct\n type t = int\n\n let cmp = compare\nend)\n\nmodule IntCmpDesc = Belt.Id.MakeComparable (struct\n type t = int\n\n let cmp left right = compare right left\nend)\n\nmodule StringCmp = Belt.Id.MakeComparable (struct\n type t = string\n\n let cmp = compare\nend)\n\nmodule IntHash = Belt.Id.MakeHashable (struct\n type t = int\n\n let hash = Hashtbl.hash\n let eq = ( = )\nend)\n\nmodule CollidingIntHash = Belt.Id.MakeHashable (struct\n type t = int\n\n let hash _ = 0\n let eq = ( = )\nend)\n"
},
{
"path": "packages/Belt/test/benchmark.ml",
"content": "open Bechamel\n\n(* From our function [make_list], we make an indexed (by [args]) test. It's a list\n of tests which are applied with [args] such as:\n\n {[\n let test =\n [ make_list 0\n ; make_list 10\n ; make_list 100\n ; make_list 400\n ; make_list 1000 ]\n ]} *)\nlet static_array = [| 33 |]\n\nlet test =\n Test.make_indexed ~name:\"Belt.Array.push\" ~fmt:\"%s %d\" ~args:[ 0; 100; 500; 1000; 10000 ] (fun words ->\n Staged.stage @@ fun () -> Belt.Array.push static_array words)\n\n(* From our test, we can start to benchmark it!\n\n A benchmark is a /run/ of your test multiple times. From results given by\n [Benchmark.all], an analyse is needed to infer measures of one call of your\n test.\n\n [Bechamel] asks 3 things:\n - what you want to record (see [instances])\n - how you want to analyse (see [ols])\n - how you want to benchmark your test (see [cfg])\n\n The core of [Bechamel] (see [Bechamel.Toolkit]) has some possible measures\n such as the [monotonic-clock] to see time performances.\n\n The analyse can be OLS (Ordinary Least Square) or RANSAC. In this example, we\n use only one.\n\n Finally, to launch the benchmark, we need some others details such as:\n - should we stabilise the GC?\n - how many /run/ you want\n - the maximum of time allowed by the benchmark\n - etc.\n\n [raw_results] is what the benchmark produced. [results] is what the analyse\n can infer. The first one is used to show graphs or to let the user (with\n [Measurement_raw]) to infer something else than what [ols] did. The second is\n mostly what you want: a synthesis of /samples/. *)\n\nlet benchmark () =\n let ols = Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] in\n let instances = Toolkit.Instance.[ minor_allocated; major_allocated; monotonic_clock ] in\n let cfg = Benchmark.cfg ~limit:2000 ~quota:(Time.second 0.5) ~kde:(Some 1000) () in\n let raw_results = Benchmark.all cfg instances test in\n let results = List.map (fun instance -> Analyze.all ols instance raw_results) instances in\n let results = Analyze.merge ols instances results in\n (results, raw_results)\n\nlet () =\n List.iter\n (fun v -> Bechamel_notty.Unit.add v (Measure.unit v))\n Toolkit.Instance.[ minor_allocated; major_allocated; monotonic_clock ]\n\nlet img (window, results) = Bechamel_notty.Multiple.image_of_ols_results ~rect:window ~predictor:Measure.run results\n\nopen Notty_unix\n\nlet () =\n let window =\n match winsize Unix.stdout with Some (w, h) -> { Bechamel_notty.w; h } | None -> { Bechamel_notty.w = 80; h = 1 }\n in\n let results, _ = benchmark () in\n img (window, results) |> eol |> output_image\n"
},
{
"path": "packages/Belt/test/dune",
"content": "(library\n (name test_belt_support)\n (wrapped false)\n (modules Test_Belt_Support)\n (libraries alcotest fmt belt js))\n\n(test\n (name test)\n (modules\n (:standard \\ Test_Belt_Support))\n (flags\n (:standard -open Test_Belt_Support))\n (libraries alcotest fmt belt js test_belt_support))\n\n; (executable\n; (name benchmark)\n; (modules benchmark)\n; (public_name belt_benchmark)\n; (libraries belt bechamel-notty bechamel unix notty.unix))\n"
},
{
"path": "packages/Belt/test/test.ml",
"content": "let () =\n Alcotest.run \"Belt\"\n (Test_Belt_Int.suites @ Test_Belt_Float.suites @ Test_Belt_Option.suites @ Test_Belt_Result.suites\n @ Test_Belt_Array.suites @ Test_Belt_List.suites @ Test_Belt_Map.suites @ Test_Belt_Map_Dict.suites\n @ Test_Belt_Map_Int.suites @ Test_Belt_Map_String.suites @ Test_Belt_Set.suites @ Test_Belt_Set_Dict.suites\n @ Test_Belt_Set_Int.suites @ Test_Belt_Set_String.suites @ Test_Belt_SortArray.suites\n @ Test_Belt_SortArray_Int.suites @ Test_Belt_SortArray_String.suites @ Test_Belt_MutableMap.suites\n @ Test_Belt_MutableMap_Int.suites @ Test_Belt_MutableMap_String.suites @ Test_Belt_MutableSet.suites\n @ Test_Belt_MutableSet_Int.suites @ Test_Belt_MutableSet_String.suites @ Test_Belt_HashMap.suites\n @ Test_Belt_HashMap_Int.suites @ Test_Belt_HashMap_String.suites @ Test_Belt_HashSet_Int.suites\n @ Test_Belt_HashSet_String.suites @ Test_Belt_MutableQueue.suites @ Test_Belt_MutableStack.suites)\n"
},
{
"path": "packages/Dom/Dom.ml",
"content": "type _baseClass\ntype animation (* Web Animations API *)\n\n(* TODO: Should we bother with this indirection?\n (* core *)\n type domString = string\n type domTimestamp = float\n*)\n\n(* css *)\ntype cssStyleDeclaration\ntype cssStyleSheet\n\n(* events (early) *)\ntype 'a eventTarget_like\ntype eventTarget = _baseClass eventTarget_like\n\n(* nodes *)\ntype 'a _node\ntype 'a node_like = 'a _node eventTarget_like\ntype node = _baseClass node_like\ntype _attr\ntype attr = _attr node_like\ntype 'a _characterData\ntype 'a characterData_like = 'a _characterData node_like\ntype characterData = _baseClass characterData_like\ntype _cdataSection\ntype cdataSection = _cdataSection characterData_like\ntype _comment\ntype comment = _comment characterData_like\ntype 'a _document\ntype 'a document_like = 'a _document node_like\ntype document = _baseClass document_like\ntype _documentFragment\ntype documentFragment = _documentFragment node_like\ntype _documentType\ntype documentType = _documentType node_like\ntype domImplementation\ntype 'a _element\ntype 'a element_like = 'a _element node_like\ntype element = _baseClass element_like\ntype htmlCollection\ntype htmlFormControlsCollection\ntype htmlOptionsCollection\ntype intersectionObserver\ntype intersectionObserverEntry\ntype mutationObserver\ntype mutationRecord\ntype performanceObserver\ntype performanceObserverEntryList\ntype reportingObserver\ntype reportingObserverOptions\ntype resizeObserver\ntype resizeObserverEntry\ntype namedNodeMap\ntype nodeList\ntype radioNodeList\ntype processingInstruction\ntype _shadowRoot\ntype shadowRoot = _shadowRoot node_like\ntype _text\ntype text = _text characterData_like\n\n(* geometry *)\ntype domRect\n\n(* html *)\ntype dataTransfer (* Drag and Drop API *)\ntype domStringMap\ntype history\ntype _htmlDocument\ntype htmlDocument = _htmlDocument document_like\ntype 'a _htmlElement\ntype 'a htmlElement_like = 'a _htmlElement element_like\ntype htmlElement = _baseClass htmlElement_like\ntype _htmlAnchorElement\ntype htmlAnchorElement = _htmlAnchorElement htmlElement_like\ntype _htmlAreaElement\ntype htmlAreaElement = _htmlAreaElement htmlElement_like\ntype _htmlAudioElement\ntype htmlAudioElement = _htmlAudioElement htmlElement_like\ntype _htmlBaseElement\ntype htmlBaseElement = _htmlBaseElement htmlElement_like\ntype _htmlBodyElement\ntype htmlBodyElement = _htmlBodyElement htmlElement_like\ntype _htmlBrElement\ntype htmlBrElement = _htmlBrElement htmlElement_like\ntype _htmlButtonElement\ntype htmlButtonElement = _htmlButtonElement htmlElement_like\ntype _htmlCanvasElement\ntype htmlCanvasElement = _htmlCanvasElement htmlElement_like\ntype _htmlDataElement\ntype htmlDataElement = _htmlDataElement htmlElement_like\ntype _htmlDataListElement\ntype htmlDataListElement = _htmlDataListElement htmlElement_like\ntype _htmlDialogElement\ntype htmlDialogElement = _htmlDialogElement htmlElement_like\ntype _htmlDivElement\ntype htmlDivElement = _htmlDivElement htmlElement_like\ntype _htmlDlistElement\ntype htmlDlistElement = _htmlDlistElement htmlElement_like\ntype _htmlEmbedElement\ntype htmlEmbedElement = _htmlEmbedElement htmlElement_like\ntype _htmlFieldSetElement\ntype htmlFieldSetElement = _htmlFieldSetElement htmlElement_like\ntype _htmlFormElement\ntype htmlFormElement = _htmlFormElement htmlElement_like\ntype _htmlHeadElement\ntype htmlHeadElement = _htmlHeadElement htmlElement_like\ntype _htmlHeadingElement\ntype htmlHeadingElement = _htmlHeadingElement htmlElement_like\ntype _htmlHrElement\ntype htmlHrElement = _htmlHrElement htmlElement_like\ntype _htmlHtmlElement\ntype htmlHtmlElement = _htmlHtmlElement htmlElement_like\ntype _htmlIframeElement\ntype htmlIframeElement = _htmlIframeElement htmlElement_like\ntype _htmlImageElement\ntype htmlImageElement = _htmlImageElement htmlElement_like\ntype _htmlInputElement\ntype htmlInputElement = _htmlInputElement htmlElement_like\ntype _htmlLabelElement\ntype htmlLabelElement = _htmlLabelElement htmlElement_like\ntype _htmlLegendElement\ntype htmlLegendElement = _htmlLegendElement htmlElement_like\ntype _htmlLiElement\ntype htmlLiElement = _htmlLiElement htmlElement_like\ntype _htmlLinkElement\ntype htmlLinkElement = _htmlLinkElement htmlElement_like\ntype _htmlMapElement\ntype htmlMapElement = _htmlMapElement htmlElement_like\ntype _htmlMediaElement\ntype htmlMediaElement = _htmlMediaElement htmlElement_like\ntype _htmlMenuElement\ntype htmlMenuElement = _htmlMenuElement htmlElement_like\ntype _htmlMetaElement\ntype htmlMetaElement = _htmlMetaElement htmlElement_like\ntype _htmlMeterElement\ntype htmlMeterElement = _htmlMeterElement htmlElement_like\ntype _htmlModElement\ntype htmlModElement = _htmlModElement htmlElement_like\ntype _htmlOListElement\ntype htmlOListElement = _htmlOListElement htmlElement_like\ntype _htmlObjectElement\ntype htmlObjectElement = _htmlObjectElement htmlElement_like\ntype _htmlOptGroupElement\ntype htmlOptGroupElement = _htmlOptGroupElement htmlElement_like\ntype _htmlOptionElement\ntype htmlOptionElement = _htmlOptionElement htmlElement_like\ntype _htmlOutputElement\ntype htmlOutputElement = _htmlOutputElement htmlElement_like\ntype _htmlParagraphElement\ntype htmlParagraphElement = _htmlParagraphElement htmlElement_like\ntype _htmlParamElement\ntype htmlParamElement = _htmlParamElement htmlElement_like\ntype _htmlPreElement\ntype htmlPreElement = _htmlPreElement htmlElement_like\ntype _htmlProgressElement\ntype htmlProgressElement = _htmlProgressElement htmlElement_like\ntype _htmlQuoteElement\ntype htmlQuoteElement = _htmlQuoteElement htmlElement_like\ntype _htmlScriptElement\ntype htmlScriptElement = _htmlScriptElement htmlElement_like\ntype _htmlSelectElement\ntype htmlSelectElement = _htmlSelectElement htmlElement_like\ntype _htmlSlotElement\ntype htmlSlotElement = _htmlSlotElement htmlElement_like\ntype _htmlSourceElement\ntype htmlSourceElement = _htmlSourceElement htmlElement_like\ntype _htmlSpanElement\ntype htmlSpanElement = _htmlSpanElement htmlElement_like\ntype _htmlStyleElement\ntype htmlStyleElement = _htmlStyleElement htmlElement_like\ntype _htmlTableCaptionElement\ntype htmlTableCaptionElement = _htmlTableCaptionElement htmlElement_like\ntype _htmlTableCellElement\ntype htmlTableCellElement = _htmlTableCellElement htmlElement_like\ntype _htmlTableColElement\ntype htmlTableColElement = _htmlTableColElement htmlElement_like\ntype _htmlTableDataCellElement\ntype htmlTableDataCellElement = _htmlTableDataCellElement htmlElement_like\ntype _htmlTableElement\ntype htmlTableElement = _htmlTableElement htmlElement_like\ntype _htmlTableHeaderCellElement\ntype htmlTableHeaderCellElement = _htmlTableHeaderCellElement htmlElement_like\ntype _htmlTableRowElement\ntype htmlTableRowElement = _htmlTableRowElement htmlElement_like\ntype _htmlTableSectionElement\ntype htmlTableSectionElement = _htmlTableSectionElement htmlElement_like\ntype _htmlTextAreaElement\ntype htmlTextAreaElement = _htmlTextAreaElement htmlElement_like\ntype _htmlTimeElement\ntype htmlTimeElement = _htmlTimeElement htmlElement_like\ntype _htmlTitleElement\ntype htmlTitleElement = _htmlTitleElement htmlElement_like\ntype _htmlTrackElement\ntype htmlTrackElement = _htmlTrackElement htmlElement_like\ntype _htmlUlistElement\ntype htmlUlistElement = _htmlUlistElement htmlElement_like\ntype _htmlUnknownElement\ntype htmlUnknownElement = _htmlUnknownElement htmlElement_like\ntype _htmlVideoElement\ntype htmlVideoElement = _htmlVideoElement htmlElement_like\ntype location\ntype window\ntype _xmlDocument\ntype xmlDocument = _xmlDocument document_like\n\n(* events *)\ntype 'a event_like\ntype event = _baseClass event_like\ntype 'a _uiEvent\ntype 'a uiEvent_like = 'a _uiEvent event_like\ntype uiEvent = _baseClass uiEvent_like\ntype _animationEvent\ntype animationEvent = _animationEvent event_like\ntype _beforeUnloadEvent\ntype beforeUnloadEvent = _beforeUnloadEvent event_like\ntype _clipboardEvent\ntype clipboardEvent = _clipboardEvent event_like\ntype _closeEvent\ntype closeEvent = _closeEvent event_like\ntype _compositionEvent\ntype compositionEvent = _compositionEvent uiEvent_like\ntype _customEvent\ntype customEvent = _customEvent event_like\ntype _dragEvent\ntype dragEvent = _dragEvent event_like\ntype _errorEvent\ntype errorEvent = _errorEvent event_like\ntype _focusEvent\ntype focusEvent = _focusEvent uiEvent_like\ntype _idbVersionChangeEvent\ntype idbVersionChangeEvent = _idbVersionChangeEvent event_like\ntype _inputEvent\ntype inputEvent = _inputEvent uiEvent_like\ntype _keyboardEvent\ntype keyboardEvent = _keyboardEvent uiEvent_like\ntype 'a _mouseEvent\ntype 'a mouseEvent_like = 'a _mouseEvent uiEvent_like\ntype mouseEvent = _baseClass mouseEvent_like\ntype _pageTransitionEvent\ntype pageTransitionEvent = _pageTransitionEvent event_like\ntype _pointerEvent\ntype pointerEvent = _pointerEvent mouseEvent_like\ntype _popStateEvent\ntype popStateEvent = _popStateEvent event_like\ntype _progressEvent\ntype progressEvent = _progressEvent event_like\ntype _relatedEvent\ntype relatedEvent = _relatedEvent event_like\ntype _storageEvent\ntype storageEvent = _storageEvent event_like\ntype _svgZoomEvent\ntype svgZoomEvent = _svgZoomEvent event_like\ntype _timeEvent\ntype timeEvent = _timeEvent event_like\ntype _touchEvent\ntype touchEvent = _touchEvent uiEvent_like\ntype _trackEvent\ntype trackEvent = _trackEvent event_like\ntype _transitionEvent\ntype transitionEvent = _transitionEvent event_like\ntype _webGlContextEvent\ntype webGlContextEvent = _webGlContextEvent event_like\ntype _wheelEvent\ntype wheelEvent = _wheelEvent uiEvent_like\n\n(* ranges *)\ntype range\n\n(* selection (TODO: move out of dom?) *)\ntype selection\n\n(* sets *)\ntype domTokenList\ntype domSettableTokenList\n\n(* traversal *)\ntype nodeFilter = {\n acceptNode : element -> int; (* return type should be NodeFilter.action, but that would create a cycle *)\n}\n\ntype nodeIterator\ntype treeWalker\n\n(* SVG *)\ntype svgRect\ntype svgPoint\n\n(* special *)\ntype eventPointerId\n\nmodule Storage = Dom_storage\n"
},
{
"path": "packages/Dom/Dom_storage.ml",
"content": "type t\n\nexternal getItem : string -> string option = \"getItem\" [@@mel.send.pipe: t] [@@mel.return null_to_opt]\nexternal setItem : string -> string -> unit = \"setItem\" [@@mel.send.pipe: t]\nexternal removeItem : string -> unit = \"removeItem\" [@@mel.send.pipe: t]\nexternal clear : unit = \"clear\" [@@mel.send.pipe: t]\nexternal key : int -> string option = \"key\" [@@mel.send.pipe: t] [@@mel.return null_to_opt]\nexternal length : t -> int = \"length\" [@@mel.get]\n(* external localStorage : t = \"localStorage\" *)\n(* external sessionStorage : t = \"sessionStorage\" *)\n"
},
{
"path": "packages/Dom/dune",
"content": "(library\n (name dom)\n (public_name server-reason-react.dom)\n (preprocess\n (pps melange_native_ppx)))\n"
},
{
"path": "packages/Js/lib/Js.ml",
"content": "(** The Js equivalent library (very unsafe) *)\n\ninclude Js_internal\n\ntype 'a t = < .. > as 'a\n\nmodule Fn = struct\n type 'a arity0 = { i0 : unit -> 'a [@internal] }\n type 'a arity1 = { i1 : 'a [@internal] }\n type 'a arity2 = { i2 : 'a [@internal] }\n type 'a arity3 = { i3 : 'a [@internal] }\n type 'a arity4 = { i4 : 'a [@internal] }\n type 'a arity5 = { i5 : 'a [@internal] }\n type 'a arity6 = { i6 : 'a [@internal] }\n type 'a arity7 = { i7 : 'a [@internal] }\n type 'a arity8 = { i8 : 'a [@internal] }\n type 'a arity9 = { i9 : 'a [@internal] }\n type 'a arity10 = { i10 : 'a [@internal] }\n type 'a arity11 = { i11 : 'a [@internal] }\n type 'a arity12 = { i12 : 'a [@internal] }\n type 'a arity13 = { i13 : 'a [@internal] }\n type 'a arity14 = { i14 : 'a [@internal] }\n type 'a arity15 = { i15 : 'a [@internal] }\n type 'a arity16 = { i16 : 'a [@internal] }\n type 'a arity17 = { i17 : 'a [@internal] }\n type 'a arity18 = { i18 : 'a [@internal] }\n type 'a arity19 = { i19 : 'a [@internal] }\n type 'a arity20 = { i20 : 'a [@internal] }\n type 'a arity21 = { i21 : 'a [@internal] }\n type 'a arity22 = { i22 : 'a [@internal] }\nend\n\n(**/**)\n\n(* module MapperRt = Js_mapperRt *)\nmodule Internal = struct\n (* open Fn *)\n\n (* Use opaque instead of [._n] to prevent some optimizations happening *)\nend\n\n(**/**)\n\ntype +'a null = 'a Js_internal.null\ntype +'a undefined = 'a Js_internal.undefined\ntype +'a nullable = 'a Js_internal.nullable\n\nexternal toOption : 'a null -> 'a option = \"%identity\"\nexternal nullToOption : 'a null -> 'a option = \"%identity\"\nexternal undefinedToOption : 'a null -> 'a option = \"%identity\"\nexternal fromOpt : 'a option -> 'a undefined = \"%identity\"\n\n(** The same as [empty] {!Js.Undefined} will be compiled as [undefined]*)\nlet undefined = None\n\n(** The same as [empty] in {!Js.Null} will be compiled as [null]*)\nlet null = None\n\nlet empty = None\n\ntype (+'a, +'e) promise\n\n(* external eqNull : 'a -> 'a null -> bool = \"%bs_equal_null\" *)\n(* let eqNull : 'a -> 'a null -> bool = fun x -> x == None *)\n\n(* external eqUndefined : 'a -> 'a undefined -> bool = \"%bs_equal_undefined\" *)\n(* let eqUndefined : 'a -> 'a undefined -> bool = function\n | Some _ -> false\n | None -> true *)\n\n(* external eqNullable : 'a -> 'a nullable -> bool = \"%bs_equal_nullable\" *)\n(* let eqNullable : 'a -> 'a nullable -> bool = function\n | Some _ -> false\n | None -> true *)\n\n(** [typeof x] will be compiled as [typeof x] in JS Please consider functions in {!Types} for a type safe way of\n reflection *)\nlet typeof _ = notImplemented \"Js\" \"typeof\"\n\n(** {4 operators}*)\n\n(* external unsafe_lt : 'a -> 'a -> bool = \"#unsafe_lt\" *)\n(** [unsafe_lt a b] will be compiled as [a < b]. It is marked as unsafe, since it is impossible to give a proper\n semantics for comparision which applies to any type *)\n\n(* external unsafe_le : 'a -> 'a -> bool = \"#unsafe_le\" *)\n(** [unsafe_le a b] will be compiled as [a <= b]. See also {!unsafe_lt} *)\n\n(* external unsafe_gt : 'a -> 'a -> bool = \"#unsafe_gt\" *)\n(** [unsafe_gt a b] will be compiled as [a > b]. See also {!unsafe_lt} *)\n\n(* external unsafe_ge : 'a -> 'a -> bool = \"#unsafe_ge\" *)\n(** [unsafe_ge a b] will be compiled as [a >= b]. See also {!unsafe_lt} *)\n\n(** {12 nested modules}*)\n\nmodule Null = Js_null\nmodule Undefined = Js_undefined\nmodule Nullable = Js_nullable\nmodule Null_undefined = Nullable\nmodule Exn = Js_exn\nmodule Array = Js_array\nmodule Re = Js_re\nmodule String = Js_string\nmodule Promise = Js_promise\nmodule Date = Js_date\nmodule Dict = Js_dict\nmodule Global = Js_global\nmodule Types = Js_types\nmodule Json = Js_json\nmodule Math = Js_math\nmodule Obj = Js_obj\nmodule Typed_array = Js_typed_array\nmodule TypedArray2 = Js_typed_array2\nmodule Float = Js_float\nmodule Int = Js_int\nmodule Bigint = Js_bigint\nmodule Vector = Js_vector\nmodule Console = Js_console\n\nlet log = Console.log\nlet log2 = Console.log2\nlet log3 = Console.log3\nlet log4 = Console.log4\nlet logMany = Console.logMany\n\nmodule Set = Js_set\nmodule WeakSet = Js_weakset\nmodule Map = Js_map\nmodule WeakMap = Js_weakmap\nmodule FormData = Js_formdata\n"
},
{
"path": "packages/Js/lib/Js.mli",
"content": "(** The Js equivalent library (very unsafe) *)\n\ninclude module type of Js_internal\n\ntype 'a t = 'a constraint 'a = < .. >\n\nmodule Fn : sig\n type 'a arity0 = { i0 : unit -> 'a }\n type 'a arity1 = { i1 : 'a }\n type 'a arity2 = { i2 : 'a }\n type 'a arity3 = { i3 : 'a }\n type 'a arity4 = { i4 : 'a }\n type 'a arity5 = { i5 : 'a }\n type 'a arity6 = { i6 : 'a }\n type 'a arity7 = { i7 : 'a }\n type 'a arity8 = { i8 : 'a }\n type 'a arity9 = { i9 : 'a }\n type 'a arity10 = { i10 : 'a }\n type 'a arity11 = { i11 : 'a }\n type 'a arity12 = { i12 : 'a }\n type 'a arity13 = { i13 : 'a }\n type 'a arity14 = { i14 : 'a }\n type 'a arity15 = { i15 : 'a }\n type 'a arity16 = { i16 : 'a }\n type 'a arity17 = { i17 : 'a }\n type 'a arity18 = { i18 : 'a }\n type 'a arity19 = { i19 : 'a }\n type 'a arity20 = { i20 : 'a }\n type 'a arity21 = { i21 : 'a }\n type 'a arity22 = { i22 : 'a }\nend\n\nexternal toOption : 'a null -> 'a option = \"%identity\"\nexternal nullToOption : 'a null -> 'a option = \"%identity\"\nexternal undefinedToOption : 'a null -> 'a option = \"%identity\"\nexternal fromOpt : 'a option -> 'a undefined = \"%identity\"\nval undefined : 'a option\nval null : 'a option\nval empty : 'a option\n\ntype (+'a, +'e) promise\n\nval typeof : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nmodule Null : module type of Js_null\nmodule Undefined : module type of Js_undefined\nmodule Nullable : module type of Js_nullable\nmodule Null_undefined = Nullable\nmodule Exn : module type of Js_exn\nmodule Array : module type of Js_array\nmodule Re : module type of Js_re\nmodule String : module type of Js_string\nmodule Promise : module type of Js_promise\nmodule Date : module type of Js_date\nmodule Dict : module type of Js_dict\nmodule Global : module type of Js_global\nmodule Types : module type of Js_types\nmodule Json : module type of Js_json\nmodule Math : module type of Js_math\nmodule Obj : module type of Js_obj\nmodule Typed_array : module type of Js_typed_array\nmodule TypedArray2 : module type of Js_typed_array2\nmodule Float : module type of Js_float\nmodule Int : module type of Js_int\nmodule Bigint : module type of Js_bigint\nmodule Vector : module type of Js_vector\nmodule Console : module type of Js_console\n\nval log : string -> unit\nval log2 : string -> string -> unit\nval log3 : string -> string -> string -> unit\nval log4 : string -> string -> string -> string -> unit\nval logMany : string array -> unit\n\nmodule Set : module type of Js_set\nmodule WeakSet : module type of Js_weakset\nmodule Map : module type of Js_map\nmodule WeakMap : module type of Js_weakmap\nmodule FormData : module type of Js_formdata\n"
},
{
"path": "packages/Js/lib/Js_array.ml",
"content": "(** JavaScript Array API *)\n\ntype 'a t = 'a array\ntype 'a array_like\n\nlet from _ = Js_internal.notImplemented \"Js.Array\" \"from\"\nlet fromMap _ ~f:_ = Js_internal.notImplemented \"Js.Array\" \"fromMap\"\n\n(* This doesn't behave the same as melange-js, since it's a runtime check so lists are represented as arrays in the runtime: isArray([1, 2]) == true *)\nlet isArray (_arr : 'a) = true\nlet length arr = Stdlib.Array.length arr\n\n(* Mutator functions *)\nlet copyWithin ~to_:_ ?start:_ ?end_:_ _ = Js_internal.notImplemented \"Js.Array\" \"copyWithin\"\nlet fill ~value:_ ?start:_ ?end_:_ _ = Js_internal.notImplemented \"Js.Array\" \"fill\"\nlet pop _ = Js_internal.notImplemented \"Js.Array\" \"pop\"\nlet push ~value:_ _ = Js_internal.notImplemented \"Js.Array\" \"push\"\nlet pushMany ~values:_ _ = Js_internal.notImplemented \"Js.Array\" \"pushMany\"\nlet reverseInPlace _ = Js_internal.notImplemented \"Js.Array\" \"reverseInPlace\"\nlet sortInPlace _ = Js_internal.notImplemented \"Js.Array\" \"sortInPlace\"\nlet sortInPlaceWith ~f:_ _ = Js_internal.notImplemented \"Js.Array\" \"sortInPlaceWith\"\nlet spliceInPlace ~start:_ ~remove:_ ~add:_ _ = Js_internal.notImplemented \"Js.Array\" \"spliceInPlace\"\nlet removeFromInPlace ~start:_ _ = Js_internal.notImplemented \"Js.Array\" \"removeFromInPlace\"\nlet removeCountInPlace ~start:_ ~count:_ _ = Js_internal.notImplemented \"Js.Array\" \"removeCountInPlace\"\nlet shift _ = Js_internal.notImplemented \"Js.Array\" \"shift\"\nlet unshift ~value:_ _ = Js_internal.notImplemented \"Js.Array\" \"unshift\"\nlet unshiftMany ~values:_ _ = Js_internal.notImplemented \"Js.Array\" \"unshiftMany\"\n\n(* Accessor functions *)\nlet concat ~other:second first = Stdlib.Array.append first second\nlet concatMany ~arrays arr = Stdlib.Array.concat (arr :: Stdlib.Array.to_list arrays)\nlet includes ~value arr = Stdlib.Array.exists (fun x -> x = value) arr\n\nlet indexOf ~value ?start arr =\n let rec aux idx = if idx >= Stdlib.Array.length arr then -1 else if arr.(idx) = value then idx else aux (idx + 1) in\n match start with None -> aux 0 | Some from -> if from < 0 || from >= Stdlib.Array.length arr then -1 else aux from\n\nlet join ?sep arr =\n (* js bindings can really take in `'a array`, while native is constrained to `string array` *)\n match sep with\n | None -> Stdlib.Array.to_list arr |> String.concat \",\"\n | Some sep -> Stdlib.Array.to_list arr |> String.concat sep\n\nlet lastIndexOf ~value arr =\n let rec aux idx = if idx < 0 then -1 else if arr.(idx) = value then idx else aux (idx - 1) in\n aux (Stdlib.Array.length arr - 1)\n\nlet lastIndexOfFrom ~value ~start arr =\n let rec aux idx = if idx < 0 then -1 else if arr.(idx) = value then idx else aux (idx - 1) in\n if start < 0 || start >= Stdlib.Array.length arr then -1 else aux start\n\nlet slice ?start ?end_ arr =\n let len = Stdlib.Array.length arr in\n let start = match start with None -> 0 | Some s -> s in\n let end_ = match end_ with None -> Stdlib.Array.length arr | Some e -> e in\n let s = max 0 (if start < 0 then len + start else start) in\n let e = min len (if end_ < 0 then len + end_ else end_) in\n if s >= e then [||] else Stdlib.Array.sub arr s (e - s)\n\nlet copy = Stdlib.Array.copy\nlet toString _ = Js_internal.notImplemented \"Js.Array\" \"toString\"\nlet toLocaleString _ = Js_internal.notImplemented \"Js.Array\" \"toLocaleString\"\n\n(* Iteration functions *)\nlet everyi ~f arr =\n let len = Stdlib.Array.length arr in\n let rec aux idx = if idx >= len then true else if f arr.(idx) idx then aux (idx + 1) else false in\n aux 0\n\nlet every ~f arr =\n let len = Stdlib.Array.length arr in\n let rec aux idx = if idx >= len then true else if f arr.(idx) then aux (idx + 1) else false in\n aux 0\n\nlet filter ~f arr = arr |> Stdlib.Array.to_list |> List.filter f |> Stdlib.Array.of_list\nlet filteri ~f arr = arr |> Stdlib.Array.to_list |> List.filteri (fun i a -> f a i) |> Stdlib.Array.of_list\n\nlet findi ~f arr =\n let len = Stdlib.Array.length arr in\n let rec aux idx = if idx >= len then None else if f arr.(idx) idx then Some arr.(idx) else aux (idx + 1) in\n aux 0\n\nlet find ~f arr =\n let len = Stdlib.Array.length arr in\n let rec aux idx = if idx >= len then None else if f arr.(idx) then Some arr.(idx) else aux (idx + 1) in\n aux 0\n\nlet findIndexi ~f arr =\n let len = Stdlib.Array.length arr in\n let rec aux idx = if idx >= len then -1 else if f arr.(idx) idx then idx else aux (idx + 1) in\n aux 0\n\nlet findIndex ~f arr =\n let len = Stdlib.Array.length arr in\n let rec aux idx = if idx >= len then -1 else if f arr.(idx) then idx else aux (idx + 1) in\n aux 0\n\nlet forEach ~f arr = Stdlib.Array.iter f arr\nlet forEachi ~f arr = Stdlib.Array.iteri (fun i a -> f a i) arr\nlet map ~f arr = Stdlib.Array.map f arr\nlet mapi ~f arr = Stdlib.Array.mapi (fun i a -> f a i) arr\n\nlet reduce ~f ~init arr =\n let r = ref init in\n for i = 0 to length arr - 1 do\n r := f !r (Stdlib.Array.unsafe_get arr i)\n done;\n !r\n\nlet reducei ~f ~init arr =\n let r = ref init in\n for i = 0 to length arr - 1 do\n r := f !r (Stdlib.Array.unsafe_get arr i) i\n done;\n !r\n\nlet reduceRight ~f ~init arr =\n let r = ref init in\n for i = length arr - 1 downto 0 do\n r := f !r (Stdlib.Array.unsafe_get arr i)\n done;\n !r\n\nlet reduceRighti ~f ~init arr =\n let r = ref init in\n for i = length arr - 1 downto 0 do\n r := f !r (Stdlib.Array.unsafe_get arr i) i\n done;\n !r\n\nlet some ~f arr =\n let n = Stdlib.Array.length arr in\n let rec loop i = if i = n then false else if f (Stdlib.Array.unsafe_get arr i) then true else loop (succ i) in\n loop 0\n\nlet somei ~f arr =\n let n = Stdlib.Array.length arr in\n let rec loop i = if i = n then false else if f (Stdlib.Array.unsafe_get arr i) i then true else loop (succ i) in\n loop 0\n\nlet unsafe_get arr idx = Stdlib.Array.unsafe_get arr idx\nlet unsafe_set arr idx item = Stdlib.Array.unsafe_set arr idx item\n"
},
{
"path": "packages/Js/lib/Js_array.mli",
"content": "(** JavaScript Array API *)\n\ntype 'a t = 'a array\ntype 'a array_like\n\nval from : 'a array_like -> 'a t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval fromMap : 'a array_like -> f:('a -> 'b) -> 'b t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval isArray : 'a array -> bool\nval length : 'a array -> int\n\nval copyWithin : to_:int -> ?start:int -> ?end_:int -> 'a t -> 'a t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval fill : value:'a -> ?start:int -> ?end_:int -> 'a t -> 'a t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval pop : 'a t -> 'a Js_internal.nullable\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval push : value:'a -> 'a t -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval pushMany : values:'a t -> 'a t -> int\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval reverseInPlace : 'a t -> 'a t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval shift : 'a t -> 'a option [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval sortInPlace : 'a t -> 'a t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval sortInPlaceWith : f:('a -> 'a -> int) -> 'a t -> 'a t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval spliceInPlace : start:int -> remove:int -> add:'a t -> 'a t -> 'a t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval removeFromInPlace : start:int -> 'a t -> 'a t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval removeCountInPlace : start:int -> count:int -> 'a t -> 'a t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval unshift : value:'a -> 'a t -> int\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval unshiftMany : values:'a t -> 'a t -> int\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval concat : other:'a t -> 'a t -> 'a t\nval concatMany : arrays:'a t t -> 'a t -> 'a t\nval includes : value:'a -> 'a t -> bool\nval indexOf : value:'a -> ?start:int -> 'a t -> int\nval join : ?sep:string -> string t -> string\nval lastIndexOf : value:'a -> 'a t -> int\nval lastIndexOfFrom : value:'a -> start:int -> 'a t -> int\nval slice : ?start:int -> ?end_:int -> 'a t -> 'a t\nval copy : 'a array -> 'a array\nval toString : 'a t -> string [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval toLocaleString : 'a t -> string\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval everyi : f:('a -> int -> bool) -> 'a t -> bool\nval every : f:('a -> bool) -> 'a t -> bool\nval filter : f:('a -> bool) -> 'a t -> 'a t\nval filteri : f:('a -> int -> bool) -> 'a t -> 'a t\nval findi : f:('a -> int -> bool) -> 'a t -> 'a Js_internal.nullable\nval find : f:('a -> bool) -> 'a t -> 'a Js_internal.nullable\nval findIndexi : f:('a -> int -> bool) -> 'a t -> int\nval findIndex : f:('a -> bool) -> 'a t -> int\nval forEach : f:('a -> unit) -> 'a t -> unit\nval forEachi : f:('a -> int -> unit) -> 'a t -> unit\nval map : f:('a -> 'b) -> 'a t -> 'b t\nval mapi : f:('a -> int -> 'b) -> 'a t -> 'b t\nval reduce : f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b\nval reducei : f:('b -> 'a -> int -> 'b) -> init:'b -> 'a t -> 'b\nval reduceRight : f:('b -> 'a -> 'b) -> init:'b -> 'a t -> 'b\nval reduceRighti : f:('b -> 'a -> int -> 'b) -> init:'b -> 'a t -> 'b\nval some : f:('a -> bool) -> 'a t -> bool\nval somei : f:('a -> int -> bool) -> 'a t -> bool\nval unsafe_get : 'a array -> int -> 'a\nval unsafe_set : 'a array -> int -> 'a -> unit\n"
},
{
"path": "packages/Js/lib/Js_bigint.ml",
"content": "(** Provide utilities for bigint *)\n\ntype t = Z.t\n\n(* {1 Constructors} *)\n\nlet of_int = Z.of_int\nlet of_int64 = Z.of_int64\n\n(* Helper to check if a character is whitespace *)\nlet is_whitespace c = c = ' ' || c = '\\t' || c = '\\n' || c = '\\r'\n\n(* Trim whitespace from both ends of a string *)\nlet trim s =\n let len = String.length s in\n let i = ref 0 in\n while !i < len && is_whitespace (String.get s !i) do\n incr i\n done;\n let j = ref (len - 1) in\n while !j >= !i && is_whitespace (String.get s !j) do\n decr j\n done;\n if !i > !j then \"\" else String.sub s !i (!j - !i + 1)\n\n(* Check if string contains only valid chars for given base, after sign *)\nlet is_valid_for_base s base start_idx =\n let valid_char c =\n match base with\n | 2 -> c = '0' || c = '1'\n | 8 -> c >= '0' && c <= '7'\n | 10 -> c >= '0' && c <= '9'\n | 16 -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')\n | _ -> false\n in\n let len = String.length s in\n if start_idx >= len then false\n else\n let result = ref true in\n for i = start_idx to len - 1 do\n if not (valid_char (String.get s i)) then result := false\n done;\n !result\n\n(* Parse string with JS BigInt semantics (strict version that raises) *)\nlet of_string_exn s =\n let s = trim s in\n let len = String.length s in\n if len = 0 then failwith \"BigInt: cannot convert empty string\";\n (* Check for sign-only strings *)\n if s = \"+\" || s = \"-\" then failwith \"BigInt: cannot convert sign-only string\";\n (* Check for null character *)\n if String.contains s '\\x00' then failwith \"BigInt: invalid character\";\n (* Check for decimal point or scientific notation *)\n if String.contains s '.' then failwith \"BigInt: cannot have decimal point\";\n if String.contains s 'e' || String.contains s 'E' then failwith \"BigInt: cannot use scientific notation\";\n (* Determine sign and starting position *)\n let negative = len > 0 && String.get s 0 = '-' in\n let has_sign = len > 0 && (String.get s 0 = '-' || String.get s 0 = '+') in\n let start = if has_sign then 1 else 0 in\n if start >= len then failwith \"BigInt: invalid format\";\n (* Check for radix prefix *)\n let has_prefix =\n len > start + 1\n && String.get s start = '0'\n &&\n let c = String.get s (start + 1) in\n c = 'x' || c = 'X' || c = 'b' || c = 'B' || c = 'o' || c = 'O'\n in\n let base, num_start =\n if has_prefix then\n let c = String.get s (start + 1) in\n match c with\n | 'x' | 'X' -> (16, start + 2)\n | 'b' | 'B' -> (2, start + 2)\n | 'o' | 'O' -> (8, start + 2)\n | _ -> (10, start)\n else (10, start)\n in\n (* Validate the numeric part *)\n if num_start >= len then failwith \"BigInt: missing digits after prefix\";\n if not (is_valid_for_base s base num_start) then failwith \"BigInt: invalid characters for base\";\n (* Parse the number *)\n let num_str = String.sub s num_start (len - num_start) in\n let abs_value = Z.of_string_base base num_str in\n if negative then Z.neg abs_value else abs_value\n\n(* Parse string with JS BigInt semantics (lenient version) *)\nlet of_string s =\n let s = trim s in\n if String.length s = 0 then Z.zero\n else\n try of_string_exn s\n with Failure _ ->\n (* For the lenient version, invalid strings just return 0 *)\n Z.zero\n\n(* {1 Conversions} *)\n\n(* Convert a digit to its character representation for bases up to 36 *)\nlet digit_to_char d = if d < 10 then Char.chr (d + Char.code '0') else Char.chr (d - 10 + Char.code 'a')\n\n(* Convert BigInt to string with given radix *)\nlet to_string ?(radix = 10) n =\n if radix < 2 || radix > 36 then invalid_arg \"to_string: radix must be between 2 and 36\";\n if Z.equal n Z.zero then \"0\"\n else\n let negative = Z.sign n < 0 in\n let n = Z.abs n in\n let radix_z = Z.of_int radix in\n let buf = Buffer.create 64 in\n let rec loop n =\n if Z.equal n Z.zero then ()\n else\n let q, r = Z.div_rem n radix_z in\n Buffer.add_char buf (digit_to_char (Z.to_int r));\n loop q\n in\n loop n;\n if negative then Buffer.add_char buf '-';\n (* Reverse the buffer contents *)\n let s = Buffer.contents buf in\n let len = String.length s in\n String.init len (fun i -> String.get s (len - 1 - i))\n\nlet toString = to_string ~radix:10\nlet to_float = Z.to_float\n\n(* {1 Arithmetic operations} *)\n\nlet neg = Z.neg\nlet abs = Z.abs\nlet add = Z.add\nlet sub = Z.sub\nlet mul = Z.mul\n\n(* Division truncating toward zero - this is what Z.div does *)\nlet div a b = if Z.equal b Z.zero then raise Division_by_zero else Z.div a b\n\n(* Remainder with sign following dividend - this is what Z.rem does *)\nlet rem a b = if Z.equal b Z.zero then raise Division_by_zero else Z.rem a b\n\n(* Power - raises on negative exponent *)\nlet pow base exp =\n if Z.sign exp < 0 then invalid_arg \"BigInt.pow: negative exponent\"\n else\n let exp_int = Z.to_int exp in\n Z.pow base exp_int\n\n(* {1 Bitwise operations} *)\n\nlet logand = Z.logand\nlet logor = Z.logor\nlet logxor = Z.logxor\nlet lognot = Z.lognot\nlet shift_left = Z.shift_left\nlet shift_right = Z.shift_right\n\n(* {1 Comparison operations} *)\n\nlet compare a b =\n let c = Z.compare a b in\n if c < 0 then -1 else if c > 0 then 1 else 0\n\nlet equal = Z.equal\nlet lt a b = Z.compare a b < 0\nlet le a b = Z.compare a b <= 0\nlet gt a b = Z.compare a b > 0\nlet ge a b = Z.compare a b >= 0\n\n(* {1 Bit width conversion} *)\n\n(* asUintN: wrap to unsigned n-bit integer *)\nlet as_uint_n bits x =\n if bits = 0 then Z.zero\n else\n let modulus = Z.shift_left Z.one bits in\n Z.erem x modulus\n\n(* asIntN: wrap to signed n-bit integer *)\nlet as_int_n bits x =\n if bits = 0 then Z.zero\n else\n let modulus = Z.shift_left Z.one bits in\n let half = Z.shift_left Z.one (bits - 1) in\n let wrapped = Z.erem x modulus in\n (* If wrapped >= 2^(bits-1), subtract 2^bits to get negative *)\n if Z.compare wrapped half >= 0 then Z.sub wrapped modulus else wrapped\n"
},
{
"path": "packages/Js/lib/Js_bigint.mli",
"content": "(** Provide utilities for bigint *)\n\ntype t\n(** The BigInt type, representing arbitrary precision integers *)\n\n(** {1 Constructors} *)\n\nval of_int : int -> t\n(** [of_int n] creates a BigInt from an OCaml integer *)\n\nval of_int64 : int64 -> t\n(** [of_int64 n] creates a BigInt from an OCaml int64 *)\n\nval of_string : string -> t\n(** [of_string s] creates a BigInt from a string representation. Supports decimal, hexadecimal (0x prefix), binary (0b\n prefix), and octal (0o prefix) formats. Whitespace is trimmed. Empty string returns 0. Invalid strings return 0. *)\n\nval of_string_exn : string -> t\n(** [of_string_exn s] creates a BigInt from a string representation. Like [of_string] but raises [Failure] on invalid\n input. *)\n\n(** {1 Conversions} *)\n\nval to_string : ?radix:int -> t -> string\n(** [to_string ?radix bigint] returns a string representation. [radix] can be 2-36 (default 10). *)\n\nval toString : t -> string\n(** Alias for [to_string] with default radix 10 *)\n\nval to_float : t -> float\n(** [to_float bigint] converts to float. May lose precision for large values. *)\n\n(** {1 Arithmetic operations} *)\n\nval neg : t -> t\n(** [neg x] returns the negation of [x] *)\n\nval abs : t -> t\n(** [abs x] returns the absolute value of [x] *)\n\nval add : t -> t -> t\n(** [add x y] returns [x + y] *)\n\nval sub : t -> t -> t\n(** [sub x y] returns [x - y] *)\n\nval mul : t -> t -> t\n(** [mul x y] returns [x * y] *)\n\nval div : t -> t -> t\n(** [div x y] returns [x / y], truncated toward zero. Raises [Division_by_zero] if [y] is zero. *)\n\nval rem : t -> t -> t\n(** [rem x y] returns the remainder of [x / y]. The sign follows the dividend (JavaScript semantics). Raises\n [Division_by_zero] if [y] is zero. *)\n\nval pow : t -> t -> t\n(** [pow base exp] returns [base] raised to the power [exp]. Raises [Invalid_argument] if [exp] is negative. *)\n\n(** {1 Bitwise operations} *)\n\nval logand : t -> t -> t\n(** [logand x y] returns the bitwise AND of [x] and [y] *)\n\nval logor : t -> t -> t\n(** [logor x y] returns the bitwise OR of [x] and [y] *)\n\nval logxor : t -> t -> t\n(** [logxor x y] returns the bitwise XOR of [x] and [y] *)\n\nval lognot : t -> t\n(** [lognot x] returns the bitwise NOT of [x] (two's complement) *)\n\nval shift_left : t -> int -> t\n(** [shift_left x n] returns [x] shifted left by [n] bits *)\n\nval shift_right : t -> int -> t\n(** [shift_right x n] returns [x] arithmetically shifted right by [n] bits. Sign-extending for negative numbers. *)\n\n(** {1 Comparison operations} *)\n\nval compare : t -> t -> int\n(** [compare x y] returns -1 if [x < y], 0 if [x = y], 1 if [x > y] *)\n\nval equal : t -> t -> bool\n(** [equal x y] returns [true] if [x = y] *)\n\nval lt : t -> t -> bool\n(** [lt x y] returns [true] if [x < y] *)\n\nval le : t -> t -> bool\n(** [le x y] returns [true] if [x <= y] *)\n\nval gt : t -> t -> bool\n(** [gt x y] returns [true] if [x > y] *)\n\nval ge : t -> t -> bool\n(** [ge x y] returns [true] if [x >= y] *)\n\n(** {1 Bit width conversion} *)\n\nval as_int_n : int -> t -> t\n(** [as_int_n bits x] wraps [x] to a signed integer of [bits] bits. Equivalent to JavaScript's BigInt.asIntN. *)\n\nval as_uint_n : int -> t -> t\n(** [as_uint_n bits x] wraps [x] to an unsigned integer of [bits] bits. Equivalent to JavaScript's BigInt.asUintN. *)\n"
},
{
"path": "packages/Js/lib/Js_console.ml",
"content": "let log _ = ()\nlet log2 _ _ = ()\nlet log3 _ _ _ = ()\nlet log4 _ _ _ _ = ()\nlet logMany _arr = ()\nlet info = log\nlet info2 = log2\nlet info3 = log3\nlet info4 = log4\nlet infoMany = logMany\nlet error = log\nlet error2 = log2\nlet error3 = log3\nlet error4 = log4\nlet errorMany = logMany\nlet warn = log\nlet warn2 = log2\nlet warn3 = log3\nlet warn4 = log4\nlet warnMany = logMany\nlet trace () = ()\nlet timeStart _ = ()\nlet timeEnd _ = ()\n"
},
{
"path": "packages/Js/lib/Js_console.mli",
"content": "val log : string -> unit\nval log2 : string -> string -> unit\nval log3 : string -> string -> string -> unit\nval log4 : string -> string -> string -> string -> unit\nval logMany : string array -> unit\nval info : string -> unit\nval info2 : string -> string -> unit\nval info3 : string -> string -> string -> unit\nval info4 : string -> string -> string -> string -> unit\nval infoMany : string array -> unit\nval error : string -> unit\nval error2 : string -> string -> unit\nval error3 : string -> string -> string -> unit\nval error4 : string -> string -> string -> string -> unit\nval errorMany : string array -> unit\nval warn : string -> unit\nval warn2 : string -> string -> unit\nval warn3 : string -> string -> string -> unit\nval warn4 : string -> string -> string -> string -> unit\nval warnMany : string array -> unit\nval trace : unit -> unit [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval timeStart : 'a -> unit [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval timeEnd : 'a -> unit [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n"
},
{
"path": "packages/Js/lib/Js_date.ml",
"content": "type t = float\n\nlet ms_per_second = 1000.\nlet ms_per_minute = 60000.\nlet ms_per_hour = 3600000.\nlet ms_per_day = 86400000.\nlet max_time_value = 8.64e15\nlet is_valid_time t = (not (Float.is_nan t)) && Float.abs t <= max_time_value\nlet day t = Float.floor (t /. ms_per_day)\n\nlet time_within_day t =\n let r = Float.rem t ms_per_day in\n if r < 0. then r +. ms_per_day else r\n\nlet days_in_year y =\n if Float.rem y 4. <> 0. then 365\n else if Float.rem y 100. <> 0. then 366\n else if Float.rem y 400. <> 0. then 365\n else 366\n\nlet day_from_year y =\n let y = y -. 1970. in\n (365. *. y) +. Float.floor ((y +. 1.) /. 4.) -. Float.floor ((y +. 69.) /. 100.) +. Float.floor ((y +. 369.) /. 400.)\n\nlet year_from_time t =\n if Float.is_nan t then nan\n else\n let d = day t in\n let estimate = 1970. +. Float.floor (d /. 365.2425) in\n let rec search lo hi =\n if lo >= hi then lo\n else\n let mid = Float.floor ((lo +. hi +. 1.) /. 2.) in\n if day_from_year mid <= d then search mid hi else search lo (mid -. 1.)\n in\n search (estimate -. 2.) (estimate +. 2.)\n\nlet in_leap_year t = days_in_year (year_from_time t) = 366\n\nlet day_within_year t =\n let d = day t in\n let y = year_from_time t in\n d -. day_from_year y\n\nlet month_start_days = [| 0; 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334; 365 |]\nlet month_start_days_leap = [| 0; 31; 60; 91; 121; 152; 182; 213; 244; 274; 305; 335; 366 |]\n\nlet month_from_time t =\n if Float.is_nan t then nan\n else\n let d = int_of_float (day_within_year t) in\n let table = if in_leap_year t then month_start_days_leap else month_start_days in\n let rec find_month m = if m >= 11 then 11 else if d < table.(m + 1) then m else find_month (m + 1) in\n Float.of_int (find_month 0)\n\nlet date_from_time t =\n if Float.is_nan t then nan\n else\n let d = int_of_float (day_within_year t) in\n let m = int_of_float (month_from_time t) in\n let table = if in_leap_year t then month_start_days_leap else month_start_days in\n Float.of_int (d - table.(m) + 1)\n\nlet week_day t =\n if Float.is_nan t then nan\n else\n let d = day t +. 4. in\n let r = Float.rem d 7. in\n if r < 0. then r +. 7. else r\n\nlet hour_from_time t =\n if Float.is_nan t then nan\n else\n let r = Float.rem (Float.floor (t /. ms_per_hour)) 24. in\n if r < 0. then r +. 24. else r\n\nlet min_from_time t =\n if Float.is_nan t then nan\n else\n let r = Float.rem (Float.floor (t /. ms_per_minute)) 60. in\n if r < 0. then r +. 60. else r\n\nlet sec_from_time t =\n if Float.is_nan t then nan\n else\n let r = Float.rem (Float.floor (t /. ms_per_second)) 60. in\n if r < 0. then r +. 60. else r\n\nlet ms_from_time t =\n if Float.is_nan t then nan\n else\n let r = Float.rem t ms_per_second in\n if r < 0. then r +. ms_per_second else r\n\nlet make_time ~hour ~min ~sec ~ms =\n if Float.is_nan hour || Float.is_nan min || Float.is_nan sec || Float.is_nan ms then nan\n else\n let h = Float.trunc hour in\n let m = Float.trunc min in\n let s = Float.trunc sec in\n let milli = Float.trunc ms in\n (h *. ms_per_hour) +. (m *. ms_per_minute) +. (s *. ms_per_second) +. milli\n\nlet make_day ~year ~month ~date =\n if Float.is_nan year || Float.is_nan month || Float.is_nan date then nan\n else if (not (Float.is_finite year)) || (not (Float.is_finite month)) || not (Float.is_finite date) then nan\n else\n let y = Float.trunc year in\n let m = Float.trunc month in\n let dt = Float.trunc date in\n let ym = y +. Float.floor (m /. 12.) in\n let mn = Float.rem m 12. in\n let mn = if mn < 0. then mn +. 12. else mn in\n let d = day_from_year ym in\n let is_leap = days_in_year ym = 366 in\n let month_table = if is_leap then month_start_days_leap else month_start_days in\n let d = d +. Float.of_int month_table.(int_of_float mn) in\n d +. dt -. 1.\n\nlet make_date ~day ~time =\n if Float.is_nan day || Float.is_nan time then nan\n else if (not (Float.is_finite day)) || not (Float.is_finite time) then nan\n else (day *. ms_per_day) +. time\n\nlet time_clip t =\n if Float.is_nan t then nan\n else if not (Float.is_finite t) then nan\n else if Float.abs t > max_time_value then nan\n else Float.trunc t\n\nlet local_tz_offset_ms utc_time =\n if Float.is_nan utc_time then 0.\n else\n let seconds = utc_time /. 1000. in\n try\n let local_tm = Unix.localtime seconds in\n let utc_tm = Unix.gmtime seconds in\n let local_secs = (local_tm.Unix.tm_hour * 3600) + (local_tm.Unix.tm_min * 60) + local_tm.Unix.tm_sec in\n let utc_secs = (utc_tm.Unix.tm_hour * 3600) + (utc_tm.Unix.tm_min * 60) + utc_tm.Unix.tm_sec in\n let day_diff = local_tm.Unix.tm_yday - utc_tm.Unix.tm_yday in\n let day_diff = if day_diff > 1 then -1 else if day_diff < -1 then 1 else day_diff in\n Float.of_int ((day_diff * 86400) + local_secs - utc_secs) *. 1000.\n with _ -> 0.\n\nlet utc_to_local t = if Float.is_nan t then nan else t +. local_tz_offset_ms t\nlet local_to_utc t = if Float.is_nan t then nan else t -. local_tz_offset_ms t\n\nlet compute_utc ~year ?(month = 0.) ?(date = 1.) ?(hours = 0.) ?(minutes = 0.) ?(seconds = 0.) ?(ms = 0.) () =\n let y =\n if Float.is_nan year then nan\n else\n let y = Float.trunc year in\n if y >= 0. && y <= 99. then 1900. +. y else y\n in\n let m = if Float.is_nan month then nan else Float.trunc month in\n let d = make_day ~year:y ~month:m ~date in\n let t = make_time ~hour:hours ~min:minutes ~sec:seconds ~ms in\n time_clip (make_date ~day:d ~time:t)\n\nlet now () =\n let t = Unix.gettimeofday () in\n Float.trunc (t *. 1000.)\n\nlet utc ~year ?(month = 0.) ?(date = 1.) ?(hours = 0.) ?(minutes = 0.) ?(seconds = 0.) () =\n compute_utc ~year ~month ~date ~hours ~minutes ~seconds ()\n\nlet make ?year ?month ?date ?hours ?minutes ?seconds () =\n match year with\n | None -> time_clip (now ())\n | Some year ->\n let month = match month with Some m -> m | None -> 0. in\n let date = match date with Some d -> d | None -> 1. in\n let hours = match hours with Some h -> h | None -> 0. in\n let minutes = match minutes with Some m -> m | None -> 0. in\n let seconds = match seconds with Some s -> s | None -> 0. in\n let y = if year >= 0. && year <= 99. then 1900. +. year else year in\n let d = make_day ~year:y ~month ~date in\n let t = make_time ~hour:hours ~min:minutes ~sec:seconds ~ms:0. in\n time_clip (local_to_utc (make_date ~day:d ~time:t))\n\nlet fromFloat ms = time_clip ms\nlet valueOf t = t\nlet getTime t = t\nlet getUTCFullYear t = if Float.is_nan t then nan else year_from_time t\nlet getUTCMonth t = if Float.is_nan t then nan else month_from_time t\nlet getUTCDate t = if Float.is_nan t then nan else date_from_time t\nlet getUTCDay t = if Float.is_nan t then nan else week_day t\nlet getUTCHours t = if Float.is_nan t then nan else hour_from_time t\nlet getUTCMinutes t = if Float.is_nan t then nan else min_from_time t\nlet getUTCSeconds t = if Float.is_nan t then nan else sec_from_time t\nlet getUTCMilliseconds t = if Float.is_nan t then nan else ms_from_time t\nlet getFullYear t = if Float.is_nan t then nan else year_from_time (utc_to_local t)\nlet getMonth t = if Float.is_nan t then nan else month_from_time (utc_to_local t)\nlet getDate t = if Float.is_nan t then nan else date_from_time (utc_to_local t)\nlet getDay t = if Float.is_nan t then nan else week_day (utc_to_local t)\nlet getHours t = if Float.is_nan t then nan else hour_from_time (utc_to_local t)\nlet getMinutes t = if Float.is_nan t then nan else min_from_time (utc_to_local t)\nlet getSeconds t = if Float.is_nan t then nan else sec_from_time (utc_to_local t)\nlet getMilliseconds t = if Float.is_nan t then nan else ms_from_time (utc_to_local t)\nlet getTimezoneOffset t = if Float.is_nan t then nan else -.local_tz_offset_ms t /. ms_per_minute\n\nlet pad n i =\n let s = string_of_int (abs i) in\n let len = String.length s in\n if len >= n then s else String.make (n - len) '0' ^ s\n\nlet format_year year =\n let y = int_of_float year in\n if y >= 0 && y <= 9999 then pad 4 y\n else if y < 0 then Printf.sprintf \"-%s\" (pad 6 (-y))\n else Printf.sprintf \"+%s\" (pad 6 y)\n\nlet toISOString t =\n if Float.is_nan t then raise (Invalid_argument \"Invalid Date\")\n else if not (is_valid_time t) then raise (Invalid_argument \"Invalid Date\")\n else\n let year = year_from_time t in\n let month = int_of_float (month_from_time t) + 1 in\n let day = int_of_float (date_from_time t) in\n let hours = int_of_float (hour_from_time t) in\n let minutes = int_of_float (min_from_time t) in\n let seconds = int_of_float (sec_from_time t) in\n let ms = int_of_float (ms_from_time t) in\n Printf.sprintf \"%s-%s-%sT%s:%s:%s.%sZ\" (format_year year) (pad 2 month) (pad 2 day) (pad 2 hours) (pad 2 minutes)\n (pad 2 seconds) (pad 3 ms)\n\nlet toJSON t = if Float.is_nan t || not (is_valid_time t) then None else Some (toISOString t)\nlet toJSONUnsafe t = toISOString t\nlet day_names = [| \"Sun\"; \"Mon\"; \"Tue\"; \"Wed\"; \"Thu\"; \"Fri\"; \"Sat\" |]\nlet month_names = [| \"Jan\"; \"Feb\"; \"Mar\"; \"Apr\"; \"May\"; \"Jun\"; \"Jul\"; \"Aug\"; \"Sep\"; \"Oct\"; \"Nov\"; \"Dec\" |]\n\nlet format_tz_offset offset_ms =\n let offset_min = int_of_float (offset_ms /. ms_per_minute) in\n let sign = if offset_min >= 0 then \"+\" else \"-\" in\n let abs_offset = abs offset_min in\n let hours = abs_offset / 60 in\n let mins = abs_offset mod 60 in\n Printf.sprintf \"GMT%s%s%s\" sign (pad 2 hours) (pad 2 mins)\n\nlet toUTCString t =\n if Float.is_nan t then \"Invalid Date\"\n else\n let day_name = day_names.(int_of_float (week_day t)) in\n let day = int_of_float (date_from_time t) in\n let month_name = month_names.(int_of_float (month_from_time t)) in\n let year = int_of_float (year_from_time t) in\n let hours = int_of_float (hour_from_time t) in\n let minutes = int_of_float (min_from_time t) in\n let seconds = int_of_float (sec_from_time t) in\n Printf.sprintf \"%s, %s %s %d %s:%s:%s GMT\" day_name (pad 2 day) month_name year (pad 2 hours) (pad 2 minutes)\n (pad 2 seconds)\n\nlet toDateString t =\n if Float.is_nan t then \"Invalid Date\"\n else\n let local = utc_to_local t in\n let day_name = day_names.(int_of_float (week_day local)) in\n let month_name = month_names.(int_of_float (month_from_time local)) in\n let day = int_of_float (date_from_time local) in\n let year = int_of_float (year_from_time local) in\n Printf.sprintf \"%s %s %s %d\" day_name month_name (pad 2 day) year\n\nlet toTimeString t =\n if Float.is_nan t then \"Invalid Date\"\n else\n let local = utc_to_local t in\n let hours = int_of_float (hour_from_time local) in\n let minutes = int_of_float (min_from_time local) in\n let seconds = int_of_float (sec_from_time local) in\n let tz = format_tz_offset (local_tz_offset_ms t) in\n Printf.sprintf \"%s:%s:%s %s\" (pad 2 hours) (pad 2 minutes) (pad 2 seconds) tz\n\nlet toString t = if Float.is_nan t then \"Invalid Date\" else Printf.sprintf \"%s %s\" (toDateString t) (toTimeString t)\nlet toLocaleString t = toString t\nlet toLocaleDateString t = toDateString t\nlet toLocaleTimeString t = toTimeString t\nlet parse_int_opt s = try Some (int_of_string s) with _ -> None\nlet ( let* ) = Option.bind\nlet guard condition = if condition then Some () else None\nlet read_chars s ~pos ~len:n = if pos + n > String.length s then None else Some (String.sub s pos n)\n\nlet parse_int_in_range s ~min ~max =\n let* value = parse_int_opt s in\n let* () = guard (value >= min && value <= max) in\n Some value\n\nlet parse_year s =\n let len = String.length s in\n if len = 0 then None\n else\n let sign, start, digits = match s.[0] with '+' -> (1., 1, 6) | '-' -> (-1., 1, 6) | _ -> (1., 0, 4) in\n let* year_str = read_chars s ~pos:start ~len:digits in\n let* year_int = parse_int_opt year_str in\n let* () = guard (not (sign < 0. && year_int = 0)) in\n let year = sign *. Float.of_int year_int in\n let next_pos = start + digits in\n Some (year, next_pos)\n\nlet parse_2digit_component s ~pos ~delimiter ~min ~max =\n let len = String.length s in\n if pos >= len then None\n else if s.[pos] <> delimiter then None\n else\n let pos = pos + 1 in\n let* component_str = read_chars s ~pos ~len:2 in\n let* value = parse_int_in_range component_str ~min ~max in\n Some (value, pos + 2)\n\nlet parse_seconds s ~pos =\n let len = String.length s in\n if pos >= len || s.[pos] <> ':' then Some (0., pos)\n else\n let pos = pos + 1 in\n match read_chars s ~pos ~len:2 with\n | None -> None\n | Some sec_str -> (\n match parse_int_in_range sec_str ~min:0 ~max:59 with\n | None -> None\n | Some sec -> Some (Float.of_int sec, pos + 2))\n\nlet parse_milliseconds s ~pos =\n let len = String.length s in\n if pos >= len || s.[pos] <> '.' then (0., pos)\n else\n let pos = pos + 1 in\n let ms_start = pos in\n let rec count_digits p = if p < len && s.[p] >= '0' && s.[p] <= '9' then count_digits (p + 1) else p in\n let ms_end = count_digits ms_start in\n let digit_count = ms_end - ms_start in\n if digit_count = 0 then (0., ms_end)\n else\n let ms_str = String.sub s ms_start (min digit_count 3) in\n let ms_str =\n let pad_len = 3 - String.length ms_str in\n if pad_len > 0 then ms_str ^ String.make pad_len '0' else ms_str\n in\n let ms = match parse_int_opt ms_str with Some v -> Float.of_int v | None -> 0. in\n (ms, ms_end)\n\nlet parse_timezone s ~pos =\n let len = String.length s in\n if pos >= len then (0., pos)\n else\n match s.[pos] with\n | 'Z' -> (0., pos + 1)\n | ('+' | '-') as sign_char ->\n let sign = if sign_char = '-' then -1. else 1. in\n let pos = pos + 1 in\n let tz_hours, pos =\n match read_chars s ~pos ~len:2 with\n | Some h_str -> ( match parse_int_opt h_str with Some h -> (Float.of_int h, pos + 2) | None -> (0., pos))\n | None -> (0., pos)\n in\n let tz_minutes, pos =\n if pos < len && s.[pos] = ':' then\n let pos = pos + 1 in\n match read_chars s ~pos ~len:2 with\n | Some m_str -> ( match parse_int_opt m_str with Some m -> (Float.of_int m, pos + 2) | None -> (0., pos))\n | None -> (0., pos)\n else (0., pos)\n in\n let offset_ms = sign *. ((tz_hours *. ms_per_hour) +. (tz_minutes *. ms_per_minute)) in\n (offset_ms, pos)\n | _ -> (0., pos)\n\nlet parse_time_component s ~pos ~year ~month ~date =\n let len = String.length s in\n if pos >= len then Some (compute_utc ~year ~month ~date ())\n else if s.[pos] <> 'T' && s.[pos] <> ' ' then None\n else\n let pos = pos + 1 in\n let* hours_str = read_chars s ~pos ~len:2 in\n let* hours_int = parse_int_in_range hours_str ~min:0 ~max:24 in\n let hours = Float.of_int hours_int in\n let pos = pos + 2 in\n let* () = guard (pos < len && s.[pos] = ':') in\n let pos = pos + 1 in\n let* minutes_str = read_chars s ~pos ~len:2 in\n let* minutes_int = parse_int_in_range minutes_str ~min:0 ~max:59 in\n let minutes = Float.of_int minutes_int in\n let pos = pos + 2 in\n let* seconds, pos = parse_seconds s ~pos in\n let ms, pos = parse_milliseconds s ~pos in\n let tz_offset_ms, _pos = parse_timezone s ~pos in\n let* () = guard (not (hours_int = 24 && (minutes_int <> 0 || seconds <> 0. || ms <> 0.))) in\n let result = compute_utc ~year ~month ~date ~hours ~minutes ~seconds ~ms () in\n Some (result -. tz_offset_ms)\n\nlet parse_iso8601 s =\n let len = String.length s in\n if len = 0 then None\n else\n let* year, pos = parse_year s in\n if pos >= len then Some (compute_utc ~year ~month:0. ())\n else\n let* month_int, pos = parse_2digit_component s ~pos ~delimiter:'-' ~min:1 ~max:12 in\n let month = Float.of_int (month_int - 1) in\n if pos >= len then Some (compute_utc ~year ~month ())\n else\n let* date_int, pos = parse_2digit_component s ~pos ~delimiter:'-' ~min:1 ~max:31 in\n let date = Float.of_int date_int in\n parse_time_component s ~pos ~year ~month ~date\n\nlet weekdays = [ \"Sun\"; \"Mon\"; \"Tue\"; \"Wed\"; \"Thu\"; \"Fri\"; \"Sat\" ]\n\nlet strip_weekday s =\n let parts = String.split_on_char ' ' (String.trim s) in\n match parts with day :: rest when List.mem day weekdays -> String.concat \" \" rest | _ -> s\n\nlet array_find_index pred arr =\n let len = Array.length arr in\n let rec loop i = if i >= len then None else if pred arr.(i) then Some i else loop (i + 1) in\n loop 0\n\nlet parse_month_name name = array_find_index (fun m -> String.equal m name) month_names |> Option.map Float.of_int\n\nlet parse_gmt_offset tz_str =\n let len = String.length tz_str in\n if len < 3 || String.sub tz_str 0 3 <> \"GMT\" then 0.\n else\n let tz_part = String.sub tz_str 3 (len - 3) in\n if String.length tz_part < 5 then 0.\n else\n let sign = if tz_part.[0] = '-' then -1. else 1. in\n let h_str = String.sub tz_part 1 2 in\n let m_str = String.sub tz_part 3 2 in\n match (parse_int_opt h_str, parse_int_opt m_str) with\n | Some h, Some m -> sign *. ((Float.of_int h *. ms_per_hour) +. (Float.of_int m *. ms_per_minute))\n | _ -> 0.\n\nlet parse_time_string time_str =\n match String.split_on_char ':' time_str with\n | [ h; m; s ] -> (\n match (parse_int_opt h, parse_int_opt m, parse_int_opt s) with\n | Some hi, Some mi, Some si -> Some (Float.of_int hi, Float.of_int mi, Float.of_int si)\n | _ -> None)\n | _ -> None\n\nlet parse_legacy_time_and_tz rest =\n match rest with\n | [] -> (0., 0., 0., 0.)\n | time_str :: tz_rest -> (\n match parse_time_string time_str with\n | Some (hours, minutes, seconds) ->\n let tz_offset = match tz_rest with [] -> 0. | tz_str :: _ -> parse_gmt_offset tz_str in\n (hours, minutes, seconds, tz_offset)\n | None -> (0., 0., 0., 0.))\n\nlet parse_legacy s =\n let s = strip_weekday s in\n let parts = String.split_on_char ' ' (String.trim s) in\n match parts with\n | month_str :: day_str :: year_str :: rest ->\n let* month = parse_month_name month_str in\n let* day_int = parse_int_opt day_str in\n let* year_int = parse_int_opt year_str in\n let date = Float.of_int day_int in\n let year = Float.of_int year_int in\n let hours, minutes, seconds, tz_offset = parse_legacy_time_and_tz rest in\n let result = compute_utc ~year ~month ~date ~hours ~minutes ~seconds () in\n Some (result -. tz_offset)\n | _ -> None\n\nlet parse s =\n let s = String.trim s in\n if String.length s = 0 then nan\n else match parse_iso8601 s with Some t -> t | None -> ( match parse_legacy s with Some t -> t | None -> nan)\n\nlet parseAsFloat = parse\nlet fromString s = time_clip (parse s)\nlet setTime ~time _t = time_clip time\nlet setUTCTime ~time _t = time_clip time\n\nlet setUTCMilliseconds ~milliseconds t =\n if Float.is_nan t then nan\n else\n let d = day t in\n let time = time_within_day t in\n let new_time = time -. ms_from_time t +. Float.trunc milliseconds in\n time_clip (make_date ~day:d ~time:new_time)\n\nlet setUTCSeconds ~seconds ?milliseconds t =\n if Float.is_nan t then nan\n else\n let h = hour_from_time t in\n let m = min_from_time t in\n let s = Float.trunc seconds in\n let ms = match milliseconds with Some ms -> Float.trunc ms | None -> ms_from_time t in\n let d = day t in\n let time = make_time ~hour:h ~min:m ~sec:s ~ms in\n time_clip (make_date ~day:d ~time)\n\nlet setUTCMinutes ~minutes ?seconds ?milliseconds t =\n if Float.is_nan t then nan\n else\n let h = hour_from_time t in\n let m = Float.trunc minutes in\n let s = match seconds with Some s -> Float.trunc s | None -> sec_from_time t in\n let ms = match milliseconds with Some ms -> Float.trunc ms | None -> ms_from_time t in\n let d = day t in\n let time = make_time ~hour:h ~min:m ~sec:s ~ms in\n time_clip (make_date ~day:d ~time)\n\nlet setUTCHours ~hours ?minutes ?seconds ?milliseconds t =\n if Float.is_nan t then nan\n else\n let h = Float.trunc hours in\n let m = match minutes with Some m -> Float.trunc m | None -> min_from_time t in\n let s = match seconds with Some s -> Float.trunc s | None -> sec_from_time t in\n let ms = match milliseconds with Some ms -> Float.trunc ms | None -> ms_from_time t in\n let d = day t in\n let time = make_time ~hour:h ~min:m ~sec:s ~ms in\n time_clip (make_date ~day:d ~time)\n\nlet setUTCDate ~date t =\n if Float.is_nan t then nan\n else\n let year = year_from_time t in\n let month = month_from_time t in\n let d = make_day ~year ~month ~date:(Float.trunc date) in\n let time = time_within_day t in\n time_clip (make_date ~day:d ~time)\n\nlet setUTCMonth ~month ?date t =\n if Float.is_nan t then nan\n else\n let year = year_from_time t in\n let dt = match date with Some d -> Float.trunc d | None -> date_from_time t in\n let d = make_day ~year ~month:(Float.trunc month) ~date:dt in\n let time = time_within_day t in\n time_clip (make_date ~day:d ~time)\n\nlet setUTCFullYear ~year ?month ?date t =\n let t = if Float.is_nan t then 0. else t in\n let m = match month with Some m -> Float.trunc m | None -> month_from_time t in\n let dt = match date with Some d -> Float.trunc d | None -> date_from_time t in\n let d = make_day ~year:(Float.trunc year) ~month:m ~date:dt in\n let time = time_within_day t in\n time_clip (make_date ~day:d ~time)\n\nlet setMilliseconds ~milliseconds t =\n if Float.is_nan t then nan\n else\n let local = utc_to_local t in\n let d = day local in\n let time = time_within_day local in\n let new_time = time -. ms_from_time local +. Float.trunc milliseconds in\n time_clip (local_to_utc (make_date ~day:d ~time:new_time))\n\nlet setSeconds ~seconds ?milliseconds t =\n if Float.is_nan t then nan\n else\n let local = utc_to_local t in\n let h = hour_from_time local in\n let m = min_from_time local in\n let s = Float.trunc seconds in\n let ms = match milliseconds with Some ms -> Float.trunc ms | None -> ms_from_time local in\n let d = day local in\n let time = make_time ~hour:h ~min:m ~sec:s ~ms in\n time_clip (local_to_utc (make_date ~day:d ~time))\n\nlet setMinutes ~minutes ?seconds ?milliseconds t =\n if Float.is_nan t then nan\n else\n let local = utc_to_local t in\n let h = hour_from_time local in\n let m = Float.trunc minutes in\n let s = match seconds with Some s -> Float.trunc s | None -> sec_from_time local in\n let ms = match milliseconds with Some ms -> Float.trunc ms | None -> ms_from_time local in\n let d = day local in\n let time = make_time ~hour:h ~min:m ~sec:s ~ms in\n time_clip (local_to_utc (make_date ~day:d ~time))\n\nlet setHours ~hours ?minutes ?seconds ?milliseconds t =\n if Float.is_nan t then nan\n else\n let local = utc_to_local t in\n let h = Float.trunc hours in\n let m = match minutes with Some m -> Float.trunc m | None -> min_from_time local in\n let s = match seconds with Some s -> Float.trunc s | None -> sec_from_time local in\n let ms = match milliseconds with Some ms -> Float.trunc ms | None -> ms_from_time local in\n let d = day local in\n let time = make_time ~hour:h ~min:m ~sec:s ~ms in\n time_clip (local_to_utc (make_date ~day:d ~time))\n\nlet setDate ~date t =\n if Float.is_nan t then nan\n else\n let local = utc_to_local t in\n let year = year_from_time local in\n let month = month_from_time local in\n let d = make_day ~year ~month ~date:(Float.trunc date) in\n let time = time_within_day local in\n time_clip (local_to_utc (make_date ~day:d ~time))\n\nlet setMonth ~month ?date t =\n if Float.is_nan t then nan\n else\n let local = utc_to_local t in\n let year = year_from_time local in\n let dt = match date with Some d -> Float.trunc d | None -> date_from_time local in\n let d = make_day ~year ~month:(Float.trunc month) ~date:dt in\n let time = time_within_day local in\n time_clip (local_to_utc (make_date ~day:d ~time))\n\nlet setFullYear ~year ?month ?date t =\n let t = if Float.is_nan t then 0. else t in\n let local = utc_to_local t in\n let m = match month with Some m -> Float.trunc m | None -> month_from_time local in\n let dt = match date with Some d -> Float.trunc d | None -> date_from_time local in\n let d = make_day ~year:(Float.trunc year) ~month:m ~date:dt in\n let time = time_within_day local in\n time_clip (local_to_utc (make_date ~day:d ~time))\n"
},
{
"path": "packages/Js/lib/Js_date.mli",
"content": "(** JavaScript Date API *)\n\ntype t = float\n\nval valueOf : t -> float\nval fromFloat : float -> t\nval fromString : string -> t\nval make : ?year:float -> ?month:float -> ?date:float -> ?hours:float -> ?minutes:float -> ?seconds:float -> unit -> t\nval utc : year:float -> ?month:float -> ?date:float -> ?hours:float -> ?minutes:float -> ?seconds:float -> unit -> float\nval now : unit -> float\nval parseAsFloat : string -> float\nval getDate : t -> float\nval getDay : t -> float\nval getFullYear : t -> float\nval getHours : t -> float\nval getMilliseconds : t -> float\nval getMinutes : t -> float\nval getMonth : t -> float\nval getSeconds : t -> float\nval getTime : t -> float\nval getTimezoneOffset : t -> float\nval getUTCDate : t -> float\nval getUTCDay : t -> float\nval getUTCFullYear : t -> float\nval getUTCHours : t -> float\nval getUTCMilliseconds : t -> float\nval getUTCMinutes : t -> float\nval getUTCMonth : t -> float\nval getUTCSeconds : t -> float\nval setDate : date:float -> t -> float\nval setFullYear : year:float -> ?month:float -> ?date:float -> t -> float\nval setHours : hours:float -> ?minutes:float -> ?seconds:float -> ?milliseconds:float -> t -> float\nval setMilliseconds : milliseconds:float -> t -> float\nval setMinutes : minutes:float -> ?seconds:float -> ?milliseconds:float -> t -> float\nval setMonth : month:float -> ?date:float -> t -> float\nval setSeconds : seconds:float -> ?milliseconds:float -> t -> float\nval setTime : time:float -> t -> float\nval setUTCDate : date:float -> t -> float\nval setUTCFullYear : year:float -> ?month:float -> ?date:float -> t -> float\nval setUTCHours : hours:float -> ?minutes:float -> ?seconds:float -> ?milliseconds:float -> t -> float\nval setUTCMilliseconds : milliseconds:float -> t -> float\nval setUTCMinutes : minutes:float -> ?seconds:float -> ?milliseconds:float -> t -> float\nval setUTCMonth : month:float -> ?date:float -> t -> float\nval setUTCSeconds : seconds:float -> ?milliseconds:float -> t -> float\nval setUTCTime : time:float -> t -> float\nval toDateString : t -> string\nval toISOString : t -> string\nval toJSON : t -> string option\nval toJSONUnsafe : t -> string\nval toLocaleDateString : t -> string\nval toLocaleString : t -> string\nval toLocaleTimeString : t -> string\nval toString : t -> string\nval toTimeString : t -> string\nval toUTCString : t -> string\n"
},
{
"path": "packages/Js/lib/Js_dict.ml",
"content": "(** Provide utilities for JS dictionary object *)\n\ntype key = string\ntype 'a t = (key, 'a) Hashtbl.t\n\nlet empty () : 'a t = Hashtbl.create 10\n\nlet entries (dict : 'a t) : (string * 'a) array =\n Hashtbl.fold (fun k v acc -> (k, v) :: acc) dict [] |> Stdlib.Array.of_list\n\nlet get (dict : 'a t) (k : key) : 'a option = try Some (Hashtbl.find dict k) with Not_found -> None\n\nlet map ~(f : 'a -> 'b) (dict : 'a t) =\n Hashtbl.fold\n (fun k v acc ->\n Hashtbl.add acc k (f v);\n acc)\n dict (empty ())\n\nlet set (dict : 'a t) (k : key) (x : 'a) : unit = Hashtbl.replace dict k x\n\nlet fromList (lst : (key * 'a) list) : 'a t =\n let length = Stdlib.List.length lst in\n let dict = Hashtbl.create length in\n Stdlib.List.iter (fun (k, v) -> Hashtbl.add dict k v) lst;\n dict\n\nlet fromArray (arr : (key * 'a) array) : 'a t =\n let length = Stdlib.Array.length arr in\n let dict = Hashtbl.create length in\n Stdlib.Array.iter (fun (k, v) -> Hashtbl.add dict k v) arr;\n dict\n\nlet keys (dict : 'a t) = Hashtbl.fold (fun k _ acc -> k :: acc) dict [] |> Stdlib.Array.of_list\nlet values (dict : 'a t) = Hashtbl.fold (fun _k value acc -> value :: acc) dict [] |> Stdlib.Array.of_list\nlet unsafeGet (dict : 'a t) (k : key) : 'a = Hashtbl.find dict k\nlet unsafeDeleteKey (dict : 'a t) (key : key) = Hashtbl.remove dict key\n"
},
{
"path": "packages/Js/lib/Js_dict.mli",
"content": "(** Provide utilities for JS dictionary object *)\n\ntype 'a t\n(** Dictionary type *)\n\ntype key = string\n(** Key type *)\n\nval get : 'a t -> key -> 'a option\n(** [get dict key] returns [None] if the [key] is not found in the dictionary, [Some value] otherwise *)\n\nval unsafeGet : 'a t -> key -> 'a\n\nval set : 'a t -> key -> 'a -> unit\n(** [set dict key value] sets the [key]/[value] in [dict] *)\n\nval keys : 'a t -> string array\n(** [keys dict] returns all the keys in the dictionary [dict]*)\n\nval empty : unit -> 'a t\n(** [empty ()] returns an empty dictionary *)\n\nval unsafeDeleteKey : string t -> string -> unit\n(** Experimental internal function *)\n\nval entries : 'a t -> (key * 'a) array\n(** [entries dict] returns the key value pairs in [dict] *)\n\nval values : 'a t -> 'a array\n(** [values dict] returns the values in [dict] *)\n\nval fromList : (key * 'a) list -> 'a t\n(** [fromList entries] creates a new dictionary containing each [(key, value)] pair in [entries] *)\n\nval fromArray : (key * 'a) array -> 'a t\n(** [fromArray entries] creates a new dictionary containing each [(key, value)] pair in [entries] *)\n\nval map : f:('a -> 'b) -> 'a t -> 'b t\n(** [map f dict] maps [dict] to a new dictionary with the same keys, using [f] to map each value *)\n"
},
{
"path": "packages/Js/lib/Js_exn.ml",
"content": "type t\n\ntype exn +=\n | Error of string\n | EvalError of string\n | RangeError of string\n | ReferenceError of string\n | SyntaxError of string\n | TypeError of string\n | UriError of string\n\nlet asJsExn _ = Js_internal.notImplemented \"Js.Exn\" \"asJsExn\"\nlet stack _ = Js_internal.notImplemented \"Js.Exn\" \"stack\"\nlet message _ = Js_internal.notImplemented \"Js.Exn\" \"message\"\nlet name _ = Js_internal.notImplemented \"Js.Exn\" \"name\"\nlet fileName _ = Js_internal.notImplemented \"Js.Exn\" \"fileName\"\nlet anyToExnInternal _ = Js_internal.notImplemented \"Js.Exn\" \"anyToExnInternal\"\nlet isCamlExceptionOrOpenVariant _ = Js_internal.notImplemented \"Js.Exn\" \"isCamlExceptionOrOpenVariant\"\nlet raiseError str = raise (Error str)\nlet raiseEvalError str = raise (EvalError str)\nlet raiseRangeError str = raise (RangeError str)\nlet raiseReferenceError str = raise (ReferenceError str)\nlet raiseSyntaxError str = raise (SyntaxError str)\nlet raiseTypeError str = raise (TypeError str)\nlet raiseUriError str = raise (UriError str)\n"
},
{
"path": "packages/Js/lib/Js_exn.mli",
"content": "type t\n\ntype exn +=\n | Error of string\n | EvalError of string\n | RangeError of string\n | ReferenceError of string\n | SyntaxError of string\n | TypeError of string\n | UriError of string\n\nval asJsExn : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval stack : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval message : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval name : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval fileName : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval anyToExnInternal : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval isCamlExceptionOrOpenVariant : 'a -> 'b\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval raiseError : string -> 'a\nval raiseEvalError : string -> 'a\nval raiseRangeError : string -> 'a\nval raiseReferenceError : string -> 'a\nval raiseSyntaxError : string -> 'a\nval raiseTypeError : string -> 'a\nval raiseUriError : string -> 'a\n"
},
{
"path": "packages/Js/lib/Js_float.ml",
"content": "type t = float\n\nmodule SpecialValues = struct\n let _NaN = Stdlib.Float.nan\n let isNaN float = Stdlib.Float.is_nan float\n\n let fromString str =\n match str with\n | \"NaN\" -> _NaN\n | \"Infinity\" -> infinity\n | \"-Infinity\" -> neg_infinity\n | _ -> raise (Failure \"Invalid special value\")\nend\n\nlet _NaN = SpecialValues._NaN\nlet isNaN = SpecialValues.isNaN\nlet isFinite float = Stdlib.Float.is_finite float\nlet isInteger float = Stdlib.Float.is_finite float && Stdlib.Float.is_integer float\n\nlet toExponential ?digits f =\n match digits with\n | None -> Quickjs.Number.Prototype.to_string f\n | Some d ->\n if d < 0 || d > 100 then raise (Invalid_argument \"toExponential() digits argument must be between 0 and 100\")\n else Quickjs.Number.Prototype.to_exponential d f\n\nlet toFixed ?(digits = 0) f =\n if digits < 0 || digits > 100 then raise (Failure \"toFixed() digits argument must be between 0 and 100\")\n else Quickjs.Number.Prototype.to_fixed digits f\n\nlet toPrecision ?digits f =\n match digits with\n | None -> Quickjs.Number.Prototype.to_string f\n | Some d ->\n if d < 1 || d > 100 then raise (Invalid_argument \"toPrecision() digits argument must be between 1 and 100\")\n else Quickjs.Number.Prototype.to_precision d f\n\nlet toString ?radix f =\n match radix with\n | None -> Quickjs.Number.Prototype.to_string f\n | Some r ->\n if r < 2 || r > 36 then raise (Invalid_argument \"toString() radix must be between 2 and 36\")\n else Quickjs.Number.Prototype.to_radix r f\n\nlet fromString str = try SpecialValues.fromString str with _ -> Stdlib.float_of_string str\n"
},
{
"path": "packages/Js/lib/Js_float.mli",
"content": "(** Provides functions for inspecting and manipulating [float]s *)\n\ntype t = float\n\nval _NaN : t\nval isNaN : t -> bool\nval isFinite : t -> bool\n\nval isInteger : t -> bool\n(** Returns true if the value is a finite number with no fractional part *)\n\nval toExponential : ?digits:int -> t -> string\n(** Formats a number in exponential notation.\n @raise Invalid_argument if digits is not in range 0-100 *)\n\nval toFixed : ?digits:int -> t -> string\n(** Formats a number with fixed-point notation.\n @raise Failure if digits is not in range 0-100 *)\n\nval toPrecision : ?digits:int -> t -> string\n(** Formats a number with the specified number of significant digits.\n @raise Invalid_argument if digits is not in range 1-100 *)\n\nval toString : ?radix:int -> t -> string\n(** Converts a number to a string. Optionally specify a radix (2-36).\n @raise Invalid_argument if radix is not in range 2-36 *)\n\nval fromString : string -> t\n"
},
{
"path": "packages/Js/lib/Js_formdata.ml",
"content": "(* TODO: This is a bad implementation for FormData, and not compatible with the Js.FormData from melange.js *)\ntype entryValue = [ `String of string ]\ntype t = (string, entryValue) Hashtbl.t\n\nlet make = (fun () -> Hashtbl.create 10 : unit -> t)\nlet append = (fun formData key value -> Hashtbl.add formData key value : t -> string -> entryValue -> unit)\nlet get = (fun formData key -> Hashtbl.find formData key : t -> string -> entryValue)\n\nlet entries : t -> (string * entryValue) list =\n fun formData -> Hashtbl.fold (fun key value acc -> (key, value) :: acc) formData []\n"
},
{
"path": "packages/Js/lib/Js_formdata.mli",
"content": "(* TODO: This is a bad implementation for FormData, and not compatible with the Js.FormData from melange.js *)\ntype entryValue = [ `String of string ]\ntype t = (string, entryValue) Hashtbl.t\n\nval make : unit -> t\nval append : t -> string -> entryValue -> unit\nval get : t -> string -> entryValue\nval entries : t -> (string * entryValue) list\n"
},
{
"path": "packages/Js/lib/Js_global.ml",
"content": "(** Contains functions available in the global scope ([window] in a browser context) *)\n\ntype intervalId\n(** Identify an interval started by {! setInterval} *)\n\ntype timeoutId\n(** Identify timeout started by {! setTimeout} *)\n\nlet clearInterval _intervalId = Js_internal.notImplemented \"Js.Global\" \"clearInterval\"\nlet clearTimeout _timeoutId = Js_internal.notImplemented \"Js.Global\" \"clearTimeout\"\nlet setInterval ~f:_ _ = Js_internal.notImplemented \"Js.Global\" \"setInterval\"\nlet setIntervalFloat ~f:_ _ = Js_internal.notImplemented \"Js.Global\" \"setInterval\"\nlet setTimeout ~f:_ _ = Js_internal.notImplemented \"Js.Global\" \"setTimeout\"\nlet setTimeoutFloat ~f:_ _ = Js_internal.notImplemented \"Js.Global\" \"setTimeout\"\n\nmodule URI = struct\n let int_of_hex_opt str = try Some (Scanf.sscanf str \"%x%!\" (fun x -> x)) with _ -> None\n\n let hex_decode str pos =\n if pos + 2 >= String.length str then Error \"Expecting Hex digit\"\n else\n let first = int_of_hex_opt (Stdlib.String.sub str (pos + 1) 1) in\n let second = int_of_hex_opt (Stdlib.String.sub str (pos + 2) 1) in\n match (first, second) with\n | Some first, Some second -> Ok ((first lsl 4) lor second)\n | _ -> Error \"Invalid hex digit\"\n\n let is_uri_reserved c = Stdlib.String.contains \";/?:@&=+$,#\" c\n\n let decode_uri ~component s =\n let buf = Buffer.create (String.length s) in\n let decode_utf8 pos char n c_min =\n let rec loop pos char n =\n if n <= 0 then Some (pos, char)\n else\n match hex_decode s pos with\n | Ok c1 when c1 land 0xc0 = 0x80 -> loop (pos + 3) ((char lsl 6) lor (c1 land 0x3f)) (n - 1)\n | _ -> raise (Invalid_argument \"Invalid hex encoding\")\n in\n match loop pos char n with\n | Some (new_pos, char) when char >= c_min && char <= 0x10FFFF && (char < 0xd800 || char >= 0xe000) ->\n (new_pos, char)\n | _ -> raise (Invalid_argument \"Malformed UTF-8\")\n in\n let rec loop pos =\n if pos >= String.length s then Buffer.contents buf\n else\n match Stdlib.String.get s pos with\n | '%' -> (\n match hex_decode s pos with\n | Ok hex when hex >= 0 ->\n if hex < 0x80 then\n let c = Char.chr hex in\n if (not component) && is_uri_reserved c then (\n Buffer.add_char buf '%';\n Buffer.add_string buf (Stdlib.String.sub s (pos + 1) 2);\n loop (pos + 3))\n else (\n Buffer.add_char buf c;\n loop (pos + 3))\n else\n let new_pos, decoded_char =\n if hex >= 0xc0 && hex <= 0xdf then decode_utf8 (pos + 3) (hex land 0x1f) 1 0x80\n else if hex >= 0xe0 && hex <= 0xef then decode_utf8 (pos + 3) (hex land 0x0f) 2 0x800\n else if hex >= 0xf0 && hex <= 0xf7 then decode_utf8 (pos + 3) (hex land 0x07) 3 0x10000\n else raise (Invalid_argument \"Invalid UTF-8 start byte\")\n in\n Buffer.add_utf_8_uchar buf (Uchar.of_int decoded_char);\n loop new_pos\n | _ -> raise (Invalid_argument \"Invalid hex encoding\"))\n | c ->\n Buffer.add_char buf c;\n loop (pos + 1)\n in\n try loop 0 with error -> raise error\n\n let is_uri_unescaped c is_component =\n c < 0x100\n && ((c >= 0x61 && c <= 0x7a)\n || (c >= 0x41 && c <= 0x5a)\n || (c >= 0x30 && c <= 0x39)\n || Stdlib.String.contains \"-_.!~*'()\" (Char.chr c)\n || ((not is_component) && is_uri_reserved (Char.chr c)))\n\n let hex_of_int_opt c =\n let char_code = if c < 10 then Char.code '0' + c else Char.code 'A' + (c - 10) in\n try Some (Char.chr char_code) with _ -> None\n\n let encode_hex value =\n let first_digit = hex_of_int_opt (value lsr 4) in\n let second_digit = hex_of_int_opt (value land 0x0F) in\n match (first_digit, second_digit) with\n | Some first_digit, Some second_digit -> Ok (Printf.sprintf \"%%%c%c\" first_digit second_digit)\n | _ -> Error (Printf.sprintf \"Invalid hex encoding: %d\" value)\n\n let uri_char_escaped c =\n match c with\n | '\\'' -> \"'\" (* treat single quote as a regular character *)\n | c ->\n (* use Char.escaped for other special characters that need escaping *)\n let escaped = Char.escaped c in\n if c = '\\\\' then Stdlib.String.sub escaped 1 (String.length escaped - 1) else escaped\n\n let encode_uri ~component s =\n let buf = Buffer.create (String.length s * 3) in\n let rec loop pos =\n if pos >= String.length s then Buffer.contents buf\n else\n let new_pos, encoded_char =\n let c = Char.code (Stdlib.String.get s pos) in\n let new_pos = pos + 1 in\n if is_uri_unescaped c component then\n let encoded_char =\n try Ok (Char.chr c |> uri_char_escaped) with _ -> raise (Invalid_argument \"invalid character\")\n in\n (new_pos, encoded_char)\n else if c >= 0xdc00 && c <= 0xdfff then raise (Invalid_argument \"invalid character\")\n else if c >= 0xd800 && c <= 0xdbff then (\n if new_pos >= String.length s then raise (Invalid_argument \"expecting surrogate pair\");\n let c1 = Char.code (Stdlib.String.get s new_pos) in\n if c1 < 0xdc00 || c1 > 0xdfff then raise (Invalid_argument \"expecting surrogate pair\");\n let c = (((c land 0x3ff) lsl 10) lor (c1 land 0x3ff)) + 0x10000 in\n (new_pos + 1, encode_hex c))\n else (new_pos, encode_hex c)\n in\n\n match encoded_char with\n | Ok encoded_char ->\n Buffer.add_string buf encoded_char;\n loop new_pos\n | Error msg -> raise (Invalid_argument msg)\n in\n loop 0\nend\n\nlet encodeURI = URI.encode_uri ~component:false\nlet decodeURI = URI.decode_uri ~component:false\nlet encodeURIComponent = URI.encode_uri ~component:true\nlet decodeURIComponent = URI.decode_uri ~component:true\n\nlet is_js_whitespace c =\n (* JavaScript whitespace characters per ECMAScript spec *)\n match c with\n | '\\x09' (* Tab *)\n | '\\x0A' (* Line feed *)\n | '\\x0B' (* Vertical tab *)\n | '\\x0C' (* Form feed *)\n | '\\x0D' (* Carriage return *)\n | '\\x20' (* Space *)\n | '\\xA0' (* No-break space (Latin-1 encoded) *) ->\n true\n | _ -> false\n\nlet strip_leading_js_whitespace str =\n (* Strip leading JavaScript whitespace from string *)\n let len = String.length str in\n let rec find_start i =\n if i >= len then len\n else\n let c = String.get str i in\n if is_js_whitespace c then find_start (i + 1)\n else if c = '\\xC2' && i + 1 < len && String.get str (i + 1) = '\\xA0' then\n (* UTF-8 encoded non-breaking space U+00A0 *)\n find_start (i + 2)\n else if c = '\\xEF' && i + 2 < len && String.get str (i + 1) = '\\xBB' && String.get str (i + 2) = '\\xBF' then\n (* UTF-8 BOM *)\n find_start (i + 3)\n else i\n in\n let start = find_start 0 in\n if start >= len then \"\" else String.sub str start (len - start)\n\nlet parseFloat str =\n (* JavaScript's parseFloat behavior:\n - Skip leading whitespace (JS whitespace, not just ASCII)\n - Parse as much as valid number as possible\n - Return NaN if no valid number at start *)\n let trimmed = strip_leading_js_whitespace str in\n match Quickjs.Global.parse_float trimmed with Some f -> f | None -> nan\n\nlet parseInt ?radix str =\n (* JavaScript's parseInt behavior:\n - Skip leading whitespace (JS whitespace, not just ASCII)\n - Auto-detect hex from 0x/0X prefix when radix not specified\n - Does NOT accept 0o/0b prefixes (unlike ES6 literals)\n - Parse as much as valid number as possible\n - Return NaN if no valid number at start *)\n let trimmed = strip_leading_js_whitespace str in\n let radix =\n match radix with\n | Some r -> Some r\n | None ->\n (* Check for 0x/0X prefix for hex auto-detection *)\n let len = String.length trimmed in\n if len >= 2 then\n let first = String.get trimmed 0 in\n let second = String.get trimmed 1 in\n if first = '0' && (second = 'x' || second = 'X') then Some 16\n else if (first = '-' || first = '+') && len >= 3 then\n let third = String.get trimmed 2 in\n if String.get trimmed 1 = '0' && (third = 'x' || third = 'X') then Some 16 else None\n else None\n else None\n in\n match Quickjs.Global.parse_int ?radix trimmed with Some i -> Float.of_int i | None -> nan\n"
},
{
"path": "packages/Js/lib/Js_global.mli",
"content": "(** Contains functions available in the global scope ([window] in a browser context) *)\n\ntype intervalId\n(** Identify an interval started by {! setInterval} *)\n\ntype timeoutId\n(** Identify timeout started by {! setTimeout} *)\n\nval clearInterval : intervalId -> unit\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval clearTimeout : timeoutId -> unit\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval setInterval : f:(unit -> unit) -> int -> intervalId\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval setIntervalFloat : f:(unit -> unit) -> float -> intervalId\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval setTimeout : f:(unit -> unit) -> int -> timeoutId\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval setTimeoutFloat : f:(unit -> unit) -> float -> timeoutId\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval encodeURI : string -> string\nval decodeURI : string -> string\nval encodeURIComponent : string -> string\nval decodeURIComponent : string -> string\n\nval parseFloat : string -> float\n(** Parses a string and returns a floating point number. Returns NaN if parsing fails. *)\n\nval parseInt : ?radix:int -> string -> float\n(** Parses a string and returns an integer. Returns NaN if parsing fails.\n @param radix The base (2-36) to use for parsing. Default is 10. *)\n"
},
{
"path": "packages/Js/lib/Js_int.ml",
"content": "type t = int\n\nlet toExponential ?digits int =\n let f = Stdlib.float_of_int int in\n match digits with\n | None -> Quickjs.Number.Prototype.to_string f\n | Some d ->\n if d < 0 || d > 100 then raise (Invalid_argument \"toExponential() digits argument must be between 0 and 100\")\n else Quickjs.Number.Prototype.to_exponential d f\n\nlet toPrecision ?digits int =\n let f = Stdlib.float_of_int int in\n match digits with\n | None -> Quickjs.Number.Prototype.to_string f\n | Some d ->\n if d < 1 || d > 100 then raise (Invalid_argument \"toPrecision() digits argument must be between 1 and 100\")\n else Quickjs.Number.Prototype.to_precision d f\n\nlet toString ?radix int =\n match radix with\n | None -> Stdlib.string_of_int int\n | Some r ->\n if r < 2 || r > 36 then raise (Invalid_argument \"toString() radix must be between 2 and 36\")\n else Quickjs.Number.of_int_radix ~radix:r int\n\nlet toFloat int = Stdlib.float_of_int int\nlet equal = Stdlib.Int.equal\nlet max = 2147483647\nlet min = -2147483648\n"
},
{
"path": "packages/Js/lib/Js_int.mli",
"content": "(** Provides functions for inspecting and manipulating [int]s *)\n\ntype t = int\n\nval toExponential : ?digits:t -> t -> string\n(** Formats a number in exponential notation.\n @raise Invalid_argument if digits is not in range 0-100 *)\n\nval toPrecision : ?digits:t -> t -> string\n(** Formats a number with the specified number of significant digits.\n @raise Invalid_argument if digits is not in range 1-100 *)\n\nval toString : ?radix:t -> t -> string\n(** Converts an integer to a string. Optionally specify a radix (2-36).\n @raise Invalid_argument if radix is not in range 2-36 *)\n\nval toFloat : int -> float\nval equal : t -> t -> bool\nval max : int\nval min : int\n"
},
{
"path": "packages/Js/lib/Js_internal.ml",
"content": "exception Not_implemented of string\n\nlet notImplemented module_ function_ =\n let msg =\n Printf.sprintf\n \"'%s.%s' is not implemented in native on `server-reason-react.js`. You are running code that depends on the \\\n browser, this is not supported. If this case should run on native and there's no browser dependency, please \\\n open an issue at %s\"\n module_ function_ \"https://github.com/ml-in-barcelona/server-reason-react/issues\"\n in\n raise (Not_implemented msg)\n\ntype 'a null = 'a option\ntype 'a undefined = 'a option\ntype 'a nullable = 'a option\n"
},
{
"path": "packages/Js/lib/Js_internal.mli",
"content": "exception Not_implemented of string\n\nval notImplemented : string -> string -> 'a\n\ntype 'a null = 'a option\ntype 'a undefined = 'a option\ntype 'a nullable = 'a option\n"
},
{
"path": "packages/Js/lib/Js_json.ml",
"content": "(* Efficient JSON encoding using JavaScript API *)\n\ntype t\n\ntype _ kind =\n | String : Js_string.t kind\n | Number : float kind\n | Object : t Js_dict.t kind\n | Array : t array kind\n | Boolean : bool kind\n | Null : Js_types.null_val kind\n\ntype tagged_t =\n | JSONFalse\n | JSONTrue\n | JSONNull\n | JSONString of string\n | JSONNumber of float\n | JSONObject of t Js_dict.t\n | JSONArray of t array\n\nlet classify (_x : t) : tagged_t = Js_internal.notImplemented \"Js.Json\" \"classify\"\nlet test _ : bool = Js_internal.notImplemented \"Js.Json\" \"test\"\nlet decodeString _json = Js_internal.notImplemented \"Js.Json\" \"decodeString\"\nlet decodeNumber _json = Js_internal.notImplemented \"Js.Json\" \"decodeNumber\"\nlet decodeObject _json = Js_internal.notImplemented \"Js.Json\" \"decodeObject\"\nlet decodeArray _json = Js_internal.notImplemented \"Js.Json\" \"decodeArray\"\nlet decodeBoolean (_json : t) = Js_internal.notImplemented \"Js.Json\" \"decodeBoolean\"\nlet decodeNull _json = Js_internal.notImplemented \"Js.Json\" \"decodeNull\"\nlet parseExn _ = Js_internal.notImplemented \"Js.Json\" \"parseExn\"\nlet stringifyAny _ = Js_internal.notImplemented \"Js.Json\" \"stringifyAny\"\nlet null _ = Js_internal.notImplemented \"Js.Json\" \"null\"\nlet string _ = Js_internal.notImplemented \"Js.Json\" \"string\"\nlet number _ = Js_internal.notImplemented \"Js.Json\" \"number\"\nlet boolean _ = Js_internal.notImplemented \"Js.Json\" \"boolean\"\nlet object_ _ = Js_internal.notImplemented \"Js.Json\" \"object_\"\nlet array _ = Js_internal.notImplemented \"Js.Json\" \"array\"\nlet stringArray _ = Js_internal.notImplemented \"Js.Json\" \"stringArray\"\nlet numberArray _ = Js_internal.notImplemented \"Js.Json\" \"numberArray\"\nlet booleanArray _ = Js_internal.notImplemented \"Js.Json\" \"booleanArray\"\nlet objectArray _ = Js_internal.notImplemented \"Js.Json\" \"objectArray\"\nlet stringify _ = Js_internal.notImplemented \"Js.Json\" \"stringify\"\nlet stringifyWithSpace _ = Js_internal.notImplemented \"Js.Json\" \"stringifyWithSpace\"\nlet patch _ = Js_internal.notImplemented \"Js.Json\" \"patch\"\nlet serializeExn (_x : t) : string = Js_internal.notImplemented \"Js.Json\" \"serializeExn\"\nlet deserializeUnsafe (_s : string) : 'a = Js_internal.notImplemented \"Js.Json\" \"deserializeUnsafe\"\n"
},
{
"path": "packages/Js/lib/Js_json.mli",
"content": "(* Efficient JSON encoding using JavaScript API *)\n\ntype t\n\ntype _ kind =\n | String : string kind\n | Number : float kind\n | Object : t Js_dict.t kind\n | Array : t array kind\n | Boolean : bool kind\n | Null : Js_types.null_val kind\n\ntype tagged_t =\n | JSONFalse\n | JSONTrue\n | JSONNull\n | JSONString of string\n | JSONNumber of float\n | JSONObject of t Js_dict.t\n | JSONArray of t array\n\nval classify : t -> tagged_t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval test : 'a -> bool [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval decodeString : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval decodeNumber : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval decodeObject : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval decodeArray : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval decodeBoolean : t -> 'a [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval decodeNull : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval parseExn : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval stringifyAny : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval null : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval string : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval number : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval boolean : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval object_ : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval array : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval stringArray : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval numberArray : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval booleanArray : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval objectArray : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval stringify : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval stringifyWithSpace : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval patch : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval serializeExn : t -> string [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval deserializeUnsafe : string -> 'a\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n"
},
{
"path": "packages/Js/lib/Js_map.ml",
"content": "(** Provides bindings for ES6 Map *)\n\ntype ('k, 'v) t\n"
},
{
"path": "packages/Js/lib/Js_map.mli",
"content": "(** Provides bindings for ES6 Map *)\n\ntype ('k, 'v) t\n"
},
{
"path": "packages/Js/lib/Js_math.ml",
"content": "(** JavaScript Math API *)\n\n(** Euler's number *)\nlet _E = 2.718281828459045\n\n(** natural logarithm of 2 *)\nlet _LN2 = 0.6931471805599453\n\n(** natural logarithm of 10 *)\nlet _LN10 = 2.302585092994046\n\n(** base 2 logarithm of E *)\nlet _LOG2E = 1.4426950408889634\n\n(** base 10 logarithm of E *)\nlet _LOG10E = 0.4342944819032518\n\n(** Pi... (ratio of the circumference and diameter of a circle) *)\nlet _PI = 3.141592653589793\n\n(** square root of 1/2 *)\nlet _SQRT1_2 = 0.7071067811865476\n\n(** square root of 2 *)\nlet _SQRT2 = 1.41421356237\n\n(** absolute value *)\nlet abs_int _ = Js_internal.notImplemented \"Js.Math\" \"abs_int\"\n\nlet abs_float _ = Js_internal.notImplemented \"Js.Math\" \"abs_float\"\nlet acos _ = Js_internal.notImplemented \"Js.Math\" \"acos\"\nlet acosh _ = Js_internal.notImplemented \"Js.Math\" \"acosh\"\nlet asin _ = Js_internal.notImplemented \"Js.Math\" \"asin\"\nlet asinh _ = Js_internal.notImplemented \"Js.Math\" \"asinh\"\nlet atan _ = Js_internal.notImplemented \"Js.Math\" \"atan\"\nlet atanh _ = Js_internal.notImplemented \"Js.Math\" \"atanh\"\nlet atan2 ~y:_ ~x:_ = Js_internal.notImplemented \"Js.Math\" \"atan2\"\nlet cbrt _ = Js_internal.notImplemented \"Js.Math\" \"cbrt\"\nlet unsafe_ceil_int _ = Js_internal.notImplemented \"Js.Math\" \"unsafe_ceil_int\"\nlet ceil_int _ = Js_internal.notImplemented \"Js.Math\" \"ceil_int\"\nlet ceil_float _ = Js_internal.notImplemented \"Js.Math\" \"ceil_float\"\nlet clz32 _ = Js_internal.notImplemented \"Js.Math\" \"clz32\"\nlet cos = cos\nlet cosh _ = Js_internal.notImplemented \"Js.Math\" \"cosh\"\nlet exp _ = Js_internal.notImplemented \"Js.Math\" \"exp\"\nlet expm1 _ = Js_internal.notImplemented \"Js.Math\" \"expm1\"\nlet unsafe_floor_int _ = Js_internal.notImplemented \"Js.Math\" \"unsafe_floor_int\"\nlet floor_int _f = Js_internal.notImplemented \"Js.Math\" \"floor_int\"\nlet floor_float _ = Js_internal.notImplemented \"Js.Math\" \"floor_float\"\nlet fround _ = Js_internal.notImplemented \"Js.Math\" \"fround\"\nlet hypot _ = Js_internal.notImplemented \"Js.Math\" \"hypot\"\nlet hypotMany _ = Js_internal.notImplemented \"Js.Math\" \"hypotMany\"\nlet imul _ = Js_internal.notImplemented \"Js.Math\" \"imul\"\nlet log _ = Js_internal.notImplemented \"Js.Math\" \"log\"\nlet log1p _ = Js_internal.notImplemented \"Js.Math\" \"log1p\"\nlet log10 _ = Js_internal.notImplemented \"Js.Math\" \"log10\"\nlet log2 _ = Js_internal.notImplemented \"Js.Math\" \"log2\"\nlet max_int (a : int) (b : int) = Stdlib.max a b\nlet maxMany_int _ = Js_internal.notImplemented \"Js.Math\" \"maxMany_int\"\nlet max_float (a : float) (b : float) = Stdlib.max a b\nlet maxMany_float _ = Js_internal.notImplemented \"Js.Math\" \"maxMany_float\"\nlet min_int (a : int) (b : int) = Stdlib.min a b\nlet minMany_int _ = Js_internal.notImplemented \"Js.Math\" \"minMany_int\"\nlet min_float (a : float) (b : float) = Stdlib.min a b\nlet minMany_float _ = Js_internal.notImplemented \"Js.Math\" \"minMany_float\"\nlet pow_float ~base:_ ~exp:_ = Js_internal.notImplemented \"Js.Math\" \"pow_float\"\nlet random _ = Js_internal.notImplemented \"Js.Math\" \"random\"\nlet random_int _min _max = Js_internal.notImplemented \"Js.Math\" \"random_int\"\nlet unsafe_round _ = Js_internal.notImplemented \"Js.Math\" \"unsafe_round\"\nlet round _ = Js_internal.notImplemented \"Js.Math\" \"round\"\nlet sign_int _ = Js_internal.notImplemented \"Js.Math\" \"sign_int\"\nlet sign_float _ = Js_internal.notImplemented \"Js.Math\" \"sign_float\"\nlet sin = sin\nlet sinh _ = Js_internal.notImplemented \"Js.Math\" \"sinh\"\nlet sqrt _ = Js_internal.notImplemented \"Js.Math\" \"sqrt\"\nlet tan _ = Js_internal.notImplemented \"Js.Math\" \"tan\"\nlet tanh _ = Js_internal.notImplemented \"Js.Math\" \"tanh\"\nlet unsafe_trunc _ = Js_internal.notImplemented \"Js.Math\" \"unsafe_trunc\"\nlet trunc _ = Js_internal.notImplemented \"Js.Math\" \"trunc\"\n"
},
{
"path": "packages/Js/lib/Js_math.mli",
"content": "(** JavaScript Math API *)\n\nval _E : float\nval _LN2 : float\nval _LN10 : float\nval _LOG2E : float\nval _LOG10E : float\nval _PI : float\nval _SQRT1_2 : float\nval _SQRT2 : float\nval abs_int : int -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval abs_float : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval acos : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval acosh : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval asin : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval asinh : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval atan : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval atanh : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval atan2 : y:float -> x:float -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval cbrt : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval unsafe_ceil_int : float -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval ceil_int : float -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval ceil_float : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval clz32 : int -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval cos : float -> float\nval cosh : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval exp : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval expm1 : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval unsafe_floor_int : float -> int\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval floor_int : float -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval floor_float : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval fround : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval hypot : float -> float -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval hypotMany : float array -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval imul : int -> int -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval log : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval log1p : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval log10 : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval log2 : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval max_int : int -> int -> int\nval maxMany_int : int array -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval max_float : float -> float -> float\n\nval maxMany_float : float array -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval min_int : int -> int -> int\nval minMany_int : int array -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval min_float : float -> float -> float\n\nval minMany_float : float array -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval pow_float : base:float -> exp:float -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval random : unit -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval random_int : int -> int -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval unsafe_round : float -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval round : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval sign_int : int -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval sign_float : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval sin : float -> float\nval sinh : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval sqrt : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval tan : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval tanh : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval unsafe_trunc : float -> int [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval trunc : float -> float [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n"
},
{
"path": "packages/Js/lib/Js_null.ml",
"content": "type 'a t = 'a Js_internal.nullable\n\nexternal toOption : 'a t -> 'a option = \"%identity\"\nexternal fromOpt : 'a option -> 'a t = \"%identity\"\n\nlet empty = None\nlet return a = Some a\nlet getUnsafe a = match toOption a with None -> assert false | Some a -> a\nlet test = function None -> true | Some _ -> false\nlet getExn _ = Js_internal.notImplemented \"Js.Null\" \"getExn\"\nlet bind _ _ = Js_internal.notImplemented \"Js.Null\" \"bind\"\nlet iter _ _ = Js_internal.notImplemented \"Js.Null\" \"iter\"\nlet fromOption = fromOpt\nlet from_opt = fromOpt\n"
},
{
"path": "packages/Js/lib/Js_null.mli",
"content": "type 'a t = 'a Js_internal.nullable\n\nexternal toOption : 'a t -> 'a Js_internal.nullable = \"%identity\"\nexternal fromOpt : 'a Js_internal.nullable -> 'a t = \"%identity\"\nval empty : 'a Js_internal.nullable\nval return : 'a -> 'a Js_internal.nullable\nval getUnsafe : 'a t -> 'a\nval test : 'a Js_internal.nullable -> bool\nval getExn : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval bind : 'a -> 'b -> 'c [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval iter : 'a -> 'b -> 'c [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval fromOption : 'a Js_internal.nullable -> 'a t\nval from_opt : 'a Js_internal.nullable -> 'a t\n"
},
{
"path": "packages/Js/lib/Js_nullable.ml",
"content": "type 'a t = 'a option\n\nexternal toOption : 'a t -> 'a option = \"%identity\"\nexternal to_opt : 'a t -> 'a option = \"%identity\"\n\nlet return : 'a -> 'a t = fun x -> Some x\nlet isNullable : 'a t -> bool = function Some _ -> false | None -> true\nlet null : 'a t = None\nlet undefined : 'a t = None\nlet bind x f = match to_opt x with None -> ((x : 'a t) : 'b t) | Some x -> return (f x)\nlet iter x f = match to_opt x with None -> () | Some x -> f x\nlet fromOption x = match x with None -> undefined | Some x -> return x\nlet from_opt = fromOption\n"
},
{
"path": "packages/Js/lib/Js_nullable.mli",
"content": "type 'a t = 'a Js_internal.nullable\n\nexternal toOption : 'a t -> 'a Js_internal.nullable = \"%identity\"\nexternal to_opt : 'a t -> 'a Js_internal.nullable = \"%identity\"\nval return : 'a -> 'a t\nval isNullable : 'a t -> bool\nval null : 'a t\nval undefined : 'a t\nval bind : 'b t -> ('b -> 'b) -> 'b t\nval iter : 'a t -> ('a -> unit) -> unit\nval fromOption : 'a Js_internal.nullable -> 'a t\nval from_opt : 'a Js_internal.nullable -> 'a t\n"
},
{
"path": "packages/Js/lib/Js_obj.ml",
"content": "(** Provide utilities for {!Js.t} *)\n\nmodule Internal = struct\n module Registry = Ephemeron.K1.Make (struct\n type t = Obj.t\n\n let equal (left : t) (right : t) = left == right\n let hash = Hashtbl.hash\n end)\n\n type entry = {\n method_name : string;\n js_name : string;\n mutable present : bool;\n get_boxed : unit -> Obj.t;\n set_boxed : Obj.t -> unit;\n }\n\n type metadata = {\n mutable order_rev : string list;\n mutable cached_keys : string array option;\n entries : (string, entry) Hashtbl.t;\n }\n\n let registry : metadata Registry.t = Registry.create 16\n let empty_metadata () = { order_rev = []; cached_keys = Some [||]; entries = Hashtbl.create 8 }\n\n let add_key_in_order metadata js_name =\n metadata.order_rev <- js_name :: metadata.order_rev;\n metadata.cached_keys <- None\n\n let keys_in_order metadata =\n match metadata.cached_keys with\n | Some keys -> keys\n | None ->\n let keys = Array.of_list (List.rev metadata.order_rev) in\n metadata.cached_keys <- Some keys;\n keys\n\n let raw_entry ~method_name ~js_name ~present value =\n let cell = ref value in\n { method_name; js_name; present; get_boxed = (fun () -> !cell); set_boxed = (fun next -> cell := next) }\n\n let slot_ref ~method_name ~js_name ~present initial =\n let cell = ref initial in\n let entry =\n {\n method_name;\n js_name;\n present;\n get_boxed = (fun () -> Obj.repr !cell);\n set_boxed = (fun next -> cell := Obj.obj next);\n }\n in\n (cell, entry)\n\n let get_metadata object_ = Registry.find_opt registry (Obj.repr object_)\n\n let ensure_metadata object_ =\n match get_metadata object_ with\n | Some metadata -> metadata\n | None ->\n let metadata = empty_metadata () in\n Registry.add registry (Obj.repr object_) metadata;\n metadata\n\n let register_entry metadata entry =\n let was_present =\n match Hashtbl.find_opt metadata.entries entry.js_name with Some existing -> existing.present | None -> false\n in\n Hashtbl.replace metadata.entries entry.js_name entry;\n if entry.present && not was_present then add_key_in_order metadata entry.js_name\n\n let register_structural object_ entries =\n let metadata = empty_metadata () in\n List.iter (register_entry metadata) entries;\n Registry.replace registry (Obj.repr object_) metadata;\n object_\n\n let clone_entry entry =\n raw_entry ~method_name:entry.method_name ~js_name:entry.js_name ~present:entry.present (entry.get_boxed ())\n\n let present_entries metadata =\n Array.fold_right\n (fun key acc ->\n match Hashtbl.find_opt metadata.entries key with\n | Some entry when entry.present -> entry :: acc\n | Some _ | None -> acc)\n (keys_in_order metadata) []\n\n let build metadata =\n let present_entries = present_entries metadata in\n let object_ : < .. > =\n match present_entries with\n | [] -> ((object end : < >) :> < .. >)\n | _ ->\n let table =\n CamlinternalOO.create_table (Array.of_list (List.map (fun entry -> entry.method_name) present_entries))\n in\n CamlinternalOO.init_class table;\n let object_ = CamlinternalOO.create_object table in\n List.iter\n (fun entry ->\n let label = CamlinternalOO.get_method_label table entry.method_name in\n let closure : CamlinternalOO.meth =\n Obj.obj (Obj.repr (fun (_self : CamlinternalOO.obj) -> entry.get_boxed ()))\n in\n CamlinternalOO.set_method table label closure)\n present_entries;\n CamlinternalOO.run_initializers object_ table;\n Obj.obj (Obj.repr object_)\n in\n Registry.replace registry (Obj.repr object_) metadata;\n object_\n\n let copy_present_entries_into target_metadata source =\n match get_metadata source with\n | None -> ()\n | Some source_metadata ->\n Array.iter\n (fun key ->\n match Hashtbl.find_opt source_metadata.entries key with\n | None -> ()\n | Some source_entry -> (\n match Hashtbl.find_opt target_metadata.entries key with\n | Some target_entry ->\n target_entry.set_boxed (source_entry.get_boxed ());\n if not target_entry.present then add_key_in_order target_metadata key;\n target_entry.present <- true\n | None ->\n let cloned_entry = clone_entry source_entry in\n Hashtbl.add target_metadata.entries key cloned_entry;\n if cloned_entry.present then add_key_in_order target_metadata key))\n (keys_in_order source_metadata)\n\n let assign_into target source =\n let target_metadata = ensure_metadata target in\n copy_present_entries_into target_metadata source;\n target\n\n let register_abstract object_ entries = Obj.obj (Obj.repr (register_structural object_ entries))\nend\n\nlet empty () : < .. > = Internal.register_abstract ((object end : < >) :> < .. >) []\nlet assign target source = Internal.assign_into target source\n\nlet merge () left right : < .. > =\n let metadata = Internal.empty_metadata () in\n Internal.copy_present_entries_into metadata left;\n Internal.copy_present_entries_into metadata right;\n let object_ : < .. > = Internal.build metadata in\n Obj.obj (Obj.repr object_)\n\nlet keys object_ =\n match Internal.get_metadata object_ with\n | None -> [||]\n | Some metadata -> Array.copy (Internal.keys_in_order metadata)\n"
},
{
"path": "packages/Js/lib/Js_obj.mli",
"content": "(** Provide utilities for {!Js.t} *)\n\nval empty : unit -> < .. >\nval assign : (< .. > as 'a) -> < .. > -> 'a\nval merge : unit -> < .. > -> < .. > -> < .. >\nval keys : _ -> string array\n\n(**/**)\n\nmodule Internal : sig\n type entry\n\n val slot_ref : method_name:string -> js_name:string -> present:bool -> 'a -> 'a ref * entry\n val register_structural : (< .. > as 'a) -> entry list -> 'a\n val register_abstract : < .. > -> entry list -> 'a\nend\n"
},
{
"path": "packages/Js/lib/Js_promise.ml",
"content": "type +'a t = 'a Lwt.t\ntype error = exn\n\nlet make (fn : resolve:('a -> unit) -> reject:(exn -> unit) -> unit) : 'a t =\n let promise, resolver = Lwt.task () in\n let resolve value = Lwt.wakeup_later resolver value in\n let reject exn = Lwt.wakeup_later_exn resolver exn in\n fn ~resolve ~reject;\n promise\n\nlet resolve = Lwt.return\nlet reject = Lwt.fail\nlet all (promises : 'a t array) : 'a array t = Lwt.map Stdlib.Array.of_list (Lwt.all (Stdlib.Array.to_list promises))\n\nlet all2 (a, b) =\n let%lwt res_a = a in\n let%lwt res_b = b in\n Lwt.return (res_a, res_b)\n\nlet all3 (a, b, c) =\n let%lwt res_a = a in\n let%lwt res_b = b in\n let%lwt res_c = c in\n Lwt.return (res_a, res_b, res_c)\n\nlet all4 (a, b, c, d) =\n let%lwt res_a = a in\n let%lwt res_b = b in\n let%lwt res_c = c in\n let%lwt res_d = d in\n Lwt.return (res_a, res_b, res_c, res_d)\n\nlet all5 (a, b, c, d, e) =\n let%lwt res_a = a in\n let%lwt res_b = b in\n let%lwt res_c = c in\n let%lwt res_d = d in\n let%lwt res_e = e in\n Lwt.return (res_a, res_b, res_c, res_d, res_e)\n\nlet all6 (a, b, c, d, e, f) =\n let%lwt res_a = a in\n let%lwt res_b = b in\n let%lwt res_c = c in\n let%lwt res_d = d in\n let%lwt res_e = e in\n let%lwt res_f = f in\n Lwt.return (res_a, res_b, res_c, res_d, res_e, res_f)\n\nlet race (promises : 'a t array) : 'a t = Lwt.pick (Stdlib.Array.to_list promises)\nlet then_ p fn = Lwt.bind fn p\nlet catch (handler : exn -> 'a t) (promise : 'a t) : 'a t = Lwt.catch (fun () -> promise) handler\n"
},
{
"path": "packages/Js/lib/Js_promise.mli",
"content": "type 'a t = 'a Lwt.t\ntype error = exn\n\nval make : (resolve:('a -> unit) -> reject:(exn -> unit) -> unit) -> 'a Lwt.t\nval resolve : 'a -> 'a Lwt.t\nval reject : exn -> 'a Lwt.t\nval all : 'a Lwt.t array -> 'a array Lwt.t\nval all2 : 'a Lwt.t * 'b Lwt.t -> ('a * 'b) Lwt.t\nval all3 : 'a Lwt.t * 'b Lwt.t * 'c Lwt.t -> ('a * 'b * 'c) Lwt.t\nval all4 : 'a Lwt.t * 'b Lwt.t * 'c Lwt.t * 'd Lwt.t -> ('a * 'b * 'c * 'd) Lwt.t\nval all5 : 'a Lwt.t * 'b Lwt.t * 'c Lwt.t * 'd Lwt.t * 'e Lwt.t -> ('a * 'b * 'c * 'd * 'e) Lwt.t\nval all6 : 'a Lwt.t * 'b Lwt.t * 'c Lwt.t * 'd Lwt.t * 'e Lwt.t * 'f Lwt.t -> ('a * 'b * 'c * 'd * 'e * 'f) Lwt.t\nval race : 'a Lwt.t array -> 'a Lwt.t\nval then_ : ('a -> 'b Lwt.t) -> 'a Lwt.t -> 'b Lwt.t\nval catch : (exn -> 'a Lwt.t) -> 'a Lwt.t -> 'a Lwt.t\n"
},
{
"path": "packages/Js/lib/Js_re.ml",
"content": "(** Provide bindings to Js regex expression *)\n\n(* The RegExp object *)\ntype t = Quickjs.RegExp.t\n\n(* The result of a executing a RegExp on a string. *)\ntype result = Quickjs.RegExp.result\n\n(* Maps with nullable since Melange does too: https://melange.re/v3.0.0/api/re/melange/Js/Re/index.html#val-captures *)\nlet captures : result -> string Js_internal.nullable array =\n fun result -> Quickjs.RegExp.captures result |> Stdlib.Array.map (fun x -> Some x)\n\nlet index : result -> int = Quickjs.RegExp.index\nlet input : result -> string = Quickjs.RegExp.input\nlet source : t -> string = Quickjs.RegExp.source\n\nlet fromString : string -> t =\n fun str ->\n match Quickjs.RegExp.compile str ~flags:\"\" with\n | Ok regex -> regex\n | Error err -> raise (Invalid_argument (Quickjs.RegExp.compile_error_to_string err))\n\nlet fromStringWithFlags : string -> flags:string -> t =\n fun str ~flags ->\n match Quickjs.RegExp.compile str ~flags with\n | Ok regex -> regex\n | Error err -> raise (Invalid_argument (Quickjs.RegExp.compile_error_to_string err))\n\nlet flags : t -> string = fun regexp -> Quickjs.RegExp.flags regexp\nlet global : t -> bool = fun regexp -> Quickjs.RegExp.global regexp\nlet ignoreCase : t -> bool = fun regexp -> Quickjs.RegExp.ignorecase regexp\nlet multiline : t -> bool = fun regexp -> Quickjs.RegExp.multiline regexp\nlet sticky : t -> bool = fun regexp -> Quickjs.RegExp.sticky regexp\nlet unicode : t -> bool = fun regexp -> Quickjs.RegExp.unicode regexp\nlet dotAll : t -> bool = fun regexp -> Quickjs.RegExp.dotall regexp\nlet lastIndex : t -> int = fun regex -> Quickjs.RegExp.last_index regex\nlet setLastIndex : t -> int -> unit = fun regex index -> Quickjs.RegExp.set_last_index regex index\n\nlet exec : str:string -> t -> result option =\n fun ~str rex -> match Quickjs.RegExp.exec rex str with result -> Some result | exception _ -> None\n\nlet test_ : t -> string -> bool = fun regexp str -> Quickjs.RegExp.test regexp str\nlet test : str:string -> t -> bool = fun ~str regex -> test_ regex str\n\n(* Named capture groups *)\nlet groups : result -> (string * string) list = Quickjs.RegExp.groups\nlet group : string -> result -> string option = Quickjs.RegExp.group\n"
},
{
"path": "packages/Js/lib/Js_re.mli",
"content": "type t\ntype result\n\nval index : result -> int\nval input : result -> string\nval fromString : string -> t\nval fromStringWithFlags : string -> flags:string -> t\nval flags : t -> string\nval global : t -> bool\nval ignoreCase : t -> bool\nval lastIndex : t -> int\nval setLastIndex : t -> int -> unit\nval multiline : t -> bool\nval source : t -> string\nval sticky : t -> bool\nval unicode : t -> bool\n\nval dotAll : t -> bool\n(** Returns whether the dotAll (s) flag is set *)\n\nval exec : str:string -> t -> result option\nval test : str:string -> t -> bool\nval captures : result -> string Js_internal.nullable array\n\nval groups : result -> (string * string) list\n(** Returns all named capture groups as a list of (name, value) pairs *)\n\nval group : string -> result -> string option\n(** Returns the value of a named capture group, or None if not found *)\n"
},
{
"path": "packages/Js/lib/Js_set.ml",
"content": "(** Provides bindings for ES6 Set *)\n\ntype 'a t\n"
},
{
"path": "packages/Js/lib/Js_set.mli",
"content": "(** Provides bindings for ES6 Set *)\n\ntype 'a t\n"
},
{
"path": "packages/Js/lib/Js_string.ml",
"content": "(** JavaScript String API *)\n\ntype t = string\n\nlet make _whatever = Js_internal.notImplemented \"Js.String\" \"make\"\n\nlet fromCharCode code =\n let uchar = Uchar.of_int code in\n let char_value = Uchar.to_char uchar in\n Stdlib.String.make 1 char_value\n\nlet fromCharCodeMany _ = Js_internal.notImplemented \"Js.String\" \"fromCharCodeMany\"\n\nlet fromCodePoint code_point =\n let ch = Char.chr code_point in\n Stdlib.String.make 1 ch\n\nlet fromCodePointMany _ = Js_internal.notImplemented \"Js.String\" \"fromCodePointMany\"\nlet length = Stdlib.String.length\n\nlet get str index =\n let ch = Stdlib.String.get str index in\n Stdlib.String.make 1 ch\n\n(* TODO (davesnx): If the string contains characters outside the range [\\u0000-\\uffff], it will return the first 16-bit value at that position in the string. *)\nlet charAt ~index str =\n if index < 0 || index >= Stdlib.String.length str then \"\"\n else\n let ch = Stdlib.String.get str index in\n Stdlib.String.make 1 ch\n\nlet charCodeAt ~index:n s =\n if n < 0 || n >= Stdlib.String.length s then nan else float_of_int (Stdlib.Char.code (Stdlib.String.get s n))\n\nlet codePointAt ~index str =\n let str_length = Stdlib.String.length str in\n if index >= 0 && index < str_length then\n let uchar = Uchar.of_char (Stdlib.String.get str index) in\n Some (Uchar.to_int uchar)\n else None\n\nlet concat ~other:str2 str1 = Stdlib.String.concat \"\" [ str1; str2 ]\n\nlet concatMany ~strings:many original =\n let many_list = Stdlib.Array.to_list many in\n Stdlib.String.concat \"\" (original :: many_list)\n\nlet endsWith ~suffix ?len str =\n let str_length = Stdlib.String.length str in\n let end_idx = match len with Some i -> Stdlib.min str_length i | None -> str_length in\n let sub_str = Stdlib.String.sub str 0 end_idx in\n Stdlib.String.ends_with ~suffix sub_str\n\nlet includes ~search ?start str =\n let str_length = Stdlib.String.length str in\n let search_length = Stdlib.String.length search in\n let rec includes_helper idx =\n if idx + search_length > str_length then false\n else if Stdlib.String.sub str idx search_length = search then true\n else includes_helper (idx + 1)\n in\n let from = match start with None -> 0 | Some f -> f in\n includes_helper from\n\nlet indexOf ~search ?start str =\n let str_length = Stdlib.String.length str in\n let search_length = Stdlib.String.length search in\n let rec index_helper idx =\n if idx + search_length > str_length then -1\n else if Stdlib.String.sub str idx search_length = search then idx\n else index_helper (idx + 1)\n in\n let from = match start with None -> 0 | Some f -> f in\n index_helper from\n\nlet lastIndexOf ~search ?(start = max_int) str =\n let len = String.length str in\n let rec find_index i =\n if i < 0 || i > start then -1\n else\n let sub_len = min (len - i) (String.length search) in\n if String.sub str i sub_len = search then i else find_index (i - 1)\n in\n find_index (min (len - 1) start)\n\nlet localeCompare ~other:_ _ = Js_internal.notImplemented \"Js.String\" \"localeCompare\"\n\nlet match_ ~regexp str =\n let match_next str regex =\n match Js_re.exec ~str regex with None -> None | Some result -> Some (Js_re.captures result)\n in\n\n let match_all : t -> Js_re.t -> t Js_internal.nullable array Js_internal.nullable =\n fun str regex ->\n match match_next str regex with\n | None -> None\n | Some result -> (\n match match_next str regex with None -> Some result | Some second -> Some (Stdlib.Array.append result second))\n in\n\n if Js_re.global regexp then match_all str regexp else match_next str regexp\n\nlet normalize ?(form = `NFC) str =\n let normalization =\n match form with\n | `NFC -> Quickjs.String.NFC\n | `NFD -> Quickjs.String.NFD\n | `NFKC -> Quickjs.String.NFKC\n | `NFKD -> Quickjs.String.NFKD\n in\n match Quickjs.String.Prototype.normalize normalization str with Some s -> s | None -> str\n\n(* TODO(davesnx): RangeError *)\nlet repeat ~count str =\n let rec repeat' str acc remaining = if remaining <= 0 then acc else repeat' str (str ^ acc) (remaining - 1) in\n repeat' str \"\" count\n\n(* If pattern is a string, only the first occurrence will be replaced.\n https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace *)\nlet replace ~search ~replacement str =\n let search_regexp = Str.regexp_string search in\n Str.replace_first search_regexp replacement str\n\n(* Process replacement string with backreferences like $1, $2, $&, $$, $`, $' *)\nlet process_replacement ~replacement ~matches ~prefix ~suffix =\n let len = String.length replacement in\n let buf = Buffer.create len in\n let i = ref 0 in\n while !i < len do\n if replacement.[!i] = '$' && !i + 1 < len then (\n let next = replacement.[!i + 1] in\n match next with\n | '$' ->\n (* $$ -> literal $ *)\n Buffer.add_char buf '$';\n i := !i + 2\n | '&' ->\n (* $& -> the matched substring *)\n let matched = Stdlib.Array.get matches 0 |> Option.value ~default:\"\" in\n Buffer.add_string buf matched;\n i := !i + 2\n | '`' ->\n (* $` -> portion before the match *)\n Buffer.add_string buf prefix;\n i := !i + 2\n | '\\'' ->\n (* $' -> portion after the match *)\n Buffer.add_string buf suffix;\n i := !i + 2\n | '0' .. '9' ->\n (* $n or $nn -> capturing group *)\n let start_digit = !i + 1 in\n (* Check for two-digit group number *)\n let group_num, advance =\n if !i + 2 < len then\n match replacement.[!i + 2] with\n | '0' .. '9' ->\n let two_digit = int_of_string (String.sub replacement start_digit 2) in\n if two_digit < Array.length matches then (two_digit, 3) else (Char.code next - Char.code '0', 2)\n | _ -> (Char.code next - Char.code '0', 2)\n else (Char.code next - Char.code '0', 2)\n in\n if group_num > 0 && group_num < Array.length matches then\n let group_value = Stdlib.Array.get matches group_num |> Option.value ~default:\"\" in\n Buffer.add_string buf group_value\n else (\n (* Invalid group reference, keep as literal *)\n Buffer.add_char buf '$';\n Buffer.add_char buf next;\n if advance = 3 then Buffer.add_char buf replacement.[!i + 2]);\n i := !i + advance\n | _ ->\n (* Unknown $ sequence, keep as literal *)\n Buffer.add_char buf '$';\n incr i)\n else (\n Buffer.add_char buf replacement.[!i];\n incr i)\n done;\n Buffer.contents buf\n\nlet replaceByRe ~regexp ~replacement str =\n let rec replace_all str =\n Js_re.setLastIndex regexp 0;\n match Js_re.exec ~str regexp with\n | None -> str\n | Some result when Stdlib.Array.length (Js_re.captures result) == 0 -> str\n | Some result ->\n let matches = Js_re.captures result in\n let matched_str = Stdlib.Array.get matches 0 |> Option.get in\n let prefix = Stdlib.String.sub str 0 (Js_re.index result) in\n let suffix_start = Js_re.index result + String.length matched_str in\n let suffix = Stdlib.String.sub str suffix_start (String.length str - suffix_start) in\n let processed_replacement = process_replacement ~replacement ~matches ~prefix ~suffix in\n Js_re.setLastIndex regexp suffix_start;\n prefix ^ processed_replacement ^ replace_all suffix\n in\n let replace_first str =\n match Js_re.exec ~str regexp with\n | None -> str\n | Some result ->\n let matches = Js_re.captures result in\n let matched_str = Stdlib.Array.get matches 0 |> Option.get in\n let prefix = Stdlib.String.sub str 0 (Js_re.index result) in\n let suffix_start = Js_re.index result + String.length matched_str in\n let suffix = Stdlib.String.sub str suffix_start (String.length str - suffix_start) in\n let processed_replacement = process_replacement ~replacement ~matches ~prefix ~suffix in\n prefix ^ processed_replacement ^ suffix\n in\n\n if Js_re.global regexp then replace_all str else replace_first str\n\nlet unsafeReplaceBy0 ~regexp:_ ~f:_ _ = Js_internal.notImplemented \"Js.String\" \"unsafeReplaceBy0\"\nlet unsafeReplaceBy1 ~regexp:_ ~f:_ _ = Js_internal.notImplemented \"Js.String\" \"unsafeReplaceBy1\"\nlet unsafeReplaceBy2 ~regexp:_ ~f:_ _ = Js_internal.notImplemented \"Js.String\" \"unsafeReplaceBy2\"\nlet unsafeReplaceBy3 ~regexp:_ ~f:_ _ = Js_internal.notImplemented \"Js.String\" \"unsafeReplaceBy3\"\n\nlet search ~regexp str =\n (* Save and reset lastIndex for consistent behavior *)\n let saved_last_index = Js_re.lastIndex regexp in\n Js_re.setLastIndex regexp 0;\n let result =\n if Js_re.test ~str regexp then (\n (* Reset lastIndex again since test modified it *)\n Js_re.setLastIndex regexp 0;\n match Js_re.exec ~str regexp with Some result -> Js_re.index result | None -> -1)\n else -1\n in\n Js_re.setLastIndex regexp saved_last_index;\n result\n\nlet slice ?start ?end_ str =\n let str_length = Stdlib.String.length str in\n let start = match start with None -> 0 | Some s -> s in\n let end_ = match end_ with None -> str_length | Some s -> s in\n let start_idx = Stdlib.max 0 (Stdlib.min start str_length) in\n let end_idx = Stdlib.max start_idx (Stdlib.min end_ str_length) in\n if start_idx >= end_idx then \"\" else Stdlib.String.sub str start_idx (end_idx - start_idx)\n\nlet split ?sep ?limit str =\n let sep = Option.value sep ~default:str in\n let regexp = Str.regexp_string sep in\n (* On js split, it don't return an empty string on end when separator is an empty string *)\n (* but \"split_delim\" does *)\n (* https://melange.re/unstable/playground/?language=OCaml&code=SnMubG9nKEpzLlN0cmluZy5zcGxpdCB%2Bc2VwOiIiICJzdGFydCIpOw%3D%3D&live=off *)\n let split = if sep <> \"\" then Str.split_delim else Str.split in\n let items = split regexp str |> Stdlib.Array.of_list in\n let limit = Option.value limit ~default:(Stdlib.Array.length items) in\n match limit with\n | limit when limit >= 0 && limit < Stdlib.Array.length items -> Stdlib.Array.sub items 0 limit\n | _ -> items\n\nlet splitByRe ~regexp ?limit str =\n let rev_array arr = arr |> Stdlib.Array.to_list |> Stdlib.List.rev |> Stdlib.Array.of_list in\n let rec split_all str acc =\n Js_re.setLastIndex regexp 0;\n match Js_re.exec ~str regexp with\n | Some result when Stdlib.Array.length (Js_re.captures result) = 0 ->\n Stdlib.Array.append [| Some str |] acc |> rev_array\n | None -> Stdlib.Array.append [| Some str |] acc |> rev_array\n | Some result ->\n let matches = Js_re.captures result in\n let matched_str = Stdlib.Array.get matches 0 |> Option.get in\n let prefix = String.sub str 0 (Js_re.index result) in\n let suffix_start = Js_re.index result + String.length matched_str in\n let suffix = String.sub str suffix_start (String.length str - suffix_start) in\n let suffix_matches = Stdlib.Array.append [| Some prefix |] acc in\n split_all suffix suffix_matches\n in\n\n let split_next str acc =\n Js_re.setLastIndex regexp 0;\n match Js_re.exec ~str regexp with\n | None -> Stdlib.Array.append [| Some str |] acc |> rev_array\n | Some result ->\n let matches = Js_re.captures result in\n let matched_str = Stdlib.Array.get matches 0 |> Option.get in\n let index = Js_re.index result in\n let prefix = String.sub str 0 index in\n let suffix_start = index + String.length matched_str in\n let suffix = String.sub str suffix_start (String.length str - suffix_start) in\n Stdlib.Array.append [| Some prefix |] (split_all suffix acc)\n in\n\n let _ = limit in\n if Js_re.global regexp then split_all str [||] else split_next str [||]\n\nlet startsWith ~prefix ?(start = 0) str =\n let len_prefix = String.length prefix in\n let len_str = String.length str in\n if start < 0 || start > len_str then false\n else\n let rec compare_prefix i =\n i = len_prefix || (i < len_str && prefix.[i] = str.[start + i] && compare_prefix (i + 1))\n in\n compare_prefix 0\n\nlet substr ?(start = 0) ?len str =\n let str_length = Stdlib.String.length str in\n let len = match len with None -> str_length | Some s -> s in\n let start_idx = max 0 (min start str_length) in\n let end_idx = min (start_idx + len) str_length in\n if start_idx >= end_idx then \"\" else Stdlib.String.sub str start_idx (end_idx - start_idx)\n\nlet substring ?start ?end_ str =\n let str_length = Stdlib.String.length str in\n let start = match start with None -> 0 | Some s -> s in\n let end_ = match end_ with None -> str_length | Some s -> s in\n let start_idx = max 0 (min start str_length) in\n let end_idx = max 0 (min end_ str_length) in\n if start_idx >= end_idx then Stdlib.String.sub str end_idx (start_idx - end_idx)\n else Stdlib.String.sub str start_idx (end_idx - start_idx)\n\nlet case_to_utf_8 case_map s =\n let rec loop buf s i max =\n if i > max then Buffer.contents buf\n else\n let dec = String.get_utf_8_uchar s i in\n let u = Uchar.utf_decode_uchar dec in\n (match case_map u with\n | `Self -> Buffer.add_utf_8_uchar buf u\n | `Uchars us -> List.iter (Buffer.add_utf_8_uchar buf) us);\n loop buf s (i + Uchar.utf_decode_length dec) max\n in\n let buf = Buffer.create (String.length s * 2) in\n loop buf s 0 (String.length s - 1)\n\nlet toLowerCase s = case_to_utf_8 Uucp.Case.Map.to_lower s\nlet toLocaleLowerCase _ = Js_internal.notImplemented \"Js.String\" \"toLocaleLowerCase\"\nlet toUpperCase s = case_to_utf_8 Uucp.Case.Map.to_upper s\nlet toLocaleUpperCase _ = Js_internal.notImplemented \"Js.String\" \"toLocaleUpperCase\"\n\nlet trim str =\n let whitespace = \" \\t\\n\\r\" in\n let is_whitespace c = Stdlib.String.contains whitespace c in\n let length = Stdlib.String.length str in\n let rec trim_start idx =\n if idx >= length then length else if is_whitespace (Stdlib.String.get str idx) then trim_start (idx + 1) else idx\n in\n let rec trim_end idx =\n if idx <= 0 then 0 else if is_whitespace (Stdlib.String.get str (idx - 1)) then trim_end (idx - 1) else idx\n in\n let start_idx = trim_start 0 in\n let end_idx = trim_end length in\n if start_idx >= end_idx then \"\" else Stdlib.String.sub str start_idx (end_idx - start_idx)\n\nlet anchor ~name:_ _ = Js_internal.notImplemented \"Js.String\" \"anchor\"\nlet link ~href:_ _ = Js_internal.notImplemented \"Js.String\" \"link\"\n"
},
{
"path": "packages/Js/lib/Js_string.mli",
"content": "(** JavaScript String API *)\n\ntype t = string\n\nval make : 'a -> t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval fromCharCode : int -> t\n\nval fromCharCodeMany : int array -> t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval fromCodePoint : int -> t\n\nval fromCodePointMany : int array -> t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval length : t -> int\nval get : t -> int -> t\nval charAt : index:int -> t -> t\nval charCodeAt : index:int -> t -> float\nval codePointAt : index:int -> t -> int Js_internal.nullable\nval concat : other:t -> t -> t\nval concatMany : strings:t array -> t -> t\nval endsWith : suffix:t -> ?len:int -> t -> bool\nval includes : search:t -> ?start:int -> t -> bool\nval indexOf : search:t -> ?start:int -> t -> int\nval lastIndexOf : search:t -> ?start:int -> t -> int\n\nval localeCompare : other:t -> t -> float\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval match_ : regexp:Js_re.t -> t -> t Js_internal.nullable array Js_internal.nullable\n\nval normalize : ?form:[ `NFC | `NFD | `NFKC | `NFKD ] -> t -> t\n(** Returns the Unicode Normalization Form of a string. *)\n\nval repeat : count:int -> t -> t\nval replace : search:t -> replacement:t -> t -> t\nval replaceByRe : regexp:Js_re.t -> replacement:t -> t -> t\n\nval unsafeReplaceBy0 : regexp:Js_re.t -> f:(t -> int -> t -> t) -> t -> t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval unsafeReplaceBy1 : regexp:Js_re.t -> f:(t -> t -> int -> t -> t) -> t -> t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval unsafeReplaceBy2 : regexp:Js_re.t -> f:(t -> t -> t -> int -> t -> t) -> t -> t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval unsafeReplaceBy3 : regexp:Js_re.t -> f:(t -> t -> t -> t -> int -> t -> t) -> t -> t\n[@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\nval search : regexp:Js_re.t -> t -> int\n(** Searches for a match in a string. Returns the index of the first match, or -1 if not found. *)\n\nval slice : ?start:int -> ?end_:int -> t -> t\nval split : ?sep:t -> ?limit:int -> t -> t array\nval splitByRe : regexp:Js_re.t -> ?limit:int -> t -> t Js_internal.nullable array\nval startsWith : prefix:t -> ?start:int -> t -> bool\nval substr : ?start:int -> ?len:int -> t -> t\nval substring : ?start:int -> ?end_:int -> t -> t\nval toLowerCase : t -> t\nval toLocaleLowerCase : t -> t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval toUpperCase : t -> t\nval toLocaleUpperCase : t -> t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval trim : t -> t\nval anchor : name:t -> t -> t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval link : href:t -> t -> t [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n"
},
{
"path": "packages/Js/lib/Js_typed_array.ml",
"content": "(** Provide bindings for JS typed array *)\n\nmodule Uint16Array = struct\n type t\nend\n\nmodule Uint8ClampedArray = struct\n type t\nend\n\nmodule Float32Array = struct\n type t\nend\n"
},
{
"path": "packages/Js/lib/Js_typed_array.mli",
"content": "(** Provide bindings for JS typed array *)\n\nmodule Uint16Array : sig\n type t\nend\n\nmodule Uint8ClampedArray : sig\n type t\nend\n\nmodule Float32Array : sig\n type t\nend\n"
},
{
"path": "packages/Js/lib/Js_typed_array2.ml",
"content": "(** Provide bindings for JS typed array *)\n"
},
{
"path": "packages/Js/lib/Js_typed_array2.mli",
"content": "(** Provide bindings for JS typed array *)\n"
},
{
"path": "packages/Js/lib/Js_types.ml",
"content": "(** Provide utilities for manipulating JS types *)\n\ntype symbol\n(**Js symbol type only available in ES6 *)\n\ntype bigint_val\n(** Js bigint type only available in ES2020 *)\n\ntype obj_val\n\ntype undefined_val\n(** This type has only one value [undefined] *)\n\ntype null_val\n(** This type has only one value [null] *)\n\ntype function_val\n\ntype _ t =\n | Undefined : undefined_val t\n | Null : null_val t\n | Boolean : bool t\n | Number : float t\n | String : string t\n | Function : function_val t\n | Object : obj_val t\n | Symbol : symbol t\n | BigInt : bigint_val t\n\n(** {[\n test \"x\" String = true\n ]}*)\nlet test _ _ = Js_internal.notImplemented \"Js.Types\" \"test\"\n\ntype tagged_t =\n | JSFalse\n | JSTrue\n | JSNull\n | JSUndefined\n | JSNumber of float\n | JSString of string\n | JSFunction of function_val\n | JSObject of obj_val\n | JSSymbol of symbol\n | JSBigInt of bigint_val\n\nlet classify _ = Js_internal.notImplemented \"Js.Types\" \"classify\"\n"
},
{
"path": "packages/Js/lib/Js_types.mli",
"content": "(** Provide utilities for manipulating JS types *)\n\ntype symbol\ntype bigint_val\ntype obj_val\ntype undefined_val\ntype null_val\ntype function_val\n\ntype _ t =\n | Undefined : undefined_val t\n | Null : null_val t\n | Boolean : bool t\n | Number : float t\n | String : string t\n | Function : function_val t\n | Object : obj_val t\n | Symbol : symbol t\n | BigInt : bigint_val t\n\nval test : 'a -> 'b -> 'c [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n\ntype tagged_t =\n | JSFalse\n | JSTrue\n | JSNull\n | JSUndefined\n | JSNumber of float\n | JSString of string\n | JSFunction of function_val\n | JSObject of obj_val\n | JSSymbol of symbol\n | JSBigInt of bigint_val\n\nval classify : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\n"
},
{
"path": "packages/Js/lib/Js_undefined.ml",
"content": "type 'a t = 'a Js_internal.undefined\n\nlet return a = Some a\nlet empty = None\n\nexternal toOption : 'a t -> 'a option = \"%identity\"\nexternal fromOpt : 'a option -> 'a t = \"%identity\"\n\nlet getExn _ = Js_internal.notImplemented \"Js.Undefined\" \"getExn\"\nlet getUnsafe a = match toOption a with None -> assert false | Some a -> a\nlet bind _ _ = Js_internal.notImplemented \"Js.Undefined\" \"bind\"\nlet iter _ _ = Js_internal.notImplemented \"Js.Undefined\" \"iter\"\nlet testAny _ = Js_internal.notImplemented \"Js.Undefined\" \"testAny\"\nlet test _ = Js_internal.notImplemented \"Js.Undefined\" \"test\"\nlet fromOption = fromOpt\nlet from_opt = fromOpt\n"
},
{
"path": "packages/Js/lib/Js_undefined.mli",
"content": "type 'a t = 'a Js_internal.nullable\n\nval return : 'a -> 'a t\nval empty : 'a Js_internal.nullable\nexternal toOption : 'a t -> 'a Js_internal.nullable = \"%identity\"\nexternal fromOpt : 'a Js_internal.nullable -> 'a t = \"%identity\"\nval getExn : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval getUnsafe : 'a t -> 'a\nval bind : 'a -> 'b -> 'c [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval iter : 'a -> 'b -> 'c [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval testAny : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval test : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval fromOption : 'a Js_internal.nullable -> 'a t\nval from_opt : 'a Js_internal.nullable -> 'a t\n"
},
{
"path": "packages/Js/lib/Js_vector.ml",
"content": "(** Provide utilities for Vector *)\n\ntype 'a t = 'a array\n\nlet filterInPlace _ = Js_internal.notImplemented \"Js.Vector\" \"filterInPlace\"\nlet empty _ = Js_internal.notImplemented \"Js.Vector\" \"empty\"\nlet pushBack _ = Js_internal.notImplemented \"Js.Vector\" \"pushBack\"\nlet copy _ = Js_internal.notImplemented \"Js.Vector\" \"copy\"\nlet memByRef _ = Js_internal.notImplemented \"Js.Vector\" \"memByRef\"\nlet iter _ = Js_internal.notImplemented \"Js.Vector\" \"iter\"\nlet iteri _ = Js_internal.notImplemented \"Js.Vector\" \"iteri\"\nlet toList _ = Js_internal.notImplemented \"Js.Vector\" \"toList\"\nlet map _ = Js_internal.notImplemented \"Js.Vector\" \"map\"\nlet mapi _ = Js_internal.notImplemented \"Js.Vector\" \"mapi\"\nlet foldLeft _ = Js_internal.notImplemented \"Js.Vector\" \"foldLeft\"\nlet foldRight _ = Js_internal.notImplemented \"Js.Vector\" \"foldRight\"\n\nexternal length : 'a t -> int = \"%array_length\"\nexternal get : 'a t -> int -> 'a = \"%array_safe_get\"\nexternal set : 'a t -> int -> 'a -> unit = \"%array_safe_set\"\nexternal make : int -> 'a -> 'a t = \"caml_make_vect\"\n\nlet init _ = Js_internal.notImplemented \"Js.Vector\" \"init\"\nlet append _ = Js_internal.notImplemented \"Js.Vector\" \"append\"\n\nexternal unsafe_get : 'a t -> int -> 'a = \"%array_unsafe_get\"\nexternal unsafe_set : 'a t -> int -> 'a -> unit = \"%array_unsafe_set\"\n"
},
{
"path": "packages/Js/lib/Js_vector.mli",
"content": "(** Provide utilities for Vector *)\n\ntype 'a t = 'a array\n\nval filterInPlace : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval empty : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval pushBack : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval copy : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval memByRef : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval iter : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval iteri : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval toList : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval map : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval mapi : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval foldLeft : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval foldRight : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nexternal length : 'a t -> int = \"%array_length\"\nexternal get : 'a t -> int -> 'a = \"%array_safe_get\"\nexternal set : 'a t -> int -> 'a -> unit = \"%array_safe_set\"\nexternal make : int -> 'a -> 'a t = \"caml_make_vect\"\nval init : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nval append : 'a -> 'b [@@alert not_implemented \"is not implemented in native under server-reason-react.js\"]\nexternal unsafe_get : 'a t -> int -> 'a = \"%array_unsafe_get\"\nexternal unsafe_set : 'a t -> int -> 'a -> unit = \"%array_unsafe_set\"\n"
},
{
"path": "packages/Js/lib/Js_weakmap.ml",
"content": "(** Provides bindings for ES6 WeakMap *)\n\ntype ('k, 'v) t\n"
},
{
"path": "packages/Js/lib/Js_weakmap.mli",
"content": "(** Provides bindings for ES6 WeakMap *)\n\ntype ('k, 'v) t\n"
},
{
"path": "packages/Js/lib/Js_weakset.ml",
"content": "(** Provides bindings for ES6 WeakSet *)\n\ntype 'a t\n"
},
{
"path": "packages/Js/lib/Js_weakset.mli",
"content": "(** Provides bindings for ES6 WeakSet *)\n\ntype 'a t\n"
},
{
"path": "packages/Js/lib/dune",
"content": "(library\n (name js)\n (public_name server-reason-react.js)\n (libraries quickjs lwt str uucp zarith unix)\n (preprocess\n (pps lwt_ppx)))\n"
},
{
"path": "packages/Js/test/bigint_tests/arithmetic.ml",
"content": "(** TC39 Test262: BigInt arithmetic tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt\n\n Tests for BigInt arithmetic operations: add, sub, mul, div, rem, pow, neg, abs *)\n\nopen Helpers\n\n(* ===================================================================\n Addition\n =================================================================== *)\n\nlet add_positive () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int 20 in\n assert_bigint (BigInt.add a b) (BigInt.of_int 30)\n\nlet add_negative () =\n let a = BigInt.of_int (-10) in\n let b = BigInt.of_int (-20) in\n assert_bigint (BigInt.add a b) (BigInt.of_int (-30))\n\nlet add_mixed () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int (-20) in\n assert_bigint (BigInt.add a b) (BigInt.of_int (-10))\n\nlet add_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.add a b) (BigInt.of_int 42)\n\nlet add_large () =\n (* Large number addition *)\n let a = BigInt.of_string \"9007199254740992\" in\n (* 2^53 *)\n let b = BigInt.of_int 1 in\n assert_bigint_string (BigInt.add a b) \"9007199254740993\"\n\n(* ===================================================================\n Subtraction\n =================================================================== *)\n\nlet sub_positive () =\n let a = BigInt.of_int 30 in\n let b = BigInt.of_int 10 in\n assert_bigint (BigInt.sub a b) (BigInt.of_int 20)\n\nlet sub_negative_result () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int 30 in\n assert_bigint (BigInt.sub a b) (BigInt.of_int (-20))\n\nlet sub_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.sub a b) (BigInt.of_int 42)\n\nlet sub_self () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.sub a a) (BigInt.of_int 0)\n\n(* ===================================================================\n Multiplication\n =================================================================== *)\n\nlet mul_positive () =\n let a = BigInt.of_int 6 in\n let b = BigInt.of_int 7 in\n assert_bigint (BigInt.mul a b) (BigInt.of_int 42)\n\nlet mul_negative () =\n let a = BigInt.of_int (-6) in\n let b = BigInt.of_int 7 in\n assert_bigint (BigInt.mul a b) (BigInt.of_int (-42))\n\nlet mul_both_negative () =\n let a = BigInt.of_int (-6) in\n let b = BigInt.of_int (-7) in\n assert_bigint (BigInt.mul a b) (BigInt.of_int 42)\n\nlet mul_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.mul a b) (BigInt.of_int 0)\n\nlet mul_one () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 1 in\n assert_bigint (BigInt.mul a b) (BigInt.of_int 42)\n\nlet mul_large () =\n (* From QuickJS: 3^100 *)\n let three = BigInt.of_int 3 in\n let result = ref (BigInt.of_int 1) in\n for _ = 1 to 100 do\n result := BigInt.mul !result three\n done;\n assert_bigint_string !result \"515377520732011331036461129765621272702107522001\"\n\n(* ===================================================================\n Division (truncates toward zero)\n =================================================================== *)\n\nlet div_exact () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 6 in\n assert_bigint (BigInt.div a b) (BigInt.of_int 7)\n\nlet div_truncate_positive () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int 3 in\n assert_bigint (BigInt.div a b) (BigInt.of_int 3)\n\nlet div_truncate_negative () =\n (* -10 / 3 = -3 (truncate toward zero, not floor) *)\n let a = BigInt.of_int (-10) in\n let b = BigInt.of_int 3 in\n assert_bigint (BigInt.div a b) (BigInt.of_int (-3))\n\nlet div_negative_divisor () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int (-3) in\n assert_bigint (BigInt.div a b) (BigInt.of_int (-3))\n\nlet div_both_negative () =\n let a = BigInt.of_int (-10) in\n let b = BigInt.of_int (-3) in\n assert_bigint (BigInt.div a b) (BigInt.of_int 3)\n\nlet div_large () =\n (* From QuickJS test *)\n let a = BigInt.of_string \"3213213213213213432453243\" in\n let b = BigInt.of_string \"123434343439\" in\n assert_bigint_string (BigInt.div a b) \"26031760073331\"\n\nlet div_large_negative () =\n let a = BigInt.of_string \"-3213213213213213432453243\" in\n let b = BigInt.of_string \"123434343439\" in\n assert_bigint_string (BigInt.div a b) \"-26031760073331\"\n\nlet div_by_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint_raises (fun () -> ignore (BigInt.div a b))\n\n(* ===================================================================\n Remainder\n =================================================================== *)\n\nlet rem_positive () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int 3 in\n assert_bigint (BigInt.rem a b) (BigInt.of_int 1)\n\nlet rem_negative_dividend () =\n (* -10 % 3 = -1 (sign follows dividend in JS) *)\n let a = BigInt.of_int (-10) in\n let b = BigInt.of_int 3 in\n assert_bigint (BigInt.rem a b) (BigInt.of_int (-1))\n\nlet rem_negative_divisor () =\n (* 10 % -3 = 1 (sign follows dividend) *)\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int (-3) in\n assert_bigint (BigInt.rem a b) (BigInt.of_int 1)\n\nlet rem_both_negative () =\n (* -10 % -3 = -1 *)\n let a = BigInt.of_int (-10) in\n let b = BigInt.of_int (-3) in\n assert_bigint (BigInt.rem a b) (BigInt.of_int (-1))\n\nlet rem_large () =\n (* From QuickJS test *)\n let a = BigInt.of_string \"-3213213213213213432453243\" in\n let b = BigInt.of_string \"-123434343439\" in\n assert_bigint_string (BigInt.rem a b) \"-26953727934\"\n\nlet rem_large_positive () =\n let a = BigInt.of_string \"3213213213213213432453243\" in\n let b = BigInt.of_string \"123434343439\" in\n assert_bigint_string (BigInt.rem a b) \"26953727934\"\n\nlet rem_by_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint_raises (fun () -> ignore (BigInt.rem a b))\n\n(* ===================================================================\n Exponentiation\n =================================================================== *)\n\nlet pow_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.pow a b) (BigInt.of_int 1)\n\nlet pow_one () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 1 in\n assert_bigint (BigInt.pow a b) (BigInt.of_int 42)\n\nlet pow_positive () =\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 10 in\n assert_bigint (BigInt.pow a b) (BigInt.of_int 1024)\n\nlet pow_negative_base () =\n (* (-2)^127 *)\n let a = BigInt.of_int (-2) in\n let b = BigInt.of_int 127 in\n assert_bigint_string (BigInt.pow a b) \"-170141183460469231731687303715884105728\"\n\nlet pow_large () =\n (* 2^127 *)\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 127 in\n assert_bigint_string (BigInt.pow a b) \"170141183460469231731687303715884105728\"\n\nlet pow_negative_exponent () =\n (* Negative exponent should raise - BigInt doesn't support fractions *)\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int (-1) in\n assert_bigint_raises (fun () -> ignore (BigInt.pow a b))\n\nlet pow_from_quickjs_1 () =\n (* (-256)^11 *)\n let a = BigInt.of_int (-256) in\n let b = BigInt.of_int 11 in\n assert_bigint_string (BigInt.pow a b) \"-309485009821345068724781056\"\n\nlet pow_from_quickjs_2 () =\n (* 7^20 *)\n let a = BigInt.of_int 7 in\n let b = BigInt.of_int 20 in\n assert_bigint_string (BigInt.pow a b) \"79792266297612001\"\n\n(* ===================================================================\n Unary negation\n =================================================================== *)\n\nlet neg_positive () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.neg a) (BigInt.of_int (-42))\n\nlet neg_negative () =\n let a = BigInt.of_int (-42) in\n assert_bigint (BigInt.neg a) (BigInt.of_int 42)\n\nlet neg_zero () =\n let a = BigInt.of_int 0 in\n assert_bigint (BigInt.neg a) (BigInt.of_int 0)\n\n(* ===================================================================\n Absolute value\n =================================================================== *)\n\nlet abs_positive () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.abs a) (BigInt.of_int 42)\n\nlet abs_negative () =\n let a = BigInt.of_int (-42) in\n assert_bigint (BigInt.abs a) (BigInt.of_int 42)\n\nlet abs_zero () =\n let a = BigInt.of_int 0 in\n assert_bigint (BigInt.abs a) (BigInt.of_int 0)\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* Addition *)\n test \"add: positive + positive\" add_positive;\n test \"add: negative + negative\" add_negative;\n test \"add: positive + negative\" add_mixed;\n test \"add: with zero\" add_zero;\n test \"add: large numbers\" add_large;\n (* Subtraction *)\n test \"sub: positive result\" sub_positive;\n test \"sub: negative result\" sub_negative_result;\n test \"sub: with zero\" sub_zero;\n test \"sub: self\" sub_self;\n (* Multiplication *)\n test \"mul: positive * positive\" mul_positive;\n test \"mul: negative * positive\" mul_negative;\n test \"mul: negative * negative\" mul_both_negative;\n test \"mul: with zero\" mul_zero;\n test \"mul: with one\" mul_one;\n test \"mul: 3^100\" mul_large;\n (* Division *)\n test \"div: exact division\" div_exact;\n test \"div: truncate positive\" div_truncate_positive;\n test \"div: truncate negative (toward zero)\" div_truncate_negative;\n test \"div: negative divisor\" div_negative_divisor;\n test \"div: both negative\" div_both_negative;\n test \"div: large numbers\" div_large;\n test \"div: large negative\" div_large_negative;\n test \"div: by zero throws\" div_by_zero;\n (* Remainder *)\n test \"rem: positive % positive\" rem_positive;\n test \"rem: negative dividend\" rem_negative_dividend;\n test \"rem: negative divisor\" rem_negative_divisor;\n test \"rem: both negative\" rem_both_negative;\n test \"rem: large numbers\" rem_large;\n test \"rem: large positive\" rem_large_positive;\n test \"rem: by zero throws\" rem_by_zero;\n (* Exponentiation *)\n test \"pow: exponent zero\" pow_zero;\n test \"pow: exponent one\" pow_one;\n test \"pow: 2^10\" pow_positive;\n test \"pow: (-2)^127\" pow_negative_base;\n test \"pow: 2^127\" pow_large;\n test \"pow: negative exponent throws\" pow_negative_exponent;\n test \"pow: (-256)^11\" pow_from_quickjs_1;\n test \"pow: 7^20\" pow_from_quickjs_2;\n (* Negation *)\n test \"neg: positive\" neg_positive;\n test \"neg: negative\" neg_negative;\n test \"neg: zero\" neg_zero;\n (* Absolute value *)\n test \"abs: positive\" abs_positive;\n test \"abs: negative\" abs_negative;\n test \"abs: zero\" abs_zero;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/as_int_n.ml",
"content": "(** TC39 Test262: BigInt.asIntN tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt/asIntN\n\n BigInt.asIntN(bits, bigint) wraps a BigInt value to a signed integer within the given number of bits. *)\n\nopen Helpers\nmodule BigInt = Js.Bigint\n\n(* ===================================================================\n Basic asIntN tests\n =================================================================== *)\n\nlet as_int_n_zero_bits () =\n (* asIntN(0, x) always returns 0n *)\n assert_bigint_equal (BigInt.as_int_n 0 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 0 (BigInt.of_int 1)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 0 (BigInt.of_int (-1))) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 0 (BigInt.of_int 100)) (BigInt.of_int 0)\n\nlet as_int_n_1_bit () =\n (* asIntN(1, x) returns 0n or -1n (sign bit only) *)\n assert_bigint_equal (BigInt.as_int_n 1 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 1 (BigInt.of_int 1)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 1 (BigInt.of_int 2)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 1 (BigInt.of_int 3)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 1 (BigInt.of_int (-1))) (BigInt.of_int (-1))\n\nlet as_int_n_8_bit () =\n (* asIntN(8, x) wraps to signed 8-bit integer (-128 to 127) *)\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int 127)) (BigInt.of_int 127);\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int 128)) (BigInt.of_int (-128));\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int 255)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int 256)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-1))) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-128))) (BigInt.of_int (-128));\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-129))) (BigInt.of_int 127)\n\nlet as_int_n_16_bit () =\n (* asIntN(16, x) wraps to signed 16-bit integer (-32768 to 32767) *)\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int 32767)) (BigInt.of_int 32767);\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int 32768)) (BigInt.of_int (-32768));\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int 65535)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int 65536)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int (-1))) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int (-32768))) (BigInt.of_int (-32768));\n assert_bigint_equal (BigInt.as_int_n 16 (BigInt.of_int (-32769))) (BigInt.of_int 32767)\n\nlet as_int_n_32_bit () =\n (* asIntN(32, x) wraps to signed 32-bit integer *)\n assert_bigint_equal (BigInt.as_int_n 32 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 32 (BigInt.of_int (-1))) (BigInt.of_int (-1));\n (* 2^31 - 1 = 2147483647 *)\n assert_bigint_equal (BigInt.as_int_n 32 (BigInt.of_string \"2147483647\")) (BigInt.of_string \"2147483647\");\n (* 2^31 = 2147483648 -> -2147483648 *)\n assert_bigint_equal (BigInt.as_int_n 32 (BigInt.of_string \"2147483648\")) (BigInt.of_string \"-2147483648\");\n (* 2^32 - 1 = 4294967295 -> -1 *)\n assert_bigint_equal (BigInt.as_int_n 32 (BigInt.of_string \"4294967295\")) (BigInt.of_int (-1));\n (* 2^32 = 4294967296 -> 0 *)\n assert_bigint_equal (BigInt.as_int_n 32 (BigInt.of_string \"4294967296\")) (BigInt.of_int 0)\n\nlet as_int_n_64_bit () =\n (* asIntN(64, x) wraps to signed 64-bit integer *)\n assert_bigint_equal (BigInt.as_int_n 64 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 64 (BigInt.of_int (-1))) (BigInt.of_int (-1));\n (* 2^63 - 1 stays the same *)\n let max_int64 = BigInt.of_string \"9223372036854775807\" in\n assert_bigint_equal (BigInt.as_int_n 64 max_int64) max_int64;\n (* 2^63 wraps to negative *)\n let two_63 = BigInt.of_string \"9223372036854775808\" in\n let neg_two_63 = BigInt.of_string \"-9223372036854775808\" in\n assert_bigint_equal (BigInt.as_int_n 64 two_63) neg_two_63\n\nlet as_int_n_preserves_small_positive () =\n (* Small positive values within range are preserved *)\n for i = 0 to 127 do\n let n = BigInt.of_int i in\n assert_bigint_equal (BigInt.as_int_n 8 n) n\n done\n\nlet as_int_n_preserves_small_negative () =\n (* Small negative values within range are preserved *)\n for i = -128 to -1 do\n let n = BigInt.of_int i in\n assert_bigint_equal (BigInt.as_int_n 8 n) n\n done\n\nlet as_int_n_wrapping () =\n (* Test wrapping behavior *)\n (* 300 in 8-bit signed = 300 - 256 = 44 *)\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int 300)) (BigInt.of_int 44);\n (* -300 in 8-bit signed = -300 + 256 = -44 *)\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-300))) (BigInt.of_int (-44))\n\nlet as_int_n_large_bits () =\n (* Test with larger bit sizes *)\n let x = BigInt.of_string \"123456789012345678901234567890\" in\n (* With very large bits, value should be preserved *)\n assert_bigint_equal (BigInt.as_int_n 256 x) x\n\nlet as_int_n_negative_input () =\n (* asIntN with negative input *)\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-1))) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-128))) (BigInt.of_int (-128));\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-129))) (BigInt.of_int 127);\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-256))) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 8 (BigInt.of_int (-257))) (BigInt.of_int (-1))\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet as_int_n_bit_boundary_2 () =\n (* 2-bit signed: -2 to 1 *)\n assert_bigint_equal (BigInt.as_int_n 2 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 2 (BigInt.of_int 1)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_int_n 2 (BigInt.of_int 2)) (BigInt.of_int (-2));\n assert_bigint_equal (BigInt.as_int_n 2 (BigInt.of_int 3)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 2 (BigInt.of_int 4)) (BigInt.of_int 0)\n\nlet as_int_n_bit_boundary_3 () =\n (* 3-bit signed: -4 to 3 *)\n assert_bigint_equal (BigInt.as_int_n 3 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 3 (BigInt.of_int 3)) (BigInt.of_int 3);\n assert_bigint_equal (BigInt.as_int_n 3 (BigInt.of_int 4)) (BigInt.of_int (-4));\n assert_bigint_equal (BigInt.as_int_n 3 (BigInt.of_int 7)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 3 (BigInt.of_int 8)) (BigInt.of_int 0)\n\nlet as_int_n_bit_boundary_4 () =\n (* 4-bit signed: -8 to 7 *)\n assert_bigint_equal (BigInt.as_int_n 4 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_int_n 4 (BigInt.of_int 7)) (BigInt.of_int 7);\n assert_bigint_equal (BigInt.as_int_n 4 (BigInt.of_int 8)) (BigInt.of_int (-8));\n assert_bigint_equal (BigInt.as_int_n 4 (BigInt.of_int 15)) (BigInt.of_int (-1));\n assert_bigint_equal (BigInt.as_int_n 4 (BigInt.of_int 16)) (BigInt.of_int 0)\n\nlet as_int_n_identity_for_zero () =\n (* asIntN(n, 0) = 0 for any n > 0 *)\n let zero = BigInt.of_int 0 in\n assert_bigint_equal (BigInt.as_int_n 1 zero) zero;\n assert_bigint_equal (BigInt.as_int_n 8 zero) zero;\n assert_bigint_equal (BigInt.as_int_n 16 zero) zero;\n assert_bigint_equal (BigInt.as_int_n 32 zero) zero;\n assert_bigint_equal (BigInt.as_int_n 64 zero) zero;\n assert_bigint_equal (BigInt.as_int_n 128 zero) zero\n\nlet as_int_n_minus_one () =\n (* asIntN(n, -1) = -1 for any n > 0 *)\n let neg_one = BigInt.of_int (-1) in\n assert_bigint_equal (BigInt.as_int_n 1 neg_one) neg_one;\n assert_bigint_equal (BigInt.as_int_n 8 neg_one) neg_one;\n assert_bigint_equal (BigInt.as_int_n 16 neg_one) neg_one;\n assert_bigint_equal (BigInt.as_int_n 32 neg_one) neg_one;\n assert_bigint_equal (BigInt.as_int_n 64 neg_one) neg_one\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n test \"asIntN 0 bits\" as_int_n_zero_bits;\n test \"asIntN 1 bit\" as_int_n_1_bit;\n test \"asIntN 8 bit\" as_int_n_8_bit;\n test \"asIntN 16 bit\" as_int_n_16_bit;\n test \"asIntN 32 bit\" as_int_n_32_bit;\n test \"asIntN 64 bit\" as_int_n_64_bit;\n test \"asIntN preserves small positive\" as_int_n_preserves_small_positive;\n test \"asIntN preserves small negative\" as_int_n_preserves_small_negative;\n test \"asIntN wrapping\" as_int_n_wrapping;\n test \"asIntN large bits\" as_int_n_large_bits;\n test \"asIntN negative input\" as_int_n_negative_input;\n test \"asIntN 2-bit boundary\" as_int_n_bit_boundary_2;\n test \"asIntN 3-bit boundary\" as_int_n_bit_boundary_3;\n test \"asIntN 4-bit boundary\" as_int_n_bit_boundary_4;\n test \"asIntN identity for zero\" as_int_n_identity_for_zero;\n test \"asIntN minus one\" as_int_n_minus_one;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/as_uint_n.ml",
"content": "(** TC39 Test262: BigInt.asUintN tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt/asUintN\n\n BigInt.asUintN(bits, bigint) wraps a BigInt value to an unsigned integer within the given number of bits. *)\n\nopen Helpers\nmodule BigInt = Js.Bigint\n\n(* ===================================================================\n Basic asUintN tests\n =================================================================== *)\n\nlet as_uint_n_zero_bits () =\n (* asUintN(0, x) always returns 0n *)\n assert_bigint_equal (BigInt.as_uint_n 0 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 0 (BigInt.of_int 1)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 0 (BigInt.of_int (-1))) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 0 (BigInt.of_int 100)) (BigInt.of_int 0)\n\nlet as_uint_n_1_bit () =\n (* asUintN(1, x) returns 0n or 1n *)\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int 1)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int 2)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int 3)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int (-1))) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int (-2))) (BigInt.of_int 0)\n\nlet as_uint_n_8_bit () =\n (* asUintN(8, x) wraps to unsigned 8-bit integer (0 to 255) *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 127)) (BigInt.of_int 127);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 128)) (BigInt.of_int 128);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 255)) (BigInt.of_int 255);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 256)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 257)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-1))) (BigInt.of_int 255);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-2))) (BigInt.of_int 254);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-128))) (BigInt.of_int 128);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-256))) (BigInt.of_int 0)\n\nlet as_uint_n_16_bit () =\n (* asUintN(16, x) wraps to unsigned 16-bit integer (0 to 65535) *)\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int 32767)) (BigInt.of_int 32767);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int 32768)) (BigInt.of_int 32768);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int 65535)) (BigInt.of_int 65535);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int 65536)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int (-1))) (BigInt.of_int 65535);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int (-32768))) (BigInt.of_int 32768);\n assert_bigint_equal (BigInt.as_uint_n 16 (BigInt.of_int (-65536))) (BigInt.of_int 0)\n\nlet as_uint_n_32_bit () =\n (* asUintN(32, x) wraps to unsigned 32-bit integer *)\n assert_bigint_equal (BigInt.as_uint_n 32 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 32 (BigInt.of_int (-1))) (BigInt.of_string \"4294967295\");\n (* 2^31 - 1 = 2147483647 *)\n assert_bigint_equal (BigInt.as_uint_n 32 (BigInt.of_string \"2147483647\")) (BigInt.of_string \"2147483647\");\n (* 2^31 = 2147483648 *)\n assert_bigint_equal (BigInt.as_uint_n 32 (BigInt.of_string \"2147483648\")) (BigInt.of_string \"2147483648\");\n (* 2^32 - 1 = 4294967295 *)\n assert_bigint_equal (BigInt.as_uint_n 32 (BigInt.of_string \"4294967295\")) (BigInt.of_string \"4294967295\");\n (* 2^32 = 4294967296 -> 0 *)\n assert_bigint_equal (BigInt.as_uint_n 32 (BigInt.of_string \"4294967296\")) (BigInt.of_int 0)\n\nlet as_uint_n_64_bit () =\n (* asUintN(64, x) wraps to unsigned 64-bit integer *)\n assert_bigint_equal (BigInt.as_uint_n 64 (BigInt.of_int 0)) (BigInt.of_int 0);\n (* 2^63 - 1 *)\n let max_int63 = BigInt.of_string \"9223372036854775807\" in\n assert_bigint_equal (BigInt.as_uint_n 64 max_int63) max_int63;\n (* 2^64 - 1 *)\n let max_uint64 = BigInt.of_string \"18446744073709551615\" in\n assert_bigint_equal (BigInt.as_uint_n 64 max_uint64) max_uint64;\n (* 2^64 -> 0 *)\n let two_64 = BigInt.of_string \"18446744073709551616\" in\n assert_bigint_equal (BigInt.as_uint_n 64 two_64) (BigInt.of_int 0);\n (* -1 -> 2^64 - 1 *)\n assert_bigint_equal (BigInt.as_uint_n 64 (BigInt.of_int (-1))) max_uint64\n\nlet as_uint_n_preserves_small_values () =\n (* Small positive values within range are preserved *)\n for i = 0 to 255 do\n let n = BigInt.of_int i in\n assert_bigint_equal (BigInt.as_uint_n 8 n) n\n done\n\nlet as_uint_n_wrapping () =\n (* Test wrapping behavior *)\n (* 300 in 8-bit unsigned = 300 mod 256 = 44 *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 300)) (BigInt.of_int 44);\n (* 512 in 8-bit unsigned = 0 *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 512)) (BigInt.of_int 0);\n (* 513 in 8-bit unsigned = 1 *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 513)) (BigInt.of_int 1)\n\nlet as_uint_n_large_bits () =\n (* Test with larger bit sizes *)\n let x = BigInt.of_string \"123456789012345678901234567890\" in\n (* With very large bits, positive value should be preserved *)\n assert_bigint_equal (BigInt.as_uint_n 256 x) x\n\nlet as_uint_n_negative_becomes_positive () =\n (* Negative numbers become their two's complement unsigned representation *)\n (* -1 in 8-bit unsigned = 255 *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-1))) (BigInt.of_int 255);\n (* -128 in 8-bit unsigned = 128 *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-128))) (BigInt.of_int 128);\n (* -129 in 8-bit unsigned = 127 *)\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int (-129))) (BigInt.of_int 127)\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet as_uint_n_bit_boundary_2 () =\n (* 2-bit unsigned: 0 to 3 *)\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 1)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 2)) (BigInt.of_int 2);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 3)) (BigInt.of_int 3);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 4)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 5)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int (-1))) (BigInt.of_int 3);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int (-2))) (BigInt.of_int 2)\n\nlet as_uint_n_bit_boundary_3 () =\n (* 3-bit unsigned: 0 to 7 *)\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int 7)) (BigInt.of_int 7);\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int 8)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int 9)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int (-1))) (BigInt.of_int 7)\n\nlet as_uint_n_bit_boundary_4 () =\n (* 4-bit unsigned: 0 to 15 *)\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int 0)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int 15)) (BigInt.of_int 15);\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int 16)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int 17)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int (-1))) (BigInt.of_int 15)\n\nlet as_uint_n_identity_for_zero () =\n (* asUintN(n, 0) = 0 for any n *)\n let zero = BigInt.of_int 0 in\n assert_bigint_equal (BigInt.as_uint_n 0 zero) zero;\n assert_bigint_equal (BigInt.as_uint_n 1 zero) zero;\n assert_bigint_equal (BigInt.as_uint_n 8 zero) zero;\n assert_bigint_equal (BigInt.as_uint_n 16 zero) zero;\n assert_bigint_equal (BigInt.as_uint_n 32 zero) zero;\n assert_bigint_equal (BigInt.as_uint_n 64 zero) zero;\n assert_bigint_equal (BigInt.as_uint_n 128 zero) zero\n\nlet as_uint_n_one () =\n (* asUintN(n, 1) = 1 for any n > 0 *)\n let one = BigInt.of_int 1 in\n assert_bigint_equal (BigInt.as_uint_n 1 one) one;\n assert_bigint_equal (BigInt.as_uint_n 8 one) one;\n assert_bigint_equal (BigInt.as_uint_n 16 one) one;\n assert_bigint_equal (BigInt.as_uint_n 32 one) one;\n assert_bigint_equal (BigInt.as_uint_n 64 one) one\n\nlet as_uint_n_power_of_two () =\n (* asUintN(n, 2^n) = 0 *)\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int 2)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 4)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int 8)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int 16)) (BigInt.of_int 0);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 256)) (BigInt.of_int 0)\n\nlet as_uint_n_power_of_two_minus_one () =\n (* asUintN(n, 2^n - 1) = 2^n - 1 *)\n assert_bigint_equal (BigInt.as_uint_n 1 (BigInt.of_int 1)) (BigInt.of_int 1);\n assert_bigint_equal (BigInt.as_uint_n 2 (BigInt.of_int 3)) (BigInt.of_int 3);\n assert_bigint_equal (BigInt.as_uint_n 3 (BigInt.of_int 7)) (BigInt.of_int 7);\n assert_bigint_equal (BigInt.as_uint_n 4 (BigInt.of_int 15)) (BigInt.of_int 15);\n assert_bigint_equal (BigInt.as_uint_n 8 (BigInt.of_int 255)) (BigInt.of_int 255)\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n test \"asUintN 0 bits\" as_uint_n_zero_bits;\n test \"asUintN 1 bit\" as_uint_n_1_bit;\n test \"asUintN 8 bit\" as_uint_n_8_bit;\n test \"asUintN 16 bit\" as_uint_n_16_bit;\n test \"asUintN 32 bit\" as_uint_n_32_bit;\n test \"asUintN 64 bit\" as_uint_n_64_bit;\n test \"asUintN preserves small values\" as_uint_n_preserves_small_values;\n test \"asUintN wrapping\" as_uint_n_wrapping;\n test \"asUintN large bits\" as_uint_n_large_bits;\n test \"asUintN negative becomes positive\" as_uint_n_negative_becomes_positive;\n test \"asUintN 2-bit boundary\" as_uint_n_bit_boundary_2;\n test \"asUintN 3-bit boundary\" as_uint_n_bit_boundary_3;\n test \"asUintN 4-bit boundary\" as_uint_n_bit_boundary_4;\n test \"asUintN identity for zero\" as_uint_n_identity_for_zero;\n test \"asUintN one\" as_uint_n_one;\n test \"asUintN power of two\" as_uint_n_power_of_two;\n test \"asUintN power of two minus one\" as_uint_n_power_of_two_minus_one;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/bitwise.ml",
"content": "(** TC39 Test262: BigInt bitwise operation tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt\n\n Tests for BigInt bitwise operations:\n - Bitwise AND (&)\n - Bitwise OR (|)\n - Bitwise XOR (^)\n - Bitwise NOT (~)\n - Left shift (<<)\n - Right shift (>>) - arithmetic shift, sign-extending *)\n\nopen Helpers\n\n(* ===================================================================\n Bitwise AND\n =================================================================== *)\n\nlet and_basic () =\n (* From QuickJS: 0x5a463ca6 & 0x67376856 = 1107699718 *)\n let a = BigInt.of_string \"0x5a463ca6\" in\n let b = BigInt.of_string \"0x67376856\" in\n assert_bigint (BigInt.logand a b) (BigInt.of_int 1107699718)\n\nlet and_zero () =\n let a = BigInt.of_int 0xFF in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.logand a b) (BigInt.of_int 0)\n\nlet and_all_ones () =\n let a = BigInt.of_int 0b1010 in\n let b = BigInt.of_int 0b1111 in\n assert_bigint (BigInt.logand a b) (BigInt.of_int 0b1010)\n\nlet and_negative () =\n (* -1 in two's complement is all 1s *)\n let a = BigInt.of_int 0xFF in\n let b = BigInt.of_int (-1) in\n assert_bigint (BigInt.logand a b) (BigInt.of_int 0xFF)\n\n(* ===================================================================\n Bitwise OR\n =================================================================== *)\n\nlet or_basic () =\n (* From QuickJS: 0x5a463ca6 | 0x67376856 = 2138537206 *)\n let a = BigInt.of_string \"0x5a463ca6\" in\n let b = BigInt.of_string \"0x67376856\" in\n assert_bigint (BigInt.logor a b) (BigInt.of_int 2138537206)\n\nlet or_zero () =\n let a = BigInt.of_int 0b1010 in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.logor a b) (BigInt.of_int 0b1010)\n\nlet or_disjoint () =\n let a = BigInt.of_int 0b1010 in\n let b = BigInt.of_int 0b0101 in\n assert_bigint (BigInt.logor a b) (BigInt.of_int 0b1111)\n\n(* ===================================================================\n Bitwise XOR\n =================================================================== *)\n\nlet xor_basic () =\n (* From QuickJS: 0x5a463ca6 ^ 0x67376856 = 1030837488 *)\n let a = BigInt.of_string \"0x5a463ca6\" in\n let b = BigInt.of_string \"0x67376856\" in\n assert_bigint (BigInt.logxor a b) (BigInt.of_int 1030837488)\n\nlet xor_same () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.logxor a a) (BigInt.of_int 0)\n\nlet xor_zero () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 0 in\n assert_bigint (BigInt.logxor a b) (BigInt.of_int 42)\n\n(* ===================================================================\n Bitwise NOT\n =================================================================== *)\n\nlet not_basic () =\n (* From QuickJS: ~0x5a653ca6 = -1516584103 *)\n let a = BigInt.of_string \"0x5a653ca6\" in\n assert_bigint (BigInt.lognot a) (BigInt.of_int (-1516584103))\n\nlet not_zero () =\n let a = BigInt.of_int 0 in\n assert_bigint (BigInt.lognot a) (BigInt.of_int (-1))\n\nlet not_negative_one () =\n let a = BigInt.of_int (-1) in\n assert_bigint (BigInt.lognot a) (BigInt.of_int 0)\n\nlet not_positive () =\n (* ~5 = -6 *)\n let a = BigInt.of_int 5 in\n assert_bigint (BigInt.lognot a) (BigInt.of_int (-6))\n\nlet not_negative () =\n (* ~(-6) = 5 *)\n let a = BigInt.of_int (-6) in\n assert_bigint (BigInt.lognot a) (BigInt.of_int 5)\n\n(* ===================================================================\n Left shift\n =================================================================== *)\n\nlet shift_left_basic () =\n let a = BigInt.of_int 1 in\n assert_bigint (BigInt.shift_left a 10) (BigInt.of_int 1024)\n\nlet shift_left_31 () =\n (* From QuickJS: 1 << 31 = 2147483648 *)\n let a = BigInt.of_int 1 in\n assert_bigint_string (BigInt.shift_left a 31) \"2147483648\"\n\nlet shift_left_32 () =\n (* From QuickJS: 1 << 32 = 4294967296 *)\n let a = BigInt.of_int 1 in\n assert_bigint_string (BigInt.shift_left a 32) \"4294967296\"\n\nlet shift_left_100 () =\n (* From QuickJS: 1 << 100 = 1267650600228229401496703205376 *)\n let a = BigInt.of_int 1 in\n assert_bigint_string (BigInt.shift_left a 100) \"1267650600228229401496703205376\"\n\nlet shift_left_large () =\n (* From QuickJS: 0x5a4653ca673768565b41f775 << 78 *)\n let a = BigInt.of_string \"0x5a4653ca673768565b41f775\" in\n assert_bigint_string (BigInt.shift_left a 78) \"8443945299673273647701379149826607537748959488376832\"\n\nlet shift_left_negative () =\n (* From QuickJS: -0x5a4653ca673768565b41f775 << 78 *)\n let a = BigInt.of_string \"-0x5a4653ca673768565b41f775\" in\n assert_bigint_string (BigInt.shift_left a 78) \"-8443945299673273647701379149826607537748959488376832\"\n\nlet shift_left_zero () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.shift_left a 0) (BigInt.of_int 42)\n\n(* ===================================================================\n Right shift (arithmetic - sign extending)\n =================================================================== *)\n\nlet shift_right_basic () =\n let a = BigInt.of_int 1024 in\n assert_bigint (BigInt.shift_right a 5) (BigInt.of_int 32)\n\nlet shift_right_large () =\n (* From QuickJS: 0x5a4653ca673768565b41f775 >> 78 = 92441 *)\n let a = BigInt.of_string \"0x5a4653ca673768565b41f775\" in\n assert_bigint (BigInt.shift_right a 78) (BigInt.of_int 92441)\n\nlet shift_right_negative () =\n (* From QuickJS: -0x5a4653ca673768565b41f775 >> 78 = -92442 *)\n (* Arithmetic shift extends sign bit *)\n let a = BigInt.of_string \"-0x5a4653ca673768565b41f775\" in\n assert_bigint (BigInt.shift_right a 78) (BigInt.of_int (-92442))\n\nlet shift_right_zero () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.shift_right a 0) (BigInt.of_int 42)\n\nlet shift_right_negative_small () =\n (* -8 >> 2 = -2 (arithmetic shift) *)\n let a = BigInt.of_int (-8) in\n assert_bigint (BigInt.shift_right a 2) (BigInt.of_int (-2))\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* AND *)\n test \"and: basic\" and_basic;\n test \"and: with zero\" and_zero;\n test \"and: with all ones\" and_all_ones;\n test \"and: negative (two's complement)\" and_negative;\n (* OR *)\n test \"or: basic\" or_basic;\n test \"or: with zero\" or_zero;\n test \"or: disjoint bits\" or_disjoint;\n (* XOR *)\n test \"xor: basic\" xor_basic;\n test \"xor: same value\" xor_same;\n test \"xor: with zero\" xor_zero;\n (* NOT *)\n test \"not: basic\" not_basic;\n test \"not: zero\" not_zero;\n test \"not: -1\" not_negative_one;\n test \"not: positive\" not_positive;\n test \"not: negative\" not_negative;\n (* Left shift *)\n test \"shift_left: basic\" shift_left_basic;\n test \"shift_left: 1 << 31\" shift_left_31;\n test \"shift_left: 1 << 32\" shift_left_32;\n test \"shift_left: 1 << 100\" shift_left_100;\n test \"shift_left: large number\" shift_left_large;\n test \"shift_left: negative number\" shift_left_negative;\n test \"shift_left: by zero\" shift_left_zero;\n (* Right shift *)\n test \"shift_right: basic\" shift_right_basic;\n test \"shift_right: large number\" shift_right_large;\n test \"shift_right: negative (arithmetic)\" shift_right_negative;\n test \"shift_right: by zero\" shift_right_zero;\n test \"shift_right: small negative\" shift_right_negative_small;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/comparison.ml",
"content": "(** TC39 Test262: BigInt comparison tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt\n\n Tests for BigInt comparison operations:\n - Equal (=)\n - Less than (<)\n - Less than or equal (<=)\n - Greater than (>)\n - Greater than or equal (>=)\n - Compare (returns -1, 0, 1) *)\n\nopen Helpers\n\n(* ===================================================================\n Equality\n =================================================================== *)\n\nlet equal_same () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 42 in\n assert_bool (BigInt.equal a b) true\n\nlet equal_different () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int 43 in\n assert_bool (BigInt.equal a b) false\n\nlet equal_negative () =\n let a = BigInt.of_int (-42) in\n let b = BigInt.of_int (-42) in\n assert_bool (BigInt.equal a b) true\n\nlet equal_opposite_sign () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_int (-42) in\n assert_bool (BigInt.equal a b) false\n\nlet equal_zero () =\n let a = BigInt.of_int 0 in\n let b = BigInt.of_int 0 in\n assert_bool (BigInt.equal a b) true\n\nlet equal_large () =\n (* From QuickJS test *)\n let a = BigInt.of_string \"515377520732011331036461129765621272702107522001\" in\n let b = BigInt.of_string \"515377520732011331036461129765621272702107522001\" in\n assert_bool (BigInt.equal a b) true\n\nlet equal_large_different () =\n let a = BigInt.of_string \"515377520732011331036461129765621272702107522001\" in\n let b = BigInt.of_string \"515377520732011331036461129765621272702107522000\" in\n assert_bool (BigInt.equal a b) false\n\n(* ===================================================================\n Compare (returns -1, 0, 1)\n =================================================================== *)\n\nlet compare_less () =\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 3 in\n assert_int (BigInt.compare a b) (-1)\n\nlet compare_greater () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 2 in\n assert_int (BigInt.compare a b) 1\n\nlet compare_equal () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 3 in\n assert_int (BigInt.compare a b) 0\n\nlet compare_negative () =\n let a = BigInt.of_int (-5) in\n let b = BigInt.of_int (-3) in\n assert_int (BigInt.compare a b) (-1)\n\nlet compare_mixed_sign () =\n let a = BigInt.of_int (-1) in\n let b = BigInt.of_int 1 in\n assert_int (BigInt.compare a b) (-1)\n\n(* ===================================================================\n Less than\n =================================================================== *)\n\nlet lt_true () =\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.lt a b) true\n\nlet lt_false_greater () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 2 in\n assert_bool (BigInt.lt a b) false\n\nlet lt_false_equal () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.lt a b) false\n\nlet lt_negative () =\n let a = BigInt.of_int (-5) in\n let b = BigInt.of_int (-3) in\n assert_bool (BigInt.lt a b) true\n\n(* ===================================================================\n Less than or equal\n =================================================================== *)\n\nlet le_true_less () =\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.le a b) true\n\nlet le_true_equal () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.le a b) true\n\nlet le_false () =\n let a = BigInt.of_int 4 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.le a b) false\n\n(* ===================================================================\n Greater than\n =================================================================== *)\n\nlet gt_true () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 2 in\n assert_bool (BigInt.gt a b) true\n\nlet gt_false_less () =\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.gt a b) false\n\nlet gt_false_equal () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.gt a b) false\n\n(* ===================================================================\n Greater than or equal\n =================================================================== *)\n\nlet ge_true_greater () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 2 in\n assert_bool (BigInt.ge a b) true\n\nlet ge_true_equal () =\n let a = BigInt.of_int 3 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.ge a b) true\n\nlet ge_false () =\n let a = BigInt.of_int 2 in\n let b = BigInt.of_int 3 in\n assert_bool (BigInt.ge a b) false\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* Equality *)\n test \"equal: same value\" equal_same;\n test \"equal: different values\" equal_different;\n test \"equal: negative values\" equal_negative;\n test \"equal: opposite signs\" equal_opposite_sign;\n test \"equal: zeros\" equal_zero;\n test \"equal: large same\" equal_large;\n test \"equal: large different\" equal_large_different;\n (* Compare *)\n test \"compare: less\" compare_less;\n test \"compare: greater\" compare_greater;\n test \"compare: equal\" compare_equal;\n test \"compare: negative\" compare_negative;\n test \"compare: mixed sign\" compare_mixed_sign;\n (* Less than *)\n test \"lt: true\" lt_true;\n test \"lt: false (greater)\" lt_false_greater;\n test \"lt: false (equal)\" lt_false_equal;\n test \"lt: negative\" lt_negative;\n (* Less than or equal *)\n test \"le: true (less)\" le_true_less;\n test \"le: true (equal)\" le_true_equal;\n test \"le: false\" le_false;\n (* Greater than *)\n test \"gt: true\" gt_true;\n test \"gt: false (less)\" gt_false_less;\n test \"gt: false (equal)\" gt_false_equal;\n (* Greater than or equal *)\n test \"ge: true (greater)\" ge_true_greater;\n test \"ge: true (equal)\" ge_true_equal;\n test \"ge: false\" ge_false;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/constructor.ml",
"content": "(** TC39 Test262: BigInt constructor tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt\n\n ECMA-262 Section: BigInt(value)\n\n The BigInt constructor:\n - Converts strings to BigInt (decimal, hex with 0x prefix)\n - Converts integers to BigInt\n - Throws for non-integer numbers\n - Throws for invalid string formats *)\n\nopen Helpers\n\n(* ===================================================================\n From string - basic decimal parsing\n =================================================================== *)\n\nlet from_string_empty () =\n (* BigInt(\"\") should return 0n in JavaScript *)\n assert_bigint (BigInt.of_string \"\") (BigInt.of_int 0)\n\nlet from_string_zero () = assert_bigint (BigInt.of_string \"0\") (BigInt.of_int 0)\nlet from_string_positive () = assert_bigint (BigInt.of_string \"123\") (BigInt.of_int 123)\nlet from_string_negative () = assert_bigint (BigInt.of_string \"-123\") (BigInt.of_int (-123))\nlet from_string_positive_sign () = assert_bigint (BigInt.of_string \"+456\") (BigInt.of_int 456)\n\nlet from_string_large () =\n (* A number larger than MAX_SAFE_INTEGER *)\n let large = BigInt.of_string \"9007199254740993\" in\n assert_bigint_string large \"9007199254740993\"\n\nlet from_string_very_large () =\n (* 3^100 from QuickJS test *)\n let expected = \"515377520732011331036461129765621272702107522001\" in\n let result = BigInt.of_string expected in\n assert_bigint_string result expected\n\n(* ===================================================================\n From string - whitespace handling\n =================================================================== *)\n\nlet from_string_leading_space () = assert_bigint (BigInt.of_string \" 123\") (BigInt.of_int 123)\nlet from_string_trailing_space () = assert_bigint (BigInt.of_string \"123 \") (BigInt.of_int 123)\nlet from_string_both_space () = assert_bigint (BigInt.of_string \" 123 \") (BigInt.of_int 123)\nlet from_string_tabs () = assert_bigint (BigInt.of_string \"\\t123\\t\") (BigInt.of_int 123)\nlet from_string_newlines () = assert_bigint (BigInt.of_string \"\\n123\\n\") (BigInt.of_int 123)\n\n(* ===================================================================\n From string - hexadecimal\n =================================================================== *)\n\nlet from_string_hex_lower () = assert_bigint (BigInt.of_string \"0xff\") (BigInt.of_int 255)\nlet from_string_hex_upper () = assert_bigint (BigInt.of_string \"0XFF\") (BigInt.of_int 255)\n\nlet from_string_hex_large () =\n (* From QuickJS test *)\n let result = BigInt.of_string \"0x5a4653ca673768565b41f775d6947d55cf3813d1\" in\n assert_bigint_string result \"515377520732011331036461129765621272702107522001\"\n\nlet from_string_hex_negative () = assert_bigint (BigInt.of_string \"-0x10\") (BigInt.of_int (-16))\n\n(* ===================================================================\n From string - binary (0b prefix)\n =================================================================== *)\n\nlet from_string_binary () = assert_bigint (BigInt.of_string \"0b1010\") (BigInt.of_int 10)\nlet from_string_binary_upper () = assert_bigint (BigInt.of_string \"0B1111\") (BigInt.of_int 15)\n\n(* ===================================================================\n From string - octal (0o prefix)\n =================================================================== *)\n\nlet from_string_octal () = assert_bigint (BigInt.of_string \"0o77\") (BigInt.of_int 63)\nlet from_string_octal_upper () = assert_bigint (BigInt.of_string \"0O777\") (BigInt.of_int 511)\n\n(* ===================================================================\n From string - invalid inputs (should raise)\n =================================================================== *)\n\nlet from_string_invalid_sign_only () =\n (* BigInt(\"+\") and BigInt(\"-\") should throw SyntaxError *)\n assert_bigint_raises (fun () -> BigInt.of_string_exn \"+\");\n assert_bigint_raises (fun () -> BigInt.of_string_exn \"-\")\n\nlet from_string_invalid_trailing_chars () =\n (* BigInt(\" 123 r\") should throw SyntaxError *)\n assert_bigint_raises (fun () -> BigInt.of_string_exn \"123r\");\n assert_bigint_raises (fun () -> BigInt.of_string_exn \" 123 r\")\n\nlet from_string_invalid_null_char () =\n (* BigInt(\"\\x00a\") should throw SyntaxError *)\n assert_bigint_raises (fun () -> BigInt.of_string_exn \"\\x00a\")\n\nlet from_string_invalid_decimal_point () =\n (* BigInt(\"1.5\") should throw - no decimals allowed *)\n assert_bigint_raises (fun () -> BigInt.of_string_exn \"1.5\")\n\nlet from_string_invalid_float_notation () =\n (* BigInt(\"1e10\") should throw *)\n assert_bigint_raises (fun () -> BigInt.of_string_exn \"1e10\")\n\n(* ===================================================================\n From integers\n =================================================================== *)\n\nlet from_int_zero () = assert_bigint (BigInt.of_int 0) (BigInt.of_string \"0\")\nlet from_int_positive () = assert_bigint (BigInt.of_int 42) (BigInt.of_string \"42\")\nlet from_int_negative () = assert_bigint (BigInt.of_int (-42)) (BigInt.of_string \"-42\")\n\nlet from_int_max_int () =\n let max = max_int in\n assert_bigint (BigInt.of_int max) (BigInt.of_string (string_of_int max))\n\nlet from_int_min_int () =\n let min = min_int in\n assert_bigint (BigInt.of_int min) (BigInt.of_string (string_of_int min))\n\n(* ===================================================================\n From int64\n =================================================================== *)\n\nlet from_int64_large () =\n let large = 9007199254740993L in\n (* larger than MAX_SAFE_INTEGER *)\n assert_bigint (BigInt.of_int64 large) (BigInt.of_string \"9007199254740993\")\n\nlet from_int64_negative () = assert_bigint (BigInt.of_int64 (-9007199254740993L)) (BigInt.of_string \"-9007199254740993\")\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* From string - basic *)\n test \"from_string: empty string returns 0\" from_string_empty;\n test \"from_string: zero\" from_string_zero;\n test \"from_string: positive decimal\" from_string_positive;\n test \"from_string: negative decimal\" from_string_negative;\n test \"from_string: positive sign\" from_string_positive_sign;\n test \"from_string: large number\" from_string_large;\n test \"from_string: very large number (3^100)\" from_string_very_large;\n (* From string - whitespace *)\n test \"from_string: leading whitespace\" from_string_leading_space;\n test \"from_string: trailing whitespace\" from_string_trailing_space;\n test \"from_string: both whitespace\" from_string_both_space;\n test \"from_string: tabs\" from_string_tabs;\n test \"from_string: newlines\" from_string_newlines;\n (* From string - hex *)\n test \"from_string: hex lowercase\" from_string_hex_lower;\n test \"from_string: hex uppercase\" from_string_hex_upper;\n test \"from_string: hex large\" from_string_hex_large;\n test \"from_string: hex negative\" from_string_hex_negative;\n (* From string - binary *)\n test \"from_string: binary lowercase\" from_string_binary;\n test \"from_string: binary uppercase\" from_string_binary_upper;\n (* From string - octal *)\n test \"from_string: octal lowercase\" from_string_octal;\n test \"from_string: octal uppercase\" from_string_octal_upper;\n (* From string - invalid *)\n test \"from_string: sign only throws\" from_string_invalid_sign_only;\n test \"from_string: trailing chars throws\" from_string_invalid_trailing_chars;\n test \"from_string: null char throws\" from_string_invalid_null_char;\n test \"from_string: decimal point throws\" from_string_invalid_decimal_point;\n test \"from_string: float notation throws\" from_string_invalid_float_notation;\n (* From integers *)\n test \"from_int: zero\" from_int_zero;\n test \"from_int: positive\" from_int_positive;\n test \"from_int: negative\" from_int_negative;\n test \"from_int: max_int\" from_int_max_int;\n test \"from_int: min_int\" from_int_min_int;\n (* From int64 *)\n test \"from_int64: large positive\" from_int64_large;\n test \"from_int64: large negative\" from_int64_negative;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/conversion.ml",
"content": "(** TC39 Test262: BigInt conversion tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt\n\n Tests for BigInt conversion operations:\n - toString with various radixes\n - toNumber (to float)\n - asIntN / asUintN (wrapping to fixed bit widths) *)\n\nopen Helpers\n\n(* ===================================================================\n toString - decimal (default)\n =================================================================== *)\n\nlet to_string_zero () =\n let a = BigInt.of_int 0 in\n assert_string (BigInt.to_string a) \"0\"\n\nlet to_string_positive () =\n let a = BigInt.of_int 123 in\n assert_string (BigInt.to_string a) \"123\"\n\nlet to_string_negative () =\n let a = BigInt.of_int (-123) in\n assert_string (BigInt.to_string a) \"-123\"\n\nlet to_string_large () =\n (* From QuickJS test: (1 << 100).toString(10) *)\n let a = BigInt.shift_left (BigInt.of_int 1) 100 in\n assert_string (BigInt.to_string a) \"1267650600228229401496703205376\"\n\n(* ===================================================================\n toString - with radix\n =================================================================== *)\n\nlet to_string_radix_2 () =\n let a = BigInt.of_int 10 in\n assert_string (BigInt.to_string ~radix:2 a) \"1010\"\n\nlet to_string_radix_8 () =\n (* From QuickJS: (1 << 100).toString(8) *)\n let a = BigInt.shift_left (BigInt.of_int 1) 100 in\n assert_string (BigInt.to_string ~radix:8 a) \"2000000000000000000000000000000000\"\n\nlet to_string_radix_16 () =\n let a = BigInt.of_int 255 in\n assert_string (BigInt.to_string ~radix:16 a) \"ff\"\n\nlet to_string_radix_36 () =\n (* From QuickJS: (-1 << 100).toString(36) *)\n let a = BigInt.shift_left (BigInt.of_int (-1)) 100 in\n assert_string (BigInt.to_string ~radix:36 a) \"-3ewfdnca0n6ld1ggvfgg\"\n\nlet to_string_radix_16_large () =\n let a = BigInt.of_string \"515377520732011331036461129765621272702107522001\" in\n assert_string (BigInt.to_string ~radix:16 a) \"5a4653ca673768565b41f775d6947d55cf3813d1\"\n\n(* ===================================================================\n toNumber (to float) - with precision loss for large values\n =================================================================== *)\n\nlet to_float_small () =\n let a = BigInt.of_int 42 in\n assert_float (BigInt.to_float a) 42.0\n\nlet to_float_negative () =\n let a = BigInt.of_int (-42) in\n assert_float (BigInt.to_float a) (-42.0)\n\nlet to_float_zero () =\n let a = BigInt.of_int 0 in\n assert_float (BigInt.to_float a) 0.0\n\nlet to_float_max_safe_int () =\n let a = BigInt.of_string \"9007199254740991\" in\n assert_float (BigInt.to_float a) 9007199254740991.0\n\nlet to_float_large () =\n (* From QuickJS: Number(0xffffffffffffffffn) = 18446744073709552000 *)\n let a = BigInt.of_string \"0xffffffffffffffff\" in\n assert_float (BigInt.to_float a) 18446744073709552000.0\n\nlet to_float_large_negative () =\n (* From QuickJS: Number(-0xffffffffffffffffn) = -18446744073709552000 *)\n let a = BigInt.of_string \"-0xffffffffffffffff\" in\n assert_float (BigInt.to_float a) (-18446744073709552000.0)\n\n(* ===================================================================\n asIntN - wraps BigInt to signed N-bit integer\n =================================================================== *)\n\nlet as_int_n_positive () =\n (* 127 fits in 8 bits signed *)\n let a = BigInt.of_int 127 in\n assert_bigint (BigInt.as_int_n 8 a) (BigInt.of_int 127)\n\nlet as_int_n_wrap_positive () =\n (* 128 in 8-bit signed wraps to -128 *)\n let a = BigInt.of_int 128 in\n assert_bigint (BigInt.as_int_n 8 a) (BigInt.of_int (-128))\n\nlet as_int_n_wrap_large () =\n (* 255 in 8-bit signed wraps to -1 *)\n let a = BigInt.of_int 255 in\n assert_bigint (BigInt.as_int_n 8 a) (BigInt.of_int (-1))\n\nlet as_int_n_negative () =\n (* -128 fits in 8 bits signed *)\n let a = BigInt.of_int (-128) in\n assert_bigint (BigInt.as_int_n 8 a) (BigInt.of_int (-128))\n\nlet as_int_n_wrap_negative () =\n (* -129 in 8-bit signed wraps to 127 *)\n let a = BigInt.of_int (-129) in\n assert_bigint (BigInt.as_int_n 8 a) (BigInt.of_int 127)\n\nlet as_int_n_64 () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.as_int_n 64 a) (BigInt.of_int 42)\n\n(* ===================================================================\n asUintN - wraps BigInt to unsigned N-bit integer\n =================================================================== *)\n\nlet as_uint_n_fits () =\n let a = BigInt.of_int 255 in\n assert_bigint (BigInt.as_uint_n 8 a) (BigInt.of_int 255)\n\nlet as_uint_n_wrap () =\n (* 256 in 8-bit unsigned wraps to 0 *)\n let a = BigInt.of_int 256 in\n assert_bigint (BigInt.as_uint_n 8 a) (BigInt.of_int 0)\n\nlet as_uint_n_wrap_large () =\n (* 257 in 8-bit unsigned wraps to 1 *)\n let a = BigInt.of_int 257 in\n assert_bigint (BigInt.as_uint_n 8 a) (BigInt.of_int 1)\n\nlet as_uint_n_negative () =\n (* -1 in 8-bit unsigned wraps to 255 *)\n let a = BigInt.of_int (-1) in\n assert_bigint (BigInt.as_uint_n 8 a) (BigInt.of_int 255)\n\nlet as_uint_n_64 () =\n let a = BigInt.of_int 42 in\n assert_bigint (BigInt.as_uint_n 64 a) (BigInt.of_int 42)\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* toString decimal *)\n test \"toString: zero\" to_string_zero;\n test \"toString: positive\" to_string_positive;\n test \"toString: negative\" to_string_negative;\n test \"toString: large (1 << 100)\" to_string_large;\n (* toString with radix *)\n test \"toString: radix 2\" to_string_radix_2;\n test \"toString: radix 8\" to_string_radix_8;\n test \"toString: radix 16\" to_string_radix_16;\n test \"toString: radix 36\" to_string_radix_36;\n test \"toString: radix 16 large\" to_string_radix_16_large;\n (* toFloat *)\n test \"toFloat: small\" to_float_small;\n test \"toFloat: negative\" to_float_negative;\n test \"toFloat: zero\" to_float_zero;\n test \"toFloat: MAX_SAFE_INTEGER\" to_float_max_safe_int;\n test \"toFloat: large (0xffffffffffffffff)\" to_float_large;\n test \"toFloat: large negative\" to_float_large_negative;\n (* asIntN *)\n test \"asIntN: positive fits\" as_int_n_positive;\n test \"asIntN: positive wraps\" as_int_n_wrap_positive;\n test \"asIntN: 255 -> -1\" as_int_n_wrap_large;\n test \"asIntN: negative fits\" as_int_n_negative;\n test \"asIntN: negative wraps\" as_int_n_wrap_negative;\n test \"asIntN: 64 bits\" as_int_n_64;\n (* asUintN *)\n test \"asUintN: fits\" as_uint_n_fits;\n test \"asUintN: wraps to 0\" as_uint_n_wrap;\n test \"asUintN: wraps to 1\" as_uint_n_wrap_large;\n test \"asUintN: negative wraps\" as_uint_n_negative;\n test \"asUintN: 64 bits\" as_uint_n_64;\n ]\n"
},
{
"path": "packages/Js/test/bigint_tests/prototype.ml",
"content": "(** TC39 Test262: BigInt.prototype tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/BigInt/prototype\n\n Tests for BigInt.prototype.toString, BigInt.prototype.valueOf, BigInt.prototype.toLocaleString *)\n\nopen Helpers\nmodule BigInt = Js.Bigint\n\n(* ===================================================================\n BigInt.prototype.toString tests\n =================================================================== *)\n\nlet to_string_default_radix () =\n (* Default radix is 10 *)\n assert_string_equal (BigInt.toString (BigInt.of_int 0)) \"0\";\n assert_string_equal (BigInt.toString (BigInt.of_int 1)) \"1\";\n assert_string_equal (BigInt.toString (BigInt.of_int 10)) \"10\";\n assert_string_equal (BigInt.toString (BigInt.of_int 100)) \"100\";\n assert_string_equal (BigInt.toString (BigInt.of_int (-1))) \"-1\";\n assert_string_equal (BigInt.toString (BigInt.of_int (-10))) \"-10\"\n\nlet to_string_radix_2 () =\n (* Binary representation *)\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int 0)) \"0\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int 1)) \"1\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int 2)) \"10\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int 3)) \"11\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int 4)) \"100\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int 255)) \"11111111\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int (-1))) \"-1\";\n assert_string_equal (BigInt.to_string ~radix:2 (BigInt.of_int (-2))) \"-10\"\n\nlet to_string_radix_8 () =\n (* Octal representation *)\n assert_string_equal (BigInt.to_string ~radix:8 (BigInt.of_int 0)) \"0\";\n assert_string_equal (BigInt.to_string ~radix:8 (BigInt.of_int 7)) \"7\";\n assert_string_equal (BigInt.to_string ~radix:8 (BigInt.of_int 8)) \"10\";\n assert_string_equal (BigInt.to_string ~radix:8 (BigInt.of_int 63)) \"77\";\n assert_string_equal (BigInt.to_string ~radix:8 (BigInt.of_int 64)) \"100\";\n assert_string_equal (BigInt.to_string ~radix:8 (BigInt.of_int (-8))) \"-10\"\n\nlet to_string_radix_10 () =\n (* Decimal representation (explicit) *)\n assert_string_equal (BigInt.to_string ~radix:10 (BigInt.of_int 0)) \"0\";\n assert_string_equal (BigInt.to_string ~radix:10 (BigInt.of_int 123)) \"123\";\n assert_string_equal (BigInt.to_string ~radix:10 (BigInt.of_int (-456))) \"-456\";\n assert_string_equal (BigInt.to_string ~radix:10 (BigInt.of_string \"9999999999\")) \"9999999999\"\n\nlet to_string_radix_16 () =\n (* Hexadecimal representation *)\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int 0)) \"0\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int 10)) \"a\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int 15)) \"f\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int 16)) \"10\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int 255)) \"ff\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int 256)) \"100\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int (-1))) \"-1\";\n assert_string_equal (BigInt.to_string ~radix:16 (BigInt.of_int (-255))) \"-ff\"\n\nlet to_string_radix_36 () =\n (* Base 36 (max radix) *)\n assert_string_equal (BigInt.to_string ~radix:36 (BigInt.of_int 0)) \"0\";\n assert_string_equal (BigInt.to_string ~radix:36 (BigInt.of_int 35)) \"z\";\n assert_string_equal (BigInt.to_string ~radix:36 (BigInt.of_int 36)) \"10\";\n assert_string_equal (BigInt.to_string ~radix:36 (BigInt.of_int 1295)) \"zz\";\n assert_string_equal (BigInt.to_string ~radix:36 (BigInt.of_int 1296)) \"100\"\n\nlet to_string_various_radixes () =\n (* Test various radixes *)\n let n = BigInt.of_int 100 in\n assert_string_equal (BigInt.to_string ~radix:2 n) \"1100100\";\n assert_string_equal (BigInt.to_string ~radix:3 n) \"10201\";\n assert_string_equal (BigInt.to_string ~radix:4 n) \"1210\";\n assert_string_equal (BigInt.to_string ~radix:5 n) \"400\";\n assert_string_equal (BigInt.to_string ~radix:6 n) \"244\";\n assert_string_equal (BigInt.to_string ~radix:7 n) \"202\";\n assert_string_equal (BigInt.to_string ~radix:8 n) \"144\";\n assert_string_equal (BigInt.to_string ~radix:9 n) \"121\";\n assert_string_equal (BigInt.to_string ~radix:10 n) \"100\"\n\nlet to_string_large_numbers () =\n (* Test large numbers *)\n let large = BigInt.of_string \"123456789012345678901234567890\" in\n let s10 = BigInt.to_string ~radix:10 large in\n assert_string_equal s10 \"123456789012345678901234567890\";\n (* Verify hex conversion works *)\n let s16 = BigInt.to_string ~radix:16 large in\n assert_true \"hex string non-empty\" (String.length s16 > 0)\n\nlet to_string_negative_large () =\n let neg_large = BigInt.of_string \"-123456789012345678901234567890\" in\n let s = BigInt.to_string ~radix:10 neg_large in\n assert_string_equal s \"-123456789012345678901234567890\"\n\nlet to_string_zero () =\n (* Zero in various radixes *)\n let zero = BigInt.of_int 0 in\n for r = 2 to 36 do\n assert_string_equal (BigInt.to_string ~radix:r zero) \"0\"\n done\n\n(* ===================================================================\n BigInt conversion tests (to_float)\n =================================================================== *)\n\nlet to_float_small () =\n assert_float_exact (BigInt.to_float (BigInt.of_int 0)) 0.;\n assert_float_exact (BigInt.to_float (BigInt.of_int 1)) 1.;\n assert_float_exact (BigInt.to_float (BigInt.of_int (-1))) (-1.);\n assert_float_exact (BigInt.to_float (BigInt.of_int 100)) 100.;\n assert_float_exact (BigInt.to_float (BigInt.of_int (-100))) (-100.)\n\nlet to_float_large () =\n (* Large numbers may lose precision *)\n let large = BigInt.of_string \"9007199254740992\" in\n (* 2^53 *)\n let f = BigInt.to_float large in\n assert_true \"large to_float is finite\" (Float.is_finite f)\n\nlet to_float_very_large () =\n (* Very large numbers become infinity *)\n let huge = BigInt.of_string \"1\" in\n let shifted = BigInt.shift_left huge 10000 in\n let f = BigInt.to_float shifted in\n assert_true \"huge number becomes infinity\" (f = Float.infinity || f = Float.neg_infinity)\n\n(* ===================================================================\n Constructor edge cases\n =================================================================== *)\n\nlet of_string_edge_cases () =\n (* Empty string *)\n assert_bigint_equal (BigInt.of_string \"\") (BigInt.of_int 0);\n (* Whitespace *)\n assert_bigint_equal (BigInt.of_string \" 123 \") (BigInt.of_int 123);\n (* Leading zeros *)\n assert_bigint_equal (BigInt.of_string \"00123\") (BigInt.of_int 123);\n (* Negative with leading zeros *)\n assert_bigint_equal (BigInt.of_string \"-00123\") (BigInt.of_int (-123))\n\nlet of_string_hex () =\n assert_bigint_equal (BigInt.of_string \"0x10\") (BigInt.of_int 16);\n assert_bigint_equal (BigInt.of_string \"0xFF\") (BigInt.of_int 255);\n assert_bigint_equal (BigInt.of_string \"0xABCD\") (BigInt.of_int 43981)\n\nlet of_string_binary () =\n assert_bigint_equal (BigInt.of_string \"0b1010\") (BigInt.of_int 10);\n assert_bigint_equal (BigInt.of_string \"0b11111111\") (BigInt.of_int 255)\n\nlet of_string_octal () =\n assert_bigint_equal (BigInt.of_string \"0o10\") (BigInt.of_int 8);\n assert_bigint_equal (BigInt.of_string \"0o777\") (BigInt.of_int 511)\n\n(* ===================================================================\n Comparison with different representations\n =================================================================== *)\n\nlet compare_equal () =\n let a = BigInt.of_int 42 in\n let b = BigInt.of_string \"42\" in\n assert_true \"42 == 42\" (BigInt.equal a b);\n assert_true \"compare returns 0\" (BigInt.compare a b = 0)\n\nlet compare_less () =\n let a = BigInt.of_int 10 in\n let b = BigInt.of_int 20 in\n assert_true \"10 < 20\" (BigInt.lt a b);\n assert_true \"compare returns negative\" (BigInt.compare a b < 0)\n\nlet compare_greater () =\n let a = BigInt.of_int 20 in\n let b = BigInt.of_int 10 in\n assert_true \"20 > 10\" (BigInt.gt a b);\n assert_true \"compare returns positive\" (BigInt.compare a b > 0)\n\nlet compare_negative () =\n let a = BigInt.of_int (-10) in\n let b = BigInt.of_int 10 in\n assert_true \"-10 < 10\" (BigInt.lt a b);\n let c = BigInt.of_int (-20) in\n assert_true \"-20 < -10\" (BigInt.lt c a)\n\nlet compare_large () =\n let a = BigInt.of_string \"123456789012345678901234567890\" in\n let b = BigInt.of_string \"123456789012345678901234567891\" in\n assert_true \"large a < large b\" (BigInt.lt a b);\n assert_true \"large b > large a\" (BigInt.gt b a)\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* toString *)\n test \"toString default radix\" to_string_default_radix;\n test \"toString radix 2 (binary)\" to_string_radix_2;\n test \"toString radix 8 (octal)\" to_string_radix_8;\n test \"toString radix 10 (decimal)\" to_string_radix_10;\n test \"toString radix 16 (hex)\" to_string_radix_16;\n test \"toString radix 36 (max)\" to_string_radix_36;\n test \"toString various radixes\" to_string_various_radixes;\n test \"toString large numbers\" to_string_large_numbers;\n test \"toString negative large\" to_string_negative_large;\n test \"toString zero all radixes\" to_string_zero;\n (* to_float *)\n test \"to_float small\" to_float_small;\n test \"to_float large\" to_float_large;\n test \"to_float very large\" to_float_very_large;\n (* of_string edge cases *)\n test \"of_string edge cases\" of_string_edge_cases;\n test \"of_string hex\" of_string_hex;\n test \"of_string binary\" of_string_binary;\n test \"of_string octal\" of_string_octal;\n (* comparison *)\n test \"compare equal\" compare_equal;\n test \"compare less\" compare_less;\n test \"compare greater\" compare_greater;\n test \"compare negative\" compare_negative;\n test \"compare large\" compare_large;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/getters.ml",
"content": "(** TC39 Test262: Date getter tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype\n\n Tests for Date.prototype getter methods:\n - getFullYear, getUTCFullYear\n - getMonth, getUTCMonth\n - getDate, getUTCDate\n - getDay, getUTCDay\n - getHours, getUTCHours\n - getMinutes, getUTCMinutes\n - getSeconds, getUTCSeconds\n - getMilliseconds, getUTCMilliseconds\n - getTime\n - getTimezoneOffset *)\n\nopen Helpers\n\n(* A known timestamp for testing: 2017-09-22T16:37:38.091Z (Friday)\n epoch ms: 1506098258091 *)\nlet known_timestamp = 1506098258091.\n\n(* ===================================================================\n getTime / valueOf\n =================================================================== *)\n\nlet get_time_returns_epoch_ms () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getTime d) known_timestamp\n\nlet get_time_nan_for_invalid () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getTime d)\n\n(* ===================================================================\n UTC Getters - these don't depend on timezone\n =================================================================== *)\n\nlet get_utc_full_year () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCFullYear d) 2017.\n\nlet get_utc_month () =\n (* September = month 8 (0-indexed) *)\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCMonth d) 8.\n\nlet get_utc_date () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCDate d) 22.\n\nlet get_utc_day () =\n (* Friday = day 5 (0 = Sunday) *)\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCDay d) 5.\n\nlet get_utc_hours () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCHours d) 16.\n\nlet get_utc_minutes () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCMinutes d) 37.\n\nlet get_utc_seconds () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCSeconds d) 38.\n\nlet get_utc_milliseconds () =\n let d = Date.fromFloat known_timestamp in\n assert_float_exact (Date.getUTCMilliseconds d) 91.\n\n(* ===================================================================\n UTC Getters - boundary cases\n =================================================================== *)\n\nlet get_utc_epoch () =\n (* Jan 1, 1970 00:00:00.000 UTC *)\n let d = Date.fromFloat 0. in\n assert_float_exact (Date.getUTCFullYear d) 1970.;\n assert_float_exact (Date.getUTCMonth d) 0.;\n assert_float_exact (Date.getUTCDate d) 1.;\n assert_float_exact (Date.getUTCDay d) 4.;\n (* Thursday *)\n assert_float_exact (Date.getUTCHours d) 0.;\n assert_float_exact (Date.getUTCMinutes d) 0.;\n assert_float_exact (Date.getUTCSeconds d) 0.;\n assert_float_exact (Date.getUTCMilliseconds d) 0.\n\nlet get_utc_before_epoch () =\n (* Dec 31, 1969 23:59:59.999 UTC = -1ms *)\n let d = Date.fromFloat (-1.) in\n assert_float_exact (Date.getUTCFullYear d) 1969.;\n assert_float_exact (Date.getUTCMonth d) 11.;\n (* December *)\n assert_float_exact (Date.getUTCDate d) 31.;\n assert_float_exact (Date.getUTCHours d) 23.;\n assert_float_exact (Date.getUTCMinutes d) 59.;\n assert_float_exact (Date.getUTCSeconds d) 59.;\n assert_float_exact (Date.getUTCMilliseconds d) 999.\n\nlet get_utc_y2k () =\n (* Jan 1, 2000 00:00:00.000 UTC *)\n let d = Date.fromFloat 946684800000. in\n assert_float_exact (Date.getUTCFullYear d) 2000.;\n assert_float_exact (Date.getUTCMonth d) 0.;\n assert_float_exact (Date.getUTCDate d) 1.;\n assert_float_exact (Date.getUTCDay d) 6. (* Saturday *)\n\nlet get_utc_leap_day () =\n (* Feb 29, 2020 12:00:00.000 UTC *)\n let d = Date.fromFloat 1582977600000. in\n assert_float_exact (Date.getUTCFullYear d) 2020.;\n assert_float_exact (Date.getUTCMonth d) 1.;\n (* February *)\n assert_float_exact (Date.getUTCDate d) 29.\n\n(* ===================================================================\n NaN handling - all getters return NaN for invalid date\n =================================================================== *)\n\nlet get_utc_nan_full_year () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCFullYear d)\n\nlet get_utc_nan_month () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCMonth d)\n\nlet get_utc_nan_date () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCDate d)\n\nlet get_utc_nan_day () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCDay d)\n\nlet get_utc_nan_hours () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCHours d)\n\nlet get_utc_nan_minutes () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCMinutes d)\n\nlet get_utc_nan_seconds () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCSeconds d)\n\nlet get_utc_nan_milliseconds () =\n let d = Date.fromFloat nan in\n assert_nan (Date.getUTCMilliseconds d)\n\n(* ===================================================================\n End of year / start of year transitions\n =================================================================== *)\n\nlet get_utc_new_year_transition () =\n (* Dec 31, 2019 23:59:59.999 UTC *)\n let d1 = Date.fromFloat 1577836799999. in\n assert_float_exact (Date.getUTCFullYear d1) 2019.;\n assert_float_exact (Date.getUTCMonth d1) 11.;\n assert_float_exact (Date.getUTCDate d1) 31.;\n (* Jan 1, 2020 00:00:00.000 UTC *)\n let d2 = Date.fromFloat 1577836800000. in\n assert_float_exact (Date.getUTCFullYear d2) 2020.;\n assert_float_exact (Date.getUTCMonth d2) 0.;\n assert_float_exact (Date.getUTCDate d2) 1.\n\n(* ===================================================================\n Month boundaries\n =================================================================== *)\n\nlet get_utc_month_lengths () =\n (* Jan has 31 days, Feb 28/29, etc *)\n (* Last day of January 2020 *)\n let jan31 = Date.fromFloat (Date.utc ~year:2020. ~month:0. ~date:31. ()) in\n assert_float_exact (Date.getUTCMonth jan31) 0.;\n assert_float_exact (Date.getUTCDate jan31) 31.;\n (* Feb 1 *)\n let feb1 = Date.fromFloat (Date.utc ~year:2020. ~month:1. ~date:1. ()) in\n assert_float_exact (Date.getUTCMonth feb1) 1.;\n assert_float_exact (Date.getUTCDate feb1) 1.\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* getTime *)\n test \"getTime returns epoch ms\" get_time_returns_epoch_ms;\n test \"getTime NaN for invalid date\" get_time_nan_for_invalid;\n (* UTC getters for known timestamp *)\n test \"getUTCFullYear\" get_utc_full_year;\n test \"getUTCMonth\" get_utc_month;\n test \"getUTCDate\" get_utc_date;\n test \"getUTCDay\" get_utc_day;\n test \"getUTCHours\" get_utc_hours;\n test \"getUTCMinutes\" get_utc_minutes;\n test \"getUTCSeconds\" get_utc_seconds;\n test \"getUTCMilliseconds\" get_utc_milliseconds;\n (* UTC getters - boundary cases *)\n test \"UTC getters at epoch\" get_utc_epoch;\n test \"UTC getters before epoch\" get_utc_before_epoch;\n test \"UTC getters at Y2K\" get_utc_y2k;\n test \"UTC getters on leap day\" get_utc_leap_day;\n (* NaN handling *)\n test \"getUTCFullYear NaN\" get_utc_nan_full_year;\n test \"getUTCMonth NaN\" get_utc_nan_month;\n test \"getUTCDate NaN\" get_utc_nan_date;\n test \"getUTCDay NaN\" get_utc_nan_day;\n test \"getUTCHours NaN\" get_utc_nan_hours;\n test \"getUTCMinutes NaN\" get_utc_nan_minutes;\n test \"getUTCSeconds NaN\" get_utc_nan_seconds;\n test \"getUTCMilliseconds NaN\" get_utc_nan_milliseconds;\n (* Transitions *)\n test \"new year transition\" get_utc_new_year_transition;\n test \"month lengths\" get_utc_month_lengths;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/local_getters.ml",
"content": "(** TC39 Test262: Date local time getter tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/get*\n\n Tests for local time getters: getDate, getDay, getFullYear, getHours, getMinutes, getSeconds, getMilliseconds,\n getMonth, getTime, getTimezoneOffset *)\n\nopen Helpers\nmodule Date = Js.Date\n\n(* ===================================================================\n Helper: Create dates in UTC and test local getters\n Note: These tests use UTC dates to avoid timezone dependency\n =================================================================== *)\n\n(* ===================================================================\n getTime tests\n =================================================================== *)\n\nlet get_time_basic () =\n let d = Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:10. ~seconds:11. () +. 91. in\n assert_float_exact (Date.getTime d) 1508695811091.\n\nlet get_time_epoch () = assert_float_exact (Date.getTime 0.) 0.\n\nlet get_time_negative () =\n (* 1969-12-31T23:59:59.000Z = -1000 ms *)\n assert_float_exact (Date.getTime (-1000.)) (-1000.)\n\nlet get_time_nan () = assert_nan (Date.getTime nan)\n\n(* ===================================================================\n valueOf tests - should be identical to getTime\n =================================================================== *)\n\nlet valueof_basic () =\n let d = Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:10. ~seconds:11. () +. 91. in\n assert_float_exact (Date.valueOf d) 1508695811091.\n\nlet valueof_epoch () = assert_float_exact (Date.valueOf 0.) 0.\nlet valueof_nan () = assert_nan (Date.valueOf nan)\n\nlet valueof_equals_gettime () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. () in\n assert_float_exact (Date.valueOf d) (Date.getTime d)\n\n(* ===================================================================\n getUTCFullYear tests (comprehensive - already partially covered)\n =================================================================== *)\n\nlet get_utc_full_year_2017 () =\n let d = Date.utc ~year:2017. ~month:9. ~date:22. () in\n assert_float_exact (Date.getUTCFullYear d) 2017.\n\nlet get_utc_full_year_1970 () = assert_float_exact (Date.getUTCFullYear 0.) 1970.\n\nlet get_utc_full_year_1969 () =\n let d = Date.utc ~year:1969. ~month:11. ~date:31. ~hours:23. ~minutes:59. ~seconds:59. () in\n assert_float_exact (Date.getUTCFullYear d) 1969.\n\nlet get_utc_full_year_nan () = assert_nan (Date.getUTCFullYear nan)\n\nlet get_utc_full_year_y2k () =\n let d = Date.utc ~year:2000. ~month:0. ~date:1. () in\n assert_float_exact (Date.getUTCFullYear d) 2000.\n\nlet get_utc_full_year_leap () =\n let d = Date.utc ~year:2024. ~month:1. ~date:29. () in\n assert_float_exact (Date.getUTCFullYear d) 2024.\n\n(* ===================================================================\n getUTCMonth tests\n =================================================================== *)\n\nlet get_utc_month_january () =\n let d = Date.utc ~year:2020. ~month:0. ~date:15. () in\n assert_float_exact (Date.getUTCMonth d) 0.\n\nlet get_utc_month_december () =\n let d = Date.utc ~year:2020. ~month:11. ~date:25. () in\n assert_float_exact (Date.getUTCMonth d) 11.\n\nlet get_utc_month_nan () = assert_nan (Date.getUTCMonth nan)\nlet get_utc_month_epoch () = assert_float_exact (Date.getUTCMonth 0.) 0.\n\n(* ===================================================================\n getUTCDate tests\n =================================================================== *)\n\nlet get_utc_date_first () =\n let d = Date.utc ~year:2020. ~month:5. ~date:1. () in\n assert_float_exact (Date.getUTCDate d) 1.\n\nlet get_utc_date_31st () =\n let d = Date.utc ~year:2020. ~month:0. ~date:31. () in\n assert_float_exact (Date.getUTCDate d) 31.\n\nlet get_utc_date_nan () = assert_nan (Date.getUTCDate nan)\nlet get_utc_date_epoch () = assert_float_exact (Date.getUTCDate 0.) 1.\n\n(* ===================================================================\n getUTCDay tests (day of week)\n =================================================================== *)\n\nlet get_utc_day_thursday_epoch () =\n (* Jan 1, 1970 was a Thursday (day 4) *)\n assert_float_exact (Date.getUTCDay 0.) 4.\n\nlet get_utc_day_sunday () =\n (* Find a known Sunday - Jan 3, 2021 was Sunday *)\n let d = Date.utc ~year:2021. ~month:0. ~date:3. () in\n assert_float_exact (Date.getUTCDay d) 0.\n\nlet get_utc_day_saturday () =\n (* Jan 2, 2021 was Saturday *)\n let d = Date.utc ~year:2021. ~month:0. ~date:2. () in\n assert_float_exact (Date.getUTCDay d) 6.\n\nlet get_utc_day_nan () = assert_nan (Date.getUTCDay nan)\n\n(* ===================================================================\n getUTCHours tests\n =================================================================== *)\n\nlet get_utc_hours_zero () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. () in\n assert_float_exact (Date.getUTCHours d) 0.\n\nlet get_utc_hours_23 () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:23. () in\n assert_float_exact (Date.getUTCHours d) 23.\n\nlet get_utc_hours_nan () = assert_nan (Date.getUTCHours nan)\nlet get_utc_hours_epoch () = assert_float_exact (Date.getUTCHours 0.) 0.\n\n(* ===================================================================\n getUTCMinutes tests\n =================================================================== *)\n\nlet get_utc_minutes_zero () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. () in\n assert_float_exact (Date.getUTCMinutes d) 0.\n\nlet get_utc_minutes_59 () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:59. () in\n assert_float_exact (Date.getUTCMinutes d) 59.\n\nlet get_utc_minutes_nan () = assert_nan (Date.getUTCMinutes nan)\n\n(* ===================================================================\n getUTCSeconds tests\n =================================================================== *)\n\nlet get_utc_seconds_zero () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:0. () in\n assert_float_exact (Date.getUTCSeconds d) 0.\n\nlet get_utc_seconds_59 () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:59. () in\n assert_float_exact (Date.getUTCSeconds d) 59.\n\nlet get_utc_seconds_nan () = assert_nan (Date.getUTCSeconds nan)\n\n(* ===================================================================\n getUTCMilliseconds tests\n =================================================================== *)\n\nlet get_utc_ms_zero () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n assert_float_exact (Date.getUTCMilliseconds d) 0.\n\nlet get_utc_ms_999 () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () +. 999. in\n assert_float_exact (Date.getUTCMilliseconds d) 999.\n\nlet get_utc_ms_nan () = assert_nan (Date.getUTCMilliseconds nan)\n\nlet get_utc_ms_middle () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () +. 456. in\n assert_float_exact (Date.getUTCMilliseconds d) 456.\n\n(* ===================================================================\n getTimezoneOffset tests\n Note: This is timezone-dependent, so we just verify it returns a number\n =================================================================== *)\n\nlet get_timezone_offset_returns_number () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let offset = Date.getTimezoneOffset d in\n (* Offset should be a finite number *)\n assert_true \"timezone offset should be finite\" (Float.is_finite offset)\n\nlet get_timezone_offset_nan () = assert_nan (Date.getTimezoneOffset nan)\n\nlet get_timezone_offset_range () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let offset = Date.getTimezoneOffset d in\n (* Timezone offsets range from -720 (UTC+12) to +840 (UTC-14) *)\n assert_true \"offset in valid range\" (offset >= -720. && offset <= 840.)\n\n(* ===================================================================\n Local time getter tests\n Note: These depend on the system timezone, so we test consistency\n =================================================================== *)\n\nlet local_getters_consistent () =\n (* Create a date and verify local getters return consistent values *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () +. 123. in\n let year = Date.getFullYear d in\n let month = Date.getMonth d in\n let date = Date.getDate d in\n let hours = Date.getHours d in\n let minutes = Date.getMinutes d in\n let seconds = Date.getSeconds d in\n let ms = Date.getMilliseconds d in\n (* All should be finite *)\n assert_true \"year finite\" (Float.is_finite year);\n assert_true \"month finite\" (Float.is_finite month);\n assert_true \"date finite\" (Float.is_finite date);\n assert_true \"hours finite\" (Float.is_finite hours);\n assert_true \"minutes finite\" (Float.is_finite minutes);\n assert_true \"seconds finite\" (Float.is_finite seconds);\n assert_true \"ms finite\" (Float.is_finite ms);\n (* Check ranges *)\n assert_true \"month 0-11\" (month >= 0. && month <= 11.);\n assert_true \"date 1-31\" (date >= 1. && date <= 31.);\n assert_true \"hours 0-23\" (hours >= 0. && hours <= 23.);\n assert_true \"minutes 0-59\" (minutes >= 0. && minutes <= 59.);\n assert_true \"seconds 0-59\" (seconds >= 0. && seconds <= 59.);\n assert_true \"ms 0-999\" (ms >= 0. && ms <= 999.)\n\nlet local_getters_nan () =\n (* All local getters should return NaN for invalid dates *)\n assert_nan (Date.getFullYear nan);\n assert_nan (Date.getMonth nan);\n assert_nan (Date.getDate nan);\n assert_nan (Date.getDay nan);\n assert_nan (Date.getHours nan);\n assert_nan (Date.getMinutes nan);\n assert_nan (Date.getSeconds nan);\n assert_nan (Date.getMilliseconds nan)\n\nlet get_day_range () =\n (* getDay should return 0-6 *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let day = Date.getDay d in\n assert_true \"day 0-6\" (day >= 0. && day <= 6.)\n\n(* ===================================================================\n Edge case tests\n =================================================================== *)\n\nlet getters_large_positive_date () =\n (* Test with a large date - year 275760 (near max) *)\n let d = Date.utc ~year:275760. ~month:8. ~date:13. () in\n assert_float_exact (Date.getUTCFullYear d) 275760.\n\nlet getters_large_negative_date () =\n (* Test with a date before epoch *)\n let d = Date.utc ~year:1900. ~month:0. ~date:1. () in\n assert_float_exact (Date.getUTCFullYear d) 1900.\n\nlet getters_boundary_milliseconds () =\n (* Test at millisecond boundary *)\n let d = Date.utc ~year:2020. ~month:0. ~date:1. ~hours:0. ~minutes:0. ~seconds:0. () +. 999. in\n assert_float_exact (Date.getUTCMilliseconds d) 999.\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* getTime *)\n test \"getTime basic\" get_time_basic;\n test \"getTime epoch\" get_time_epoch;\n test \"getTime negative\" get_time_negative;\n test \"getTime NaN\" get_time_nan;\n (* valueOf *)\n test \"valueOf basic\" valueof_basic;\n test \"valueOf epoch\" valueof_epoch;\n test \"valueOf NaN\" valueof_nan;\n test \"valueOf equals getTime\" valueof_equals_gettime;\n (* getUTCFullYear *)\n test \"getUTCFullYear 2017\" get_utc_full_year_2017;\n test \"getUTCFullYear 1970 (epoch)\" get_utc_full_year_1970;\n test \"getUTCFullYear 1969\" get_utc_full_year_1969;\n test \"getUTCFullYear NaN\" get_utc_full_year_nan;\n test \"getUTCFullYear Y2K\" get_utc_full_year_y2k;\n test \"getUTCFullYear leap year\" get_utc_full_year_leap;\n (* getUTCMonth *)\n test \"getUTCMonth January (0)\" get_utc_month_january;\n test \"getUTCMonth December (11)\" get_utc_month_december;\n test \"getUTCMonth NaN\" get_utc_month_nan;\n test \"getUTCMonth epoch\" get_utc_month_epoch;\n (* getUTCDate *)\n test \"getUTCDate first\" get_utc_date_first;\n test \"getUTCDate 31st\" get_utc_date_31st;\n test \"getUTCDate NaN\" get_utc_date_nan;\n test \"getUTCDate epoch\" get_utc_date_epoch;\n (* getUTCDay *)\n test \"getUTCDay Thursday (epoch)\" get_utc_day_thursday_epoch;\n test \"getUTCDay Sunday\" get_utc_day_sunday;\n test \"getUTCDay Saturday\" get_utc_day_saturday;\n test \"getUTCDay NaN\" get_utc_day_nan;\n (* getUTCHours *)\n test \"getUTCHours zero\" get_utc_hours_zero;\n test \"getUTCHours 23\" get_utc_hours_23;\n test \"getUTCHours NaN\" get_utc_hours_nan;\n test \"getUTCHours epoch\" get_utc_hours_epoch;\n (* getUTCMinutes *)\n test \"getUTCMinutes zero\" get_utc_minutes_zero;\n test \"getUTCMinutes 59\" get_utc_minutes_59;\n test \"getUTCMinutes NaN\" get_utc_minutes_nan;\n (* getUTCSeconds *)\n test \"getUTCSeconds zero\" get_utc_seconds_zero;\n test \"getUTCSeconds 59\" get_utc_seconds_59;\n test \"getUTCSeconds NaN\" get_utc_seconds_nan;\n (* getUTCMilliseconds *)\n test \"getUTCMilliseconds zero\" get_utc_ms_zero;\n test \"getUTCMilliseconds 999\" get_utc_ms_999;\n test \"getUTCMilliseconds NaN\" get_utc_ms_nan;\n test \"getUTCMilliseconds middle\" get_utc_ms_middle;\n (* getTimezoneOffset *)\n test \"getTimezoneOffset returns number\" get_timezone_offset_returns_number;\n test \"getTimezoneOffset NaN\" get_timezone_offset_nan;\n test \"getTimezoneOffset in valid range\" get_timezone_offset_range;\n (* Local getters *)\n test \"local getters consistent\" local_getters_consistent;\n test \"local getters NaN\" local_getters_nan;\n test \"getDay range 0-6\" get_day_range;\n (* Edge cases *)\n test \"getters large positive date\" getters_large_positive_date;\n test \"getters large negative date\" getters_large_negative_date;\n test \"getters boundary milliseconds\" getters_boundary_milliseconds;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/now.ml",
"content": "(** TC39 Test262: Date.now tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/now\n\n ECMA-262 Section: Date.now()\n\n Returns the current time as milliseconds since the Unix epoch. *)\n\nopen Helpers\n\n(* ===================================================================\n Basic functionality\n =================================================================== *)\n\nlet now_returns_number () =\n (* Date.now() should return a finite number *)\n let result = Date.now () in\n assert_not_nan result;\n assert_bool (Float.is_finite result) true\n\nlet now_returns_positive () =\n (* Date.now() should be positive (we're well past 1970) *)\n let result = Date.now () in\n assert_bool (result > 0.) true\n\nlet now_is_recent () =\n (* Date.now() should be reasonably recent (after year 2020) *)\n let result = Date.now () in\n let year_2020 = 1577836800000. in\n (* Jan 1, 2020 00:00:00 UTC *)\n assert_bool (result > year_2020) true\n\nlet now_increases () =\n (* Two calls to Date.now() should not decrease *)\n let t1 = Date.now () in\n (* Small busy wait - not ideal but tests the concept *)\n let t2 = Date.now () in\n assert_bool (t2 >= t1) true\n\nlet now_is_integer_like () =\n (* Date.now() should return an integer value (no fractional ms) *)\n let result = Date.now () in\n assert_bool (Float.is_integer result) true\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n test \"now returns finite number\" now_returns_number;\n test \"now returns positive\" now_returns_positive;\n test \"now is recent (after 2020)\" now_is_recent;\n test \"now is monotonic\" now_increases;\n test \"now returns integer ms\" now_is_integer_like;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/parse.ml",
"content": "(** TC39 Test262: Date.parseAsFloat tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/parse\n\n ECMA-262 Section: Date.parse(string)\n\n Date.parseAsFloat returns the time value (epoch milliseconds) from a string. Returns NaN if the string is not a\n valid date. *)\n\nopen Helpers\n\n(* ===================================================================\n ISO 8601 format: YYYY-MM-DDTHH:mm:ss.sssZ\n =================================================================== *)\n\nlet parse_empty_string () =\n (* Date.parse(\"\") returns NaN *)\n assert_nan (Date.parseAsFloat \"\")\n\nlet parse_year_only () =\n (* Date.parse(\"2000\") = Jan 1, 2000 00:00:00 UTC *)\n assert_float_exact (Date.parseAsFloat \"2000\") 946684800000.\n\nlet parse_year_month () =\n (* Date.parse(\"2000-01\") = Jan 1, 2000 00:00:00 UTC *)\n assert_float_exact (Date.parseAsFloat \"2000-01\") 946684800000.\n\nlet parse_full_date () =\n (* Date.parse(\"2000-01-01\") = Jan 1, 2000 00:00:00 UTC *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01\") 946684800000.\n\nlet parse_date_time_utc () =\n (* Date.parse(\"2000-01-01T00:00Z\") *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00Z\") 946684800000.\n\nlet parse_date_time_seconds () =\n (* Date.parse(\"2000-01-01T00:00:00Z\") *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00:00Z\") 946684800000.\n\nlet parse_date_time_millis_1 () =\n (* Date.parse(\"2000-01-01T00:00:00.1Z\") = 100ms after midnight *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00:00.1Z\") 946684800100.\n\nlet parse_date_time_millis_2 () =\n (* Date.parse(\"2000-01-01T00:00:00.10Z\") = 100ms *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00:00.10Z\") 946684800100.\n\nlet parse_date_time_millis_3 () =\n (* Date.parse(\"2000-01-01T00:00:00.100Z\") = 100ms *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00:00.100Z\") 946684800100.\n\nlet parse_date_time_millis_4 () =\n (* Date.parse(\"2000-01-01T00:00:00.1000Z\") = implementation-defined, but QuickJS returns 100ms *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00:00.1000Z\") 946684800100.\n\nlet parse_timezone_offset () =\n (* Date.parse(\"2000-01-01T00:00:00+00:00\") *)\n assert_float_exact (Date.parseAsFloat \"2000-01-01T00:00:00+00:00\") 946684800000.\n\n(* ===================================================================\n A known timestamp: 2017-09-22T16:37:38.091Z\n =================================================================== *)\n\nlet parse_known_iso_timestamp () =\n (* This is a specific timestamp from QuickJS tests *)\n assert_float_exact (Date.parseAsFloat \"2017-09-22T16:37:38.091Z\") 1506098258091.\n\nlet parse_roundtrip () =\n (* Parse an ISO string, format it back, should get same value *)\n let original = \"2020-01-01T01:01:01.123Z\" in\n let parsed = Date.parseAsFloat original in\n assert_float_exact parsed 1577840461123.\n\n(* ===================================================================\n Millisecond parsing edge cases\n =================================================================== *)\n\nlet parse_millis_single_digit () =\n (* .1Z should be 100ms *)\n assert_float_exact (Date.parseAsFloat \"2020-01-01T01:01:01.1Z\") 1577840461100.\n\nlet parse_millis_two_digits () =\n (* .12Z should be 120ms *)\n assert_float_exact (Date.parseAsFloat \"2020-01-01T01:01:01.12Z\") 1577840461120.\n\nlet parse_millis_four_digits () =\n (* .1234Z truncates to 123ms *)\n assert_float_exact (Date.parseAsFloat \"2020-01-01T01:01:01.1234Z\") 1577840461123.\n\nlet parse_millis_many_digits () =\n (* .9999Z truncates to 999ms (no rounding) *)\n assert_float_exact (Date.parseAsFloat \"2020-01-01T01:01:01.9999Z\") 1577840461999.\n\n(* ===================================================================\n Expanded years (6-digit years with +/- prefix)\n =================================================================== *)\n\nlet parse_expanded_year_positive () =\n (* +002000 is year 2000 *)\n assert_float_exact (Date.parseAsFloat \"+002000-01-01T00:00:00Z\") 946684800000.\n\nlet parse_expanded_year_negative () =\n (* -000001 is year -1 (2 BCE) *)\n let result = Date.parseAsFloat \"-000001-01-01T00:00:00Z\" in\n assert_not_nan result\n\nlet parse_expanded_year_zero_invalid () =\n (* -000000 is explicitly invalid per spec *)\n assert_nan (Date.parseAsFloat \"-000000-01-01T00:00:00Z\")\n\n(* ===================================================================\n Non-ISO formats (toString/toUTCString style)\n =================================================================== *)\n\nlet parse_month_name_format () =\n (* \"Jan 1 2000\" style *)\n let result = Date.parseAsFloat \"Jan 1 2000 00:00:00 GMT\" in\n assert_float_exact result 946684800000.\n\nlet parse_with_weekday () =\n (* \"Sat Jan 1 2000\" style *)\n let result = Date.parseAsFloat \"Sat Jan 1 2000 00:00:00 GMT\" in\n assert_float_exact result 946684800000.\n\nlet parse_timezone_abbreviation () =\n (* GMT+0100 style offset *)\n let result = Date.parseAsFloat \"Jan 1 2000 00:00:00 GMT+0100\" in\n (* 1 hour before UTC midnight = Dec 31 1999 23:00 UTC *)\n assert_float_exact result (946684800000. -. 3600000.)\n\nlet parse_timezone_abbreviation_2 () =\n (* GMT+0200 *)\n let result = Date.parseAsFloat \"Jan 1 2000 00:00:00 GMT+0200\" in\n assert_float_exact result (946684800000. -. 7200000.)\n\n(* ===================================================================\n Invalid strings\n =================================================================== *)\n\nlet parse_invalid_gibberish () = assert_nan (Date.parseAsFloat \"not a date\")\nlet parse_invalid_partial () = assert_nan (Date.parseAsFloat \"2000-\")\n\nlet parse_invalid_month () =\n (* Month 13 is invalid *)\n assert_nan (Date.parseAsFloat \"2000-13-01\")\n\nlet parse_invalid_day () =\n (* Day 32 is invalid *)\n assert_nan (Date.parseAsFloat \"2000-01-32\")\n\nlet parse_invalid_hour () =\n (* Hour 25 is invalid *)\n assert_nan (Date.parseAsFloat \"2000-01-01T25:00:00Z\")\n\nlet parse_invalid_minute () =\n (* Minute 60 is invalid *)\n assert_nan (Date.parseAsFloat \"2000-01-01T00:60:00Z\")\n\nlet parse_invalid_second () =\n (* Second 60 is invalid (except leap seconds, not supported) *)\n assert_nan (Date.parseAsFloat \"2000-01-01T00:00:60Z\")\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* ISO 8601 format *)\n test \"empty string returns NaN\" parse_empty_string;\n test \"year only: 2000\" parse_year_only;\n test \"year-month: 2000-01\" parse_year_month;\n test \"full date: 2000-01-01\" parse_full_date;\n test \"date with time UTC: 2000-01-01T00:00Z\" parse_date_time_utc;\n test \"date with seconds: 2000-01-01T00:00:00Z\" parse_date_time_seconds;\n test \"milliseconds .1Z = 100ms\" parse_date_time_millis_1;\n test \"milliseconds .10Z = 100ms\" parse_date_time_millis_2;\n test \"milliseconds .100Z = 100ms\" parse_date_time_millis_3;\n test \"milliseconds .1000Z = 100ms\" parse_date_time_millis_4;\n test \"timezone offset +00:00\" parse_timezone_offset;\n (* Known timestamp *)\n test \"known ISO timestamp\" parse_known_iso_timestamp;\n test \"roundtrip parsing\" parse_roundtrip;\n (* Millisecond edge cases *)\n test \"millis: single digit .1\" parse_millis_single_digit;\n test \"millis: two digits .12\" parse_millis_two_digits;\n test \"millis: four digits .1234 truncates\" parse_millis_four_digits;\n test \"millis: many digits .9999 truncates\" parse_millis_many_digits;\n (* Expanded years *)\n test \"expanded year +002000\" parse_expanded_year_positive;\n test \"expanded year -000001\" parse_expanded_year_negative;\n test \"expanded year -000000 is invalid\" parse_expanded_year_zero_invalid;\n (* Non-ISO formats *)\n test \"month name format: Jan 1 2000\" parse_month_name_format;\n test \"with weekday: Sat Jan 1 2000\" parse_with_weekday;\n test \"timezone GMT+0100\" parse_timezone_abbreviation;\n test \"timezone GMT+0200\" parse_timezone_abbreviation_2;\n (* Invalid strings *)\n test \"invalid: gibberish\" parse_invalid_gibberish;\n test \"invalid: partial 2000-\" parse_invalid_partial;\n test \"invalid: month 13\" parse_invalid_month;\n test \"invalid: day 32\" parse_invalid_day;\n test \"invalid: hour 25\" parse_invalid_hour;\n test \"invalid: minute 60\" parse_invalid_minute;\n test \"invalid: second 60\" parse_invalid_second;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/setters.ml",
"content": "(** TC39 Test262: Date setter tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/set*\n\n Tests for setters: setDate, setFullYear, setHours, setMinutes, setSeconds, setMilliseconds, setMonth, setTime and\n their UTC variants *)\n\nopen Helpers\nmodule Date = Js.Date\n\n(* ===================================================================\n setTime tests\n =================================================================== *)\n\nlet set_time_basic () =\n let result = Date.setTime ~time:1508695811091. 0. in\n assert_float_exact result 1508695811091.\n\nlet set_time_epoch () =\n let result = Date.setTime ~time:0. 1000. in\n assert_float_exact result 0.\n\nlet set_time_negative () =\n let result = Date.setTime ~time:(-1000.) 0. in\n assert_float_exact result (-1000.)\n\nlet set_time_nan_value () =\n let result = Date.setTime ~time:nan 0. in\n assert_nan result\n\nlet set_time_on_nan_date () =\n let result = Date.setTime ~time:1000. nan in\n assert_float_exact result 1000.\n\n(* ===================================================================\n setUTCMilliseconds tests\n =================================================================== *)\n\nlet set_utc_ms_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let result = Date.setUTCMilliseconds ~milliseconds:500. d in\n assert_float_exact (Date.getUTCMilliseconds result) 500.\n\nlet set_utc_ms_overflow () =\n (* Setting ms to 1000 should roll over to next second *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let result = Date.setUTCMilliseconds ~milliseconds:1000. d in\n assert_float_exact (Date.getUTCMilliseconds result) 0.;\n assert_float_exact (Date.getUTCSeconds result) 46.\n\nlet set_utc_ms_negative () =\n (* Negative ms should roll back *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () +. 500. in\n let result = Date.setUTCMilliseconds ~milliseconds:(-1.) d in\n assert_float_exact (Date.getUTCMilliseconds result) 999.;\n assert_float_exact (Date.getUTCSeconds result) 44.\n\nlet set_utc_ms_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCMilliseconds ~milliseconds:nan d in\n assert_nan result\n\n(* ===================================================================\n setUTCSeconds tests\n =================================================================== *)\n\nlet set_utc_seconds_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:0. () in\n let result = Date.setUTCSeconds ~seconds:45. d in\n assert_float_exact (Date.getUTCSeconds result) 45.\n\nlet set_utc_seconds_overflow () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:0. () in\n let result = Date.setUTCSeconds ~seconds:60. d in\n assert_float_exact (Date.getUTCSeconds result) 0.;\n assert_float_exact (Date.getUTCMinutes result) 31.\n\nlet set_utc_seconds_with_ms () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:0. () in\n let result = Date.setUTCSeconds ~seconds:45. ~milliseconds:123. d in\n assert_float_exact (Date.getUTCSeconds result) 45.;\n assert_float_exact (Date.getUTCMilliseconds result) 123.\n\nlet set_utc_seconds_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCSeconds ~seconds:nan d in\n assert_nan result\n\n(* ===================================================================\n setUTCMinutes tests\n =================================================================== *)\n\nlet set_utc_minutes_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. () in\n let result = Date.setUTCMinutes ~minutes:45. d in\n assert_float_exact (Date.getUTCMinutes result) 45.\n\nlet set_utc_minutes_overflow () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. () in\n let result = Date.setUTCMinutes ~minutes:60. d in\n assert_float_exact (Date.getUTCMinutes result) 0.;\n assert_float_exact (Date.getUTCHours result) 13.\n\nlet set_utc_minutes_with_seconds () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. ~seconds:0. () in\n let result = Date.setUTCMinutes ~minutes:30. ~seconds:45. d in\n assert_float_exact (Date.getUTCMinutes result) 30.;\n assert_float_exact (Date.getUTCSeconds result) 45.\n\nlet set_utc_minutes_with_seconds_ms () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. ~seconds:0. () in\n let result = Date.setUTCMinutes ~minutes:30. ~seconds:45. ~milliseconds:123. d in\n assert_float_exact (Date.getUTCMinutes result) 30.;\n assert_float_exact (Date.getUTCSeconds result) 45.;\n assert_float_exact (Date.getUTCMilliseconds result) 123.\n\nlet set_utc_minutes_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCMinutes ~minutes:nan d in\n assert_nan result\n\n(* ===================================================================\n setUTCHours tests\n =================================================================== *)\n\nlet set_utc_hours_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. () in\n let result = Date.setUTCHours ~hours:18. d in\n assert_float_exact (Date.getUTCHours result) 18.\n\nlet set_utc_hours_overflow () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. () in\n let result = Date.setUTCHours ~hours:24. d in\n assert_float_exact (Date.getUTCHours result) 0.;\n assert_float_exact (Date.getUTCDate result) 16.\n\nlet set_utc_hours_with_minutes () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. ~minutes:0. () in\n let result = Date.setUTCHours ~hours:18. ~minutes:30. d in\n assert_float_exact (Date.getUTCHours result) 18.;\n assert_float_exact (Date.getUTCMinutes result) 30.\n\nlet set_utc_hours_with_minutes_seconds () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. ~minutes:0. ~seconds:0. () in\n let result = Date.setUTCHours ~hours:18. ~minutes:30. ~seconds:45. d in\n assert_float_exact (Date.getUTCHours result) 18.;\n assert_float_exact (Date.getUTCMinutes result) 30.;\n assert_float_exact (Date.getUTCSeconds result) 45.\n\nlet set_utc_hours_all () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. ~minutes:0. ~seconds:0. () in\n let result = Date.setUTCHours ~hours:18. ~minutes:30. ~seconds:45. ~milliseconds:123. d in\n assert_float_exact (Date.getUTCHours result) 18.;\n assert_float_exact (Date.getUTCMinutes result) 30.;\n assert_float_exact (Date.getUTCSeconds result) 45.;\n assert_float_exact (Date.getUTCMilliseconds result) 123.\n\nlet set_utc_hours_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCHours ~hours:nan d in\n assert_nan result\n\n(* ===================================================================\n setUTCDate tests\n =================================================================== *)\n\nlet set_utc_date_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:1. () in\n let result = Date.setUTCDate ~date:15. d in\n assert_float_exact (Date.getUTCDate result) 15.\n\nlet set_utc_date_overflow () =\n (* June has 30 days, setting to 31 should roll to July 1 *)\n let d = Date.utc ~year:2020. ~month:5. ~date:1. () in\n let result = Date.setUTCDate ~date:31. d in\n assert_float_exact (Date.getUTCDate result) 1.;\n assert_float_exact (Date.getUTCMonth result) 6.\n\nlet set_utc_date_zero () =\n (* Day 0 means last day of previous month *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCDate ~date:0. d in\n assert_float_exact (Date.getUTCDate result) 31.;\n assert_float_exact (Date.getUTCMonth result) 4.\n\nlet set_utc_date_negative () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCDate ~date:(-1.) d in\n assert_float_exact (Date.getUTCDate result) 30.;\n assert_float_exact (Date.getUTCMonth result) 4.\n\nlet set_utc_date_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCDate ~date:nan d in\n assert_nan result\n\n(* ===================================================================\n setUTCMonth tests\n =================================================================== *)\n\nlet set_utc_month_basic () =\n let d = Date.utc ~year:2020. ~month:0. ~date:15. () in\n let result = Date.setUTCMonth ~month:5. d in\n assert_float_exact (Date.getUTCMonth result) 5.\n\nlet set_utc_month_overflow () =\n let d = Date.utc ~year:2020. ~month:0. ~date:15. () in\n let result = Date.setUTCMonth ~month:12. d in\n assert_float_exact (Date.getUTCMonth result) 0.;\n assert_float_exact (Date.getUTCFullYear result) 2021.\n\nlet set_utc_month_negative () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCMonth ~month:(-1.) d in\n assert_float_exact (Date.getUTCMonth result) 11.;\n assert_float_exact (Date.getUTCFullYear result) 2019.\n\nlet set_utc_month_with_date () =\n let d = Date.utc ~year:2020. ~month:0. ~date:1. () in\n let result = Date.setUTCMonth ~month:5. ~date:15. d in\n assert_float_exact (Date.getUTCMonth result) 5.;\n assert_float_exact (Date.getUTCDate result) 15.\n\nlet set_utc_month_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCMonth ~month:nan d in\n assert_nan result\n\n(* ===================================================================\n setUTCFullYear tests\n =================================================================== *)\n\nlet set_utc_full_year_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCFullYear ~year:2025. d in\n assert_float_exact (Date.getUTCFullYear result) 2025.\n\nlet set_utc_full_year_with_month () =\n let d = Date.utc ~year:2020. ~month:0. ~date:15. () in\n let result = Date.setUTCFullYear ~year:2025. ~month:5. d in\n assert_float_exact (Date.getUTCFullYear result) 2025.;\n assert_float_exact (Date.getUTCMonth result) 5.\n\nlet set_utc_full_year_with_month_date () =\n let d = Date.utc ~year:2020. ~month:0. ~date:1. () in\n let result = Date.setUTCFullYear ~year:2025. ~month:5. ~date:15. d in\n assert_float_exact (Date.getUTCFullYear result) 2025.;\n assert_float_exact (Date.getUTCMonth result) 5.;\n assert_float_exact (Date.getUTCDate result) 15.\n\nlet set_utc_full_year_leap_to_non_leap () =\n (* Feb 29 in leap year -> set to non-leap year *)\n let d = Date.utc ~year:2020. ~month:1. ~date:29. () in\n let result = Date.setUTCFullYear ~year:2021. d in\n (* Should roll over to March 1 *)\n assert_float_exact (Date.getUTCFullYear result) 2021.;\n assert_float_exact (Date.getUTCMonth result) 2.;\n assert_float_exact (Date.getUTCDate result) 1.\n\nlet set_utc_full_year_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setUTCFullYear ~year:nan d in\n assert_nan result\n\n(* ===================================================================\n Local time setters tests\n Note: These are timezone-dependent, so we test basic functionality\n =================================================================== *)\n\nlet set_milliseconds_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let result = Date.setMilliseconds ~milliseconds:500. d in\n (* Should have changed the ms *)\n let utc_ms = Date.getUTCMilliseconds result in\n (* Due to timezone, this might wrap around, but should be a valid ms value *)\n assert_true \"ms in range\" (utc_ms >= 0. && utc_ms <= 999.)\n\nlet set_seconds_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:0. () in\n let result = Date.setSeconds ~seconds:30. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_minutes_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. () in\n let result = Date.setMinutes ~minutes:45. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_hours_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. () in\n let result = Date.setHours ~hours:18. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_date_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:1. () in\n let result = Date.setDate ~date:15. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_month_basic () =\n let d = Date.utc ~year:2020. ~month:0. ~date:15. () in\n let result = Date.setMonth ~month:5. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_full_year_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setFullYear ~year:2025. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\n(* Local setters with multiple args *)\nlet set_seconds_with_ms () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:0. () in\n let result = Date.setSeconds ~seconds:45. ~milliseconds:123. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_minutes_with_seconds () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. ~seconds:0. () in\n let result = Date.setMinutes ~minutes:30. ~seconds:45. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_minutes_with_seconds_ms () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:0. ~seconds:0. () in\n let result = Date.setMinutes ~minutes:30. ~seconds:45. ~milliseconds:123. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_hours_with_minutes () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. ~minutes:0. () in\n let result = Date.setHours ~hours:18. ~minutes:30. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_hours_with_minutes_seconds () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. ~minutes:0. ~seconds:0. () in\n let result = Date.setHours ~hours:18. ~minutes:30. ~seconds:45. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_hours_all () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:0. ~minutes:0. ~seconds:0. () in\n let result = Date.setHours ~hours:18. ~minutes:30. ~seconds:45. ~milliseconds:123. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_month_with_date () =\n let d = Date.utc ~year:2020. ~month:0. ~date:1. () in\n let result = Date.setMonth ~month:5. ~date:15. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_full_year_with_month () =\n let d = Date.utc ~year:2020. ~month:0. ~date:15. () in\n let result = Date.setFullYear ~year:2025. ~month:5. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\nlet set_full_year_with_month_date () =\n let d = Date.utc ~year:2020. ~month:0. ~date:1. () in\n let result = Date.setFullYear ~year:2025. ~month:5. ~date:15. d in\n assert_true \"result is finite\" (Float.is_finite result)\n\n(* NaN tests for local setters *)\nlet set_milliseconds_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setMilliseconds ~milliseconds:nan d in\n assert_nan result\n\nlet set_seconds_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setSeconds ~seconds:nan d in\n assert_nan result\n\nlet set_minutes_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setMinutes ~minutes:nan d in\n assert_nan result\n\nlet set_hours_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setHours ~hours:nan d in\n assert_nan result\n\nlet set_date_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setDate ~date:nan d in\n assert_nan result\n\nlet set_month_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setMonth ~month:nan d in\n assert_nan result\n\nlet set_full_year_nan () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let result = Date.setFullYear ~year:nan d in\n assert_nan result\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* setTime *)\n test \"setTime basic\" set_time_basic;\n test \"setTime epoch\" set_time_epoch;\n test \"setTime negative\" set_time_negative;\n test \"setTime NaN value\" set_time_nan_value;\n test \"setTime on NaN date\" set_time_on_nan_date;\n (* setUTCMilliseconds *)\n test \"setUTCMilliseconds basic\" set_utc_ms_basic;\n test \"setUTCMilliseconds overflow\" set_utc_ms_overflow;\n test \"setUTCMilliseconds negative\" set_utc_ms_negative;\n test \"setUTCMilliseconds NaN\" set_utc_ms_nan;\n (* setUTCSeconds *)\n test \"setUTCSeconds basic\" set_utc_seconds_basic;\n test \"setUTCSeconds overflow\" set_utc_seconds_overflow;\n test \"setUTCSeconds with ms\" set_utc_seconds_with_ms;\n test \"setUTCSeconds NaN\" set_utc_seconds_nan;\n (* setUTCMinutes *)\n test \"setUTCMinutes basic\" set_utc_minutes_basic;\n test \"setUTCMinutes overflow\" set_utc_minutes_overflow;\n test \"setUTCMinutes with seconds\" set_utc_minutes_with_seconds;\n test \"setUTCMinutes with seconds and ms\" set_utc_minutes_with_seconds_ms;\n test \"setUTCMinutes NaN\" set_utc_minutes_nan;\n (* setUTCHours *)\n test \"setUTCHours basic\" set_utc_hours_basic;\n test \"setUTCHours overflow\" set_utc_hours_overflow;\n test \"setUTCHours with minutes\" set_utc_hours_with_minutes;\n test \"setUTCHours with minutes and seconds\" set_utc_hours_with_minutes_seconds;\n test \"setUTCHours all components\" set_utc_hours_all;\n test \"setUTCHours NaN\" set_utc_hours_nan;\n (* setUTCDate *)\n test \"setUTCDate basic\" set_utc_date_basic;\n test \"setUTCDate overflow\" set_utc_date_overflow;\n test \"setUTCDate zero\" set_utc_date_zero;\n test \"setUTCDate negative\" set_utc_date_negative;\n test \"setUTCDate NaN\" set_utc_date_nan;\n (* setUTCMonth *)\n test \"setUTCMonth basic\" set_utc_month_basic;\n test \"setUTCMonth overflow\" set_utc_month_overflow;\n test \"setUTCMonth negative\" set_utc_month_negative;\n test \"setUTCMonth with date\" set_utc_month_with_date;\n test \"setUTCMonth NaN\" set_utc_month_nan;\n (* setUTCFullYear *)\n test \"setUTCFullYear basic\" set_utc_full_year_basic;\n test \"setUTCFullYear with month\" set_utc_full_year_with_month;\n test \"setUTCFullYear with month and date\" set_utc_full_year_with_month_date;\n test \"setUTCFullYear leap to non-leap\" set_utc_full_year_leap_to_non_leap;\n test \"setUTCFullYear NaN\" set_utc_full_year_nan;\n (* Local setters *)\n test \"setMilliseconds basic\" set_milliseconds_basic;\n test \"setSeconds basic\" set_seconds_basic;\n test \"setMinutes basic\" set_minutes_basic;\n test \"setHours basic\" set_hours_basic;\n test \"setDate basic\" set_date_basic;\n test \"setMonth basic\" set_month_basic;\n test \"setFullYear basic\" set_full_year_basic;\n (* Local setters with multiple args *)\n test \"setSeconds with ms\" set_seconds_with_ms;\n test \"setMinutes with seconds\" set_minutes_with_seconds;\n test \"setMinutes with seconds and ms\" set_minutes_with_seconds_ms;\n test \"setHours with minutes\" set_hours_with_minutes;\n test \"setHours with minutes and seconds\" set_hours_with_minutes_seconds;\n test \"setHours all components\" set_hours_all;\n test \"setMonth with date\" set_month_with_date;\n test \"setFullYear with month\" set_full_year_with_month;\n test \"setFullYear with month and date\" set_full_year_with_month_date;\n (* NaN tests for local setters *)\n test \"setMilliseconds NaN\" set_milliseconds_nan;\n test \"setSeconds NaN\" set_seconds_nan;\n test \"setMinutes NaN\" set_minutes_nan;\n test \"setHours NaN\" set_hours_nan;\n test \"setDate NaN\" set_date_nan;\n test \"setMonth NaN\" set_month_nan;\n test \"setFullYear NaN\" set_full_year_nan;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/to_iso_string.ml",
"content": "(** TC39 Test262: Date.prototype.toISOString tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/toISOString\n\n ECMA-262 Section: Date.prototype.toISOString()\n\n Returns a string in ISO 8601 format: YYYY-MM-DDTHH:mm:ss.sssZ Throws RangeError for invalid dates (NaN). *)\n\nopen Helpers\n\n(* ===================================================================\n Basic formatting\n =================================================================== *)\n\nlet to_iso_string_known_timestamp () =\n (* From QuickJS tests: new Date(1506098258091).toISOString() *)\n let d = Date.fromFloat 1506098258091. in\n assert_string (Date.toISOString d) \"2017-09-22T16:37:38.091Z\"\n\nlet to_iso_string_epoch () =\n let d = Date.fromFloat 0. in\n assert_string (Date.toISOString d) \"1970-01-01T00:00:00.000Z\"\n\nlet to_iso_string_y2k () =\n let d = Date.fromFloat 946684800000. in\n assert_string (Date.toISOString d) \"2000-01-01T00:00:00.000Z\"\n\nlet to_iso_string_with_millis () =\n let d = Date.fromFloat 1577840461123. in\n assert_string (Date.toISOString d) \"2020-01-01T01:01:01.123Z\"\n\n(* ===================================================================\n Millisecond formatting (always 3 digits)\n =================================================================== *)\n\nlet to_iso_string_millis_zero () =\n (* 0ms should be formatted as .000 *)\n let d = Date.fromFloat 946684800000. in\n assert_string (Date.toISOString d) \"2000-01-01T00:00:00.000Z\"\n\nlet to_iso_string_millis_001 () =\n let d = Date.fromFloat 946684800001. in\n assert_string (Date.toISOString d) \"2000-01-01T00:00:00.001Z\"\n\nlet to_iso_string_millis_010 () =\n let d = Date.fromFloat 946684800010. in\n assert_string (Date.toISOString d) \"2000-01-01T00:00:00.010Z\"\n\nlet to_iso_string_millis_100 () =\n let d = Date.fromFloat 946684800100. in\n assert_string (Date.toISOString d) \"2000-01-01T00:00:00.100Z\"\n\nlet to_iso_string_millis_999 () =\n let d = Date.fromFloat 946684800999. in\n assert_string (Date.toISOString d) \"2000-01-01T00:00:00.999Z\"\n\n(* ===================================================================\n Zero-padding for date/time components\n =================================================================== *)\n\nlet to_iso_string_single_digit_month () =\n (* January = 01 *)\n let d = Date.fromFloat 946684800000. in\n (* 2000-01-01 *)\n let iso = Date.toISOString d in\n assert_bool (String.sub iso 5 2 = \"01\") true\n\nlet to_iso_string_single_digit_day () =\n (* Day 1 = 01 *)\n let d = Date.fromFloat 946684800000. in\n (* 2000-01-01 *)\n let iso = Date.toISOString d in\n assert_bool (String.sub iso 8 2 = \"01\") true\n\nlet to_iso_string_single_digit_hour () =\n (* Hour 1 = 01 *)\n let d = Date.fromFloat 946688400000. in\n (* 2000-01-01T01:00:00Z *)\n let iso = Date.toISOString d in\n assert_bool (String.sub iso 11 2 = \"01\") true\n\n(* ===================================================================\n Before epoch (negative timestamps)\n =================================================================== *)\n\nlet to_iso_string_before_epoch () =\n (* Dec 31, 1969 23:59:59.999 UTC *)\n let d = Date.fromFloat (-1.) in\n assert_string (Date.toISOString d) \"1969-12-31T23:59:59.999Z\"\n\nlet to_iso_string_1969_jan () =\n (* Jan 1, 1969 00:00:00.000 UTC *)\n let d = Date.fromFloat (-31536000000.) in\n assert_string (Date.toISOString d) \"1969-01-01T00:00:00.000Z\"\n\n(* ===================================================================\n Expanded years (years outside 0000-9999)\n =================================================================== *)\n\nlet to_iso_string_year_0 () =\n (* Year 0 (1 BCE) - represented as +000000 or 0000 depending on implementation *)\n let d = Date.fromFloat (-62167219200000.) in\n (* Approximately year 0 *)\n let iso = Date.toISOString d in\n (* Should have valid format *)\n assert_bool (String.length iso > 0) true\n\nlet to_iso_string_negative_year () =\n (* Year -1 (2 BCE) - formatted with minus sign *)\n let d = Date.fromFloat (-62198755200000.) in\n (* Approximately year -1 *)\n let iso = Date.toISOString d in\n assert_bool (String.length iso > 0) true\n\nlet to_iso_string_year_10000 () =\n (* Year 10000 - formatted with + prefix *)\n let d = Date.fromFloat 253402300800000. in\n (* Year 10000 *)\n let iso = Date.toISOString d in\n assert_bool (String.length iso > 0) true\n\n(* ===================================================================\n Parse/format roundtrip\n =================================================================== *)\n\nlet to_iso_string_roundtrip () =\n (* Format then parse should give same timestamp *)\n let original_ms = 1506098258091. in\n let d = Date.fromFloat original_ms in\n let iso = Date.toISOString d in\n let parsed_ms = Date.parseAsFloat iso in\n assert_float_exact parsed_ms original_ms\n\nlet to_iso_string_roundtrip_epoch () =\n let original_ms = 0. in\n let d = Date.fromFloat original_ms in\n let iso = Date.toISOString d in\n let parsed_ms = Date.parseAsFloat iso in\n assert_float_exact parsed_ms original_ms\n\nlet to_iso_string_roundtrip_before_epoch () =\n let original_ms = -86400000. in\n (* 1 day before epoch *)\n let d = Date.fromFloat original_ms in\n let iso = Date.toISOString d in\n let parsed_ms = Date.parseAsFloat iso in\n assert_float_exact parsed_ms original_ms\n\n(* ===================================================================\n QuickJS specific test cases\n =================================================================== *)\n\nlet to_iso_string_qjs_test_1 () =\n (* From QuickJS: new Date(\"2020-01-01T01:01:01.123Z\").toISOString() *)\n let d = Date.fromFloat (Date.parseAsFloat \"2020-01-01T01:01:01.123Z\") in\n assert_string (Date.toISOString d) \"2020-01-01T01:01:01.123Z\"\n\nlet to_iso_string_qjs_test_2 () =\n (* new Date(\"2020-01-01T01:01:01.1Z\").toISOString() -> \"...01.100Z\" *)\n let d = Date.fromFloat (Date.parseAsFloat \"2020-01-01T01:01:01.1Z\") in\n assert_string (Date.toISOString d) \"2020-01-01T01:01:01.100Z\"\n\nlet to_iso_string_qjs_test_3 () =\n (* new Date(\"2020-01-01T01:01:01.12Z\").toISOString() -> \"...01.120Z\" *)\n let d = Date.fromFloat (Date.parseAsFloat \"2020-01-01T01:01:01.12Z\") in\n assert_string (Date.toISOString d) \"2020-01-01T01:01:01.120Z\"\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* Basic formatting *)\n test \"known timestamp\" to_iso_string_known_timestamp;\n test \"epoch\" to_iso_string_epoch;\n test \"Y2K\" to_iso_string_y2k;\n test \"with milliseconds\" to_iso_string_with_millis;\n (* Millisecond formatting *)\n test \"millis: 000\" to_iso_string_millis_zero;\n test \"millis: 001\" to_iso_string_millis_001;\n test \"millis: 010\" to_iso_string_millis_010;\n test \"millis: 100\" to_iso_string_millis_100;\n test \"millis: 999\" to_iso_string_millis_999;\n (* Zero-padding *)\n test \"single digit month padded\" to_iso_string_single_digit_month;\n test \"single digit day padded\" to_iso_string_single_digit_day;\n test \"single digit hour padded\" to_iso_string_single_digit_hour;\n (* Before epoch *)\n test \"before epoch -1ms\" to_iso_string_before_epoch;\n test \"1969 Jan\" to_iso_string_1969_jan;\n (* Expanded years *)\n test \"year 0\" to_iso_string_year_0;\n test \"negative year\" to_iso_string_negative_year;\n test \"year 10000\" to_iso_string_year_10000;\n (* Roundtrip *)\n test \"roundtrip known timestamp\" to_iso_string_roundtrip;\n test \"roundtrip epoch\" to_iso_string_roundtrip_epoch;\n test \"roundtrip before epoch\" to_iso_string_roundtrip_before_epoch;\n (* QuickJS tests *)\n test \"QJS: 2020-01-01T01:01:01.123Z\" to_iso_string_qjs_test_1;\n test \"QJS: .1Z -> .100Z\" to_iso_string_qjs_test_2;\n test \"QJS: .12Z -> .120Z\" to_iso_string_qjs_test_3;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/to_string.ml",
"content": "(** TC39 Test262: Date toString method tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/toString\n https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/toDateString\n https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/toTimeString\n https://github.com/tc39/test262/tree/main/test/built-ins/Date/prototype/toUTCString\n\n Tests for toString, toDateString, toTimeString, toUTCString *)\n\nopen Helpers\nmodule Date = Js.Date\n\n(* ===================================================================\n toUTCString tests\n Format: \"Tue, 02 Dec 2025 09:30:00 GMT\"\n =================================================================== *)\n\nlet to_utc_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toUTCString d in\n (* Should contain \"Mon\" (June 15 2020 was Monday), \"15\", \"Jun\", \"2020\", \"12:30:45\", \"GMT\" *)\n assert_true \"contains day name\" (String.length s > 0);\n assert_true \"contains GMT\" (String.sub s (String.length s - 3) 3 = \"GMT\")\n\nlet to_utc_string_epoch () =\n let s = Date.toUTCString 0. in\n (* Thu, 01 Jan 1970 00:00:00 GMT *)\n assert_true \"contains Thu\" (String.sub s 0 3 = \"Thu\");\n assert_true \"contains 1970\" (String.length s > 10)\n\nlet to_utc_string_format () =\n let d = Date.utc ~year:2025. ~month:11. ~date:2. ~hours:9. ~minutes:30. ~seconds:0. () in\n let s = Date.toUTCString d in\n (* Verify format: \"Day, DD Mon YYYY HH:MM:SS GMT\" *)\n assert_true \"correct length roughly\" (String.length s >= 25)\n\nlet to_utc_string_nan () =\n let s = Date.toUTCString nan in\n assert_string_equal s \"Invalid Date\"\n\nlet to_utc_string_negative_year () =\n (* Test with a date before year 0 *)\n let d = Date.utc ~year:(-1.) ~month:0. ~date:1. () in\n let s = Date.toUTCString d in\n assert_true \"contains something\" (String.length s > 0)\n\nlet to_utc_string_months () =\n (* Test all month abbreviations *)\n let months = [ \"Jan\"; \"Feb\"; \"Mar\"; \"Apr\"; \"May\"; \"Jun\"; \"Jul\"; \"Aug\"; \"Sep\"; \"Oct\"; \"Nov\"; \"Dec\" ] in\n List.iteri\n (fun i expected_month ->\n let d = Date.utc ~year:2020. ~month:(Float.of_int i) ~date:15. () in\n let s = Date.toUTCString d in\n assert_true\n (Printf.sprintf \"month %d contains %s\" i expected_month)\n (String.length s > 0\n &&\n try\n let _ = Str.search_forward (Str.regexp expected_month) s 0 in\n true\n with Not_found -> false))\n months\n\nlet to_utc_string_day_names () =\n (* Test that different days of week produce correct names *)\n let d_sunday = Date.utc ~year:2021. ~month:0. ~date:3. () in\n (* Sunday *)\n let d_monday = Date.utc ~year:2021. ~month:0. ~date:4. () in\n (* Monday *)\n let s_sun = Date.toUTCString d_sunday in\n let s_mon = Date.toUTCString d_monday in\n assert_true \"Sunday starts with Sun\" (String.sub s_sun 0 3 = \"Sun\");\n assert_true \"Monday starts with Mon\" (String.sub s_mon 0 3 = \"Mon\")\n\n(* ===================================================================\n toDateString tests\n Format: \"Mon Jun 15 2020\"\n =================================================================== *)\n\nlet to_date_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toDateString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_date_string_epoch () =\n (* Note: This is timezone-dependent for local time *)\n let s = Date.toDateString 0. in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_date_string_nan () =\n let s = Date.toDateString nan in\n assert_string_equal s \"Invalid Date\"\n\nlet to_date_string_no_time () =\n (* toDateString should not contain time information like \":\" *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toDateString d in\n (* Should not have HH:MM:SS format *)\n let has_time_separator =\n try\n let _ = Str.search_forward (Str.regexp \"[0-9][0-9]:[0-9][0-9]:[0-9][0-9]\") s 0 in\n true\n with Not_found -> false\n in\n assert_true \"should not contain time\" (not has_time_separator)\n\n(* ===================================================================\n toTimeString tests\n Format: \"12:30:45 GMT+0000 (Coordinated Universal Time)\"\n =================================================================== *)\n\nlet to_time_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toTimeString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_time_string_epoch () =\n let s = Date.toTimeString 0. in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_time_string_nan () =\n let s = Date.toTimeString nan in\n assert_string_equal s \"Invalid Date\"\n\nlet to_time_string_contains_time () =\n (* toTimeString should contain time in HH:MM:SS format *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toTimeString d in\n let has_time_format =\n try\n let _ = Str.search_forward (Str.regexp \"[0-9][0-9]:[0-9][0-9]:[0-9][0-9]\") s 0 in\n true\n with Not_found -> false\n in\n assert_true \"should contain time format\" has_time_format\n\n(* ===================================================================\n toString tests\n Format: \"Mon Jun 15 2020 12:30:45 GMT+0000 (Coordinated Universal Time)\"\n =================================================================== *)\n\nlet to_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_string_epoch () =\n let s = Date.toString 0. in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_string_nan () =\n let s = Date.toString nan in\n assert_string_equal s \"Invalid Date\"\n\nlet to_string_contains_date_and_time () =\n (* toString should contain both date and time *)\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toString d in\n (* Should have time format *)\n let has_time_format =\n try\n let _ = Str.search_forward (Str.regexp \"[0-9][0-9]:[0-9][0-9]:[0-9][0-9]\") s 0 in\n true\n with Not_found -> false\n in\n assert_true \"should contain time\" has_time_format\n\nlet to_string_contains_year () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let s = Date.toString d in\n let has_year =\n try\n let _ = Str.search_forward (Str.regexp \"2020\") s 0 in\n true\n with Not_found -> false\n in\n assert_true \"should contain year\" has_year\n\n(* ===================================================================\n toJSON tests\n =================================================================== *)\n\nlet to_json_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () +. 123. in\n assert_option Alcotest.string \"toJSON should return Some\" (Date.toJSON d) (Some \"2020-06-15T12:30:45.123Z\")\n\nlet to_json_nan () = assert_option Alcotest.string \"toJSON should return None for NaN\" (Date.toJSON nan) None\n\nlet to_json_unsafe_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () +. 123. in\n let s = Date.toJSONUnsafe d in\n assert_string_equal s \"2020-06-15T12:30:45.123Z\"\n\n(* ===================================================================\n toLocaleString tests (simplified)\n =================================================================== *)\n\nlet to_locale_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toLocaleString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_locale_string_nan () =\n let s = Date.toLocaleString nan in\n assert_string_equal s \"Invalid Date\"\n\nlet to_locale_date_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. () in\n let s = Date.toLocaleDateString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_locale_date_string_nan () =\n let s = Date.toLocaleDateString nan in\n assert_string_equal s \"Invalid Date\"\n\nlet to_locale_time_string_basic () =\n let d = Date.utc ~year:2020. ~month:5. ~date:15. ~hours:12. ~minutes:30. ~seconds:45. () in\n let s = Date.toLocaleTimeString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_locale_time_string_nan () =\n let s = Date.toLocaleTimeString nan in\n assert_string_equal s \"Invalid Date\"\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet to_string_large_year () =\n let d = Date.utc ~year:275760. ~month:8. ~date:13. () in\n let s = Date.toString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_string_negative_year () =\n let d = Date.utc ~year:(-100.) ~month:0. ~date:1. () in\n let s = Date.toString d in\n assert_true \"non-empty string\" (String.length s > 0)\n\nlet to_utc_string_y2k () =\n let d = Date.utc ~year:2000. ~month:0. ~date:1. ~hours:0. ~minutes:0. ~seconds:0. () in\n let s = Date.toUTCString d in\n assert_true \"contains 2000\" (String.length s > 0)\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* toUTCString *)\n test \"toUTCString basic\" to_utc_string_basic;\n test \"toUTCString epoch\" to_utc_string_epoch;\n test \"toUTCString format\" to_utc_string_format;\n test \"toUTCString NaN\" to_utc_string_nan;\n test \"toUTCString negative year\" to_utc_string_negative_year;\n test \"toUTCString all months\" to_utc_string_months;\n test \"toUTCString day names\" to_utc_string_day_names;\n (* toDateString *)\n test \"toDateString basic\" to_date_string_basic;\n test \"toDateString epoch\" to_date_string_epoch;\n test \"toDateString NaN\" to_date_string_nan;\n test \"toDateString no time\" to_date_string_no_time;\n (* toTimeString *)\n test \"toTimeString basic\" to_time_string_basic;\n test \"toTimeString epoch\" to_time_string_epoch;\n test \"toTimeString NaN\" to_time_string_nan;\n test \"toTimeString contains time\" to_time_string_contains_time;\n (* toString *)\n test \"toString basic\" to_string_basic;\n test \"toString epoch\" to_string_epoch;\n test \"toString NaN\" to_string_nan;\n test \"toString contains date and time\" to_string_contains_date_and_time;\n test \"toString contains year\" to_string_contains_year;\n (* toJSON *)\n test \"toJSON basic\" to_json_basic;\n test \"toJSON NaN\" to_json_nan;\n test \"toJSONUnsafe basic\" to_json_unsafe_basic;\n (* toLocaleString *)\n test \"toLocaleString basic\" to_locale_string_basic;\n test \"toLocaleString NaN\" to_locale_string_nan;\n test \"toLocaleDateString basic\" to_locale_date_string_basic;\n test \"toLocaleDateString NaN\" to_locale_date_string_nan;\n test \"toLocaleTimeString basic\" to_locale_time_string_basic;\n test \"toLocaleTimeString NaN\" to_locale_time_string_nan;\n (* Edge cases *)\n test \"toString large year\" to_string_large_year;\n test \"toString negative year\" to_string_negative_year;\n test \"toUTCString Y2K\" to_utc_string_y2k;\n ]\n"
},
{
"path": "packages/Js/test/date_tests/utc.ml",
"content": "(** TC39 Test262: Date.UTC tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Date/UTC\n\n ECMA-262 Section: Date.UTC(year, month[, date[, hours[, minutes[, seconds[, ms]]]]])\n\n Date.UTC returns the time value (epoch milliseconds) for the given UTC date components. *)\n\nopen Helpers\n\n(* ===================================================================\n Basic Date.UTC tests from QuickJS test suite\n =================================================================== *)\n\nlet utc_year_only () =\n (* Date.UTC(2017) = Jan 1, 2017 00:00:00.000 UTC *)\n assert_float_exact (Date.utc ~year:2017. ~month:0. ()) 1483228800000.\n\nlet utc_year_month () =\n (* Date.UTC(2017, 9) = Oct 1, 2017 00:00:00.000 UTC *)\n assert_float_exact (Date.utc ~year:2017. ~month:9. ()) 1506816000000.\n\nlet utc_year_month_day () =\n (* Date.UTC(2017, 9, 22) = Oct 22, 2017 00:00:00.000 UTC *)\n assert_float_exact (Date.utc ~year:2017. ~month:9. ~date:22. ()) 1508630400000.\n\nlet utc_with_hours () =\n (* Date.UTC(2017, 9, 22, 18) *)\n assert_float_exact (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ()) 1508695200000.\n\nlet utc_with_minutes () =\n (* Date.UTC(2017, 9, 22, 18, 10) *)\n assert_float_exact (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:10. ()) 1508695800000.\n\nlet utc_with_seconds () =\n (* Date.UTC(2017, 9, 22, 18, 10, 11) *)\n assert_float_exact (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:10. ~seconds:11. ()) 1508695811000.\n\nlet utc_with_ms () =\n (* Date.UTC(2017, 9, 22, 18, 10, 11, 91) *)\n assert_float_exact\n (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:10. ~seconds:11. () +. 91.)\n 1508695811091.\n\n(* ===================================================================\n NaN propagation\n =================================================================== *)\n\nlet utc_nan_year () = assert_nan (Date.utc ~year:nan ~month:0. ())\nlet utc_nan_month () = assert_nan (Date.utc ~year:2017. ~month:nan ())\nlet utc_nan_day () = assert_nan (Date.utc ~year:2017. ~month:9. ~date:nan ())\nlet utc_nan_hours () = assert_nan (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:nan ())\nlet utc_nan_minutes () = assert_nan (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:nan ())\nlet utc_nan_seconds () = assert_nan (Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:10. ~seconds:nan ())\n\n(* ===================================================================\n Epoch and boundary values\n =================================================================== *)\n\nlet utc_epoch () =\n (* Unix epoch: Jan 1, 1970 00:00:00.000 UTC *)\n assert_float_exact (Date.utc ~year:1970. ~month:0. ~date:1. ()) 0.\n\nlet utc_before_epoch () =\n (* Dec 31, 1969 23:59:59.000 UTC = -1000ms *)\n assert_float_exact (Date.utc ~year:1969. ~month:11. ~date:31. ~hours:23. ~minutes:59. ~seconds:59. ()) (-1000.)\n\nlet utc_y2k () =\n (* Jan 1, 2000 00:00:00.000 UTC *)\n assert_float_exact (Date.utc ~year:2000. ~month:0. ~date:1. ()) 946684800000.\n\n(* ===================================================================\n Year handling: 0-99 maps to 1900-1999\n =================================================================== *)\n\nlet utc_year_0 () =\n (* Year 0 maps to 1900 *)\n let result = Date.utc ~year:0. ~month:0. ~date:1. () in\n (* Jan 1, 1900 00:00:00 UTC *)\n assert_float_exact result (-2208988800000.)\n\nlet utc_year_99 () =\n (* Year 99 maps to 1999 *)\n let result = Date.utc ~year:99. ~month:0. ~date:1. () in\n (* Jan 1, 1999 00:00:00 UTC *)\n assert_float_exact result 915148800000.\n\nlet utc_year_100 () =\n (* Year 100 stays as year 100 (not mapped) *)\n let result = Date.utc ~year:100. ~month:0. ~date:1. () in\n assert_not_nan result\n\n(* ===================================================================\n Month overflow/underflow\n =================================================================== *)\n\nlet utc_month_overflow () =\n (* Month 12 = January of next year *)\n let m12 = Date.utc ~year:2017. ~month:12. ~date:1. () in\n let jan_next = Date.utc ~year:2018. ~month:0. ~date:1. () in\n assert_float_exact m12 jan_next\n\nlet utc_month_underflow () =\n (* Month -1 = December of previous year *)\n let m_neg1 = Date.utc ~year:2017. ~month:(-1.) ~date:1. () in\n let dec_prev = Date.utc ~year:2016. ~month:11. ~date:1. () in\n assert_float_exact m_neg1 dec_prev\n\n(* ===================================================================\n Day overflow/underflow\n =================================================================== *)\n\nlet utc_day_overflow () =\n (* Day 32 in January = Feb 1 *)\n let d32 = Date.utc ~year:2017. ~month:0. ~date:32. () in\n let feb1 = Date.utc ~year:2017. ~month:1. ~date:1. () in\n assert_float_exact d32 feb1\n\nlet utc_day_zero () =\n (* Day 0 = last day of previous month *)\n let d0 = Date.utc ~year:2017. ~month:1. ~date:0. () in\n let jan31 = Date.utc ~year:2017. ~month:0. ~date:31. () in\n assert_float_exact d0 jan31\n\nlet utc_day_negative () =\n (* Day -1 = second-to-last day of previous month *)\n let d_neg1 = Date.utc ~year:2017. ~month:1. ~date:(-1.) () in\n let jan30 = Date.utc ~year:2017. ~month:0. ~date:30. () in\n assert_float_exact d_neg1 jan30\n\n(* ===================================================================\n Leap year handling\n =================================================================== *)\n\nlet utc_leap_year_feb_29 () =\n (* Feb 29, 2020 is valid (2020 is a leap year) *)\n let result = Date.utc ~year:2020. ~month:1. ~date:29. () in\n assert_not_nan result\n\nlet utc_non_leap_year_feb_29 () =\n (* Feb 29, 2019 overflows to Mar 1, 2019 (not a leap year) *)\n let feb29_2019 = Date.utc ~year:2019. ~month:1. ~date:29. () in\n let mar1_2019 = Date.utc ~year:2019. ~month:2. ~date:1. () in\n assert_float_exact feb29_2019 mar1_2019\n\nlet utc_leap_year_2000 () =\n (* 2000 is a leap year (divisible by 400) *)\n let result = Date.utc ~year:2000. ~month:1. ~date:29. () in\n assert_not_nan result\n\nlet utc_non_leap_year_1900 () =\n (* 1900 is NOT a leap year (divisible by 100 but not 400) *)\n let feb29_1900 = Date.utc ~year:1900. ~month:1. ~date:29. () in\n let mar1_1900 = Date.utc ~year:1900. ~month:2. ~date:1. () in\n assert_float_exact feb29_1900 mar1_1900\n\n(* ===================================================================\n Large value handling\n =================================================================== *)\n\nlet utc_large_day_offset () =\n (* From QuickJS: Date.UTC(2017, 9, 22 - 1e10, 18 + 24e10) *)\n let result = Date.utc ~year:2017. ~month:9. ~date:(22. -. 1e10) ~hours:(18. +. 24e10) () in\n assert_float_exact result 1508695200000.\n\nlet utc_large_minute_offset () =\n (* Date.UTC(2017, 9, 22, 18 - 1e10, 10 + 60e10) *)\n let result = Date.utc ~year:2017. ~month:9. ~date:22. ~hours:(18. -. 1e10) ~minutes:(10. +. 60e10) () in\n assert_float_exact result 1508695800000.\n\nlet utc_large_second_offset () =\n (* Date.UTC(2017, 9, 22, 18, 10 - 1e10, 11 + 60e10) *)\n let result = Date.utc ~year:2017. ~month:9. ~date:22. ~hours:18. ~minutes:(10. -. 1e10) ~seconds:(11. +. 60e10) () in\n assert_float_exact result 1508695811000.\n\n(* ===================================================================\n Test list\n =================================================================== *)\n\nlet tests =\n [\n (* Basic UTC construction *)\n test \"UTC year only\" utc_year_only;\n test \"UTC year and month\" utc_year_month;\n test \"UTC year, month, day\" utc_year_month_day;\n test \"UTC with hours\" utc_with_hours;\n test \"UTC with minutes\" utc_with_minutes;\n test \"UTC with seconds\" utc_with_seconds;\n test \"UTC with milliseconds\" utc_with_ms;\n (* NaN propagation *)\n test \"UTC NaN year\" utc_nan_year;\n test \"UTC NaN month\" utc_nan_month;\n test \"UTC NaN day\" utc_nan_day;\n test \"UTC NaN hours\" utc_nan_hours;\n test \"UTC NaN minutes\" utc_nan_minutes;\n test \"UTC NaN seconds\" utc_nan_seconds;\n (* Epoch and boundaries *)\n test \"UTC Unix epoch\" utc_epoch;\n test \"UTC before epoch\" utc_before_epoch;\n test \"UTC Y2K\" utc_y2k;\n (* Year mapping 0-99 -> 1900-1999 *)\n test \"UTC year 0 -> 1900\" utc_year_0;\n test \"UTC year 99 -> 1999\" utc_year_99;\n test \"UTC year 100 stays 100\" utc_year_100;\n (* Month overflow/underflow *)\n test \"UTC month 12 = January next year\" utc_month_overflow;\n test \"UTC month -1 = December prev year\" utc_month_underflow;\n (* Day overflow/underflow *)\n test \"UTC day 32 Jan = Feb 1\" utc_day_overflow;\n test \"UTC day 0 = last day prev month\" utc_day_zero;\n test \"UTC day -1 = second-to-last prev\" utc_day_negative;\n (* Leap years *)\n test \"UTC leap year Feb 29 valid\" utc_leap_year_feb_29;\n test \"UTC non-leap Feb 29 = Mar 1\" utc_non_leap_year_feb_29;\n test \"UTC 2000 is leap year\" utc_leap_year_2000;\n test \"UTC 1900 is NOT leap year\" utc_non_leap_year_1900;\n (* Large value handling *)\n test \"UTC large day offset\" utc_large_day_offset;\n test \"UTC large minute offset\" utc_large_minute_offset;\n test \"UTC large second offset\" utc_large_second_offset;\n ]\n"
},
{
"path": "packages/Js/test/dune",
"content": "(include_subdirs qualified)\n\n(test\n (name test)\n (libraries alcotest alcotest-lwt lwt js fmt str)\n (preprocess\n (pps lwt_ppx melange_native_ppx)))\n"
},
{
"path": "packages/Js/test/helpers.ml",
"content": "(** Shared test helpers for test262 tests *)\n\nmodule BigInt = Js.Bigint\nmodule Date = Js.Date\n\nmodule Number = struct\n include Js.Float\n\n let parseFloat = Js.Global.parseFloat\n let parseInt = Js.Global.parseInt\nend\n\nlet test title fn = Alcotest_lwt.test_case_sync title `Quick fn\nlet test_async title fn = Alcotest_lwt.test_case title `Quick fn\nlet assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\nlet assert_string_equal left right = Alcotest.check Alcotest.string \"should be equal\" right left\nlet assert_int left right = Alcotest.check Alcotest.int \"should be equal\" right left\nlet assert_float left right = Alcotest.check (Alcotest.float 2.) \"should be equal\" right left\nlet assert_float_exact left right = Alcotest.check (Alcotest.float 0.) \"should be equal\" right left\n\n(* assert_bool for comparing boolean values - compatible with existing tests *)\nlet assert_bool left right = Alcotest.check Alcotest.bool \"should be equal\" right left\n\n(* assert_true for checking a condition with a message *)\nlet assert_true msg cond = if not cond then Alcotest.fail msg\n\n(* assert_option for comparing option values with proper Alcotest output *)\nlet assert_option ty msg left right = Alcotest.check (Alcotest.option ty) msg right left\n\nlet assert_raises fn exn =\n match fn () with\n | exception exn -> assert_string (Printexc.to_string exn) (Printexc.to_string exn)\n | _ -> Alcotest.failf \"Expected exception %s\" (Printexc.to_string exn)\n\n(* BigInt helpers *)\nlet bigint_testable = Alcotest.testable (Fmt.of_to_string BigInt.toString) (fun a b -> BigInt.compare a b = 0)\nlet assert_bigint left right = Alcotest.check bigint_testable \"should be equal\" right left\nlet assert_bigint_equal left right = Alcotest.check bigint_testable \"should be equal\" right left\n\nlet assert_bigint_string left expected_str =\n let expected = BigInt.of_string expected_str in\n Alcotest.check bigint_testable \"should be equal\" expected left\n\nlet assert_bigint_raises fn = match fn () with exception _ -> () | _ -> Alcotest.fail \"Expected exception\"\n\n(* Float/Number helpers *)\nlet nan = Float.nan\nlet infinity = Float.infinity\nlet neg_infinity = Float.neg_infinity\nlet max_value = Float.max_float\nlet min_value = Float.min_float\nlet max_safe_integer = 9007199254740991.\nlet min_safe_integer = -9007199254740991.\nlet epsilon = Float.epsilon\nlet assert_not_nan value = if Float.is_nan value then Alcotest.fail \"Expected non-NaN value\"\nlet assert_nan value = if not (Float.is_nan value) then Alcotest.fail \"Expected NaN value\"\nlet assert_infinity value = if not (value = infinity) then Alcotest.failf \"Expected Infinity, got %f\" value\nlet assert_neg_infinity value = if not (value = neg_infinity) then Alcotest.failf \"Expected -Infinity, got %f\" value\nlet assert_negative_zero value = if not (1. /. value = neg_infinity) then Alcotest.fail \"Expected negative zero\"\n"
},
{
"path": "packages/Js/test/number_tests/is_finite.ml",
"content": "(** TC39 Test262: Number.isFinite tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Number/isFinite\n\n ECMA-262 Section: Number.isFinite(number)\n\n Note: Number.isFinite is different from global isFinite:\n - Number.isFinite only returns true for finite number values\n - It does NOT perform type coercion\n - Returns false for NaN and Infinity *)\n\nopen Helpers\n\n(* ===================================================================\n Infinity values should return false\n =================================================================== *)\n\nlet positive_infinity () = assert_bool (Number.isFinite infinity) false\nlet negative_infinity () = assert_bool (Number.isFinite neg_infinity) false\n\n(* ===================================================================\n NaN should return false\n =================================================================== *)\n\nlet nan_value () = assert_bool (Number.isFinite nan) false\n\nlet nan_from_operations () =\n assert_bool (Number.isFinite (0.0 /. 0.0)) false;\n assert_bool (Number.isFinite (infinity -. infinity)) false\n\n(* ===================================================================\n Finite numbers should return true\n =================================================================== *)\n\nlet zero_values () =\n assert_bool (Number.isFinite 0.0) true;\n assert_bool (Number.isFinite (-0.0)) true\n\nlet positive_integers () =\n assert_bool (Number.isFinite 1.0) true;\n assert_bool (Number.isFinite 42.0) true;\n assert_bool (Number.isFinite 100.0) true\n\nlet negative_integers () =\n assert_bool (Number.isFinite (-1.0)) true;\n assert_bool (Number.isFinite (-42.0)) true;\n assert_bool (Number.isFinite (-100.0)) true\n\nlet decimals () =\n assert_bool (Number.isFinite 0.5) true;\n assert_bool (Number.isFinite 3.14159) true;\n assert_bool (Number.isFinite (-2.71828)) true\n\nlet max_min_values () =\n (* MAX_VALUE and MIN_VALUE are finite *)\n assert_bool (Number.isFinite max_value) true;\n assert_bool (Number.isFinite min_value) true;\n assert_bool (Number.isFinite (-.max_value)) true\n\nlet safe_integer_bounds () =\n (* MAX_SAFE_INTEGER and MIN_SAFE_INTEGER are finite *)\n assert_bool (Number.isFinite max_safe_integer) true;\n assert_bool (Number.isFinite min_safe_integer) true\n\nlet epsilon_value () = assert_bool (Number.isFinite epsilon) true\n\nlet very_small_numbers () =\n assert_bool (Number.isFinite 1e-300) true;\n assert_bool (Number.isFinite 5e-324) true (* MIN_VALUE *)\n\nlet very_large_numbers () =\n assert_bool (Number.isFinite 1e308) true;\n assert_bool (Number.isFinite (-1e308)) true\n\n(* Note: In OCaml, Number.isFinite only takes float values, so we don't need\n to test non-number types. Those would be type errors at compile time. *)\n\nlet tests =\n [\n (* Infinity - returns false *)\n test \"infinity: positive Infinity returns false\" positive_infinity;\n test \"negative_infinity: negative Infinity returns false\" negative_infinity;\n (* NaN - returns false *)\n test \"nan: NaN returns false\" nan_value;\n test \"nan_from_operations: NaN from operations returns false\" nan_from_operations;\n (* Finite numbers - return true *)\n test \"finite_numbers: zeros\" zero_values;\n test \"finite_numbers: positive integers\" positive_integers;\n test \"finite_numbers: negative integers\" negative_integers;\n test \"finite_numbers: decimals\" decimals;\n test \"finite_numbers: MAX/MIN_VALUE\" max_min_values;\n test \"finite_numbers: safe integer bounds\" safe_integer_bounds;\n test \"finite_numbers: epsilon\" epsilon_value;\n test \"finite_numbers: very small\" very_small_numbers;\n test \"finite_numbers: very large\" very_large_numbers;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/is_integer.ml",
"content": "(** TC39 Test262: Number.isInteger tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Number/isInteger\n\n ECMA-262 Section: Number.isInteger(number)\n\n Note: Number.isInteger returns true if the number is a finite number with no fractional part. *)\n\nopen Helpers\n\n(* ===================================================================\n Integer values should return true\n =================================================================== *)\n\nlet zero_values () =\n assert_bool (Number.isInteger 0.0) true;\n assert_bool (Number.isInteger (-0.0)) true\n\nlet positive_integers () =\n assert_bool (Number.isInteger 1.0) true;\n assert_bool (Number.isInteger 2.0) true;\n assert_bool (Number.isInteger 42.0) true;\n assert_bool (Number.isInteger 100.0) true;\n assert_bool (Number.isInteger 1000000.0) true\n\nlet negative_integers () =\n assert_bool (Number.isInteger (-1.0)) true;\n assert_bool (Number.isInteger (-2.0)) true;\n assert_bool (Number.isInteger (-42.0)) true;\n assert_bool (Number.isInteger (-100.0)) true\n\nlet large_integers () =\n assert_bool (Number.isInteger max_safe_integer) true;\n assert_bool (Number.isInteger min_safe_integer) true;\n assert_bool (Number.isInteger 9007199254740992.0) true (* MAX_SAFE_INTEGER + 1 *)\n\nlet decimal_zero_fraction () =\n (* Numbers that look like decimals but have .0 *)\n assert_bool (Number.isInteger 5.0) true;\n assert_bool (Number.isInteger 123.0) true;\n assert_bool (Number.isInteger 1e10) true (* 10000000000.0 *)\n\n(* ===================================================================\n Non-integer values should return false\n =================================================================== *)\n\nlet decimals () =\n assert_bool (Number.isInteger 0.1) false;\n assert_bool (Number.isInteger 0.5) false;\n assert_bool (Number.isInteger 1.5) false;\n assert_bool (Number.isInteger 3.14159) false;\n assert_bool (Number.isInteger (-2.71828)) false\n\nlet small_fractions () =\n assert_bool (Number.isInteger 0.0001) false;\n assert_bool (Number.isInteger 1.0001) false;\n assert_bool (Number.isInteger 1e-10) false\n\n(* ===================================================================\n Special values should return false\n =================================================================== *)\n\nlet nan_value () = assert_bool (Number.isInteger nan) false\n\nlet infinity_values () =\n assert_bool (Number.isInteger infinity) false;\n assert_bool (Number.isInteger neg_infinity) false\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet max_value_is_integer () =\n (* MAX_VALUE is an integer (though very large) *)\n assert_bool (Number.isInteger max_value) true;\n assert_bool (Number.isInteger (-.max_value)) true\n\nlet min_value_is_not_integer () =\n (* MIN_VALUE is 5e-324, a very small fraction *)\n assert_bool (Number.isInteger min_value) false\n\nlet epsilon_is_not_integer () = assert_bool (Number.isInteger epsilon) false\n\nlet powers_of_two () =\n assert_bool (Number.isInteger (2.0 ** 10.0)) true;\n (* 1024 *)\n assert_bool (Number.isInteger (2.0 ** 52.0)) true;\n (* Within safe integer range *)\n assert_bool (Number.isInteger (2.0 ** 53.0)) true (* MAX_SAFE_INTEGER + 1 *)\n\nlet scientific_notation () =\n assert_bool (Number.isInteger 1e5) true;\n (* 100000 *)\n assert_bool (Number.isInteger 5e3) true;\n (* 5000 *)\n assert_bool (Number.isInteger 1e-5) false (* 0.00001 *)\n\n(* Note: In OCaml, Number.isInteger only takes float values, so we don't need\n to test non-number types. Those would be type errors at compile time. *)\n\nlet tests =\n [\n (* Integer values - return true *)\n test \"integers: zeros\" zero_values;\n test \"integers: positive\" positive_integers;\n test \"integers: negative\" negative_integers;\n test \"integers: large\" large_integers;\n test \"integers: decimal zero fraction\" decimal_zero_fraction;\n (* Non-integer values - return false *)\n test \"non_integers: decimals\" decimals;\n test \"non_integers: small fractions\" small_fractions;\n (* Special values - return false *)\n test \"special: NaN\" nan_value;\n test \"special: Infinity\" infinity_values;\n (* Edge cases *)\n test \"edge: MAX_VALUE is integer\" max_value_is_integer;\n test \"edge: MIN_VALUE is not integer\" min_value_is_not_integer;\n test \"edge: epsilon is not integer\" epsilon_is_not_integer;\n test \"edge: powers of two\" powers_of_two;\n test \"edge: scientific notation\" scientific_notation;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/is_nan.ml",
"content": "(** TC39 Test262: Number.isNaN tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Number/isNaN\n\n ECMA-262 Section: Number.isNaN(number)\n\n Note: Number.isNaN is different from global isNaN:\n - Number.isNaN only returns true for the actual NaN value\n - It does NOT perform type coercion *)\n\nopen Helpers\n\n(* ===================================================================\n Basic NaN detection\n =================================================================== *)\n\nlet nan_value () =\n (* NaN should return true *)\n assert_bool (Number.isNaN nan) true\n\nlet nan_from_operation () =\n (* NaN from operations should return true *)\n assert_bool (Number.isNaN (0.0 /. 0.0)) true;\n assert_bool (Number.isNaN (infinity -. infinity)) true;\n assert_bool (Number.isNaN (infinity *. 0.0)) true;\n assert_bool (Number.isNaN (sqrt (-1.0))) true\n\nlet nan_from_parseint () =\n (* NaN from parseInt should return true *)\n assert_bool (Number.isNaN (Number.parseInt \"abc\")) true;\n assert_bool (Number.isNaN (Number.parseInt \"\")) true\n\nlet nan_from_parsefloat () =\n (* NaN from parseFloat should return true *)\n assert_bool (Number.isNaN (Number.parseFloat \"xyz\")) true;\n assert_bool (Number.isNaN (Number.parseFloat \"\")) true\n\n(* ===================================================================\n Non-NaN values should return false\n =================================================================== *)\n\nlet finite_numbers () =\n (* Finite numbers return false *)\n assert_bool (Number.isNaN 0.0) false;\n assert_bool (Number.isNaN 1.0) false;\n assert_bool (Number.isNaN (-1.0)) false;\n assert_bool (Number.isNaN 42.0) false;\n assert_bool (Number.isNaN 3.14159) false;\n assert_bool (Number.isNaN (-3.14159)) false\n\nlet zero_values () =\n (* Zero values return false *)\n assert_bool (Number.isNaN 0.0) false;\n assert_bool (Number.isNaN (-0.0)) false\n\nlet infinity_values () =\n (* Infinity returns false (Infinity is not NaN) *)\n assert_bool (Number.isNaN infinity) false;\n assert_bool (Number.isNaN neg_infinity) false\n\nlet max_min_values () =\n (* Extreme values return false *)\n assert_bool (Number.isNaN max_value) false;\n assert_bool (Number.isNaN min_value) false;\n assert_bool (Number.isNaN max_safe_integer) false;\n assert_bool (Number.isNaN min_safe_integer) false\n\nlet epsilon_value () =\n (* Epsilon returns false *)\n assert_bool (Number.isNaN epsilon) false\n\n(* Note: In OCaml, Number.isNaN only takes float values, so we don't need\n to test non-number types like strings, objects, undefined, null, etc.\n Those would be type errors at compile time. *)\n\nlet tests =\n [\n (* NaN detection *)\n test \"nan_value: NaN returns true\" nan_value;\n test \"nan_from_operation: NaN from operations\" nan_from_operation;\n test \"nan_from_parseInt: NaN from parseInt\" nan_from_parseint;\n test \"nan_from_parseFloat: NaN from parseFloat\" nan_from_parsefloat;\n (* Non-NaN values *)\n test \"finite_numbers: finite numbers return false\" finite_numbers;\n test \"zero_values: zeros return false\" zero_values;\n test \"infinity_values: Infinity returns false\" infinity_values;\n test \"max_min_values: extreme values return false\" max_min_values;\n test \"epsilon_value: epsilon returns false\" epsilon_value;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/parse_float.ml",
"content": "(** TC39 Test262: parseFloat tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/parseFloat\n\n ECMA-262 Section: parseFloat(string)\n\n Test naming convention follows tc39/test262:\n - [S15.1.2.3_A_T] format for legacy tests *)\n\nopen Helpers\n\n(* ===================================================================\n S15.1.2.3_A1: Basic parsing tests\n =================================================================== *)\n\nlet a1_t1 () =\n (* parseFloat(\"\") should return NaN *)\n assert_nan (Number.parseFloat \"\")\n\nlet a1_t2 () =\n (* parseFloat with simple integers *)\n assert_float (Number.parseFloat \"0\") 0.0;\n assert_float (Number.parseFloat \"1\") 1.0;\n assert_float (Number.parseFloat \"123\") 123.0\n\nlet a1_t3 () =\n (* parseFloat with no numeric characters should return NaN *)\n assert_nan (Number.parseFloat \"abc\");\n assert_nan (Number.parseFloat \"xyz123\")\n(* starts with non-digit *)\n\nlet a1_t4 () =\n (* parseFloat with decimal numbers *)\n assert_float (Number.parseFloat \"3.14\") 3.14;\n assert_float (Number.parseFloat \"0.5\") 0.5;\n assert_float (Number.parseFloat \"123.456\") 123.456\n\nlet a1_t5 () =\n (* parseFloat stops at invalid character *)\n assert_float (Number.parseFloat \"123abc\") 123.0;\n assert_float (Number.parseFloat \"3.14xyz\") 3.14;\n assert_float (Number.parseFloat \"1.5.6\") 1.5 (* second decimal point stops parsing *)\n\nlet a1_t6 () =\n (* parseFloat with only whitespace returns NaN *)\n assert_nan (Number.parseFloat \" \");\n assert_nan (Number.parseFloat \"\\t\\n\")\n\nlet a1_t7 () =\n (* parseFloat behavior with various invalid starts *)\n assert_nan (Number.parseFloat \"$123\");\n assert_nan (Number.parseFloat \"#123\");\n assert_nan (Number.parseFloat \"@3.14\")\n\n(* ===================================================================\n S15.1.2.3_A2: Whitespace handling\n =================================================================== *)\n\nlet a2_t1 () =\n (* Leading spaces *)\n assert_float (Number.parseFloat \" 123\") 123.0;\n assert_float (Number.parseFloat \" 3.14\") 3.14\n\nlet a2_t2 () =\n (* Leading tabs *)\n assert_float (Number.parseFloat \"\\t123\") 123.0;\n assert_float (Number.parseFloat \"\\t3.14\") 3.14\n\nlet a2_t3 () =\n (* Leading newlines *)\n assert_float (Number.parseFloat \"\\n123\") 123.0;\n assert_float (Number.parseFloat \"\\n3.14\") 3.14\n\nlet a2_t4 () =\n (* Leading carriage return *)\n assert_float (Number.parseFloat \"\\r123\") 123.0\n\nlet a2_t5 () =\n (* Leading form feed *)\n assert_float (Number.parseFloat \"\\x0C123\") 123.0\n\nlet a2_t6 () =\n (* Leading vertical tab *)\n assert_float (Number.parseFloat \"\\x0B123\") 123.0\n\nlet a2_t7 () =\n (* Multiple whitespace types *)\n assert_float (Number.parseFloat \" \\t\\n\\r3.14159\") 3.14159\n\nlet a2_t8 () =\n (* Non-breaking space (U+00A0) - JavaScript treats NBSP as whitespace in parseFloat *)\n assert_float (Number.parseFloat \"\\xC2\\xA0123.5\") 123.5\n\nlet a2_t9 () =\n (* Trailing characters are ignored *)\n assert_float (Number.parseFloat \"123 \") 123.0;\n assert_float (Number.parseFloat \"3.14 abc\") 3.14\n\nlet a2_t10 () =\n (* Whitespace between sign and number *)\n assert_nan (Number.parseFloat \"- 123\");\n assert_nan (Number.parseFloat \"+ 3.14\")\n\n(* ===================================================================\n S15.1.2.3_A3: Sign handling\n =================================================================== *)\n\nlet a3_t1 () =\n (* Positive sign *)\n assert_float (Number.parseFloat \"+123\") 123.0;\n assert_float (Number.parseFloat \"+3.14\") 3.14\n\nlet a3_t2 () =\n (* Negative sign *)\n assert_float (Number.parseFloat \"-123\") (-123.0);\n assert_float (Number.parseFloat \"-3.14\") (-3.14)\n\nlet a3_t3 () =\n (* Sign with whitespace before *)\n assert_float (Number.parseFloat \" +123\") 123.0;\n assert_float (Number.parseFloat \" -3.14\") (-3.14)\n\n(* ===================================================================\n S15.1.2.3_A4: Scientific notation (exponent)\n =================================================================== *)\n\nlet a4_t1 () =\n (* Basic exponent with e *)\n assert_float (Number.parseFloat \"1e10\") 1e10;\n assert_float (Number.parseFloat \"1e5\") 100000.0;\n assert_float (Number.parseFloat \"5e0\") 5.0\n\nlet a4_t2 () =\n (* Exponent with E (uppercase) *)\n assert_float (Number.parseFloat \"1E10\") 1e10;\n assert_float (Number.parseFloat \"2E3\") 2000.0\n\nlet a4_t3 () =\n (* Negative exponent *)\n assert_float (Number.parseFloat \"1e-3\") 0.001;\n assert_float (Number.parseFloat \"5e-1\") 0.5;\n assert_float (Number.parseFloat \"1.5e-2\") 0.015\n\nlet a4_t4 () =\n (* Positive exponent with explicit + *)\n assert_float (Number.parseFloat \"1e+10\") 1e10;\n assert_float (Number.parseFloat \"2e+3\") 2000.0\n\nlet a4_t5 () =\n (* Decimal with exponent *)\n assert_float (Number.parseFloat \"1.5e3\") 1500.0;\n assert_float (Number.parseFloat \"3.14e2\") 314.0;\n assert_float (Number.parseFloat \"2.5e-1\") 0.25\n\nlet a4_t6 () =\n (* Exponent edge cases *)\n assert_float (Number.parseFloat \"1e\") 1.0;\n (* incomplete exponent - returns mantissa *)\n assert_float (Number.parseFloat \"1e+\") 1.0;\n (* incomplete exponent *)\n assert_float (Number.parseFloat \"1e-\") 1.0 (* incomplete exponent *)\n\nlet a4_t7 () =\n (* Very large exponents *)\n assert_infinity (Number.parseFloat \"1e309\");\n (* Overflow to Infinity *)\n assert_float (Number.parseFloat \"1e308\") 1e308\n\n(* ===================================================================\n S15.1.2.3_A5: Infinity\n =================================================================== *)\n\nlet a5_t1 () =\n (* Infinity string *)\n assert_infinity (Number.parseFloat \"Infinity\");\n assert_neg_infinity (Number.parseFloat \"-Infinity\")\n\nlet a5_t2 () =\n (* Infinity with sign *)\n assert_infinity (Number.parseFloat \"+Infinity\");\n assert_neg_infinity (Number.parseFloat \"-Infinity\")\n\nlet a5_t3 () =\n (* Infinity with leading whitespace *)\n assert_infinity (Number.parseFloat \" Infinity\");\n assert_neg_infinity (Number.parseFloat \" -Infinity\")\n\nlet a5_t4 () =\n (* Infinity followed by characters *)\n assert_infinity (Number.parseFloat \"Infinityxyz\");\n assert_infinity (Number.parseFloat \"Infinity123\")\n\n(* ===================================================================\n S15.1.2.3_A6: Miscellaneous edge cases\n =================================================================== *)\n\nlet a6 () =\n (* Multiple decimal points *)\n assert_float (Number.parseFloat \"1.2.3\") 1.2;\n (* In JavaScript, both \"...3\" and \"..3\" return NaN:\n - First \".\" is valid but followed by another \".\" which stops parsing\n - No valid digits found, so result is NaN *)\n assert_nan (Number.parseFloat \"...3\");\n assert_nan (Number.parseFloat \"..3\")\n\nlet a7_5 () =\n (* Leading decimal point *)\n assert_float (Number.parseFloat \".5\") 0.5;\n assert_float (Number.parseFloat \".123\") 0.123;\n assert_float (Number.parseFloat \"-.5\") (-0.5);\n assert_float (Number.parseFloat \"+.5\") 0.5\n\nlet a7_6 () =\n (* Trailing decimal point *)\n assert_float (Number.parseFloat \"5.\") 5.0;\n assert_float (Number.parseFloat \"123.\") 123.0\n\nlet a7_7 () =\n (* Decimal point with exponent *)\n assert_float (Number.parseFloat \".5e2\") 50.0;\n assert_float (Number.parseFloat \"5.e2\") 500.0;\n assert_float (Number.parseFloat \".1e-1\") 0.01\n\n(* ===================================================================\n Additional edge cases\n =================================================================== *)\n\nlet misc_t1 () =\n (* Hex notation NOT supported by parseFloat *)\n assert_float (Number.parseFloat \"0x10\") 0.0;\n (* stops at 'x' *)\n assert_float (Number.parseFloat \"0xFF\") 0.0\n\nlet misc_t2 () =\n (* Binary/Octal prefixes NOT supported *)\n assert_float (Number.parseFloat \"0b101\") 0.0;\n (* stops at 'b' *)\n assert_float (Number.parseFloat \"0o777\") 0.0 (* stops at 'o' *)\n\nlet misc_t3 () =\n (* Leading zeros *)\n assert_float (Number.parseFloat \"00123\") 123.0;\n assert_float (Number.parseFloat \"007.5\") 7.5;\n assert_float (Number.parseFloat \"0000\") 0.0\n\nlet misc_t4 () =\n (* NaN string does NOT parse to NaN value *)\n assert_nan (Number.parseFloat \"NaN\");\n (* Actually JS returns NaN for \"NaN\" *)\n assert_nan (Number.parseFloat \"nan\")\n(* case sensitive *)\n\nlet misc_t5 () =\n (* Sign edge cases *)\n assert_nan (Number.parseFloat \"+\");\n assert_nan (Number.parseFloat \"-\");\n assert_nan (Number.parseFloat \"++1\");\n assert_nan (Number.parseFloat \"--1\");\n assert_nan (Number.parseFloat \"+-1\")\n\nlet misc_t6 () =\n (* Very small numbers *)\n assert_float (Number.parseFloat \"1e-323\") 1e-323;\n assert_float (Number.parseFloat \"5e-324\") 5e-324 (* MIN_VALUE *)\n\nlet misc_t7 () =\n (* Negative zero *)\n let result = Number.parseFloat \"-0\" in\n assert_float result 0.0;\n (* -0.0 = 0.0 in comparison *)\n assert_negative_zero result\n\nlet misc_t8 () =\n (* Numbers that would lose precision *)\n assert_float (Number.parseFloat \"9007199254740993\") 9007199254740992.0;\n (* > MAX_SAFE_INTEGER *)\n assert_float (Number.parseFloat \"0.1\") 0.1 (* known floating point representation issue *)\n\nlet misc_t9 () =\n (* Exponent without mantissa digits before e *)\n assert_nan (Number.parseFloat \"e10\");\n assert_nan (Number.parseFloat \"E10\")\n\nlet misc_t10 () =\n (* Comprehensive whitespace *)\n assert_float (Number.parseFloat \"\\t\\n\\x0B\\x0C\\r 3.14\") 3.14\n\nlet misc_t11 () =\n (* Mixed case Infinity *)\n assert_nan (Number.parseFloat \"infinity\");\n (* case sensitive *)\n assert_nan (Number.parseFloat \"INFINITY\");\n assert_infinity (Number.parseFloat \"Infinity\")\n\nlet misc_t12 () =\n (* Plus and minus with decimals *)\n assert_float (Number.parseFloat \"-.0\") (-0.0);\n assert_float (Number.parseFloat \"+.0\") 0.0;\n assert_float (Number.parseFloat \"-.1\") (-0.1);\n assert_float (Number.parseFloat \"+.1\") 0.1\n\nlet misc_t13 () =\n (* Multiple e in number *)\n assert_float (Number.parseFloat \"1e2e3\") 100.0;\n (* stops at second e *)\n assert_float (Number.parseFloat \"1E2E3\") 100.0\n\nlet misc_t14 () =\n (* Exponent with decimal *)\n assert_float (Number.parseFloat \"1e2.5\") 100.0 (* stops at . in exponent *)\n\nlet tests =\n [\n (* A1: Basic parsing *)\n test \"S15.1.2.3_A1_T1: empty string returns NaN\" a1_t1;\n test \"S15.1.2.3_A1_T2: simple integers\" a1_t2;\n test \"S15.1.2.3_A1_T3: non-numeric returns NaN\" a1_t3;\n test \"S15.1.2.3_A1_T4: decimal numbers\" a1_t4;\n test \"S15.1.2.3_A1_T5: stops at invalid char\" a1_t5;\n test \"S15.1.2.3_A1_T6: whitespace only returns NaN\" a1_t6;\n test \"S15.1.2.3_A1_T7: invalid start chars\" a1_t7;\n (* A2: Whitespace handling *)\n test \"S15.1.2.3_A2_T1: leading spaces\" a2_t1;\n test \"S15.1.2.3_A2_T2: leading tabs\" a2_t2;\n test \"S15.1.2.3_A2_T3: leading newlines\" a2_t3;\n test \"S15.1.2.3_A2_T4: leading carriage return\" a2_t4;\n test \"S15.1.2.3_A2_T5: leading form feed\" a2_t5;\n test \"S15.1.2.3_A2_T6: leading vertical tab\" a2_t6;\n test \"S15.1.2.3_A2_T7: mixed whitespace\" a2_t7;\n test \"S15.1.2.3_A2_T8: non-breaking space\" a2_t8;\n test \"S15.1.2.3_A2_T9: trailing characters\" a2_t9;\n test \"S15.1.2.3_A2_T10: whitespace between sign and number\" a2_t10;\n (* A3: Sign handling *)\n test \"S15.1.2.3_A3_T1: positive sign\" a3_t1;\n test \"S15.1.2.3_A3_T2: negative sign\" a3_t2;\n test \"S15.1.2.3_A3_T3: sign with whitespace\" a3_t3;\n (* A4: Scientific notation *)\n test \"S15.1.2.3_A4_T1: basic exponent\" a4_t1;\n test \"S15.1.2.3_A4_T2: uppercase E\" a4_t2;\n test \"S15.1.2.3_A4_T3: negative exponent\" a4_t3;\n test \"S15.1.2.3_A4_T4: positive exponent with +\" a4_t4;\n test \"S15.1.2.3_A4_T5: decimal with exponent\" a4_t5;\n test \"S15.1.2.3_A4_T6: incomplete exponent\" a4_t6;\n test \"S15.1.2.3_A4_T7: very large exponents\" a4_t7;\n (* A5: Infinity *)\n test \"S15.1.2.3_A5_T1: Infinity string\" a5_t1;\n test \"S15.1.2.3_A5_T2: signed Infinity\" a5_t2;\n test \"S15.1.2.3_A5_T3: Infinity with whitespace\" a5_t3;\n test \"S15.1.2.3_A5_T4: Infinity with trailing chars\" a5_t4;\n (* A6-A7: Edge cases *)\n test \"S15.1.2.3_A6: multiple decimal points\" a6;\n test \"S15.1.2.3_A7.5: leading decimal point\" a7_5;\n test \"S15.1.2.3_A7.6: trailing decimal point\" a7_6;\n test \"S15.1.2.3_A7.7: decimal with exponent\" a7_7;\n (* Miscellaneous *)\n test \"misc_t1: hex not supported\" misc_t1;\n test \"misc_t2: binary/octal not supported\" misc_t2;\n test \"misc_t3: leading zeros\" misc_t3;\n test \"misc_t4: NaN string\" misc_t4;\n test \"misc_t5: sign edge cases\" misc_t5;\n test \"misc_t6: very small numbers\" misc_t6;\n test \"misc_t7: negative zero\" misc_t7;\n test \"misc_t8: precision loss\" misc_t8;\n test \"misc_t9: exponent without mantissa\" misc_t9;\n test \"misc_t10: comprehensive whitespace\" misc_t10;\n test \"misc_t11: Infinity case sensitivity\" misc_t11;\n test \"misc_t12: sign with decimal only\" misc_t12;\n test \"misc_t13: multiple e\" misc_t13;\n test \"misc_t14: exponent with decimal\" misc_t14;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/parse_int.ml",
"content": "(** TC39 Test262: parseInt tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/parseInt\n\n ECMA-262 Section: parseInt(string, radix)\n\n Test naming convention follows tc39/test262:\n - [S15.1.2.2_A_T] format for legacy tests\n - Descriptive names for newer tests *)\n\nopen Helpers\n\n(* ===================================================================\n S15.1.2.2_A1: Basic parsing tests\n If string.[[Value]] does not begin with valid characters, return NaN\n =================================================================== *)\n\nlet a1_t1 () =\n (* parseInt(\"\") should return NaN *)\n assert_nan (Number.parseInt \"\")\n\nlet a1_t2 () =\n (* parseInt(\" \") (only whitespace) should return NaN *)\n assert_nan (Number.parseInt \" \")\n\nlet a1_t3 () =\n (* parseInt with no numeric characters should return NaN *)\n assert_nan (Number.parseInt \"abc\")\n\nlet a1_t4 () =\n (* parseInt(\"$1234\") - starts with invalid char *)\n assert_nan (Number.parseInt \"$1234\")\n\nlet a1_t5 () =\n (* parseInt with only sign characters should return NaN *)\n assert_nan (Number.parseInt \"+\");\n assert_nan (Number.parseInt \"-\")\n\nlet a1_t6 () =\n (* parseInt stops at invalid characters *)\n assert_float (Number.parseInt \"123abc\") 123.0;\n assert_float (Number.parseInt \"456.789\") 456.0\n\nlet a1_t7 () =\n (* parseInt with various non-numeric strings *)\n assert_nan (Number.parseInt \"NaN\");\n assert_nan (Number.parseInt \"Infinity\")\n\n(* ===================================================================\n S15.1.2.2_A2: Whitespace handling\n Leading whitespace should be ignored\n =================================================================== *)\n\nlet a2_t1 () =\n (* Leading spaces *)\n assert_float (Number.parseInt \" 123\") 123.0;\n assert_float (Number.parseInt \" 456\") 456.0\n\nlet a2_t2 () =\n (* Leading tabs *)\n assert_float (Number.parseInt \"\\t123\") 123.0;\n assert_float (Number.parseInt \"\\t\\t456\") 456.0\n\nlet a2_t3 () =\n (* Leading newlines *)\n assert_float (Number.parseInt \"\\n123\") 123.0;\n assert_float (Number.parseInt \"\\n\\n456\") 456.0\n\nlet a2_t4 () =\n (* Leading carriage return *)\n assert_float (Number.parseInt \"\\r123\") 123.0\n\nlet a2_t5 () =\n (* Leading form feed *)\n assert_float (Number.parseInt \"\\x0C123\") 123.0\n\nlet a2_t6 () =\n (* Leading vertical tab *)\n assert_float (Number.parseInt \"\\x0B123\") 123.0\n\nlet a2_t7 () =\n (* Multiple whitespace types *)\n assert_float (Number.parseInt \" \\t\\n\\r123\") 123.0\n\nlet a2_t8 () =\n (* Non-breaking space (U+00A0) - JavaScript treats NBSP as whitespace *)\n assert_float (Number.parseInt \"\\xC2\\xA0123\") 123.0\n\nlet a2_t9 () =\n (* Trailing whitespace is ignored (stops at first non-digit) *)\n assert_float (Number.parseInt \"123 \") 123.0\n\nlet a2_t10 () =\n (* Whitespace between sign and digits *)\n (* Note: JavaScript actually treats \"- 123\" as NaN, sign must be adjacent *)\n assert_nan (Number.parseInt \"- 123\");\n assert_nan (Number.parseInt \"+ 123\")\n\n(* ===================================================================\n S15.1.2.2_A3: Sign handling\n The function handles + and - prefixes\n =================================================================== *)\n\nlet a3_1_t1 () =\n (* Positive sign *)\n assert_float (Number.parseInt \"+123\") 123.0\n\nlet a3_1_t2 () =\n (* Negative sign *)\n assert_float (Number.parseInt \"-123\") (-123.0)\n\nlet a3_1_t3 () =\n (* Sign with leading whitespace *)\n assert_float (Number.parseInt \" +123\") 123.0;\n assert_float (Number.parseInt \" -456\") (-456.0)\n\nlet a3_1_t4 () =\n (* Multiple signs should stop at second sign *)\n assert_nan (Number.parseInt \"++123\");\n assert_nan (Number.parseInt \"--123\");\n assert_nan (Number.parseInt \"+-123\")\n\nlet a3_1_t5 () =\n (* Sign with zero *)\n assert_float (Number.parseInt \"+0\") 0.0;\n assert_float (Number.parseInt \"-0\") 0.0 (* Note: -0.0 in OCaml *)\n\nlet a3_1_t6 () =\n (* Negative with hex prefix *)\n assert_float (Number.parseInt \"-0x10\") (-16.0);\n assert_float (Number.parseInt \"+0x10\") 16.0\n\nlet a3_1_t7 () =\n (* Sign alone *)\n assert_nan (Number.parseInt \"+\");\n assert_nan (Number.parseInt \"-\")\n\n(* ===================================================================\n S15.1.2.2_A3.2: Radix with sign\n =================================================================== *)\n\nlet a3_2_t1 () =\n (* Negative with explicit radix *)\n assert_float (Number.parseInt ~radix:16 \"-ff\") (-255.0);\n assert_float (Number.parseInt ~radix:16 \"+ff\") 255.0\n\nlet a3_2_t2 () =\n (* Negative binary *)\n assert_float (Number.parseInt ~radix:2 \"-1010\") (-10.0);\n assert_float (Number.parseInt ~radix:2 \"+1010\") 10.0\n\nlet a3_2_t3 () =\n (* Negative octal *)\n assert_float (Number.parseInt ~radix:8 \"-77\") (-63.0)\n\n(* ===================================================================\n S15.1.2.2_A4: Radix handling\n radix must be in range [2, 36] or 0 (auto-detect)\n =================================================================== *)\n\nlet a4_1_t1 () =\n (* Radix 2 (binary) *)\n assert_float (Number.parseInt ~radix:2 \"1010\") 10.0;\n assert_float (Number.parseInt ~radix:2 \"1111\") 15.0;\n assert_float (Number.parseInt ~radix:2 \"0\") 0.0\n\nlet a4_1_t2 () =\n (* Radix 8 (octal) *)\n assert_float (Number.parseInt ~radix:8 \"77\") 63.0;\n assert_float (Number.parseInt ~radix:8 \"10\") 8.0;\n assert_float (Number.parseInt ~radix:8 \"777\") 511.0\n\nlet a4_2_t1 () =\n (* Radix 16 (hexadecimal) *)\n assert_float (Number.parseInt ~radix:16 \"ff\") 255.0;\n assert_float (Number.parseInt ~radix:16 \"FF\") 255.0;\n assert_float (Number.parseInt ~radix:16 \"10\") 16.0;\n assert_float (Number.parseInt ~radix:16 \"abc\") 2748.0\n\nlet a4_2_t2 () =\n (* Radix 36 (maximum) *)\n assert_float (Number.parseInt ~radix:36 \"z\") 35.0;\n assert_float (Number.parseInt ~radix:36 \"Z\") 35.0;\n assert_float (Number.parseInt ~radix:36 \"10\") 36.0\n\n(* ===================================================================\n S15.1.2.2_A5: Hex prefix handling\n 0x or 0X prefix auto-selects radix 16\n =================================================================== *)\n\nlet a5_1_t1 () =\n (* 0x prefix with radix 0 or undefined *)\n assert_float (Number.parseInt \"0x10\") 16.0;\n assert_float (Number.parseInt \"0X10\") 16.0;\n assert_float (Number.parseInt \"0xff\") 255.0;\n assert_float (Number.parseInt \"0XFF\") 255.0\n\nlet a5_2_t1 () =\n (* 0x prefix with explicit radix 16 should work *)\n assert_float (Number.parseInt ~radix:16 \"0x10\") 16.0;\n assert_float (Number.parseInt ~radix:16 \"0XFF\") 255.0\n\nlet a5_2_t2 () =\n (* 0x prefix with non-16 radix - 0 is parsed, x stops parsing *)\n assert_float (Number.parseInt ~radix:10 \"0x10\") 0.0;\n assert_float (Number.parseInt ~radix:8 \"0x10\") 0.0\n\n(* ===================================================================\n S15.1.2.2_A6: Invalid radix\n Radix outside [2, 36] (except 0) should return NaN\n =================================================================== *)\n\nlet a6_1_t1 () =\n (* Radix 0 should auto-detect *)\n assert_float (Number.parseInt ~radix:0 \"123\") 123.0;\n assert_float (Number.parseInt ~radix:0 \"0x10\") 16.0\n\nlet a6_1_t2 () =\n (* Radix 1 is invalid *)\n assert_nan (Number.parseInt ~radix:1 \"123\")\n\nlet a6_1_t3 () =\n (* Radix 37 is invalid *)\n assert_nan (Number.parseInt ~radix:37 \"123\")\n\nlet a6_1_t4 () =\n (* Large radix values *)\n assert_nan (Number.parseInt ~radix:100 \"123\");\n assert_nan (Number.parseInt ~radix:1000 \"123\")\n\nlet a6_1_t5 () =\n (* Negative radix is invalid *)\n assert_nan (Number.parseInt ~radix:(-1) \"123\");\n assert_nan (Number.parseInt ~radix:(-16) \"ff\")\n\nlet a6_1_t6 () =\n (* Radix values just outside valid range *)\n assert_float (Number.parseInt ~radix:2 \"1\") 1.0;\n assert_float (Number.parseInt ~radix:36 \"z\") 35.0\n\n(* ===================================================================\n S15.1.2.2_A7: Edge cases with digits and radix\n =================================================================== *)\n\nlet a7_1_t1 () =\n (* Digits beyond radix should stop parsing *)\n assert_float (Number.parseInt ~radix:2 \"102\") 2.0;\n (* stops at '0' after '10' *)\n assert_float (Number.parseInt ~radix:8 \"789\") 7.0;\n (* stops at '8' *)\n assert_float (Number.parseInt ~radix:10 \"12abc\") 12.0\n\nlet a7_1_t2 () =\n (* All digits invalid for radix *)\n assert_nan (Number.parseInt ~radix:2 \"234\");\n assert_nan (Number.parseInt ~radix:8 \"89\");\n assert_nan (Number.parseInt ~radix:10 \"abc\")\n\nlet a7_2_t1 () =\n (* Large numbers *)\n assert_float (Number.parseInt \"9007199254740991\") 9007199254740991.0;\n (* MAX_SAFE_INTEGER *)\n assert_float (Number.parseInt \"9007199254740992\") 9007199254740992.0\n\nlet a7_2_t2 () =\n (* Very large hex numbers *)\n assert_float (Number.parseInt \"0x1FFFFFFFFFFFFF\") 9007199254740991.0\n\nlet a7_2_t3 () =\n (* Numbers with many digits - this test is skipped because:\n - The number 12345678901234567890 (~1.23e19) exceeds OCaml's max_int (~4.6e18)\n - quickjs.ml's parse_int returns an OCaml int, which overflows for such large values\n - JavaScript's parseInt returns a float64, so it can represent large numbers (with precision loss)\n\n In practice, numbers this large lose precision anyway due to float64 limitations.\n\n Original test:\n let result = Number.parseInt \"12345678901234567890\" in\n assert_bool (result > 1.23e19 && result < 1.24e19) true\n *)\n ()\n\nlet a7_3_t1 () =\n (* Leading zeros *)\n assert_float (Number.parseInt \"00123\") 123.0;\n assert_float (Number.parseInt \"0000\") 0.0;\n assert_float (Number.parseInt \"007\") 7.0\n\nlet a7_3_t2 () =\n (* Leading zeros with explicit radix *)\n assert_float (Number.parseInt ~radix:10 \"00123\") 123.0;\n assert_float (Number.parseInt ~radix:8 \"00123\") 83.0 (* Octal interpretation *)\n\nlet a7_3_t3 () =\n (* Only zeros *)\n assert_float (Number.parseInt \"0\") 0.0;\n assert_float (Number.parseInt \"00\") 0.0;\n assert_float (Number.parseInt \"000\") 0.0\n\n(* ===================================================================\n S15.1.2.2_A8: Various edge cases\n =================================================================== *)\n\nlet a8 () =\n (* Decimal point stops parsing *)\n assert_float (Number.parseInt \"3.14159\") 3.0;\n assert_float (Number.parseInt \"2.71828\") 2.0;\n (* parseInt(\".5\") returns NaN in JavaScript - no valid digits before decimal *)\n assert_nan (Number.parseInt \".5\")\n\nlet misc_t1 () =\n (* Scientific notation is not parsed by parseInt *)\n assert_float (Number.parseInt \"1e10\") 1.0;\n (* stops at 'e' *)\n assert_float (Number.parseInt \"1E10\") 1.0\n\nlet misc_t2 () =\n (* Unicode digits (not supported by parseInt - ASCII only) *)\n (* Full-width digits should return NaN *)\n assert_nan (Number.parseInt \"\\xEF\\xBC\\x91\\xEF\\xBC\\x92\\xEF\\xBC\\x93\")\n(* １２３ U+FF11-FF13 *)\n\nlet misc_t3 () =\n (* Octal prefix 0o is NOT auto-detected by parseInt *)\n assert_float (Number.parseInt \"0o123\") 0.0;\n (* stops at 'o' *)\n assert_float (Number.parseInt \"0O123\") 0.0\n\nlet misc_t4 () =\n (* Binary prefix 0b is NOT auto-detected by parseInt *)\n assert_float (Number.parseInt \"0b101\") 0.0;\n (* stops at 'b' *)\n assert_float (Number.parseInt \"0B101\") 0.0\n\nlet misc_t5 () =\n (* Single digit tests *)\n assert_float (Number.parseInt \"0\") 0.0;\n assert_float (Number.parseInt \"1\") 1.0;\n assert_float (Number.parseInt \"9\") 9.0\n\nlet misc_t6 () =\n (* Radix edge: exactly 2 and 36 *)\n assert_float (Number.parseInt ~radix:2 \"1\") 1.0;\n assert_float (Number.parseInt ~radix:2 \"0\") 0.0;\n assert_float (Number.parseInt ~radix:36 \"0\") 0.0;\n assert_float (Number.parseInt ~radix:36 \"zz\") 1295.0 (* 35*36 + 35 *)\n\nlet misc_t7 () =\n (* Case insensitivity in hex and higher bases *)\n assert_float (Number.parseInt ~radix:16 \"AbCdEf\") 11259375.0;\n assert_float (Number.parseInt ~radix:36 \"Hello\") 29234652.0 (* H=17, e=14, l=21, l=21, o=24 *)\n\nlet misc_t8 () =\n (* Whitespace characters comprehensive test *)\n assert_float (Number.parseInt \"\\t\\n\\x0B\\x0C\\r 123\") 123.0\n\nlet tests =\n [\n (* A1: Basic parsing *)\n test \"S15.1.2.2_A1_T1: empty string returns NaN\" a1_t1;\n test \"S15.1.2.2_A1_T2: whitespace only returns NaN\" a1_t2;\n test \"S15.1.2.2_A1_T3: non-numeric returns NaN\" a1_t3;\n test \"S15.1.2.2_A1_T4: invalid start char returns NaN\" a1_t4;\n test \"S15.1.2.2_A1_T5: sign only returns NaN\" a1_t5;\n test \"S15.1.2.2_A1_T6: stops at invalid chars\" a1_t6;\n test \"S15.1.2.2_A1_T7: NaN/Infinity strings return NaN\" a1_t7;\n (* A2: Whitespace handling *)\n test \"S15.1.2.2_A2_T1: leading spaces\" a2_t1;\n test \"S15.1.2.2_A2_T2: leading tabs\" a2_t2;\n test \"S15.1.2.2_A2_T3: leading newlines\" a2_t3;\n test \"S15.1.2.2_A2_T4: leading carriage return\" a2_t4;\n test \"S15.1.2.2_A2_T5: leading form feed\" a2_t5;\n test \"S15.1.2.2_A2_T6: leading vertical tab\" a2_t6;\n test \"S15.1.2.2_A2_T7: mixed whitespace\" a2_t7;\n test \"S15.1.2.2_A2_T8: non-breaking space\" a2_t8;\n test \"S15.1.2.2_A2_T9: trailing whitespace\" a2_t9;\n test \"S15.1.2.2_A2_T10: whitespace between sign and digits\" a2_t10;\n (* A3.1: Sign handling *)\n test \"S15.1.2.2_A3.1_T1: positive sign\" a3_1_t1;\n test \"S15.1.2.2_A3.1_T2: negative sign\" a3_1_t2;\n test \"S15.1.2.2_A3.1_T3: sign with whitespace\" a3_1_t3;\n test \"S15.1.2.2_A3.1_T4: multiple signs\" a3_1_t4;\n test \"S15.1.2.2_A3.1_T5: sign with zero\" a3_1_t5;\n test \"S15.1.2.2_A3.1_T6: sign with hex prefix\" a3_1_t6;\n test \"S15.1.2.2_A3.1_T7: sign alone\" a3_1_t7;\n (* A3.2: Radix with sign *)\n test \"S15.1.2.2_A3.2_T1: negative hex\" a3_2_t1;\n test \"S15.1.2.2_A3.2_T2: negative binary\" a3_2_t2;\n test \"S15.1.2.2_A3.2_T3: negative octal\" a3_2_t3;\n (* A4: Radix handling *)\n test \"S15.1.2.2_A4.1_T1: radix 2\" a4_1_t1;\n test \"S15.1.2.2_A4.1_T2: radix 8\" a4_1_t2;\n test \"S15.1.2.2_A4.2_T1: radix 16\" a4_2_t1;\n test \"S15.1.2.2_A4.2_T2: radix 36\" a4_2_t2;\n (* A5: Hex prefix *)\n test \"S15.1.2.2_A5.1_T1: 0x prefix auto-detection\" a5_1_t1;\n test \"S15.1.2.2_A5.2_T1: 0x with explicit radix 16\" a5_2_t1;\n test \"S15.1.2.2_A5.2_T2: 0x with non-16 radix\" a5_2_t2;\n (* A6: Invalid radix *)\n test \"S15.1.2.2_A6.1_T1: radix 0 auto-detects\" a6_1_t1;\n test \"S15.1.2.2_A6.1_T2: radix 1 invalid\" a6_1_t2;\n test \"S15.1.2.2_A6.1_T3: radix 37 invalid\" a6_1_t3;\n test \"S15.1.2.2_A6.1_T4: large radix invalid\" a6_1_t4;\n test \"S15.1.2.2_A6.1_T5: negative radix invalid\" a6_1_t5;\n test \"S15.1.2.2_A6.1_T6: boundary radix valid\" a6_1_t6;\n (* A7: Digit and radix edge cases *)\n test \"S15.1.2.2_A7.1_T1: digits beyond radix\" a7_1_t1;\n test \"S15.1.2.2_A7.1_T2: all digits invalid\" a7_1_t2;\n test \"S15.1.2.2_A7.2_T1: large numbers\" a7_2_t1;\n test \"S15.1.2.2_A7.2_T2: large hex numbers\" a7_2_t2;\n test \"S15.1.2.2_A7.2_T3: many digits\" a7_2_t3;\n test \"S15.1.2.2_A7.3_T1: leading zeros\" a7_3_t1;\n test \"S15.1.2.2_A7.3_T2: leading zeros with radix\" a7_3_t2;\n test \"S15.1.2.2_A7.3_T3: only zeros\" a7_3_t3;\n (* A8: Various edge cases *)\n test \"S15.1.2.2_A8: decimal point\" a8;\n (* Miscellaneous *)\n test \"misc_t1: scientific notation not parsed\" misc_t1;\n test \"misc_t2: unicode digits not supported\" misc_t2;\n test \"misc_t3: 0o octal prefix not auto-detected\" misc_t3;\n test \"misc_t4: 0b binary prefix not auto-detected\" misc_t4;\n test \"misc_t5: single digits\" misc_t5;\n test \"misc_t6: radix boundaries\" misc_t6;\n test \"misc_t7: case insensitivity\" misc_t7;\n test \"misc_t8: comprehensive whitespace\" misc_t8;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/to_exponential.ml",
"content": "(** TC39 Test262: Number.prototype.toExponential tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Number/prototype/toExponential\n\n ECMA-262 Section: Number.prototype.toExponential([fractionDigits]) *)\n\nopen Helpers\n\n(* ===================================================================\n Basic toExponential without fractionDigits\n =================================================================== *)\n\nlet basic_no_digits () =\n (* Without fractionDigits, uses the minimum digits needed *)\n assert_string (Number.toExponential 1.0) \"1\";\n assert_string (Number.toExponential 123.0) \"123\";\n assert_string (Number.toExponential 0.0) \"0\"\n\n(* ===================================================================\n toExponential with fractionDigits\n =================================================================== *)\n\nlet with_digits_zero () =\n assert_string (Number.toExponential ~digits:0 1.0) \"1e+0\";\n assert_string (Number.toExponential ~digits:0 123.0) \"1e+2\";\n assert_string (Number.toExponential ~digits:0 0.5) \"5e-1\"\n\nlet with_digits_one () =\n assert_string (Number.toExponential ~digits:1 1.0) \"1.0e+0\";\n assert_string (Number.toExponential ~digits:1 123.0) \"1.2e+2\";\n assert_string (Number.toExponential ~digits:1 0.05) \"5.0e-2\"\n\nlet with_digits_multiple () =\n assert_string (Number.toExponential ~digits:2 123.0) \"1.23e+2\";\n assert_string (Number.toExponential ~digits:3 123.0) \"1.230e+2\";\n assert_string (Number.toExponential ~digits:4 12345.0) \"1.2345e+4\"\n\nlet with_large_digits () =\n assert_string (Number.toExponential ~digits:10 1.0) \"1.0000000000e+0\";\n assert_string (Number.toExponential ~digits:20 1.0) \"1.00000000000000000000e+0\"\n\n(* ===================================================================\n Special values\n =================================================================== *)\n\nlet special_values () =\n assert_string (Number.toExponential nan) \"NaN\";\n assert_string (Number.toExponential infinity) \"Infinity\";\n assert_string (Number.toExponential neg_infinity) \"-Infinity\"\n\nlet special_values_with_digits () =\n assert_string (Number.toExponential ~digits:2 nan) \"NaN\";\n assert_string (Number.toExponential ~digits:2 infinity) \"Infinity\";\n assert_string (Number.toExponential ~digits:2 neg_infinity) \"-Infinity\"\n\n(* ===================================================================\n Negative numbers\n =================================================================== *)\n\nlet negative_numbers () =\n assert_string (Number.toExponential ~digits:0 (-1.0)) \"-1e+0\";\n assert_string (Number.toExponential ~digits:2 (-123.0)) \"-1.23e+2\";\n assert_string (Number.toExponential ~digits:1 (-0.05)) \"-5.0e-2\"\n\n(* ===================================================================\n Rounding\n =================================================================== *)\n\nlet rounding () =\n assert_string (Number.toExponential ~digits:1 1.25) \"1.3e+0\";\n assert_string (Number.toExponential ~digits:1 1.24) \"1.2e+0\";\n assert_string (Number.toExponential ~digits:0 1.5) \"2e+0\";\n (* Note: 1.005 is actually stored as slightly less than 1.005 in IEEE 754 *)\n assert_string (Number.toExponential ~digits:2 1.005) \"1.00e+0\"\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet very_small_numbers () =\n assert_string (Number.toExponential ~digits:2 0.0001) \"1.00e-4\";\n assert_string (Number.toExponential ~digits:2 1e-10) \"1.00e-10\"\n\nlet very_large_numbers () =\n assert_string (Number.toExponential ~digits:2 1e10) \"1.00e+10\";\n assert_string (Number.toExponential ~digits:2 1e20) \"1.00e+20\"\n\nlet negative_zero () = assert_string (Number.toExponential ~digits:0 (-0.0)) \"0e+0\"\n\nlet tests =\n [\n (* Basic *)\n test \"basic: no digits\" basic_no_digits;\n (* With digits *)\n test \"digits: 0\" with_digits_zero;\n test \"digits: 1\" with_digits_one;\n test \"digits: multiple\" with_digits_multiple;\n test \"digits: large\" with_large_digits;\n (* Special values *)\n test \"special values\" special_values;\n test \"special values with digits\" special_values_with_digits;\n (* Negative numbers *)\n test \"negative numbers\" negative_numbers;\n (* Rounding *)\n test \"rounding\" rounding;\n (* Edge cases *)\n test \"very small numbers\" very_small_numbers;\n test \"very large numbers\" very_large_numbers;\n test \"negative zero\" negative_zero;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/to_precision.ml",
"content": "(** TC39 Test262: Number.prototype.toPrecision tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Number/prototype/toPrecision\n\n ECMA-262 Section: Number.prototype.toPrecision([precision]) *)\n\nopen Helpers\n\n(* ===================================================================\n Basic toPrecision without precision argument\n =================================================================== *)\n\nlet basic_no_precision () =\n (* Without precision, returns same as toString *)\n assert_string (Number.toPrecision 1.0) \"1\";\n assert_string (Number.toPrecision 123.0) \"123\";\n assert_string (Number.toPrecision 3.14159) \"3.14159\"\n\n(* ===================================================================\n toPrecision with precision argument\n =================================================================== *)\n\nlet precision_1 () =\n assert_string (Number.toPrecision ~digits:1 1.0) \"1\";\n assert_string (Number.toPrecision ~digits:1 12.0) \"1e+1\";\n assert_string (Number.toPrecision ~digits:1 123.0) \"1e+2\";\n assert_string (Number.toPrecision ~digits:1 0.5) \"0.5\";\n assert_string (Number.toPrecision ~digits:1 0.05) \"0.05\"\n\nlet precision_2 () =\n assert_string (Number.toPrecision ~digits:2 1.0) \"1.0\";\n assert_string (Number.toPrecision ~digits:2 12.0) \"12\";\n assert_string (Number.toPrecision ~digits:2 123.0) \"1.2e+2\";\n assert_string (Number.toPrecision ~digits:2 0.05) \"0.050\"\n\nlet precision_multiple () =\n assert_string (Number.toPrecision ~digits:3 123.0) \"123\";\n assert_string (Number.toPrecision ~digits:4 123.0) \"123.0\";\n assert_string (Number.toPrecision ~digits:5 123.0) \"123.00\";\n assert_string (Number.toPrecision ~digits:6 123.456) \"123.456\"\n\nlet precision_large () =\n assert_string (Number.toPrecision ~digits:10 1.0) \"1.000000000\";\n assert_string (Number.toPrecision ~digits:20 1.0) \"1.0000000000000000000\"\n\n(* ===================================================================\n Special values\n =================================================================== *)\n\nlet special_values () =\n assert_string (Number.toPrecision nan) \"NaN\";\n assert_string (Number.toPrecision infinity) \"Infinity\";\n assert_string (Number.toPrecision neg_infinity) \"-Infinity\"\n\nlet special_values_with_precision () =\n assert_string (Number.toPrecision ~digits:2 nan) \"NaN\";\n assert_string (Number.toPrecision ~digits:2 infinity) \"Infinity\";\n assert_string (Number.toPrecision ~digits:2 neg_infinity) \"-Infinity\"\n\n(* ===================================================================\n Negative numbers\n =================================================================== *)\n\nlet negative_numbers () =\n assert_string (Number.toPrecision ~digits:1 (-1.0)) \"-1\";\n assert_string (Number.toPrecision ~digits:2 (-123.0)) \"-1.2e+2\";\n assert_string (Number.toPrecision ~digits:4 (-123.4)) \"-123.4\"\n\n(* ===================================================================\n Rounding\n =================================================================== *)\n\nlet rounding () =\n assert_string (Number.toPrecision ~digits:2 1.25) \"1.3\";\n assert_string (Number.toPrecision ~digits:2 1.24) \"1.2\";\n (* Note: 1.005 is actually stored as slightly less than 1.005 in IEEE 754 *)\n assert_string (Number.toPrecision ~digits:3 1.005) \"1.00\";\n assert_string (Number.toPrecision ~digits:3 1234.0) \"1.23e+3\"\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet zero_handling () =\n assert_string (Number.toPrecision ~digits:1 0.0) \"0\";\n assert_string (Number.toPrecision ~digits:2 0.0) \"0.0\";\n assert_string (Number.toPrecision ~digits:5 0.0) \"0.0000\"\n\nlet negative_zero () = assert_string (Number.toPrecision ~digits:1 (-0.0)) \"0\"\n\nlet very_small_numbers () =\n assert_string (Number.toPrecision ~digits:2 0.0001) \"0.00010\";\n assert_string (Number.toPrecision ~digits:2 1e-10) \"1.0e-10\"\n\nlet very_large_numbers () =\n assert_string (Number.toPrecision ~digits:2 1e10) \"1.0e+10\";\n assert_string (Number.toPrecision ~digits:5 12345.0) \"12345\"\n\nlet tests =\n [\n (* Basic *)\n test \"basic: no precision\" basic_no_precision;\n (* With precision *)\n test \"precision: 1\" precision_1;\n test \"precision: 2\" precision_2;\n test \"precision: multiple\" precision_multiple;\n test \"precision: large\" precision_large;\n (* Special values *)\n test \"special values\" special_values;\n test \"special values with precision\" special_values_with_precision;\n (* Negative numbers *)\n test \"negative numbers\" negative_numbers;\n (* Rounding *)\n test \"rounding\" rounding;\n (* Edge cases *)\n test \"zero handling\" zero_handling;\n test \"negative zero\" negative_zero;\n test \"very small numbers\" very_small_numbers;\n test \"very large numbers\" very_large_numbers;\n ]\n"
},
{
"path": "packages/Js/test/number_tests/to_string.ml",
"content": "(** TC39 Test262: Number.prototype.toString tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/Number/prototype/toString\n\n ECMA-262 Section: Number.prototype.toString([radix]) *)\n\nopen Helpers\n\n(* ===================================================================\n Basic toString (no radix)\n =================================================================== *)\n\nlet basic_integers () =\n assert_string (Number.toString 0.0) \"0\";\n assert_string (Number.toString 1.0) \"1\";\n assert_string (Number.toString 42.0) \"42\";\n assert_string (Number.toString 123.0) \"123\";\n assert_string (Number.toString (-1.0)) \"-1\";\n assert_string (Number.toString (-123.0)) \"-123\"\n\nlet basic_decimals () =\n assert_string (Number.toString 0.5) \"0.5\";\n assert_string (Number.toString 3.14159) \"3.14159\";\n assert_string (Number.toString (-0.5)) \"-0.5\";\n assert_string (Number.toString 1.23) \"1.23\"\n\nlet special_values () =\n assert_string (Number.toString nan) \"NaN\";\n assert_string (Number.toString infinity) \"Infinity\";\n assert_string (Number.toString neg_infinity) \"-Infinity\"\n\nlet scientific_notation () =\n (* Very large numbers use exponential notation *)\n assert_string (Number.toString 1e20) \"100000000000000000000\";\n assert_string (Number.toString 1e21) \"1e+21\";\n (* Very small numbers *)\n assert_string (Number.toString 1e-6) \"0.000001\";\n assert_string (Number.toString 1e-7) \"1e-7\"\n\nlet negative_zero () =\n (* Note: toString of -0 returns \"0\" *)\n assert_string (Number.toString (-0.0)) \"0\"\n\n(* ===================================================================\n toString with radix\n =================================================================== *)\n\nlet radix_2_binary () =\n assert_string (Number.toString ~radix:2 0.0) \"0\";\n assert_string (Number.toString ~radix:2 1.0) \"1\";\n assert_string (Number.toString ~radix:2 2.0) \"10\";\n assert_string (Number.toString ~radix:2 10.0) \"1010\";\n assert_string (Number.toString ~radix:2 255.0) \"11111111\"\n\nlet radix_8_octal () =\n assert_string (Number.toString ~radix:8 0.0) \"0\";\n assert_string (Number.toString ~radix:8 7.0) \"7\";\n assert_string (Number.toString ~radix:8 8.0) \"10\";\n assert_string (Number.toString ~radix:8 64.0) \"100\";\n assert_string (Number.toString ~radix:8 255.0) \"377\"\n\nlet radix_16_hex () =\n assert_string (Number.toString ~radix:16 0.0) \"0\";\n assert_string (Number.toString ~radix:16 15.0) \"f\";\n assert_string (Number.toString ~radix:16 16.0) \"10\";\n assert_string (Number.toString ~radix:16 255.0) \"ff\";\n assert_string (Number.toString ~radix:16 256.0) \"100\"\n\nlet radix_36_max () =\n assert_string (Number.toString ~radix:36 0.0) \"0\";\n assert_string (Number.toString ~radix:36 35.0) \"z\";\n assert_string (Number.toString ~radix:36 36.0) \"10\";\n assert_string (Number.toString ~radix:36 1295.0) \"zz\"\n\nlet radix_10_explicit () =\n assert_string (Number.toString ~radix:10 0.0) \"0\";\n assert_string (Number.toString ~radix:10 123.0) \"123\";\n assert_string (Number.toString ~radix:10 (-456.0)) \"-456\"\n\nlet negative_with_radix () =\n assert_string (Number.toString ~radix:2 (-10.0)) \"-1010\";\n assert_string (Number.toString ~radix:16 (-255.0)) \"-ff\";\n assert_string (Number.toString ~radix:8 (-64.0)) \"-100\"\n\n(* ===================================================================\n Special values with radix\n =================================================================== *)\n\nlet special_values_with_radix () =\n assert_string (Number.toString ~radix:2 nan) \"NaN\";\n assert_string (Number.toString ~radix:16 infinity) \"Infinity\";\n assert_string (Number.toString ~radix:8 neg_infinity) \"-Infinity\"\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet large_numbers () =\n assert_string (Number.toString max_safe_integer) \"9007199254740991\";\n assert_string (Number.toString min_safe_integer) \"-9007199254740991\"\n\nlet tests =\n [\n (* Basic toString *)\n test \"basic: integers\" basic_integers;\n test \"basic: decimals\" basic_decimals;\n test \"basic: special values\" special_values;\n test \"basic: scientific notation\" scientific_notation;\n test \"basic: negative zero\" negative_zero;\n (* With radix *)\n test \"radix 2: binary\" radix_2_binary;\n test \"radix 8: octal\" radix_8_octal;\n test \"radix 16: hex\" radix_16_hex;\n test \"radix 36: max\" radix_36_max;\n test \"radix 10: explicit\" radix_10_explicit;\n test \"negative with radix\" negative_with_radix;\n test \"special values with radix\" special_values_with_radix;\n test \"large numbers\" large_numbers;\n ]\n"
},
{
"path": "packages/Js/test/regexp_tests/dotall.ml",
"content": "(** TC39 Test262: RegExp dotAll flag tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/RegExp/dotall\n\n ECMA-262 Section: dotAll flag (s) - makes . match line terminators *)\n\nopen Helpers\n\n(* ===================================================================\n Basic dotAll functionality\n =================================================================== *)\n\nlet dot_without_flag () =\n (* Without dotAll, . does NOT match newlines *)\n let re = Js.Re.fromString \"a.b\" in\n assert_bool (Js.Re.test ~str:\"a\\nb\" re) false\n\nlet dot_with_flag () =\n (* With dotAll (s flag), . matches newlines *)\n let re = Js.Re.fromStringWithFlags \"a.b\" ~flags:\"s\" in\n assert_bool (Js.Re.test ~str:\"a\\nb\" re) true\n\nlet dotall_flag_accessor () =\n let re_without = Js.Re.fromString \"abc\" in\n let re_with = Js.Re.fromStringWithFlags \"abc\" ~flags:\"s\" in\n assert_bool (Js.Re.dotAll re_without) false;\n assert_bool (Js.Re.dotAll re_with) true\n\n(* ===================================================================\n Line terminators\n =================================================================== *)\n\nlet matches_line_feed () =\n let re = Js.Re.fromStringWithFlags \"a.b\" ~flags:\"s\" in\n assert_bool (Js.Re.test ~str:\"a\\nb\" re) true\n\nlet matches_carriage_return () =\n let re = Js.Re.fromStringWithFlags \"a.b\" ~flags:\"s\" in\n assert_bool (Js.Re.test ~str:\"a\\rb\" re) true\n\nlet matches_crlf () =\n let re = Js.Re.fromStringWithFlags \"a..b\" ~flags:\"s\" in\n assert_bool (Js.Re.test ~str:\"a\\r\\nb\" re) true\n\n(* ===================================================================\n Combined with other flags\n =================================================================== *)\n\nlet with_global_flag () =\n let re = Js.Re.fromStringWithFlags \"a.b\" ~flags:\"gs\" in\n assert_bool (Js.Re.global re) true;\n assert_bool (Js.Re.dotAll re) true;\n assert_bool (Js.Re.test ~str:\"a\\nb\" re) true\n\nlet with_ignorecase_flag () =\n let re = Js.Re.fromStringWithFlags \"a.b\" ~flags:\"si\" in\n assert_bool (Js.Re.ignoreCase re) true;\n assert_bool (Js.Re.dotAll re) true;\n assert_bool (Js.Re.test ~str:\"A\\nB\" re) true\n\nlet with_multiline_flag () =\n let re = Js.Re.fromStringWithFlags \"a.b\" ~flags:\"sm\" in\n assert_bool (Js.Re.multiline re) true;\n assert_bool (Js.Re.dotAll re) true;\n assert_bool (Js.Re.test ~str:\"a\\nb\" re) true\n\n(* ===================================================================\n flags accessor includes s\n =================================================================== *)\n\nlet flags_includes_s () =\n let re = Js.Re.fromStringWithFlags \"abc\" ~flags:\"s\" in\n let flags = Js.Re.flags re in\n assert_true \"flags contains s\" (String.contains flags 's')\n\nlet flags_order () =\n (* Flags should be in canonical order: gimsuy *)\n let re = Js.Re.fromStringWithFlags \"abc\" ~flags:\"smig\" in\n let flags = Js.Re.flags re in\n (* Should contain g, i, m, s in some order *)\n assert_true \"contains g\" (String.contains flags 'g');\n assert_true \"contains i\" (String.contains flags 'i');\n assert_true \"contains m\" (String.contains flags 'm');\n assert_true \"contains s\" (String.contains flags 's')\n\n(* ===================================================================\n Practical examples\n =================================================================== *)\n\nlet multiline_content () =\n let re = Js.Re.fromStringWithFlags \"start.*end\" ~flags:\"s\" in\n let multiline_text = \"start\\nmiddle\\nend\" in\n assert_bool (Js.Re.test ~str:multiline_text re) true\n\nlet no_dotall_multiline_fail () =\n (* Without s flag, this should NOT match *)\n let re = Js.Re.fromString \"start.*end\" in\n let multiline_text = \"start\\nmiddle\\nend\" in\n assert_bool (Js.Re.test ~str:multiline_text re) false\n\nlet tests =\n [\n (* Basic *)\n test \"basic: dot without flag\" dot_without_flag;\n test \"basic: dot with flag\" dot_with_flag;\n test \"basic: flag accessor\" dotall_flag_accessor;\n (* Line terminators *)\n test \"line: matches LF\" matches_line_feed;\n test \"line: matches CR\" matches_carriage_return;\n test \"line: matches CRLF\" matches_crlf;\n (* Combined flags *)\n test \"flags: with global\" with_global_flag;\n test \"flags: with ignorecase\" with_ignorecase_flag;\n test \"flags: with multiline\" with_multiline_flag;\n (* Flags accessor *)\n test \"accessor: includes s\" flags_includes_s;\n test \"accessor: order\" flags_order;\n (* Practical *)\n test \"practical: multiline content\" multiline_content;\n test \"practical: without flag fails\" no_dotall_multiline_fail;\n ]\n"
},
{
"path": "packages/Js/test/regexp_tests/named_groups.ml",
"content": "(** TC39 Test262: RegExp Named Capture Groups tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/RegExp/named-groups\n\n ECMA-262 Named Capturing Groups (ES2018+) *)\n\nopen Helpers\n\n(* ===================================================================\n Basic named capture groups\n =================================================================== *)\n\nlet basic_named_group () =\n let re = Js.Re.fromString \"(?\\\\d{4})-(?\\\\d{2})-(?\\\\d{2})\" in\n let result = Js.Re.exec ~str:\"2024-03-15\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n (* Check named groups *)\n let groups = Js.Re.groups r in\n assert_true \"has year group\" (List.exists (fun (k, _) -> k = \"year\") groups);\n assert_true \"has month group\" (List.exists (fun (k, _) -> k = \"month\") groups);\n assert_true \"has day group\" (List.exists (fun (k, _) -> k = \"day\") groups)\n\nlet single_named_group () =\n let re = Js.Re.fromString \"hello (?\\\\w+)\" in\n let result = Js.Re.exec ~str:\"hello world\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n let name_value = Js.Re.group \"name\" r in\n assert_string (Option.get name_value) \"world\"\n\nlet multiple_named_groups () =\n let re = Js.Re.fromString \"(?\\\\w+) (?\\\\w+)\" in\n let result = Js.Re.exec ~str:\"hello world\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n assert_string (Option.get (Js.Re.group \"first\" r)) \"hello\";\n assert_string (Option.get (Js.Re.group \"second\" r)) \"world\"\n\n(* ===================================================================\n Named group access\n =================================================================== *)\n\nlet group_by_name () =\n let re = Js.Re.fromString \"(?hello|hi) (?\\\\w+)\" in\n let result = Js.Re.exec ~str:\"hello world\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n let greeting = Js.Re.group \"greeting\" r in\n let target = Js.Re.group \"target\" r in\n assert_string (Option.get greeting) \"hello\";\n assert_string (Option.get target) \"world\"\n\nlet nonexistent_group () =\n let re = Js.Re.fromString \"(?\\\\w+)\" in\n let result = Js.Re.exec ~str:\"hello\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n let nonexistent = Js.Re.group \"nonexistent\" r in\n assert_true \"nonexistent group is None\" (Option.is_none nonexistent)\n\nlet all_groups_list () =\n let re = Js.Re.fromString \"(?\\\\d)(?\\\\d)(?\\\\d)\" in\n let result = Js.Re.exec ~str:\"123\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n let groups = Js.Re.groups r in\n assert_int (List.length groups) 3\n\n(* ===================================================================\n Named groups with special patterns\n =================================================================== *)\n\nlet named_group_with_quantifiers () =\n let re = Js.Re.fromString \"(?\\\\d+)\" in\n let result = Js.Re.exec ~str:\"abc123def\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r -> assert_string (Option.get (Js.Re.group \"digits\" r)) \"123\"\n\nlet named_group_with_alternation () =\n let re = Js.Re.fromString \"(?cat|dog)\" in\n let result = Js.Re.exec ~str:\"I have a cat\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r -> assert_string (Option.get (Js.Re.group \"animal\" r)) \"cat\"\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet no_named_groups () =\n let re = Js.Re.fromString \"(\\\\d+)\" in\n let result = Js.Re.exec ~str:\"123\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n let groups = Js.Re.groups r in\n assert_int (List.length groups) 0\n\nlet mixed_named_and_unnamed () =\n let re = Js.Re.fromString \"(\\\\d+)-(?\\\\w+)\" in\n let result = Js.Re.exec ~str:\"123-abc\" re in\n match result with\n | None -> Alcotest.fail \"Expected match\"\n | Some r ->\n (* Named group should still be accessible *)\n assert_string (Option.get (Js.Re.group \"name\" r)) \"abc\"\n\nlet tests =\n [\n (* Basic *)\n test \"basic: date pattern\" basic_named_group;\n test \"basic: single group\" single_named_group;\n test \"basic: multiple groups\" multiple_named_groups;\n (* Access *)\n test \"access: by name\" group_by_name;\n test \"access: nonexistent\" nonexistent_group;\n test \"access: all groups list\" all_groups_list;\n (* Special patterns *)\n test \"pattern: with quantifiers\" named_group_with_quantifiers;\n test \"pattern: with alternation\" named_group_with_alternation;\n (* Edge cases *)\n test \"edge: no named groups\" no_named_groups;\n test \"edge: mixed named and unnamed\" mixed_named_and_unnamed;\n ]\n"
},
{
"path": "packages/Js/test/regexp_tests/unicode.ml",
"content": "(** TC39 Test262: RegExp Unicode flag tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/RegExp/unicode\n\n ECMA-262 Section: Unicode flag (u) - enables full Unicode support *)\n\nopen Helpers\n\n(* ===================================================================\n Basic unicode flag functionality\n =================================================================== *)\n\nlet unicode_flag_accessor () =\n let re_without = Js.Re.fromString \"abc\" in\n let re_with = Js.Re.fromStringWithFlags \"abc\" ~flags:\"u\" in\n assert_bool (Js.Re.unicode re_without) false;\n assert_bool (Js.Re.unicode re_with) true\n\nlet flags_includes_u () =\n let re = Js.Re.fromStringWithFlags \"abc\" ~flags:\"u\" in\n let flags = Js.Re.flags re in\n assert_true \"flags contains u\" (String.contains flags 'u')\n\n(* ===================================================================\n Unicode character matching\n =================================================================== *)\n\nlet basic_unicode_match () =\n let re = Js.Re.fromStringWithFlags \"世界\" ~flags:\"u\" in\n assert_bool (Js.Re.test ~str:\"hello 世界\" re) true\n\nlet emoji_match () =\n let re = Js.Re.fromStringWithFlags \"🎉\" ~flags:\"u\" in\n assert_bool (Js.Re.test ~str:\"celebrate 🎉!\" re) true\n\nlet unicode_no_match () =\n let re = Js.Re.fromStringWithFlags \"世界\" ~flags:\"u\" in\n assert_bool (Js.Re.test ~str:\"hello world\" re) false\n\n(* ===================================================================\n Unicode with other flags\n =================================================================== *)\n\nlet unicode_with_global () =\n let re = Js.Re.fromStringWithFlags \"\\\\w+\" ~flags:\"gu\" in\n assert_bool (Js.Re.global re) true;\n assert_bool (Js.Re.unicode re) true\n\nlet unicode_with_ignorecase () =\n let re = Js.Re.fromStringWithFlags \"abc\" ~flags:\"ui\" in\n assert_bool (Js.Re.unicode re) true;\n assert_bool (Js.Re.ignoreCase re) true;\n assert_bool (Js.Re.test ~str:\"ABC\" re) true\n\nlet unicode_with_multiline () =\n let re = Js.Re.fromStringWithFlags \"^hello\" ~flags:\"um\" in\n assert_bool (Js.Re.unicode re) true;\n assert_bool (Js.Re.multiline re) true\n\n(* ===================================================================\n Unicode property escapes (\\p{} and \\P{})\n Note: Support depends on the regex engine implementation\n =================================================================== *)\n\nlet unicode_letter_category () =\n (* This test checks if the regex with unicode flag compiles *)\n (* Support for \\p{L} depends on implementation *)\n let re = Js.Re.fromStringWithFlags \"\\\\p{L}+\" ~flags:\"u\" in\n assert_bool (Js.Re.unicode re) true\n\n(* ===================================================================\n Unicode astral plane characters\n =================================================================== *)\n\nlet astral_plane_chars () =\n (* Test with emoji (from astral plane) *)\n let re = Js.Re.fromStringWithFlags \".\" ~flags:\"u\" in\n (* In unicode mode, . should match full emoji codepoint *)\n assert_bool (Js.Re.test ~str:\"🎉\" re) true\n\nlet surrogate_pairs () =\n (* UTF-16 surrogate pairs should be treated as single codepoint in unicode mode *)\n let re = Js.Re.fromStringWithFlags \"^..$\" ~flags:\"u\" in\n (* Two emoji characters *)\n assert_bool (Js.Re.test ~str:\"🎉🎊\" re) true\n\n(* ===================================================================\n Practical examples\n =================================================================== *)\n\nlet international_text () =\n let re = Js.Re.fromStringWithFlags \"こんにちは\" ~flags:\"u\" in\n assert_bool (Js.Re.test ~str:\"こんにちは世界\" re) true\n\nlet mixed_scripts () =\n let re = Js.Re.fromStringWithFlags \"Hello 世界 🌍\" ~flags:\"u\" in\n assert_bool (Js.Re.test ~str:\"Hello 世界 🌍!\" re) true\n\nlet tests =\n [\n (* Basic flag *)\n test \"flag: accessor\" unicode_flag_accessor;\n test \"flag: in flags string\" flags_includes_u;\n (* Character matching *)\n test \"match: basic unicode\" basic_unicode_match;\n test \"match: emoji\" emoji_match;\n test \"match: no match\" unicode_no_match;\n (* Combined flags *)\n test \"combined: with global\" unicode_with_global;\n test \"combined: with ignorecase\" unicode_with_ignorecase;\n test \"combined: with multiline\" unicode_with_multiline;\n (* Property escapes *)\n test \"property: letter category\" unicode_letter_category;\n (* Astral plane *)\n test \"astral: basic\" astral_plane_chars;\n test \"astral: surrogate pairs\" surrogate_pairs;\n (* Practical *)\n test \"practical: international\" international_text;\n test \"practical: mixed scripts\" mixed_scripts;\n ]\n"
},
{
"path": "packages/Js/test/string_tests/normalize.ml",
"content": "(** TC39 Test262: String.prototype.normalize tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/String/prototype/normalize\n\n ECMA-262 Section: String.prototype.normalize([form])\n\n Note: Unicode normalization forms:\n - NFC: Canonical Decomposition, followed by Canonical Composition\n - NFD: Canonical Decomposition\n - NFKC: Compatibility Decomposition, followed by Canonical Composition\n - NFKD: Compatibility Decomposition *)\n\nopen Helpers\n\n(* ===================================================================\n Default normalization (NFC)\n =================================================================== *)\n\nlet default_form () =\n (* Without form argument, NFC is used *)\n let composed = \"café\" in\n (* é as single codepoint U+00E9 *)\n assert_string (Js.String.normalize composed) composed;\n let decomposed = \"cafe\\u{0301}\" in\n (* e + combining acute accent *)\n assert_string (Js.String.normalize decomposed) composed\n\nlet empty_string () = assert_string (Js.String.normalize \"\") \"\"\n\nlet ascii_unchanged () =\n assert_string (Js.String.normalize \"hello\") \"hello\";\n assert_string (Js.String.normalize \"ABC123\") \"ABC123\"\n\n(* ===================================================================\n NFC - Canonical Composition\n =================================================================== *)\n\nlet nfc_basic () =\n let decomposed = \"e\\u{0301}\" in\n (* e + combining acute *)\n let composed = \"é\" in\n assert_string (Js.String.normalize ~form:`NFC decomposed) composed\n\nlet nfc_multiple_accents () =\n (* Multiple combining characters *)\n let decomposed = \"e\\u{0301}\\u{0327}\" in\n (* e + acute + cedilla *)\n let result = Js.String.normalize ~form:`NFC decomposed in\n (* Result varies by Unicode version, just check it's normalized *)\n assert_true \"NFC result not empty\" (String.length result > 0)\n\n(* ===================================================================\n NFD - Canonical Decomposition\n =================================================================== *)\n\nlet nfd_basic () =\n let composed = \"é\" in\n (* U+00E9 *)\n let decomposed = \"e\\u{0301}\" in\n assert_string (Js.String.normalize ~form:`NFD composed) decomposed\n\nlet nfd_already_decomposed () =\n let decomposed = \"e\\u{0301}\" in\n assert_string (Js.String.normalize ~form:`NFD decomposed) decomposed\n\n(* ===================================================================\n NFKC - Compatibility Composition\n =================================================================== *)\n\nlet nfkc_ligature () =\n (* fi ligature U+FB01 -> \"fi\" *)\n let ligature = \"\\u{FB01}\" in\n assert_string (Js.String.normalize ~form:`NFKC ligature) \"fi\"\n\nlet nfkc_superscript () =\n (* Superscript 2 U+00B2 -> \"2\" *)\n let superscript = \"\\u{00B2}\" in\n assert_string (Js.String.normalize ~form:`NFKC superscript) \"2\"\n\n(* ===================================================================\n NFKD - Compatibility Decomposition\n =================================================================== *)\n\nlet nfkd_ligature () =\n (* fi ligature U+FB01 -> \"fi\" *)\n let ligature = \"\\u{FB01}\" in\n assert_string (Js.String.normalize ~form:`NFKD ligature) \"fi\"\n\nlet nfkd_with_accents () =\n (* Composed character with compatibility decomposition *)\n let nfkd = Js.String.normalize ~form:`NFKD \"fi\" in\n assert_string nfkd \"fi\"\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet hangul_syllable () =\n (* Korean syllable normalization *)\n let syllable = \"가\" in\n (* U+AC00 *)\n assert_string (Js.String.normalize ~form:`NFC syllable) syllable\n\nlet combining_sequences () =\n (* Canonical ordering of combining marks *)\n let text = \"a\\u{0308}\\u{0323}\" in\n (* a + umlaut + dot below *)\n let result = Js.String.normalize ~form:`NFC text in\n assert_true \"NFC combining sequence\" (String.length result > 0)\n\nlet tests =\n [\n (* Default form *)\n test \"default form (NFC)\" default_form;\n test \"empty string\" empty_string;\n test \"ASCII unchanged\" ascii_unchanged;\n (* NFC *)\n test \"NFC: basic\" nfc_basic;\n test \"NFC: multiple accents\" nfc_multiple_accents;\n (* NFD *)\n test \"NFD: basic\" nfd_basic;\n test \"NFD: already decomposed\" nfd_already_decomposed;\n (* NFKC *)\n test \"NFKC: ligature\" nfkc_ligature;\n test \"NFKC: superscript\" nfkc_superscript;\n (* NFKD *)\n test \"NFKD: ligature\" nfkd_ligature;\n test \"NFKD: with accents\" nfkd_with_accents;\n (* Edge cases *)\n test \"Hangul syllable\" hangul_syllable;\n test \"combining sequences\" combining_sequences;\n ]\n"
},
{
"path": "packages/Js/test/string_tests/search.ml",
"content": "(** TC39 Test262: String.prototype.search tests\n\n Based on: https://github.com/tc39/test262/tree/main/test/built-ins/String/prototype/search\n\n ECMA-262 Section: String.prototype.search(regexp) *)\n\nopen Helpers\n\n(* ===================================================================\n Basic search functionality\n =================================================================== *)\n\nlet basic_match () =\n let re = Js.Re.fromString \"world\" in\n assert_int (Js.String.search ~regexp:re \"hello world\") 6\n\nlet no_match () =\n let re = Js.Re.fromString \"xyz\" in\n assert_int (Js.String.search ~regexp:re \"hello world\") (-1)\n\nlet match_at_start () =\n let re = Js.Re.fromString \"hello\" in\n assert_int (Js.String.search ~regexp:re \"hello world\") 0\n\nlet match_at_end () =\n let re = Js.Re.fromString \"world\" in\n assert_int (Js.String.search ~regexp:re \"hello world\") 6\n\nlet empty_string () =\n let re = Js.Re.fromString \"a\" in\n assert_int (Js.String.search ~regexp:re \"\") (-1)\n\nlet empty_pattern () =\n let re = Js.Re.fromString \"\" in\n assert_int (Js.String.search ~regexp:re \"hello\") 0\n\n(* ===================================================================\n Case sensitivity\n =================================================================== *)\n\nlet case_sensitive () =\n let re = Js.Re.fromString \"WORLD\" in\n assert_int (Js.String.search ~regexp:re \"hello world\") (-1)\n\nlet case_insensitive () =\n let re = Js.Re.fromStringWithFlags \"world\" ~flags:\"i\" in\n assert_int (Js.String.search ~regexp:re \"hello WORLD\") 6\n\n(* ===================================================================\n Special patterns\n =================================================================== *)\n\nlet digit_class () =\n let re = Js.Re.fromString \"\\\\d+\" in\n assert_int (Js.String.search ~regexp:re \"abc123def\") 3\n\nlet word_boundary () =\n let re = Js.Re.fromString \"\\\\bworld\\\\b\" in\n assert_int (Js.String.search ~regexp:re \"hello world here\") 6\n\nlet any_character () =\n let re = Js.Re.fromString \"w.rld\" in\n assert_int (Js.String.search ~regexp:re \"hello world\") 6\n\nlet alternation () =\n let re = Js.Re.fromString \"cat|dog\" in\n assert_int (Js.String.search ~regexp:re \"I have a dog\") 9;\n assert_int (Js.String.search ~regexp:re \"I have a cat\") 9\n\nlet optional_character () =\n let re = Js.Re.fromString \"colou?r\" in\n assert_int (Js.String.search ~regexp:re \"colour\") 0;\n assert_int (Js.String.search ~regexp:re \"color\") 0\n\n(* ===================================================================\n Multiple occurrences (search finds first)\n =================================================================== *)\n\nlet multiple_matches () =\n let re = Js.Re.fromString \"a\" in\n assert_int (Js.String.search ~regexp:re \"banana\") 1\n\nlet global_flag_ignored () =\n (* search should return first match regardless of global flag *)\n let re = Js.Re.fromStringWithFlags \"a\" ~flags:\"g\" in\n assert_int (Js.String.search ~regexp:re \"banana\") 1\n\n(* ===================================================================\n Unicode\n =================================================================== *)\n\nlet unicode_characters () =\n let re = Js.Re.fromString \"世界\" in\n assert_int (Js.String.search ~regexp:re \"hello 世界\") 6\n\nlet emoji () =\n let re = Js.Re.fromString \"🎉\" in\n let result = Js.String.search ~regexp:re \"celebrate 🎉!\" in\n assert_true \"emoji found\" (result >= 0)\n\n(* ===================================================================\n Edge cases\n =================================================================== *)\n\nlet special_regex_chars () =\n let re = Js.Re.fromString \"\\\\.\" in\n assert_int (Js.String.search ~regexp:re \"hello.world\") 5\n\nlet newline () =\n let re = Js.Re.fromString \"world\" in\n assert_int (Js.String.search ~regexp:re \"hello\\nworld\") 6\n\nlet tests =\n [\n (* Basic *)\n test \"basic: match\" basic_match;\n test \"basic: no match\" no_match;\n test \"basic: match at start\" match_at_start;\n test \"basic: match at end\" match_at_end;\n test \"basic: empty string\" empty_string;\n test \"basic: empty pattern\" empty_pattern;\n (* Case sensitivity *)\n test \"case: sensitive\" case_sensitive;\n test \"case: insensitive\" case_insensitive;\n (* Special patterns *)\n test \"pattern: digit class\" digit_class;\n test \"pattern: word boundary\" word_boundary;\n test \"pattern: any character\" any_character;\n test \"pattern: alternation\" alternation;\n test \"pattern: optional\" optional_character;\n (* Multiple matches *)\n test \"multiple: finds first\" multiple_matches;\n test \"multiple: global flag ignored\" global_flag_ignored;\n (* Unicode *)\n test \"unicode: characters\" unicode_characters;\n test \"unicode: emoji\" emoji;\n (* Edge cases *)\n test \"edge: special regex chars\" special_regex_chars;\n test \"edge: newline\" newline;\n ]\n"
},
{
"path": "packages/Js/test/test.ml",
"content": "let assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\nlet assert_option x left right = Alcotest.check (Alcotest.option x) \"should be equal\" right left\nlet assert_array ty left right = Alcotest.check (Alcotest.array ty) \"should be equal\" right left\nlet assert_string_array = assert_array Alcotest.string\nlet assert_string_option_array = assert_array (Alcotest.option Alcotest.string)\nlet assert_array_int = assert_array Alcotest.int\n\nlet assert_dict_entries type_ left right =\n Alcotest.check (Alcotest.array (Alcotest.pair Alcotest.string type_)) \"should be equal\" right left\n\nlet assert_int_dict_entries = assert_dict_entries Alcotest.int\nlet assert_string_dict_entries = assert_dict_entries Alcotest.string\nlet assert_option_int = assert_option Alcotest.int\n(* let assert_option_string = assert_option Alcotest.string *)\n\nlet assert_int left right = Alcotest.check Alcotest.int \"should be equal\" right left\nlet assert_float left right = Alcotest.check (Alcotest.float 2.) \"should be equal\" right left\nlet assert_bool left right = Alcotest.check Alcotest.bool \"should be equal\" right left\n\nlet assert_raises fn exn =\n match fn () with\n | exception exn -> assert_string (Printexc.to_string exn) (Printexc.to_string exn)\n | _ -> Alcotest.failf \"Expected exception %s\" (Printexc.to_string exn)\n\nlet test title fn = Alcotest_lwt.test_case_sync title `Quick fn\nlet test_async title fn = Alcotest_lwt.test_case title `Quick fn\n\nlet re_tests =\n [\n test \"captures\" (fun () ->\n let abc_regex = Js.Re.fromString \"abc\" in\n let result = Js.Re.exec ~str:\"abcdefabcdef\" abc_regex |> Option.get in\n let matches = Js.Re.captures result |> Array.map Option.get in\n assert_string_array matches [| \"abc\" |]);\n test \"exec\" (fun () ->\n let regex = Js.Re.fromString \".ats\" in\n let input = \"cats and bats\" in\n let regex_and_capture = Js.Re.exec ~str:input regex |> Option.get |> Js.Re.captures |> Array.map Option.get in\n assert_string_array regex_and_capture [| \"cats\" |];\n assert_string_array regex_and_capture [| \"cats\" |];\n assert_string_array regex_and_capture [| \"cats\" |]);\n test \"exec with global\" (fun () ->\n let regex = Js.Re.fromStringWithFlags ~flags:\"g\" \".ats\" in\n let input = \"cats and bats and mats\" in\n assert_bool (Js.Re.global regex) true;\n assert_string_array\n (Js.Re.exec ~str:input regex |> Option.get |> Js.Re.captures |> Array.map Option.get)\n [| \"cats\" |];\n assert_string_array\n (Js.Re.exec ~str:input regex |> Option.get |> Js.Re.captures |> Array.map Option.get)\n [| \"bats\" |];\n assert_string_array\n (Js.Re.exec ~str:input regex |> Option.get |> Js.Re.captures |> Array.map Option.get)\n [| \"mats\" |]);\n test \"modifier: end ($)\" (fun () ->\n let regex = Js.Re.fromString \"cat$\" in\n assert_bool (Js.Re.test ~str:\"The cat and mouse\" regex) false;\n assert_bool (Js.Re.test ~str:\"The mouse and cat\" regex) true);\n test \"modifier: more than one (+)\" (fun () ->\n let regex = Js.Re.fromStringWithFlags ~flags:\"i\" \"boo+(hoo+)+\" in\n assert_bool (Js.Re.test ~str:\"Boohoooohoohooo\" regex) true);\n test \"global (g) and caseless (i)\" (fun () ->\n let regex = Js.Re.fromStringWithFlags ~flags:\"gi\" \"Hello\" in\n let result = Js.Re.exec ~str:\"Hello gello! hello\" regex |> Option.get in\n let matches = Js.Re.captures result |> Array.map Option.get in\n assert_string_array matches [| \"Hello\" |];\n let result = Js.Re.exec ~str:\"Hello gello! hello\" regex |> Option.get in\n let matches = Js.Re.captures result |> Array.map Option.get in\n assert_string_array matches [| \"hello\" |]);\n test \"modifier: or ([])\" (fun () ->\n let regex = Js.Re.fromString \"(\\\\w+)\\\\s(\\\\w+)\" in\n assert_bool (Js.Re.test ~str:\"Jane Smith\" regex) true;\n assert_bool (Js.Re.test ~str:\"Wololo\" regex) false);\n test \"backreferencing\" (fun () ->\n let regex = Js.Re.fromString \"[bt]ear\" in\n assert_bool (Js.Re.test ~str:\"bear\" regex) true;\n assert_bool (Js.Re.test ~str:\"tear\" regex) true;\n assert_bool (Js.Re.test ~str:\"fear\" regex) false);\n test \"http|s example\" (fun () ->\n let regex = Js.Re.fromString \"^[https?]+:\\\\/\\\\/((w{3}\\\\.)?[\\\\w+]+)\\\\.[\\\\w+]+$\" in\n assert_bool (Js.Re.test ~str:\"https://www.example.com\" regex) true;\n assert_bool (Js.Re.test ~str:\"http://example.com\" regex) true;\n assert_bool (Js.Re.test ~str:\"https://example\" regex) false);\n test \"index\" (fun () ->\n let regex = Js.Re.fromString \"zbar\" in\n match Js.Re.exec ~str:\"foobarbazbar\" regex with\n | Some res -> assert_int (Js.Re.index res) 8\n | None -> Alcotest.fail \"should have matched\");\n test \"lastIndex\" (fun () ->\n let regex = Js.Re.fromStringWithFlags ~flags:\"g\" \"y\" in\n Js.Re.setLastIndex regex 3;\n match Js.Re.exec ~str:\"xyzzy\" regex with\n | Some res ->\n assert_int (Js.Re.index res) 4;\n assert_int (Js.Re.lastIndex regex) 5\n | None -> Alcotest.fail \"should have matched\");\n test \"input\" (fun () ->\n let regex = Js.Re.fromString \"zbar\" in\n match Js.Re.exec ~str:\"foobarbazbar\" regex with\n | Some res -> assert_string (Js.Re.input res) \"foobarbazbar\"\n | None -> Alcotest.fail \"should have matched\");\n ]\n\nlet string_tests =\n [\n test \"make\" (fun () ->\n (* assert_string (make 3.5) \"3.5\"; *)\n (* assert_string (make [| 1; 2; 3 |]) \"1,2,3\"); *)\n ());\n test \"length\" (fun () -> assert_int (Js.String.length \"abcd\") 4);\n test \"get\" (fun () ->\n assert_string (Js.String.get \"Reason\" 0) \"R\";\n assert_string (Js.String.get \"Reason\" 4) \"o\" (* assert_string (Js.String.get {js|Rẽasöń|js} 5) {js|ń|js}; *));\n test \"fromCharCode\" (fun () ->\n assert_string (Js.String.fromCharCode 65) \"A\";\n (* assert_string (Js.String.fromCharCode 0x3c8) {js|ψ|js}; *)\n (* assert_string (Js.String.fromCharCode 0xd55c) {js|한|js} *)\n (* assert_string (Js.String.fromCharCode -64568) {js|ψ|js}; *)\n ());\n test \"fromCharCodeMany\" (fun () ->\n (* fromCharCodeMany([|0xd55c, 0xae00, 33|]) = {js|한글!|js} *)\n ());\n test \"fromCodePoint\" (fun () ->\n assert_string (Js.String.fromCodePoint 65) \"A\"\n (* assert_string (Js.String.fromCodePoint 0x3c8) {js|ψ|js}; *)\n (* assert_string (Js.String.fromCodePoint 0xd55c) {js|한|js} *)\n (* assert_string (Js.String.fromCodePoint 0x1f63a) {js|😺|js} *));\n test \"fromCodePointMany\" (fun () ->\n (* assert_string\n (Js.String.fromCodePointMany [| 0xd55c; 0xae00; 0x1f63a |])\n {js|한글😺|js} *)\n ());\n test \"charAt\" (fun () ->\n assert_string (Js.String.charAt \"Reason\" ~index:0) \"R\";\n assert_string (Js.String.charAt \"Reason\" ~index:12) \"\"\n (* assert_string (Js.String.charAt {js|Rẽasöń|js} 5) {js|ń|js} *));\n test \"charCodeAt\" (fun () ->\n (* charCodeAt {js|😺|js} 0) 0xd83d *)\n assert_float (Js.String.charCodeAt \"lola\" ~index:1) 111.;\n assert_float (Js.String.charCodeAt \"lola\" ~index:0) 108.);\n test \"codePointAt\" (fun () ->\n assert_option_int (Js.String.codePointAt \"lola\" ~index:1) (Some 111);\n (* assert_option_int (Js.String.codePointAt {js|¿😺?|js} 1) (Some 0x1f63a); *)\n assert_option_int (Js.String.codePointAt \"abc\" ~index:5) None);\n test \"concat\" (fun () -> assert_string (Js.String.concat \"cow\" ~other:\"bell\") \"cowbell\");\n test \"concatMany\" (fun () ->\n assert_string (Js.String.concatMany \"1st\" ~strings:[| \"2nd\"; \"3rd\"; \"4th\" |]) \"1st2nd3rd4th\");\n test \"endsWith\" (fun () ->\n assert_bool (Js.String.endsWith \"ReScript\" ~suffix:\"Script\") true;\n assert_bool (Js.String.endsWith \"ReShoes\" ~suffix:\"Script\") false;\n assert_bool (Js.String.endsWith \"abcd\" ~suffix:\"cd\" ~len:4) true;\n assert_bool (Js.String.endsWith \"abcde\" ~suffix:\"cd\" ~len:3) false;\n (* assert_bool (Js.String.endsWith \"abcde\" ~suffix:\"cde\" ~len:99) true; *)\n assert_bool (Js.String.endsWith \"example.dat\" ~suffix:\"ple\" ~len:7) true);\n test \"includes\" (fun () ->\n assert_bool (Js.String.includes \"programmer\" ~search:\"gram\") true;\n assert_bool (Js.String.includes \"programmer\" ~search:\"er\") true;\n assert_bool (Js.String.includes \"programmer\" ~search:\"pro\") true;\n assert_bool (Js.String.includes \"programmer\" ~search:\"xyz\") false;\n assert_bool (Js.String.includes \"programmer\" ~search:\"gram\" ~start:1) true;\n assert_bool (Js.String.includes \"programmer\" ~search:\"gram\" ~start:4) false\n (* assert_bool (Js.String.includesFrom {js|한|js} {js|대한민국|js} 1) true *));\n test \"indexOf\" (fun () ->\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"ok\") 2;\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"sell\") 4;\n assert_int (Js.String.indexOf \"beekeeper\" ~search:\"ee\") 1;\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"xyz\") (-1);\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"ok\" ~start:1) 2;\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"sell\" ~start:2) 4;\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"sell\" ~start:5) (-1);\n assert_int (Js.String.indexOf \"bookseller\" ~search:\"xyz\") (-1));\n test \"lastIndexOf\" (fun () ->\n assert_int (Js.String.lastIndexOf \"bookseller\" ~search:\"ok\") 2;\n assert_int (Js.String.lastIndexOf \"beekeeper\" ~search:\"ee\") 4;\n assert_int (Js.String.lastIndexOf \"abcdefg\" ~search:\"xyz\") (-1);\n assert_int (Js.String.lastIndexOf \"bookseller\" ~search:\"ok\" ~start:6) 2;\n assert_int (Js.String.lastIndexOf \"beekeeper\" ~search:\"ee\" ~start:8) 4;\n assert_int (Js.String.lastIndexOf \"beekeeper\" ~search:\"ee\" ~start:3) 1;\n assert_int (Js.String.lastIndexOf \"abcdefg\" ~search:\"xyz\" ~start:4) (-1));\n (* test \"localeCompare\" (fun () ->\n localeCompare \"ant\" \"zebra\" > 0.0\n localeCompare \"zebra\" \"ant\" < 0.0\n localeCompare \"cat\" \"cat\" = 0.0\n localeCompare \"cat\" \"CAT\" > 0.0\n ());\n *)\n test \"match\" (fun () ->\n let unsafe_match s r = Js.String.match_ ~regexp:r s |> Stdlib.Option.get in\n assert_string_option_array (unsafe_match \"The better bats\" (Js.Re.fromString \"b[aeiou]t\")) [| Some \"bet\" |]);\n test \"match 0\" (fun () ->\n let unsafe_match r s = Js.String.match_ ~regexp:r s |> Stdlib.Option.value ~default:[||] in\n assert_string_option_array (unsafe_match (Js.Re.fromString \"b[aeiou]t\") \"The better bats\") [| Some \"bet\" |];\n assert_string_option_array\n (unsafe_match (Js.Re.fromStringWithFlags \"b[aeiou]t\" ~flags:\"g\") \"The better bats\")\n [| Some \"bet\"; Some \"bat\" |];\n assert_string_option_array\n (unsafe_match [%re \"/(\\\\d+)-(\\\\d+)-(\\\\d+)/\"] \"Today is 2018-04-05.\")\n [| Some \"2018-04-05\"; Some \"2018\"; Some \"04\"; Some \"05\" |];\n assert_string_option_array (unsafe_match [%re \"/b[aeiou]g/\"] \"The large container.\") [||]);\n test \"repeat\" (fun () ->\n assert_string (Js.String.repeat \"ha\" ~count:3) \"hahaha\";\n assert_string (Js.String.repeat \"empty\" ~count:0) \"\");\n test \"replace\" (fun () ->\n assert_string (Js.String.replace ~search:\"old\" ~replacement:\"new\" \"old string\") \"new string\";\n assert_string (Js.String.replace ~search:\"the\" ~replacement:\"this\" \"the cat and the dog\") \"this cat and the dog\");\n test \"replaceByRe\" (fun () ->\n assert_string (Js.String.replaceByRe \"david\" ~regexp:[%re \"/d/\"] ~replacement:\"x\") \"xavid\");\n test \"replaceByRe with references ($n)\" (fun () ->\n assert_string (Js.String.replaceByRe \"david\" ~regexp:[%re \"/d(.*?)d/g\"] ~replacement:\"$1\") \"avi\");\n test \"replaceByRe with $1 capturing group\" (fun () ->\n assert_string\n (Js.String.replaceByRe \"hello world\" ~regexp:[%re \"/(.*?)<\\\\/em>/gi\"] ~replacement:\"$1\")\n \"hello world\");\n test \"replaceByRe with multiple capturing groups\" (fun () ->\n assert_string\n (Js.String.replaceByRe \"John Smith\" ~regexp:[%re \"/(\\\\w+)\\\\s(\\\\w+)/\"] ~replacement:\"$2, $1\")\n \"Smith, John\");\n test \"replaceByRe with $&\" (fun () ->\n assert_string (Js.String.replaceByRe \"hello\" ~regexp:[%re \"/l/g\"] ~replacement:\"[$&]\") \"he[l][l]o\");\n test \"replaceByRe with $$\" (fun () ->\n assert_string (Js.String.replaceByRe \"price\" ~regexp:[%re \"/price/\"] ~replacement:\"$$100\") \"$100\");\n test \"replaceByRe with global\" (fun () ->\n assert_string\n (Js.String.replaceByRe \"vowels be gone\" ~regexp:[%re \"/[aeiou]/g\"] ~replacement:\"x\")\n \"vxwxls bx gxnx\");\n test \"unsafeReplaceBy0\" (fun () ->\n (* let str = \"beautiful vowels\" in\n let re = [%re \"/[aeiou]/g\"] in\n let matchFn matchPart offset wholeString =\n Js.String.toUpperCase matchPart\n in\n\n let replaced = Js.String.unsafeReplaceBy0 re matchFn str in\n\n assert_string replaced \"bEAUtifUl vOwEls\" *)\n ());\n test \"unsafeReplaceBy1\" (fun () ->\n (* let str = \"increment 23\" in\n let re = [%re \"/increment (\\\\d+)/g\"] in\n let matchFn matchPart p1 offset wholeString =\n wholeString ^ \" is \" ^ string_of_int (int_of_string p1 + 1)\n in\n\n let replaced = Js.String.unsafeReplaceBy1 re matchFn str in\n assert_string replaced \"increment 23 is 24\" *)\n ());\n test \"unsafeReplaceBy2\" (fun () ->\n (* let str = \"7 times 6\" in\n let re = [%re \"/(\\\\d+) times (\\\\d+)/\"] in\n let matchFn matchPart p1 p2 offset wholeString =\n string_of_int (int_of_string p1 * int_of_string p2)\n in\n\n let replaced = Js.String.unsafeReplaceBy2 re matchFn str in\n assert_string replaced \"42\" *)\n ());\n test \"search\" (fun () ->\n (* assert_int (Js.String.search [%re \"/\\\\d+/\"] \"testing 1 2 3\") 8;\n assert_int (Js.String.search [%re \"/\\\\d+/\"] \"no numbers\") (-1) *)\n ());\n test \"slice\" (fun () ->\n assert_string (Js.String.slice ~start:2 ~end_:5 \"abcdefg\") \"cde\";\n assert_string (Js.String.slice ~start:2 ~end_:9 \"abcdefg\") \"cdefg\";\n (* assert_string (Js.String.slice ~from:(-4) ~to_:(-2) \"abcdefg\") \"de\"; *)\n assert_string (Js.String.slice ~start:5 ~end_:1 \"abcdefg\") \"\";\n assert_string (Js.String.slice ~start:4 \"abcdefg\") \"efg\";\n (* assert_string (Js.String.sliceToEnd ~from:(-2) \"abcdefg\") \"fg\"; *)\n assert_string (Js.String.slice ~start:7 \"abcdefg\") \"\");\n test \"split\" (fun () ->\n assert_string_array (Js.String.split ~sep:\"\" \"\") [||];\n assert_string_array (Js.String.split ~sep:\"-\" \"2018-01-02\") [| \"2018\"; \"01\"; \"02\" |];\n assert_string_array (Js.String.split ~sep:\",\" \"a,b,,c\") [| \"a\"; \"b\"; \"\"; \"c\" |];\n assert_string_array\n (Js.String.split ~sep:\"::\" \"good::bad as great::awful\")\n [| \"good\"; \"bad as great\"; \"awful\" |];\n assert_string_array (Js.String.split ~sep:\";\" \"has-no-delimiter\") [| \"has-no-delimiter\" |];\n assert_string_array\n (Js.String.split ~sep:\"with\" \"with-sep-equals-to-beginning\")\n [| \"\"; \"-sep-equals-to-beginning\" |];\n assert_string_array (Js.String.split ~sep:\"end\" \"with-sep-equals-to-end\") [| \"with-sep-equals-to-\"; \"\" |];\n assert_string_array\n (Js.String.split ~sep:\"/\" \"/with-sep-on-beginning-and-end/\")\n [| \"\"; \"with-sep-on-beginning-and-end\"; \"\" |];\n assert_string_array\n (Js.String.split ~sep:\"\" \"with-empty-sep\")\n [| \"w\"; \"i\"; \"t\"; \"h\"; \"-\"; \"e\"; \"m\"; \"p\"; \"t\"; \"y\"; \"-\"; \"s\"; \"e\"; \"p\" |];\n assert_string_array (Js.String.split ~sep:\"-\" \"with-limit-equals-to-zero\" ~limit:0) [||];\n assert_string_array\n (Js.String.split ~sep:\"-\" \"with-limit-equals-to-length\" ~limit:5)\n [| \"with\"; \"limit\"; \"equals\"; \"to\"; \"length\" |];\n assert_string_array\n (Js.String.split ~sep:\"-\" \"with-limit-greater-than-length\" ~limit:100)\n [| \"with\"; \"limit\"; \"greater\"; \"than\"; \"length\" |];\n assert_string_array\n (Js.String.split ~sep:\"-\" \"with-limit-less-than-zero\" ~limit:(-2))\n [| \"with\"; \"limit\"; \"less\"; \"than\"; \"zero\" |]);\n test \"splitAtMost\" (fun () ->\n (* assert_string_array\n (splitAtMost \"/\" ~limit:3 \"ant/bee/cat/dog/elk\")\n [| \"ant\"; \"bee\"; \"cat\" |];\n assert_string_array\n (splitAtMost \"/\" ~limit:0 \"ant/bee/cat/dog/elk\")\n [||];\n assert_string_array\n (splitAtMost \"/\" ~limit:9 \"ant/bee/cat/dog/elk\")\n [| \"ant\"; \"bee\"; \"cat\"; \"dog\"; \"elk\" |] *)\n ());\n test \"splitByRe\" (fun () ->\n let unsafe_splitByRe s r = Js.String.splitByRe ~regexp:r s |> Stdlib.Array.map Stdlib.Option.get in\n assert_string_array\n (unsafe_splitByRe \"art; bed , cog ;dad\" [%re \"/\\\\s*[,;]\\\\s*/\"])\n [| \"art\"; \"bed\"; \"cog\"; \"dad\" |]\n (* assert_string_array\n (unsafe_splitByRe \"has:no:match\" [%re \"/[,;]/\"])\n [| \"has:no:match\" |] *));\n (* test \"splitByReAtMost\" (fun () ->\n assert_string_array\n (splitByReAtMost [%re \"/\\\\s*:\\\\s*/\"] ~limit:3\n \"one: two: three: four\")\n [| Some \"one\"; Some \"two\"; Some \"three\" |];\n assert_string_array\n (splitByReAtMost [%re \"/\\\\s*:\\\\s*/\"] ~limit:0\n \"one: two: three: four\")\n [||];\n assert_string_array\n (splitByReAtMost [%re \"/\\\\s*:\\\\s*/\"] ~limit:8\n \"one: two: three: four\")\n [| Some \"one\"; Some \"two\"; Some \"three\"; Some \"four\" |];\n assert_string_array\n (splitByReAtMost [%re \"/(#)(:)?/\"] ~limit:3 \"a#b#:c\")\n [| Some \"a\"; Some \"#\"; None |]\n ());*)\n test \"startsWith\" (fun () ->\n assert_bool (Js.String.startsWith \"ReScript\" ~prefix:\"Re\") true;\n assert_bool (Js.String.startsWith \"ReScript\" ~prefix:\"\") true;\n assert_bool (Js.String.startsWith \"JavaScript\" ~prefix:\"Re\") false;\n assert_bool (Js.String.startsWith ~prefix:\"cri\" ~start:3 \"ReScript\") true;\n assert_bool (Js.String.startsWith ~prefix:\"\" ~start:3 \"ReScript\") true;\n assert_bool (Js.String.startsWith ~prefix:\"Re\" ~start:2 \"JavaScript\") false);\n test \"substr\" (fun () ->\n assert_string (Js.String.substr ~start:3 \"abcdefghij\") \"defghij\";\n (* assert_string (Js.String.substr ~from:(-3) \"abcdefghij\") \"hij\"; *)\n assert_string (Js.String.substr ~start:12 \"abcdefghij\") \"\");\n test \"substrAtMost\" (fun () ->\n (* assert_string (Js.String.substrAtMost ~from:3 ~length:4 \"abcdefghij\") \"defghij\"; *)\n (* assert_string (Js.String.substrAtMost ~from:(-3) ~length:4 \"abcdefghij\") \"hij\"; *)\n (* assert_string (Js.String.substrAtMost ~from:12 ~length:2 \"abcdefghij\") \"\" *)\n ());\n test \"substring\" (fun () ->\n assert_string (Js.String.substring ~start:3 ~end_:6 \"playground\") \"ygr\";\n assert_string (Js.String.substring ~start:6 ~end_:3 \"playground\") \"ygr\";\n assert_string (Js.String.substring ~start:4 ~end_:12 \"playground\") \"ground\";\n assert_string (Js.String.substring ~start:4 \"playground\") \"ground\";\n assert_string (Js.String.substring ~start:(-3) \"playground\") \"playground\";\n assert_string (Js.String.substring ~start:12 \"playground\") \"\");\n test \"toLowerCase\" (fun () ->\n assert_string (Js.String.toLowerCase \"\") \"\";\n assert_string (Js.String.toLowerCase \"ASCII: ABC\") \"ascii: abc\";\n assert_string (Js.String.toLowerCase \"Non ASCII: ΣΠ\") \"non ascii: σπ\";\n assert_string (Js.String.toLowerCase \"Unicode Σ: \\u{03a3}\") \"unicode σ: \\u{03c3}\";\n assert_string\n (Js.String.toLowerCase \"Unicode Mongolian separator + Σ + Mongolian separator: \\u{180E} + \\u{03a3} + \\u{180E}\")\n \"unicode mongolian separator + σ + mongolian separator: \\u{180E} + \\u{03c3} + \\u{180E}\");\n test \"toUpperCase\" (fun () ->\n assert_string (Js.String.toUpperCase \"\") \"\";\n assert_string (Js.String.toUpperCase \"abc\") \"ABC\";\n assert_string (Js.String.toUpperCase \"Non ASCII: σπ\") \"NON ASCII: ΣΠ\";\n assert_string (Js.String.toUpperCase \"Unicode: \\u{03c3}\") \"UNICODE: \\u{03a3}\";\n assert_string\n (Js.String.toUpperCase \"Unicode Mongolian separator + σ + Mongolian separator: \\u{180E} + \\u{03c3} + \\u{180E}\")\n \"UNICODE MONGOLIAN SEPARATOR + Σ + MONGOLIAN SEPARATOR: \\u{180E} + \\u{03a3} + \\u{180E}\");\n test \"trim\" (fun () ->\n assert_string (Js.String.trim \" abc def \") \"abc def\";\n assert_string (Js.String.trim \"\\n\\r\\t abc def \\n\\n\\t\\r \") \"abc def\");\n test \"anchor\" (fun () ->\n (* assert_string\n (anchor \"page1\" \"Page One\")\n \"Page One\" *)\n ());\n test \"link\" (fun () ->\n (* assert_string\n (link \"page2.html\" \"Go to page two\")\n \"Go to page two\" *)\n ());\n ]\n\nlet global_tests =\n [\n test \"decodeURI - ascii and spaces\" (fun () ->\n assert_string (Js.Global.decodeURI \"Hello%20World\") \"Hello World\";\n assert_string (Js.Global.decodeURI \"Hello%20%20%20World\") \"Hello World\";\n assert_string (Js.Global.decodeURI \"Hello%2DWorld\") \"Hello-World\");\n test \"decodeURI - reserved characters\" (fun () ->\n assert_string (Js.Global.decodeURI \";,/?:@&=+$#\") \";,/?:@&=+$#\";\n assert_string (Js.Global.decodeURI \"-_.!~*'()\") \"-_.!~*'()\";\n assert_string (Js.Global.decodeURI \"%5B%5D\") \"[]\";\n assert_string (Js.Global.decodeURI \"%7B%7D\") \"{}\";\n assert_string (Js.Global.decodeURI \"%7C\") \"|\");\n test \"decodeURI - alphabets\" (fun () ->\n assert_string (Js.Global.decodeURI \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\") \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\";\n assert_string (Js.Global.decodeURI \"abcdefghijklmnopqrstuvwxyz\") \"abcdefghijklmnopqrstuvwxyz\";\n assert_string (Js.Global.decodeURI \"0123456789\") \"0123456789\");\n test \"decodeURI - unicode characters\" (fun () ->\n assert_string (Js.Global.decodeURI \"%D0%AE%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4\") \"Юникод\";\n assert_string (Js.Global.decodeURI \"%E2%82%AC%E2%98%85%E2%99%A0\") \"€★♠\";\n assert_string (Js.Global.decodeURI \"%E4%BD%A0%E5%A5%BD\") \"你好\");\n test \"decodeURI - mixed percent encodings and Unicode\" (fun () ->\n assert_string (Js.Global.decodeURI \"Hello%20%E4%BD%A0%E5%A5%BD%20World\") \"Hello 你好 World\";\n assert_string (Js.Global.decodeURI \"%E2%82%AC%20%24%20%C2%A3%20%C2%A5\") \"€ %24 £ ¥\");\n test \"decodeURI - complete URLs\" (fun () ->\n assert_string\n (Js.Global.decodeURI \"http://ru.wikipedia.org/wiki/%D0%AE%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4\")\n \"http://ru.wikipedia.org/wiki/Юникод\";\n assert_string\n (Js.Global.decodeURI \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\")\n \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\";\n assert_string\n (Js.Global.decodeURI \"https://example.com/path%20name/file.txt\")\n \"https://example.com/path name/file.txt\");\n test \"decodeURI - overencoded sequences\" (fun () ->\n assert_string (Js.Global.decodeURI \"Hello%2520World\") \"Hello%20World\";\n assert_string (Js.Global.decodeURI \"%25252525\") \"%252525\");\n test \"decodeURI - special characters\" (fun () ->\n assert_string (Js.Global.decodeURI \"%0A\") \"\\n\";\n assert_string (Js.Global.decodeURI \"%0D\") \"\\r\";\n assert_string (Js.Global.decodeURI \"%3C%3E%22%5C\") \"<>\\\"\\\\\");\n test \"decodeURI - beyond U+10FFFF\" (fun () ->\n assert_raises (fun () -> Js.Global.decodeURI \"%F4%90%80%80\") (Failure \"decodeURI: malformed URI sequence\"));\n test \"decodeURI - partial sequences\" (fun () ->\n (* Incomplete or malformed sequences *)\n assert_raises (fun () -> Js.Global.decodeURI \"%E4\") (Failure \"decodeURI: malformed URI sequence\");\n assert_raises (fun () -> Js.Global.decodeURI \"%E4%A\") (Failure \"decodeURI: malformed URI sequence\"));\n test \"encodeURI - ascii and spaces\" (fun () ->\n assert_string (Js.Global.encodeURI \"Hello World\") \"Hello%20World\";\n assert_string (Js.Global.encodeURI \"Hello World\") \"Hello%20%20%20World\";\n assert_string (Js.Global.encodeURI \"Hello-World\") \"Hello-World\");\n test \"encodeURI - reserved characters\" (fun () ->\n assert_string (Js.Global.encodeURI \";,/?:@&=+$#\") \";,/?:@&=+$#\";\n assert_string (Js.Global.encodeURI \"-_.!~*'()\") \"-_.!~*'()\");\n test \"encodeURI - alphabets\" (fun () ->\n assert_string (Js.Global.encodeURI \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\") \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\";\n assert_string (Js.Global.encodeURI \"abcdefghijklmnopqrstuvwxyz\") \"abcdefghijklmnopqrstuvwxyz\";\n assert_string (Js.Global.encodeURI \"0123456789\") \"0123456789\");\n test \"encodeURI - unicode characters\" (fun () ->\n assert_string (Js.Global.encodeURI \"Юникод\") \"%D0%AE%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4\";\n assert_string (Js.Global.encodeURI \"€★♠\") \"%E2%82%AC%E2%98%85%E2%99%A0\";\n assert_string (Js.Global.encodeURI \"你好\") \"%E4%BD%A0%E5%A5%BD\");\n test \"encodeURI - complete URLs\" (fun () ->\n assert_string (Js.Global.encodeURI \"http://unipro.ru/0123456789\") \"http://unipro.ru/0123456789\";\n assert_string\n (Js.Global.encodeURI \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\")\n \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\";\n assert_string (Js.Global.encodeURI \"http://unipro.ru/\\nabout\") \"http://unipro.ru/%0Aabout\";\n assert_string (Js.Global.encodeURI \"http://unipro.ru/\\rabout\") \"http://unipro.ru/%0Dabout\";\n assert_string\n (Js.Global.encodeURI \"http://ru.wikipedia.org/wiki/Юникод\")\n \"http://ru.wikipedia.org/wiki/%D0%AE%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4\";\n assert_string\n (Js.Global.encodeURI \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\")\n \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\";\n assert_string\n (Js.Global.encodeURI \"https://example.com/path name/file.txt\")\n \"https://example.com/path%20name/file.txt\");\n test \"encodeURI - special characters\" (fun () ->\n assert_string (Js.Global.encodeURI \"\\n\") \"%0A\";\n assert_string (Js.Global.encodeURI \"\\r\") \"%0D\";\n assert_string (Js.Global.encodeURI \"<>\\\"\\\\\") \"%3C%3E%22%5C\";\n assert_string (Js.Global.encodeURI \"http://unipro.ru/\\nabout\") \"http://unipro.ru/%0Aabout\";\n assert_string (Js.Global.encodeURI \"http://unipro.ru/\\rabout\") \"http://unipro.ru/%0Dabout\");\n test \"encodeURI - combining characters\" (fun () ->\n (* Characters with combining diacritical marks *)\n assert_string (Js.Global.encodeURI \"é\") (* e + acute accent as single char *) \"%C3%A9\";\n assert_string (Js.Global.encodeURI \"e\\u{0301}\") (* e + combining acute accent *) \"e%CC%81\";\n assert_string (Js.Global.encodeURI \"ế\") (* e + circumflex + acute *) \"%E1%BA%BF\");\n test \"encodeURI - Surrogate pairs\" (fun () ->\n (* Surrogate pairs for emoji and complex Unicode *)\n assert_string (Js.Global.encodeURI \"𝌆\") (* Musical symbol *) \"%F0%9D%8C%86\";\n assert_string (Js.Global.encodeURI \"🌍\") (* Earth globe *) \"%F0%9F%8C%8D\";\n assert_string\n (Js.Global.encodeURI \"👨👩👧👦\") (* Family emoji with ZWJ sequences *)\n \"%F0%9F%91%A8%E2%80%8D%F0%9F%91%A9%E2%80%8D%F0%9F%91%A7%E2%80%8D%F0%9F%91%A6\");\n (* \\v and \\f are not supported in ocaml *)\n (*\n assert_string\n (Js.Global.decodeURIComponent \"http://unipro.ru/%0Babout\")\n \"http://unipro.ru/\\vabout\";\n assert_string\n (Js.Global.decodeURIComponent \"http://unipro.ru/%0Cabout\")\n \"http://unipro.ru/\\fabout\"; *)\n test \"encodeURIComponent\" (fun () ->\n assert_string (Js.Global.encodeURIComponent \"http://unipro.ru\") \"http%3A%2F%2Funipro.ru\";\n assert_string\n (Js.Global.encodeURIComponent\n \"http://www.google.ru/support/jobs/bin/static.py?page=why-ru.html&sid=liveandwork\")\n \"http%3A%2F%2Fwww.google.ru%2Fsupport%2Fjobs%2Fbin%2Fstatic.py%3Fpage%3Dwhy-ru.html%26sid%3Dliveandwork\";\n assert_string (Js.Global.encodeURIComponent \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\") \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\";\n assert_string (Js.Global.encodeURIComponent \"abcdefghijklmnopqrstuvwxyz\") \"abcdefghijklmnopqrstuvwxyz\";\n assert_string (Js.Global.encodeURIComponent \"http://unipro.ru/\\nabout\") \"http%3A%2F%2Funipro.ru%2F%0Aabout\";\n assert_string (Js.Global.encodeURIComponent \"http://unipro.ru/\\rabout\") \"http%3A%2F%2Funipro.ru%2F%0Dabout\");\n (* \\v and \\f are not supported in ocaml\n assert_string\n (Js.Global.encodeURIComponent \"http://unipro.ru/\\vabout\")\n \"http%3A%2F%2Funipro.ru%2F%0Babout\";\n assert_string\n (Js.Global.encodeURIComponent \"http://unipro.ru/\\fabout\")\n \"http%3A%2F%2Funipro.ru%2F%0Cabout\"; *)\n ]\n\nlet obj () = Js.Dict.fromList [ (\"foo\", 43); (\"bar\", 86) ]\nlet long_obj () = Js.Dict.fromList [ (\"david\", 99); (\"foo\", 43); (\"bar\", 86) ]\nlet obj_duplicated () = Js.Dict.fromList [ (\"foo\", 43); (\"bar\", 86); (\"bar\", 1) ]\n\nmodule Obj_test = struct\n external make : onLoad:string -> ?retries:int -> unit -> < onLoad : string ; retries : int option > Js.t = \"\"\n [@@mel.obj]\n\n external makeKeyword : _type:string -> unit -> < _type : string > Js.t = \"\" [@@mel.obj]\nend\n\nlet obj_tests =\n [\n test \"empty\" (fun () -> assert_string_array (Js.Obj.keys (Js.Obj.empty ())) [||]);\n test \"@@mel.obj\" (fun () ->\n let props = Obj_test.make ~onLoad:\"ready\" () in\n assert_string props##onLoad \"ready\";\n assert_option_int props##retries None;\n assert_string_array (Js.Obj.keys props) [| \"onLoad\" |];\n let props = Obj_test.make ~onLoad:\"ready\" ~retries:2 () in\n assert_option_int props##retries (Some 2);\n assert_string_array (Js.Obj.keys props) [| \"onLoad\"; \"retries\" |]);\n test \"@@mel.obj with keyword label\" (fun () ->\n let props = Obj_test.makeKeyword ~_type:\"button\" () in\n assert_string props##_type \"button\";\n assert_string_array (Js.Obj.keys props) [| \"type\" |]);\n test \"assign mutates target\" (fun () ->\n let target = Obj_test.make ~onLoad:\"ready\" () in\n let source = Obj_test.make ~onLoad:\"updated\" ~retries:2 () in\n let returned = Js.Obj.assign target source in\n assert_int (Oo.id returned) (Oo.id target);\n assert_string target##onLoad \"updated\";\n assert_option_int target##retries (Some 2);\n assert_string_array (Js.Obj.keys target) [| \"onLoad\"; \"retries\" |];\n assert_string source##onLoad \"updated\";\n assert_option_int source##retries (Some 2));\n test \"merge creates fresh object\" (fun () ->\n let left = Obj_test.make ~onLoad:\"left\" () in\n let right = Obj_test.make ~onLoad:\"right\" ~retries:3 () in\n let merged : < onLoad : string ; retries : int option > Js.t = Obj.magic (Js.Obj.merge () left right) in\n assert_bool (Oo.id merged = Oo.id left) false;\n assert_bool (Oo.id merged = Oo.id right) false;\n assert_string merged##onLoad \"right\";\n assert_option_int merged##retries (Some 3);\n assert_string_array (Js.Obj.keys merged) [| \"onLoad\"; \"retries\" |];\n assert_string left##onLoad \"left\";\n assert_option_int left##retries None);\n test \"[%mel.obj] evaluates fields once\" (fun () ->\n let counter = ref 0 in\n let props =\n [%mel.obj\n {\n count =\n (incr counter;\n !counter);\n }]\n in\n assert_int props##count 1;\n assert_int props##count 1;\n assert_int !counter 1;\n assert_string_array (Js.Obj.keys props) [| \"count\" |]);\n ]\n\nlet dict_tests =\n [\n test \"empty\" (fun _ -> assert_string_dict_entries (Js.Dict.entries (Js.Dict.empty ())) [||]);\n test \"get\" (fun _ -> assert_option_int (Js.Dict.get (obj ()) \"foo\") (Some 43));\n test \"get from missing property\" (fun _ -> assert_option_int (Js.Dict.get (obj ()) \"baz\") None);\n test \"unsafe_get\" (fun _ -> assert_int (Js.Dict.unsafeGet (obj ()) \"foo\") 43);\n test \"set\" (fun _ ->\n let o = Js.Dict.empty () in\n Js.Dict.set o \"foo\" 36;\n assert_option_int (Js.Dict.get o \"foo\") (Some 36));\n test \"keys\" (fun _ -> assert_string_array (Js.Dict.keys (long_obj ())) [| \"bar\"; \"david\"; \"foo\" |]);\n test \"keys duplicated\" (fun _ -> assert_string_array (Js.Dict.keys (obj_duplicated ())) [| \"bar\"; \"bar\"; \"foo\" |]);\n test \"entries\" (fun _ -> assert_int_dict_entries (Js.Dict.entries (obj ())) [| (\"bar\", 86); (\"foo\", 43) |]);\n test \"values\" (fun _ -> assert_array_int (Js.Dict.values (obj ())) [| 86; 43 |]);\n test \"values duplicated\" (fun _ -> assert_array_int (Js.Dict.values (obj_duplicated ())) [| 86; 1; 43 |]);\n test \"fromList - []\" (fun _ -> assert_int_dict_entries (Js.Dict.entries (Js.Dict.fromList [])) [||]);\n test \"fromList\" (fun _ ->\n assert_int_dict_entries (Js.Dict.entries (Js.Dict.fromList [ (\"x\", 23); (\"y\", 46) ])) [| (\"x\", 23); (\"y\", 46) |]);\n test \"fromArray - []\" (fun _ -> assert_int_dict_entries (Js.Dict.entries (Js.Dict.fromArray [||])) [||]);\n test \"fromArray\" (fun _ ->\n assert_int_dict_entries\n (Js.Dict.entries (Js.Dict.fromArray [| (\"x\", 23); (\"y\", 46) |]))\n [| (\"x\", 23); (\"y\", 46) |]);\n test \"map\" (fun _ ->\n let prices = Js.Dict.fromList [ (\"pen\", 1); (\"book\", 5); (\"stapler\", 7) ] in\n let discount price = price * 10 in\n let salePrices = Js.Dict.map ~f:discount prices in\n assert_int_dict_entries (Js.Dict.entries salePrices) [| (\"book\", 50); (\"stapler\", 70); (\"pen\", 10) |]);\n ]\n\nlet promise_to_lwt (p : 'a Js.Promise.t) : 'a Lwt.t = Obj.magic p\n\nlet set_timeout callback delay =\n Lwt.async (fun () ->\n let%lwt () = Lwt_unix.sleep delay in\n callback ();\n Lwt.return ())\n\nlet set_immediate callback =\n Lwt.async (fun () ->\n let%lwt () = Lwt.pause () in\n callback ();\n Lwt.return ())\n\nlet promise_tests =\n [\n test_async \"resolve\" (fun _switch () ->\n let value = \"hi\" in\n let resolved = Js.Promise.resolve value in\n resolved |> promise_to_lwt |> Lwt.map (assert_string value));\n test_async \"all\" (fun _switch () ->\n let p0 = Js.Promise.make (fun ~resolve ~reject:_ -> resolve 5) in\n let p1 = Js.Promise.make (fun ~resolve ~reject:_ -> resolve 10) in\n let resolved = Js.Promise.all [| p0; p1 |] in\n resolved |> promise_to_lwt |> Lwt.map (assert_array_int [| 5; 10 |]));\n test_async \"all_async\" (fun _switch () ->\n let p0 = Js.Promise.make (fun ~resolve ~reject:_ -> set_immediate (fun () -> resolve 5)) in\n let p1 = Js.Promise.make (fun ~resolve ~reject:_ -> set_immediate (fun () -> resolve 99)) in\n let resolved = Js.Promise.all [| p0; p1 |] in\n resolved |> promise_to_lwt |> Lwt.map (assert_array_int [| 5; 99 |]));\n test_async \"race_async\" (fun _switch () ->\n let p0 = Js.Promise.make (fun ~resolve ~reject:_ -> set_timeout (fun () -> resolve \"second\") 0.005) in\n let p1 = Js.Promise.make (fun ~resolve ~reject:_ -> set_immediate (fun () -> resolve \"first\")) in\n let resolved = Js.Promise.race [| p0; p1 |] in\n resolved |> promise_to_lwt |> Lwt.map (assert_string \"first\"));\n ]\n\nlet float_tests =\n [\n test \"string_of_float\" (fun () ->\n assert_string (string_of_float 0.5) \"0.5\";\n assert_string (string_of_float 80.0) \"80.\";\n assert_string (string_of_float 80.) \"80.\";\n assert_string (string_of_float 80.0001) \"80.0001\";\n assert_string (string_of_float 80.00000000001) \"80.\");\n test \"toString\" (fun () ->\n assert_string (Js.Float.toString 0.5) \"0.5\";\n assert_string (Js.Float.toString 80.0) \"80\";\n assert_string (Js.Float.toString 80.) \"80\";\n assert_string (Js.Float.toString 80.0001) \"80.0001\";\n (* assert_string (Js.Float.toString 80.00000000001) \"80.00000000001\"; JS/Melange outputs \"80.00000000001\" but ocaml outputs \"80.\" *)\n assert_string (Js.Float.toString Stdlib.Float.nan) \"NaN\";\n assert_string (Js.Float.toString Stdlib.Float.infinity) \"Infinity\";\n assert_string (Js.Float.toString Stdlib.Float.neg_infinity) \"-Infinity\");\n test \"fromString\" (fun () ->\n assert_float (Js.Float.fromString \"0.5\") 0.5;\n assert_float (Js.Float.fromString \"80\") 80.;\n assert_float (Js.Float.fromString \"80.0001\") 80.0001;\n (* assert_float (Js.Float.fromString \"80.00000000001\") 80.00000000001; JS/Melange outputs 80.00000000001 but ocaml outputs 80. *)\n assert_float (Js.Float.fromString \"NaN\") Stdlib.Float.nan;\n assert_float (Js.Float.fromString \"Infinity\") Stdlib.Float.infinity;\n assert_float (Js.Float.fromString \"-Infinity\") Stdlib.Float.neg_infinity);\n test \"toFixed\" (fun () ->\n assert_string (Js.Float.toFixed 12.3456) \"12\";\n assert_string (Js.Float.toFixed ~digits:20 0.) \"0.00000000000000000000\";\n assert_string (Js.Float.toFixed ~digits:0 (-12.)) \"-12\";\n assert_string (Js.Float.toFixed ~digits:0 Stdlib.Float.nan) \"NaN\";\n assert_string (Js.Float.toFixed ~digits:0 1000000000000000128.) \"1000000000000000128\";\n assert_string (Js.Float.toFixed ~digits:3 12.3456) \"12.346\";\n assert_string (Js.Float.toFixed ~digits:50 0.3) \"0.29999999999999998889776975374843459576368331909180\";\n Alcotest.check_raises \"Expected failure\" (Failure \"toFixed() digits argument must be between 0 and 100\")\n (fun () ->\n let _ = Js.Float.toFixed ~digits:(-1) 12. in\n ());\n assert_string (Js.Float.toFixed ~digits:2 12.345) \"12.35\";\n assert_string (Js.Float.toFixed ~digits:2 12.344) \"12.34\";\n assert_string (Js.Float.toFixed ~digits:1 0.05) \"0.1\";\n assert_string (Js.Float.toFixed ~digits:5 1e20) \"100000000000000000000.00000\";\n assert_string (Js.Float.toFixed ~digits:5 1e-20) \"0.00000\";\n assert_string (Js.Float.toFixed ~digits:10 1e-10) \"0.0000000001\";\n assert_string (Js.Float.toFixed ~digits:100 0.1)\n \"0.1000000000000000055511151231257827021181583404541015625000000000000000000000000000000000000000000000\";\n assert_string (Js.Float.toFixed ~digits:0 0.99) \"1\";\n assert_string (Js.Float.toFixed ~digits:5 Float.infinity) \"Infinity\";\n assert_string (Js.Float.toFixed ~digits:5 Float.neg_infinity) \"-Infinity\";\n assert_string (Js.Float.toFixed ~digits:2 (-12.3456)) \"-12.35\";\n assert_string (Js.Float.toFixed ~digits:4 0.) \"0.0000\";\n (* assert_string (Js.Float.toFixed ~digits:0 1.2e34) \"1.2e+34\"; JS/Melange outputs \"1.2e+34\" but ocaml outputs \"11999999999999999346902771844513792\" *)\n Alcotest.check_raises \"Expected failure for negative digits\"\n (Failure \"toFixed() digits argument must be between 0 and 100\") (fun () ->\n ignore (Js.Float.toFixed ~digits:(-1) 12.34));\n Alcotest.check_raises \"Expected failure for exceeding digits limit\"\n (Failure \"toFixed() digits argument must be between 0 and 100\") (fun () ->\n ignore (Js.Float.toFixed ~digits:101 12.34)));\n ]\n\nlet () =\n Lwt_main.run\n @@ Alcotest_lwt.run \"Js\"\n [\n (\"Js.Global\", global_tests);\n (\"Js.Promise\", promise_tests);\n (\"Js.Float\", float_tests);\n (\"Js.String\", string_tests);\n (\"Js.Re\", re_tests);\n (\"Js.Obj\", obj_tests);\n (\"Js.Dict\", dict_tests);\n (\"Js.Array\", []);\n (\"Js.Undefined\", Undefined_tests.Undefined.tests);\n (* Test262 - BigInt *)\n (\"BigInt.Arithmetic\", Bigint_tests.Arithmetic.tests);\n (\"BigInt.Bitwise\", Bigint_tests.Bitwise.tests);\n (\"BigInt.Comparison\", Bigint_tests.Comparison.tests);\n (\"BigInt.Constructor\", Bigint_tests.Constructor.tests);\n (\"BigInt.Conversion\", Bigint_tests.Conversion.tests);\n (\"BigInt.AsIntN\", Bigint_tests.As_int_n.tests);\n (\"BigInt.AsUintN\", Bigint_tests.As_uint_n.tests);\n (\"BigInt.Prototype\", Bigint_tests.Prototype.tests);\n (* Test262 - Date *)\n (\"Date.Getters\", Date_tests.Getters.tests);\n (\"Date.LocalGetters\", Date_tests.Local_getters.tests);\n (\"Date.Setters\", Date_tests.Setters.tests);\n (\"Date.ToString\", Date_tests.To_string.tests);\n (\"Date.Now\", Date_tests.Now.tests);\n (\"Date.Parse\", Date_tests.Parse.tests);\n (\"Date.ToISOString\", Date_tests.To_iso_string.tests);\n (\"Date.UTC\", Date_tests.Utc.tests);\n (* Test262 - Number *)\n (\"Number.IsFinite\", Number_tests.Is_finite.tests);\n (\"Number.IsInteger\", Number_tests.Is_integer.tests);\n (\"Number.IsNaN\", Number_tests.Is_nan.tests);\n (\"Number.ParseFloat\", Number_tests.Parse_float.tests);\n (\"Number.ParseInt\", Number_tests.Parse_int.tests);\n (\"Number.ToString\", Number_tests.To_string.tests);\n (\"Number.ToExponential\", Number_tests.To_exponential.tests);\n (\"Number.ToPrecision\", Number_tests.To_precision.tests);\n (* Test262 - String *)\n (\"String.Normalize\", String_tests.Normalize.tests);\n (\"String.Search\", String_tests.Search.tests);\n (* Test262 - RegExp *)\n (\"RegExp.NamedGroups\", Regexp_tests.Named_groups.tests);\n (\"RegExp.DotAll\", Regexp_tests.Dotall.tests);\n (\"RegExp.Unicode\", Regexp_tests.Unicode.tests);\n ]\n"
},
{
"path": "packages/Js/test/undefined_tests/undefined.ml",
"content": "open Helpers\n\nlet return_int () =\n let v = Js.Undefined.return 42 in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.int \"return int should be Some\" opt (Some 42)\n\nlet return_string () =\n let v = Js.Undefined.return \"hello\" in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.string \"return string should be Some\" opt (Some \"hello\")\n\nlet return_float () =\n let v = Js.Undefined.return 3.14 in\n let opt = Js.Undefined.toOption v in\n assert_option (Alcotest.float 0.) \"return float should be Some\" opt (Some 3.14)\n\nlet return_date () =\n let d = Date.fromFloat 1506098258091. in\n let v = Js.Undefined.return d in\n let opt = Js.Undefined.toOption v in\n assert_option (Alcotest.float 0.) \"return Js.Date.t should be Some\" opt (Some 1506098258091.)\n\nlet empty_is_none () =\n let v : int Js.Undefined.t = Js.Undefined.empty in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.int \"empty should be None\" opt None\n\nlet get_unsafe_int () =\n let v = Js.Undefined.return 42 in\n let result = Js.Undefined.getUnsafe v in\n assert_int result 42\n\nlet get_unsafe_date () =\n let d = Date.fromFloat 1506098258091. in\n let v = Js.Undefined.return d in\n let result = Js.Undefined.getUnsafe v in\n assert_float_exact result 1506098258091.\n\nlet from_opt_some () =\n let v = Js.Undefined.fromOpt (Some 42) in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.int \"fromOpt (Some 42) round-trip\" opt (Some 42)\n\nlet from_opt_none () =\n let v = Js.Undefined.fromOpt None in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.int \"fromOpt None round-trip\" opt None\n\nlet from_option_some () =\n let v = Js.Undefined.fromOption (Some \"test\") in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.string \"fromOption (Some \\\"test\\\") round-trip\" opt (Some \"test\")\n\nlet from_option_none () =\n let v : string Js.Undefined.t = Js.Undefined.fromOption None in\n let opt = Js.Undefined.toOption v in\n assert_option Alcotest.string \"fromOption None round-trip\" opt None\n\nlet pattern_match_return_int () =\n let v = Js.Undefined.return 99 in\n match (v : int Js.Undefined.t) with\n | Some x -> assert_int x 99\n | None -> Alcotest.fail \"pattern match on return int should be Some\"\n\nlet pattern_match_return_float () =\n let v = Js.Undefined.return 2.718 in\n match (v : float Js.Undefined.t) with\n | Some x -> assert_float_exact x 2.718\n | None -> Alcotest.fail \"pattern match on return float should be Some\"\n\nlet pattern_match_return_date () =\n let d = Date.fromFloat 0. in\n let v = Js.Undefined.return d in\n match (v : Date.t Js.Undefined.t) with\n | Some x -> assert_float_exact x 0.\n | None -> Alcotest.fail \"pattern match on return Js.Date.t should be Some\"\n\nlet pattern_match_empty () =\n let v : int Js.Undefined.t = Js.Undefined.empty in\n match v with Some _ -> Alcotest.fail \"pattern match on empty should be None\" | None -> ()\n\nlet tests =\n [\n test \"return with int\" return_int;\n test \"return with string\" return_string;\n test \"return with float\" return_float;\n test \"return with Js.Date.t\" return_date;\n test \"empty is None\" empty_is_none;\n test \"getUnsafe on return int\" get_unsafe_int;\n test \"getUnsafe on return Js.Date.t\" get_unsafe_date;\n test \"fromOpt Some round-trip\" from_opt_some;\n test \"fromOpt None round-trip\" from_opt_none;\n test \"fromOption Some round-trip\" from_option_some;\n test \"fromOption None round-trip\" from_option_none;\n test \"pattern match on return int\" pattern_match_return_int;\n test \"pattern match on return float\" pattern_match_return_float;\n test \"pattern match on return Js.Date.t\" pattern_match_return_date;\n test \"pattern match on empty\" pattern_match_empty;\n ]\n"
},
{
"path": "packages/browser-ppx/dune",
"content": "(library\n (name browser_ppx)\n (modules ppx)\n (public_name server-reason-react.browser_ppx)\n (flags :standard -w -9)\n (libraries ppxlib ppxlib.astlib)\n (ppx_runtime_libraries runtime)\n (preprocess\n (pps ppxlib.metaquot))\n (kind ppx_rewriter))\n"
},
{
"path": "packages/browser-ppx/ppx.ml",
"content": "open Ppxlib\nmodule Builder = Ast_builder.Default\n\ntype target = Native | Js\n\nlet mode = ref Native\nlet browser_ppx = \"browser_ppx\"\nlet browser_only = \"browser_only\"\nlet platform_tag = \"platform\"\nlet is_platform_tag str = String.equal str browser_ppx || String.equal str browser_only || String.equal str platform_tag\n\nmodule Platform = struct\n let pattern = Ast_pattern.(__')\n\n let collect_expressions ~loc first second =\n match (first.pc_lhs.ppat_desc, second.pc_lhs.ppat_desc) with\n | ( Ppat_construct ({ txt = Lident \"Server\" | Ldot (Lident \"Runtime\", \"Server\"); _ }, _),\n Ppat_construct ({ txt = Lident \"Client\" | Ldot (Lident \"Runtime\", \"Client\"); _ }, _) ) ->\n Ok (first.pc_rhs, second.pc_rhs)\n | ( Ppat_construct ({ txt = Lident \"Client\" | Ldot (Lident \"Runtime\", \"Client\"); _ }, _),\n Ppat_construct ({ txt = Lident \"Server\" | Ldot (Lident \"Runtime\", \"Server\"); _ }, _) ) ->\n Ok (second.pc_rhs, first.pc_rhs)\n | _ -> Error [%expr [%ocaml.error \"[browser_only] switch%platform requires 2 cases: `Server` and `Client`\"]]\n\n let switch_platform_requires_a_match ~loc =\n [%expr [%ocaml.error \"[browser_ppx] switch%platform requires a match expression\"]]\n\n let handler ~ctxt:_ { txt = payload; loc } =\n match payload with\n | PStr [ { pstr_desc = Pstr_eval (expression, _); _ } ] -> (\n match expression.pexp_desc with\n | Pexp_match (_expression, cases) -> (\n match cases with\n | [ first; second ] -> (\n match collect_expressions ~loc first second with\n | Ok (server_expr, client_expr) -> (\n match !mode with\n (* When it's -js keep the client_expr *)\n | Js -> client_expr\n (* When it's isn't -js keep the server_expr *)\n | Native -> server_expr)\n | Error error_msg_expr -> error_msg_expr)\n | _ -> switch_platform_requires_a_match ~loc)\n | _ -> switch_platform_requires_a_match ~loc)\n | _ -> switch_platform_requires_a_match ~loc\n\n let rule = Context_free.Rule.extension (Extension.V3.declare \"platform\" Extension.Context.expression pattern handler)\nend\n\nlet remove_type_constraint pattern =\n match pattern with { ppat_desc = Ppat_constraint (pattern, _); _ } -> pattern | _ -> pattern\n\nlet rec last_expr_to_raise_impossible ~loc original_name expr =\n match expr.pexp_desc with\n | Pexp_constraint (expr, _) -> last_expr_to_raise_impossible ~loc original_name expr\n | Pexp_function\n ({ pparam_desc = Pparam_val (arg_label, _arg_expression, fun_pattern); _ } :: _rest, _, Pfunction_body expression)\n ->\n let new_fun_pattern = remove_type_constraint fun_pattern in\n let fn =\n Builder.pexp_fun ~loc arg_label None new_fun_pattern\n (last_expr_to_raise_impossible ~loc original_name expression)\n in\n { fn with pexp_attributes = expr.pexp_attributes }\n | _ -> [%expr Runtime.fail_impossible_action_in_ssr [%e Builder.estring ~loc original_name]]\n\nmodule Browser_only = struct\n let get_function_name pattern = match pattern with Ppat_var { txt = name; _ } -> name | _ -> \"\"\n\n let error_only_works_on ~loc =\n [%expr\n [%ocaml.error\n \"[browser_ppx] browser_only works on function definitions. For other cases, use switch%platform or feel free \\\n to open an issue in https://github.com/ml-in-barcelona/server-reason-react.\"]]\n\n let remove_alert_browser_only ~loc =\n Builder.attribute ~loc ~name:{ txt = \"alert\"; loc } ~payload:(PStr [ [%stri \"-browser_only\"] ])\n\n let browser_only_fun ~loc arg_label pattern expression =\n let stringified = Ppxlib.Pprintast.string_of_expression expression in\n let message = Builder.estring ~loc stringified in\n let fn = Builder.pexp_fun ~loc arg_label None pattern [%expr Runtime.fail_impossible_action_in_ssr [%e message]] in\n { fn with pexp_attributes = expression.pexp_attributes }\n\n let browser_only_value_binding pattern expression =\n let loc = pattern.ppat_loc in\n match pattern with\n | [%pat? ()] -> Builder.value_binding ~loc ~pat:pattern ~expr:[%expr ()]\n | _ -> (\n match expression.pexp_desc with\n | Pexp_constraint\n ( { pexp_desc = Pexp_function ({ pparam_desc = Pparam_val _; _ } :: _, _, Pfunction_body _); _ },\n _type_constraint ) ->\n let function_name = get_function_name pattern.ppat_desc in\n let expr = last_expr_to_raise_impossible ~loc function_name expression in\n let vb = Builder.value_binding ~loc ~pat:pattern ~expr in\n { vb with pvb_attributes = [ remove_alert_browser_only ~loc ] }\n | Pexp_function ({ pparam_desc = Pparam_val _; _ } :: _, _, Pfunction_body _) ->\n let function_name = get_function_name pattern.ppat_desc in\n let expr = last_expr_to_raise_impossible ~loc function_name expression in\n let vb = Builder.value_binding ~loc ~pat:pattern ~expr in\n { vb with pvb_attributes = [ remove_alert_browser_only ~loc ] }\n | _ -> Builder.value_binding ~loc ~pat:pattern ~expr:(error_only_works_on ~loc))\n\n let extractor_single_payload = Ast_pattern.(single_expr_payload __)\n\n let expression_handler ~ctxt payload =\n let replace_fun_body_with_raise_impossible ~loc pexp_desc =\n match pexp_desc with\n | Pexp_constraint\n ( {\n pexp_desc =\n Pexp_function\n ( { pparam_desc = Pparam_val (arg_label, _arg_expression, pattern); _ } :: _,\n _,\n Pfunction_body expression );\n _;\n },\n type_constraint ) ->\n let fn = browser_only_fun ~loc arg_label pattern expression in\n Builder.pexp_constraint ~loc { fn with pexp_attributes = expression.pexp_attributes } type_constraint\n | Pexp_function\n ({ pparam_desc = Pparam_val (arg_label, _arg_expression, pattern); _ } :: _, _, Pfunction_body expr) ->\n let function_name = get_function_name pattern.ppat_desc in\n let new_fun_pattern = remove_type_constraint pattern in\n Builder.pexp_fun ~loc arg_label None new_fun_pattern (last_expr_to_raise_impossible ~loc function_name expr)\n | Pexp_let (rec_flag, value_bindings, expression) ->\n let pexp_let =\n Builder.pexp_let ~loc rec_flag\n (List.map (fun binding -> browser_only_value_binding binding.pvb_pat binding.pvb_expr) value_bindings)\n expression\n in\n [%expr [%e pexp_let]]\n | _ -> error_only_works_on ~loc\n in\n match !mode with\n | Js -> payload\n | Native ->\n let loc = Expansion_context.Extension.extension_point_loc ctxt in\n replace_fun_body_with_raise_impossible ~loc payload.pexp_desc\n\n let expression_rule =\n Context_free.Rule.extension\n (Extension.V3.declare \"browser_only\" Extension.Context.expression extractor_single_payload expression_handler)\n\n (* Generates a structure_item with a value binding with a pattern and an expression with all the alerts and warnings *)\n let make_vb_with_browser_only ~loc ?type_constraint pattern expression =\n match type_constraint with\n | Some type_constraint ->\n [%stri\n let[@warning \"-27-32\"] ([%p pattern] :\n ([%t type_constraint]\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where JavaScript can run. \\\n You can only use it inside a let%browser_only function.\"])) =\n [%e expression] [@alert \"-browser_only\"]]\n | None ->\n [%stri\n let[@warning \"-27-32\"] ([%p pattern]\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where JavaScript can run. \\\n You can only use it inside a let%browser_only function.\"]) =\n [%e expression] [@alert \"-browser_only\"]]\n\n let extractor_vb =\n let open Ast_pattern in\n let extractor_in_let = pstr_value __ (value_binding ~pat:__ ~expr:__ ~constraint_:drop ^:: nil) in\n pstr @@ extractor_in_let ^:: nil\n\n let structure_item_handler ~ctxt rec_flag pattern expression =\n let loc = Expansion_context.Extension.extension_point_loc ctxt in\n let do_nothing rec_flag =\n match rec_flag with\n | Recursive -> [%stri let rec [%p pattern] = [%e expression]]\n | Nonrecursive -> [%stri let [%p pattern] = [%e expression]]\n in\n\n let add_browser_only_alert expression =\n match expression.pexp_desc with\n | Pexp_constraint\n ( {\n pexp_desc =\n Pexp_function\n ( { pparam_desc = Pparam_val (arg_label, _arg_expression, fun_pattern); _ } :: _,\n _,\n Pfunction_body expr );\n _;\n },\n type_constraint ) ->\n let original_function_name = get_function_name pattern.ppat_desc in\n let new_fun_pattern = remove_type_constraint fun_pattern in\n let fn =\n Builder.pexp_fun ~loc arg_label None new_fun_pattern\n (last_expr_to_raise_impossible ~loc original_function_name expr)\n in\n let item = { fn with pexp_attributes = expr.pexp_attributes } in\n make_vb_with_browser_only ~loc ~type_constraint pattern item\n | Pexp_function\n ({ pparam_desc = Pparam_val (arg_label, _arg_expression, fun_pattern); _ } :: _, _, Pfunction_body expr) ->\n let original_function_name = get_function_name pattern.ppat_desc in\n let new_fun_pattern = remove_type_constraint fun_pattern in\n let fn =\n Builder.pexp_fun ~loc arg_label None new_fun_pattern\n (last_expr_to_raise_impossible ~loc original_function_name expr)\n in\n let item = { fn with pexp_attributes = expr.pexp_attributes } in\n make_vb_with_browser_only ~loc pattern item\n | Pexp_function ([], _, Pfunction_cases (_cases, _, _)) ->\n (* Because pexp_function with cases doesn't have a pattern, neither a label, we construct an empty pattern and use it to generate the vb *)\n let original_function_name = get_function_name pattern.ppat_desc in\n let fn =\n Builder.pexp_fun ~loc Nolabel None\n [%pat? _]\n (last_expr_to_raise_impossible ~loc original_function_name expression)\n in\n let item = { fn with pexp_attributes = expression.pexp_attributes } in\n make_vb_with_browser_only ~loc pattern item\n | Pexp_ident { txt = _longident; loc } ->\n let item = [%expr Obj.magic ()] in\n make_vb_with_browser_only ~loc pattern item\n | Pexp_newtype (name, expr) ->\n let original_function_name = name.txt in\n let item = last_expr_to_raise_impossible ~loc original_function_name expr in\n make_vb_with_browser_only ~loc pattern item\n | _expr -> do_nothing rec_flag\n in\n\n match !mode with\n (* When it's -js, keep item as it is *)\n | Js -> do_nothing rec_flag\n | Native -> add_browser_only_alert expression\n\n let structure_item_rule =\n Context_free.Rule.extension\n (Extension.V3.declare \"browser_only\" Extension.Context.structure_item extractor_vb structure_item_handler)\n\n let has_browser_only_attribute expr =\n match expr.pexp_desc with Pexp_extension ({ txt = \"browser_only\" }, _) -> true | _ -> false\n\n let use_effect (expr : expression) =\n let add_browser_only_extension expr =\n match expr.pexp_desc with\n | (Pexp_apply (_, [ (Nolabel, effect_body) ]) | Pexp_apply (_, [ (Nolabel, effect_body); _ ]))\n when has_browser_only_attribute effect_body ->\n None\n | Pexp_apply (apply_expr, [ (Nolabel, effect_body); second_arg ]) ->\n let loc = expr.pexp_loc in\n let new_effect_body = [%expr [%browser_only [%e effect_body]]] in\n let new_effect_fun = Builder.pexp_apply ~loc apply_expr [ (Nolabel, new_effect_body); second_arg ] in\n Some new_effect_fun\n | Pexp_apply (apply_expr, [ (Nolabel, effect_body) ]) ->\n let loc = expr.pexp_loc in\n let new_effect_body = [%expr [%browser_only [%e effect_body]]] in\n let new_effect_fun = Builder.pexp_apply ~loc apply_expr [ (Nolabel, new_effect_body) ] in\n Some new_effect_fun\n | _ -> None\n in\n match !mode with\n (* When it's -js, keep item as it is *)\n | Js -> None\n | Native -> add_browser_only_extension expr\n\n let use_effects =\n [\n (* useEffect *)\n Context_free.Rule.special_function \"React.useEffect\" use_effect;\n Context_free.Rule.special_function \"React.useEffect0\" use_effect;\n Context_free.Rule.special_function \"React.useEffect1\" use_effect;\n Context_free.Rule.special_function \"React.useEffect2\" use_effect;\n Context_free.Rule.special_function \"React.useEffect3\" use_effect;\n Context_free.Rule.special_function \"React.useEffect4\" use_effect;\n Context_free.Rule.special_function \"React.useEffect5\" use_effect;\n Context_free.Rule.special_function \"React.useEffect6\" use_effect;\n Context_free.Rule.special_function \"React.useEffect7\" use_effect;\n (* useLayoutEffect *)\n Context_free.Rule.special_function \"React.useLayoutEffect\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect0\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect1\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect2\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect3\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect4\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect5\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect6\" use_effect;\n Context_free.Rule.special_function \"React.useLayoutEffect7\" use_effect;\n ]\nend\n\nmodule Preprocess = struct\n (* This module is heavily based on leostera `config.ml` PPX:\n https://github.com/ocaml-sys/config.ml/blob/d248987cc1795de99d3735c06635dbd355d4d642/config/cfg_ppx.ml*)\n\n let eval_attr attr =\n if not (is_platform_tag attr.attr_name.txt) then `keep\n else\n match (attr.attr_name.txt, attr.attr_payload, !mode) with\n | \"browser_only\", _, Native\n | \"platform\", PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident \"js\" } }, []); _ } ], Native\n | \"platform\", PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident \"native\" } }, []); _ } ], Js\n ->\n `drop\n | _ -> `keep\n\n let rec should_keep attrs =\n match attrs with [] -> `keep | attr :: attrs -> if eval_attr attr = `drop then `drop else should_keep attrs\n\n let rec should_keep_many list fn =\n match list with\n | [] -> `keep\n | item :: list -> if should_keep (fn item) = `drop then `drop else should_keep_many list fn\n\n let apply_config_on_types (tds : type_declaration list) =\n List.filter_map\n (fun td ->\n match td with\n | {\n ptype_kind = Ptype_abstract;\n ptype_manifest = Some ({ ptyp_desc = Ptyp_variant (rows, closed_flag, labels); _ } as manifest);\n _;\n } ->\n let rows =\n List.filter_map (fun row -> if should_keep row.prf_attributes = `keep then Some row else None) rows\n in\n\n if rows = [] then None\n else\n Some\n { td with ptype_manifest = Some { manifest with ptyp_desc = Ptyp_variant (rows, closed_flag, labels) } }\n | { ptype_kind = Ptype_variant cstrs; _ } ->\n let cstrs =\n List.filter_map (fun cstr -> if should_keep cstr.pcd_attributes = `keep then Some cstr else None) cstrs\n in\n\n if cstrs = [] then None else Some { td with ptype_kind = Ptype_variant cstrs }\n | { ptype_kind = Ptype_record labels; _ } ->\n let labels =\n List.filter_map\n (fun label -> if should_keep label.pld_attributes = `keep then Some label else None)\n labels\n in\n\n if labels = [] then None else Some { td with ptype_kind = Ptype_record labels }\n | _ -> Some td)\n tds\n\n let apply_config_on_structure_item stri =\n match stri.pstr_desc with\n | Pstr_typext { ptyext_attributes = attrs; _ }\n | Pstr_modtype { pmtd_attributes = attrs; _ }\n | Pstr_open { popen_attributes = attrs; _ }\n | Pstr_include { pincl_attributes = attrs; _ }\n | Pstr_exception { ptyexn_attributes = attrs; _ }\n | Pstr_primitive { pval_attributes = attrs; _ }\n | Pstr_eval (_, attrs)\n | Pstr_module { pmb_attributes = attrs; _ } ->\n if should_keep attrs = `keep then Some stri else None\n | Pstr_value (_, vbs) -> if should_keep_many vbs (fun vb -> vb.pvb_attributes) = `keep then Some stri else None\n | Pstr_type (recflag, tds) ->\n if should_keep_many tds (fun td -> td.ptype_attributes) = `keep then\n let tds = apply_config_on_types tds in\n Some { stri with pstr_desc = Pstr_type (recflag, tds) }\n else None\n | Pstr_recmodule md -> if should_keep_many md (fun md -> md.pmb_attributes) = `keep then Some stri else None\n | Pstr_class cds -> if should_keep_many cds (fun cd -> cd.pci_attributes) = `keep then Some stri else None\n | Pstr_class_type ctds -> if should_keep_many ctds (fun ctd -> ctd.pci_attributes) = `keep then Some stri else None\n | Pstr_extension _ | Pstr_attribute _ -> Some stri\n\n let apply_config_on_signature_item sigi =\n match sigi.psig_desc with\n | Psig_typext { ptyext_attributes = attrs; _ }\n | Psig_modtype { pmtd_attributes = attrs; _ }\n | Psig_open { popen_attributes = attrs; _ }\n | Psig_include { pincl_attributes = attrs; _ }\n | Psig_exception { ptyexn_attributes = attrs; _ }\n | Psig_value { pval_attributes = attrs; _ }\n | Psig_modtypesubst { pmtd_attributes = attrs; _ }\n | Psig_modsubst { pms_attributes = attrs; _ }\n | Psig_module { pmd_attributes = attrs; _ } ->\n if should_keep attrs = `keep then Some sigi else None\n | Psig_typesubst tds ->\n if should_keep_many tds (fun td -> td.ptype_attributes) = `keep then\n let tds = apply_config_on_types tds in\n Some { sigi with psig_desc = Psig_typesubst tds }\n else None\n | Psig_type (recflag, tds) ->\n if should_keep_many tds (fun td -> td.ptype_attributes) = `keep then\n let tds = apply_config_on_types tds in\n Some { sigi with psig_desc = Psig_type (recflag, tds) }\n else None\n | Psig_recmodule md -> if should_keep_many md (fun md -> md.pmd_attributes) = `keep then Some sigi else None\n | Psig_class cds -> if should_keep_many cds (fun cd -> cd.pci_attributes) = `keep then Some sigi else None\n | Psig_class_type ctds -> if should_keep_many ctds (fun ctd -> ctd.pci_attributes) = `keep then Some sigi else None\n | Psig_extension _ | Psig_attribute _ -> Some sigi\n\n let traverse =\n object (_ : Ast_traverse.map)\n inherit Ast_traverse.map as super\n\n method! structure str =\n let str = super#structure str in\n match str with\n | { pstr_desc = Pstr_attribute attr; _ } :: rest when is_platform_tag attr.attr_name.txt ->\n if eval_attr attr = `keep then rest else []\n | str -> List.filter_map apply_config_on_structure_item str\n\n method! signature sigi =\n let sigi = super#signature sigi in\n match sigi with\n | { psig_desc = Psig_attribute attr; _ } :: rest when is_platform_tag attr.attr_name.txt ->\n if eval_attr attr = `keep then rest else []\n | _ -> List.filter_map apply_config_on_signature_item sigi\n\n method! expression expr =\n let expr = super#expression expr in\n let loc = expr.pexp_loc in\n match expr.pexp_desc with\n | Pexp_let (_, [ { pvb_attributes = attrs; _ } ], _) ->\n let loc = expr.pexp_loc in\n if should_keep attrs = `keep then expr\n else [%expr [%ocaml.error \"Don't use browser_only on expressions, use switch%platform instead\"]]\n | _ ->\n if should_keep expr.pexp_attributes = `keep then expr\n else [%expr [%ocaml.error \"Don't use browser_only on expressions, use switch%platform instead\"]]\n\n method! pattern pat =\n match pat.ppat_desc with\n | Ppat_constraint (inner_pat, _) ->\n let loc = pat.ppat_loc in\n if should_keep inner_pat.ppat_attributes = `keep then super#pattern pat else [%pat? _]\n | _ ->\n let pat = super#pattern pat in\n let loc = pat.ppat_loc in\n if should_keep pat.ppat_attributes = `keep then pat else [%pat? _]\n end\nend\n\nlet () =\n Driver.add_arg \"-js\" (Unit (fun () -> mode := Js)) ~doc:\"preprocess for js build\";\n let rules =\n [ Browser_only.expression_rule; Browser_only.structure_item_rule; Platform.rule ] @ Browser_only.use_effects\n in\n Driver.V2.register_transformation browser_ppx ~rules\n ~impl:(fun _ -> Preprocess.traverse#structure)\n ~intf:(fun _ -> Preprocess.traverse#signature)\n"
},
{
"path": "packages/browser-ppx/tests/at_browser_only.t",
"content": "Pstr_include\n\n $ cat > input_include.ml << EOF\n > include struct\n > type t = Js.Json.t\n > end [@@browser_only]\n > EOF\n\nWith -js flag it picks the block with `[@@browser_only]`\n\n $ ./standalone.exe -impl input_include.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = Js.Json.t\n end [@@browser_only]\n\nWithout -js flag, it picks the block without `[@@browser_only]`\n\n $ ./standalone.exe -impl input_include.ml | ocamlformat - --enable-outside-detected-project --impl\n\nPstr_module\n\n $ cat > input_module.ml << EOF\n > module M = struct\n > let x = 42\n > end [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_module.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_module.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module M = struct\n let x = 42\n end\n [@@browser_only]\n\nPstr_value\n\n $ cat > input_value.ml << EOF\n > let x = 42 [@@browser_only]\n > let y = 44 \n > EOF\n\n $ ./standalone.exe -impl input_value.ml | ocamlformat - --enable-outside-detected-project --impl\n let y = 44\n\n $ ./standalone.exe -impl input_value.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let x = 42 [@@browser_only]\n let y = 44\n\nNested\n\n $ cat > input_nested.ml << EOF\n > module X = struct\n > module Y = struct\n > type t = Js.Json.t\n > let a = 4 + 4\n > end [@@browser_only]\n > end\n > EOF\n\nWith -js flag it picks the block with `[@@browser_only]`\n\n $ ./standalone.exe -impl input_nested.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module X = struct\n module Y = struct\n type t = Js.Json.t\n \n let a = 4 + 4\n end\n [@@browser_only]\n end\n\nWithout -js flag, it picks the block without `[@@browser_only]`\n\n $ ./standalone.exe -impl input_nested.ml | ocamlformat - --enable-outside-detected-project --impl\n module X = struct end\n\nPpat_tuple\n\n $ cat > input_tuple.ml << EOF\n > let (x, y [@browser_only]) = (42, 44)\n > EOF\n\n $ ./standalone.exe -impl input_tuple.ml | ocamlformat - --enable-outside-detected-project --impl\n let x, _ = (42, 44)\n\n $ ./standalone.exe -impl input_tuple.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let x, (y [@browser_only]) = (42, 44)\n\n $ ./standalone.exe -impl input_tuple.ml > input_tuple_server.ml && ocamlc -c input_tuple_server.ml\n\nPpat_var\n\n $ cat > input_var.ml << EOF\n > let x (onClick [@browser_only]) = 24\n > let y ~onClick:(onClick [@browser_only]) = 42\n > EOF\n\n $ ./standalone.exe -impl input_var.ml | ocamlformat - --enable-outside-detected-project --impl\n let x _ = 24\n let y ~onClick:_ = 42\n\n $ ./standalone.exe -impl input_var.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let x (onClick [@browser_only]) = 24\n let y ~onClick:(onClick [@browser_only]) = 42\n\n $ ./standalone.exe -impl input_var.ml > input_var_server.ml && ocamlc -c input_var_server.ml\n\nPstr_open\n\n $ cat > input_open.ml << EOF\n > open Printf [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_open.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_open.ml -js | ocamlformat - --enable-outside-detected-project --impl\n open Printf [@@browser_only]\n\n $ ./standalone.exe -impl input_open.ml > input_open_server.ml && ocamlc -c input_open_server.ml\n\nPstr_exception\n\n $ cat > input_exception.ml << EOF\n > exception MyException of string [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_exception.ml -js | ocamlformat - --enable-outside-detected-project --impl\n exception MyException of string [@@browser_only]\n\n $ ./standalone.exe -impl input_exception.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_exception.ml > input_exception_server.ml && ocamlc -c input_exception_server.ml\n\nPstr_primitive\n\n $ cat > input_primitive.ml << EOF\n > external add : int -> int -> int = \"caml_add_int\" [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_primitive.ml -js | ocamlformat - --enable-outside-detected-project --impl\n external add : int -> int -> int = \"caml_add_int\" [@@browser_only]\n\n $ ./standalone.exe -impl input_primitive.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_primitive.ml > input_primitive_server.ml && ocamlc -c input_primitive_server.ml\n\nPstr_eval\n\n $ cat > input_primitive.ml << EOF\n > 2 [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_primitive.ml -js | ocamlformat - --enable-outside-detected-project --impl\n 2 [@@browser_only]\n\n $ ./standalone.exe -impl input_primitive.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_primitive.ml > input_primitive_server.ml && ocamlc -c input_primitive_server.ml\n\nPstr_type\n\n $ cat > input_type.ml << EOF\n > type point = { x : int; y : int } [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_type.ml -js | ocamlformat - --enable-outside-detected-project --impl\n type point = { x : int; y : int } [@@browser_only]\n\n $ ./standalone.exe -impl input_type.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_type.ml > input_type_server.ml && ocamlc -c input_type_server.ml\n\nPstr_recmodule\n\n $ cat > input_recmodule.ml << EOF\n > module rec M = struct\n > let x = 42\n > end [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_recmodule.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module rec M = struct\n let x = 42\n end\n [@@browser_only]\n\n $ ./standalone.exe -impl input_recmodule.ml | ocamlformat - --enable-outside-detected-project --impl\n\nPstr_class\n\n $ cat > input_class.ml << EOF\n > class virtual ['a] base x = object\n > method get = x\n > end [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_class.ml -js | ocamlformat - --enable-outside-detected-project --impl\n class virtual ['a] base x =\n object\n method get = x\n end [@@browser_only]\n\n $ ./standalone.exe -impl input_class.ml | ocamlformat - --enable-outside-detected-project --impl\n\nPstr_class_type\n\n $ cat > input_class_type.ml << EOF\n > class type base = object\n > method get : int\n > end [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input_class_type.ml -js | ocamlformat - --enable-outside-detected-project --impl\n class type base = object\n method get : int\n end [@@browser_only]\n\n $ ./standalone.exe -impl input_class_type.ml | ocamlformat - --enable-outside-detected-project --impl\n\n $ ./standalone.exe -impl input_class_type.ml > input_class_type_server.ml && ocamlc -c input_class_type_server.ml\n\nPpat_constraint\n\n $ cat > input_constr.ml << EOF\n > let foo ~on:((on [@browser_only]): unit -> string) ?opt:((opt [@browser_only])=42) = 0\n > EOF\n\n $ ./standalone.exe -impl input_constr.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let foo ~on:((on [@browser_only]) : unit -> string)\n ?opt:((opt [@browser_only]) = 42) =\n 0\n $ ./standalone.exe -impl input_constr.ml | ocamlformat - --enable-outside-detected-project --impl\n let foo ~on:_ ?opt:(_ = 42) = 0\n\nPexp_* should be throw an error\n\n $ cat > input_let.ml << EOF\n > let x =\n > let _ = 42 [@@browser_only] in\n > let y = 44 in\n > y\n > EOF\n\n $ ./standalone.exe -impl input_let.ml | ocamlformat - --enable-outside-detected-project --impl\n let x =\n [%ocaml.error\n \"Don't use browser_only on expressions, use switch%platform instead\"]\n\n $ ./standalone.exe -impl input_let.ml > input_let_server.ml && ocamlc -c input_let_server.ml\n File \"input_let_server.ml\", line 2, characters 4-15:\n 2 | [%ocaml.error\n ^^^^^^^^^^^\n Error: Don't use browser_only on expressions, use switch%platform instead\n [2]\n"
},
{
"path": "packages/browser-ppx/tests/at_platform.t",
"content": "Nested\n\n $ cat > input.ml << EOF\n > module X = struct\n > include struct\n > type t = Js.Json.t\n > let a = 2 + 2\n > end [@@platform js]\n > \n > include struct\n > type t = Js.Json.t\n > let a = 4 + 4\n > end [@@platform native]\n > end\n > EOF\n\nWith -js flag it picks the block with `[@@platform js]`\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module X = struct\n include struct\n type t = Js.Json.t\n \n let a = 2 + 2\n end [@@platform js]\n end\n\nWithout -js flag, it picks the block with `[@@platform native]`\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n module X = struct\n include struct\n type t = Js.Json.t\n \n let a = 4 + 4\n end [@@platform native]\n end\n\nPstr_include\n\n $ cat > input.ml << EOF\n > include struct\n > type t = Js.Json.t\n > end [@@platform js]\n > \n > include struct\n > type t = string\n > end [@@platform native]\n > EOF\n\nWith -js flag it picks the block with `[@@platform js]`\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = Js.Json.t\n end [@@platform js]\n\nWithout -js flag, it picks the block with `[@@platform native]`\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = string\n end [@@platform native]\n\nUse only one of the platforms\n\n $ cat > input.ml << EOF\n > include struct\n > type t = Js.Json.t\n > end [@@platform js]\n > \n > include struct\n > type t = string\n > end\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = string\n end\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = Js.Json.t\n end [@@platform js]\n \n include struct\n type t = string\n end\n\nPstr_module\n\n $ cat > input_module.ml << EOF\n > module M = struct\n > let x = 42\n > end [@@platform js]\n > module M = struct\n > let x = 44\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_module.ml | ocamlformat - --enable-outside-detected-project --impl\n module M = struct\n let x = 44\n end\n [@@platform native]\n\n $ ./standalone.exe -impl input_module.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module M = struct\n let x = 42\n end\n [@@platform js]\n\nPstr_value\n\n $ cat > input_let.ml << EOF\n > let x = 42 [@@platform js]\n > let y = 44 [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_let.ml | ocamlformat - --enable-outside-detected-project --impl\n let y = 44 [@@platform native]\n\n $ ./standalone.exe -impl input_let.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let x = 42 [@@platform js]\n\nPstr_open\n\n $ cat > input_open.ml << EOF\n > open Printf [@@platform js]\n > open List [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_open.ml | ocamlformat - --enable-outside-detected-project --impl\n open List [@@platform native]\n\n $ ./standalone.exe -impl input_open.ml -js | ocamlformat - --enable-outside-detected-project --impl\n open Printf [@@platform js]\n\nPstr_exception\n\n $ cat > input_exception.ml << EOF\n > exception MyException of string [@@platform js]\n > exception AnotherException of int [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_exception.ml | ocamlformat - --enable-outside-detected-project --impl\n exception AnotherException of int [@@platform native]\n\n $ ./standalone.exe -impl input_exception.ml -js | ocamlformat - --enable-outside-detected-project --impl\n exception MyException of string [@@platform js]\n\nPstr_primitive\n\n $ cat > input_primitive.ml << EOF\n > external add : int -> int -> int = \"caml_add_int\" [@@platform js]\n > external subtract : int -> int -> int = \"caml_subtract_int\" [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_primitive.ml | ocamlformat - --enable-outside-detected-project --impl\n external subtract : int -> int -> int = \"caml_subtract_int\" [@@platform native]\n\n $ ./standalone.exe -impl input_primitive.ml -js | ocamlformat - --enable-outside-detected-project --impl\n external add : int -> int -> int = \"caml_add_int\" [@@platform js]\n\nPstr_eval (doesn't work)\n\n $ cat > input_primitive.ml << EOF\n > include struct\n > 2 [@@platform js]\n > end\n > \n > include struct\n > 3 [@@platform native]\n > end\n > EOF\n\n $ ./standalone.exe -impl input_primitive.ml | ocamlformat - --enable-outside-detected-project --impl\n include struct end\n \n include struct\n 3 [@@platform native]\n end\n\n $ ./standalone.exe -impl input_primitive.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n 2 [@@platform js]\n end\n \n include struct end\n\nPstr_type\n\n $ cat > input_type.ml << EOF\n > type point = { x : int; y : int } [@@platform js]\n > type color = Red | Green | Blue [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_type.ml | ocamlformat - --enable-outside-detected-project --impl\n type color = Red | Green | Blue [@@platform native]\n\n $ ./standalone.exe -impl input_type.ml -js | ocamlformat - --enable-outside-detected-project --impl\n type point = { x : int; y : int } [@@platform js]\n\nPstr_recmodule\n\n $ cat > input_recmodule.ml << EOF\n > module rec M = struct\n > let x = 42\n > end [@@platform js]\n > module rec M = struct\n > let x = 44\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_recmodule.ml | ocamlformat - --enable-outside-detected-project --impl\n module rec M = struct\n let x = 44\n end\n [@@platform native]\n\n $ ./standalone.exe -impl input_recmodule.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module rec M = struct\n let x = 42\n end\n [@@platform js]\n\nPstr_class\n\n $ cat > input_class.ml << EOF\n > class virtual ['a] base x = object\n > method get = x\n > end [@@platform js]\n > class derived = object\n > inherit base 42\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_class.ml | ocamlformat - --enable-outside-detected-project --impl\n class derived =\n object\n inherit base 42\n end [@@platform native]\n\n $ ./standalone.exe -impl input_class.ml -js | ocamlformat - --enable-outside-detected-project --impl\n class virtual ['a] base x =\n object\n method get = x\n end [@@platform js]\n\nPstr_class_type\n\n $ cat > input_class_type.ml << EOF\n > class type base = object\n > method get : int\n > end [@@platform js]\n > class type derived = object\n > inherit base\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_class_type.ml | ocamlformat - --enable-outside-detected-project --impl\n class type derived = object\n inherit base\n end [@@platform native]\n\n $ ./standalone.exe -impl input_class_type.ml -js | ocamlformat - --enable-outside-detected-project --impl\n class type base = object\n method get : int\n end [@@platform js]\n"
},
{
"path": "packages/browser-ppx/tests/dune",
"content": "(cram\n (package server-reason-react)\n (enabled_if\n (>= %{ocaml_version} 5.2.0))\n (deps %{bin:ocamlformat} standalone.exe))\n\n(executable\n (name standalone)\n (libraries ppxlib browser_ppx))\n"
},
{
"path": "packages/browser-ppx/tests/pexp_apply.t",
"content": " $ cat > input.ml << EOF\n > let pstr_value_binding = [%browser_only Webapi.Dom.getElementById \"foo\"]\n > let make () =\n > let%browser_only pstr_value_binding_2 = Webapi.Dom.getElementById \"foo\" in\n > ()\n > \n > EOF\n\nWith -js flag everything keeps as it is and browser_only extension disappears\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let pstr_value_binding = Webapi.Dom.getElementById \"foo\"\n \n let make () =\n let pstr_value_binding_2 = Webapi.Dom.getElementById \"foo\" in\n ()\n\nWithout -js flag, the compilation to native errors out indicating that a function must be used\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let pstr_value_binding =\n [%ocaml.error\n \"[browser_ppx] browser_only works on function definitions. For other \\\n cases, use switch%platform or feel free to open an issue in \\\n https://github.com/ml-in-barcelona/server-reason-react.\"]\n \n let make () =\n let pstr_value_binding_2 =\n [%ocaml.error\n \"[browser_ppx] browser_only works on function definitions. For other \\\n cases, use switch%platform or feel free to open an issue in \\\n https://github.com/ml-in-barcelona/server-reason-react.\"]\n in\n ()\n"
},
{
"path": "packages/browser-ppx/tests/pexp_constraint_re.t",
"content": " $ cat > input.re << EOF\n > let make = () => {\n > let%browser_only discard: Js.Promise.t(unit) => unit = value => ignore(value);\n > ();\n > };\n > \n > let%browser_only reifyStyle = (type a, x: 'a): (style(a), a) => {\n > let isCanvasGradient = _ => false;\n > let isCanvasPattern = _ => false;\n > \n > (\n > if (Js.typeof(x) == \"string\") {\n > Obj.magic(String);\n > } else if (isCanvasGradient(x)) {\n > Obj.magic(Gradient);\n > } else if (isCanvasPattern(x)) {\n > Obj.magic(Pattern);\n > } else {\n > invalid_arg(\"Unknown canvas style kind. Known values are: String, CanvasGradient, CanvasPattern\");\n > },\n > Obj.magic(x),\n > );\n > };\n > \n > EOF\n\n $ refmt --print ml input.re > input.ml\n\n $ ./standalone.exe -impl input.ml -js | refmt --parse ml --print re\n let make = () => {\n let discard: Js.Promise.t(unit) => unit = value => ignore(value);\n ();\n };\n let reifyStyle = (type a, x: 'a): (style(a), a) => {\n let isCanvasGradient = _ => false;\n let isCanvasPattern = _ => false;\n (\n if (Js.typeof(x) == \"string\") {\n Obj.magic(String);\n } else if (isCanvasGradient(x)) {\n Obj.magic(Gradient);\n } else if (isCanvasPattern(x)) {\n Obj.magic(Pattern);\n } else {\n invalid_arg(\n \"Unknown canvas style kind. Known values are: String, CanvasGradient, CanvasPattern\",\n );\n },\n Obj.magic(x),\n );\n };\n\n $ ./standalone.exe -impl input.ml | refmt --parse ml --print re\n let make = () => {\n [@alert \"-browser_only\"]\n let discard = value => Runtime.fail_impossible_action_in_ssr(\"discard\");\n ();\n };\n let reifyStyle = (type a, x: 'a): (style(a), a) => {\n let isCanvasGradient = _ => false;\n let isCanvasPattern = _ => false;\n (\n if (Js.typeof(x) == \"string\") {\n Obj.magic(String);\n } else if (isCanvasGradient(x)) {\n Obj.magic(Gradient);\n } else if (isCanvasPattern(x)) {\n Obj.magic(Pattern);\n } else {\n invalid_arg(\n \"Unknown canvas style kind. Known values are: String, CanvasGradient, CanvasPattern\",\n );\n },\n Obj.magic(x),\n );\n };\n"
},
{
"path": "packages/browser-ppx/tests/pexp_fun.t",
"content": " $ cat > input.ml << EOF\n > let make () =\n > let%browser_only fun_value_binding_pexp_fun_2arg evt moar_arguments =\n > Webapi.Dom.getElementById \"foo\"\n > in\n > \n > let%browser_only perform ?abortController ?(base = defaultBase) (req : ('handler, 'a, 'i, 'o) Client.request) input =\n > Js.log Foo.var;\n > Js.log record.field;\n > Local.setHtmlFetchState value;\n > Js.log abortController;\n > Js.log (fun a -> a);\n > Js.log base;\n > Js.log req;\n > Js.log input\n > in\n > \n > let%browser_only fun_value_binding_labelled_args ~argument1 ~argument2 =\n > setHtmlFetchState Loading\n > in\n > ()\n > EOF\n\nWith -js flag everything keeps as it is and browser_only extension disappears\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let fun_value_binding_pexp_fun_2arg evt moar_arguments =\n Webapi.Dom.getElementById \"foo\"\n in\n let perform ?abortController ?(base = defaultBase)\n (req : ('handler, 'a, 'i, 'o) Client.request) input =\n Js.log Foo.var;\n Js.log record.field;\n Local.setHtmlFetchState value;\n Js.log abortController;\n Js.log (fun a -> a);\n Js.log base;\n Js.log req;\n Js.log input\n in\n let fun_value_binding_labelled_args ~argument1 ~argument2 =\n setHtmlFetchState Loading\n in\n ()\n\nWithout -js flag, the compilation to native replaces the expression with a raise\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl > output.ml\n\n $ cat output.ml\n let make () =\n let fun_value_binding_pexp_fun_2arg evt =\n Runtime.fail_impossible_action_in_ssr \"fun_value_binding_pexp_fun_2arg\"\n [@@alert \"-browser_only\"]\n in\n let perform ?abortController =\n Runtime.fail_impossible_action_in_ssr \"perform\"\n [@@alert \"-browser_only\"]\n in\n let fun_value_binding_labelled_args ~argument1 =\n Runtime.fail_impossible_action_in_ssr \"fun_value_binding_labelled_args\"\n [@@alert \"-browser_only\"]\n in\n ()\n\nReplace Runtime.fail_impossible_action_in_ssr with print_endline so ocamlc can compile it without the Runtime module dependency\n $ sed \"s/Runtime.fail_impossible_action_in_ssr/print_endline/g\" output.ml > output.ml\n\n $ ocamlc -c output.ml\n"
},
{
"path": "packages/browser-ppx/tests/pexp_fun_with_vb.t",
"content": " $ cat > input.ml << EOF\n > let make () =\n > let%browser_only fun_value_binding_pexp_fun_2arg evt moar_arguments =\n > let a = \"foo\" in\n > Webapi.Dom.getElementById a\n > in\n > \n > let%browser_only fun_value_binding_pexp_fun_default_expr ?(evt=22) =\n > Webapi.Dom.getElementById evt\n > in\n > \n > let%browser_only fun_value_binding_pexp_fun_2arg evt moar_arguments =\n > let a = 1 in\n > let b = 2 in\n > Webapi.Dom.getElementById b\n > in\n > ()\n > \n > EOF\n\nWith -js flag everything keeps as it is and browser_only extension disappears\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let fun_value_binding_pexp_fun_2arg evt moar_arguments =\n let a = \"foo\" in\n Webapi.Dom.getElementById a\n in\n let fun_value_binding_pexp_fun_default_expr ?(evt = 22) =\n Webapi.Dom.getElementById evt\n in\n let fun_value_binding_pexp_fun_2arg evt moar_arguments =\n let a = 1 in\n let b = 2 in\n Webapi.Dom.getElementById b\n in\n ()\n\nWithout -js flag, the compilation to native replaces the expression with a raise\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl > output.ml\n\n $ cat output.ml\n let make () =\n let fun_value_binding_pexp_fun_2arg evt =\n Runtime.fail_impossible_action_in_ssr \"fun_value_binding_pexp_fun_2arg\"\n [@@alert \"-browser_only\"]\n in\n let fun_value_binding_pexp_fun_default_expr ?evt =\n Runtime.fail_impossible_action_in_ssr\n \"fun_value_binding_pexp_fun_default_expr\"\n [@@alert \"-browser_only\"]\n in\n let fun_value_binding_pexp_fun_2arg evt =\n Runtime.fail_impossible_action_in_ssr \"fun_value_binding_pexp_fun_2arg\"\n [@@alert \"-browser_only\"]\n in\n ()\n\nReplace Runtime.fail_impossible_action_in_ssr with print_endline so ocamlc can compile it without the Runtime module dependency\n $ sed \"s/Runtime.fail_impossible_action_in_ssr/print_endline/g\" output.ml > output.ml\n\n $ ocamlc -c output.ml\n"
},
{
"path": "packages/browser-ppx/tests/pexp_function.t",
"content": " $ cat > input.re << EOF\n > let%browser_only foo = fun\n > | x when x < 0. => None\n > | x => Some(\"bar\");\n > \n > let make = () => {\n > let%browser_only foo = fun\n > | x when x < 0. => None\n > | x => Some(\"bar\");\n > ();\n > };\n > EOF\n\n $ refmt --parse re --print ml input.re > input.ml\n\nWith -js flag everything keeps as it is and browser_only extension disappears\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let foo = function x when x < 0. -> None | x -> Some \"bar\" [@explicit_arity]\n \n let make () =\n let foo = function\n | x when x < 0. -> None\n | x -> ( Some \"bar\" [@explicit_arity])\n in\n ()\n\nWithout -js flag, the compilation to native errors out indicating that a function must be used\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let (foo\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun _ -> Runtime.fail_impossible_action_in_ssr \"foo\") [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let make () =\n let foo =\n [%ocaml.error\n \"[browser_ppx] browser_only works on function definitions. For other \\\n cases, use switch%platform or feel free to open an issue in \\\n https://github.com/ml-in-barcelona/server-reason-react.\"]\n in\n ()\n"
},
{
"path": "packages/browser-ppx/tests/pexp_ident.t",
"content": " $ cat > input.ml << EOF\n > let make () =\n > let%browser_only pexp_ident = Webapi__Dom__Element.asHtmlElement in\n > ()\n > EOF\n\nWith -js flag everything keeps as it is and browser_only extension disappears\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let pexp_ident = Webapi__Dom__Element.asHtmlElement in\n ()\n\nWithout -js flag, the compilation to native errors out indicating that a function must be used\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let pexp_ident =\n [%ocaml.error\n \"[browser_ppx] browser_only works on function definitions. For other \\\n cases, use switch%platform or feel free to open an issue in \\\n https://github.com/ml-in-barcelona/server-reason-react.\"]\n in\n ()\n"
},
{
"path": "packages/browser-ppx/tests/playground.t/input.re",
"content": "let%browser_only makeQuery =\n (~abortController, ~encoding=?, pathname, req, input) => {\n let signal =\n abortController->Option.map(abortController =>\n abortController->Fetch.AbortController.signal\n );\n let query = Js.Dict.empty();\n encoding->Option.forEach(enc =>\n query->Js.Dict.set(\"mode\", \"csv-\" ++ EncodingT.unwrap(enc))\n );\n let defaultPostHeaders = (\n \"Content-Type\",\n \"application/json; charset=utf-8\",\n );\n switch (req.config.allowed_methods) {\n | GET_or_POST =>\n let queryParam = Sensitivity.to_query_param(req.config.sensitivity);\n let inputString = input->(req.writeInput)->Js.Json.stringify;\n let cloudflareLimit =\n /* Cloudflare limit is 16358: https://ahrefs.slack.com/archives/CUPHP0EP8/p1677644203445649?thread_ts=1677599205.939129&cid=CUPHP0EP8\n but we leave some room for headers and other parts of the req */\n 15000;\n let inputStringEncoded = inputString->Js.Global.encodeURIComponent;\n String.length(inputStringEncoded) > cloudflareLimit\n ? Fetch.fetchWithInit(\n Url.makeStringWithQueryDict(~pathname, ~query, ()),\n Fetch.RequestInit.make(\n ~method_=Post,\n ~body=inputString->Fetch.BodyInit.make,\n ~credentials=Include,\n ~headers=\n makeHeadersInit(\n ~shouldBeGet=true,\n ~initHeaders=defaultPostHeaders,\n (),\n ),\n ~signal?,\n (),\n ),\n )\n : {\n Js.Dict.set(query, queryParam, inputStringEncoded);\n Fetch.fetchWithInit(\n Url.makeStringWithQueryDict(~pathname, ~query, ~encode=false, ()),\n Fetch.RequestInit.make(\n ~method_=Get,\n ~credentials=Include,\n ~headers=makeHeadersInit(),\n ~signal?,\n (),\n ),\n );\n };\n | POST_only =>\n Fetch.fetchWithInit(\n Url.makeStringWithQueryDict(~pathname, ~query, ()),\n Fetch.RequestInit.make(\n ~method_=Post,\n ~body=input->(req.writeInput)->Js.Json.stringify->Fetch.BodyInit.make,\n ~credentials=Include,\n ~headers=makeHeadersInit(~initHeaders=defaultPostHeaders, ()),\n ~signal?,\n (),\n ),\n )\n };\n};\n"
},
{
"path": "packages/browser-ppx/tests/playground.t/run.t",
"content": " $ refmt --print ml ./input.re > input.ml\n\n $ ../standalone.exe -impl input.ml -js | refmt --parse ml --print re\n let makeQuery = (~abortController, ~encoding=?, pathname, req, input) => {\n let signal =\n abortController->Option.map(abortController =>\n abortController->Fetch.AbortController.signal\n );\n let query = Js.Dict.empty();\n encoding->Option.forEach(enc =>\n query->Js.Dict.set(\"mode\", \"csv-\" ++ EncodingT.unwrap(enc))\n );\n let defaultPostHeaders = (\n \"Content-Type\",\n \"application/json; charset=utf-8\",\n );\n switch (req.config.allowed_methods) {\n | GET_or_POST =>\n let queryParam = Sensitivity.to_query_param(req.config.sensitivity);\n let inputString = input->(req.writeInput)->Js.Json.stringify;\n let cloudflareLimit = 15000;\n let inputStringEncoded = inputString->Js.Global.encodeURIComponent;\n String.length(inputStringEncoded) > cloudflareLimit\n ? Fetch.fetchWithInit(\n Url.makeStringWithQueryDict(~pathname, ~query, ()),\n Fetch.RequestInit.make(\n ~method_=Post,\n ~body=inputString->Fetch.BodyInit.make,\n ~credentials=Include,\n ~headers=\n makeHeadersInit(\n ~shouldBeGet=true,\n ~initHeaders=defaultPostHeaders,\n (),\n ),\n ~signal?,\n (),\n ),\n )\n : {\n Js.Dict.set(query, queryParam, inputStringEncoded);\n Fetch.fetchWithInit(\n Url.makeStringWithQueryDict(~pathname, ~query, ~encode=false, ()),\n Fetch.RequestInit.make(\n ~method_=Get,\n ~credentials=Include,\n ~headers=makeHeadersInit(),\n ~signal?,\n (),\n ),\n );\n };\n | POST_only =>\n Fetch.fetchWithInit(\n Url.makeStringWithQueryDict(~pathname, ~query, ()),\n Fetch.RequestInit.make(\n ~method_=Post,\n ~body=input->(req.writeInput)->Js.Json.stringify->Fetch.BodyInit.make,\n ~credentials=Include,\n ~headers=makeHeadersInit(~initHeaders=defaultPostHeaders, ()),\n ~signal?,\n (),\n ),\n )\n };\n };\n\n $ ../standalone.exe -impl input.ml | refmt --parse ml --print re\n [@warning \"-27-32\"]\n let [@alert\n browser_only(\n \"This expression is marked to only run on the browser where JavaScript can run. You can only use it inside a let%browser_only function.\",\n )\n ]\n makeQuery =\n [@alert \"-browser_only\"]\n (\n (~abortController, ~encoding=?, pathname, req, input) =>\n Runtime.fail_impossible_action_in_ssr(\"makeQuery\")\n );\n"
},
{
"path": "packages/browser-ppx/tests/preprocess.t",
"content": "Nested\n\n $ cat > input.ml << EOF\n > module X = struct\n > include struct\n > type t = Js.Json.t\n > let a = 2 + 2\n > end [@@platform js]\n > \n > include struct\n > type t = Js.Json.t\n > let a = 4 + 4\n > end [@@platform native]\n > end\n > EOF\n\nWith -js flag it picks the block with `[@@platform js]`\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module X = struct\n include struct\n type t = Js.Json.t\n \n let a = 2 + 2\n end [@@platform js]\n end\n\nWithout -js flag, it picks the block with `[@@platform native]`\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n module X = struct\n include struct\n type t = Js.Json.t\n \n let a = 4 + 4\n end [@@platform native]\n end\n\nPstr_include\n\n $ cat > input.ml << EOF\n > include struct\n > type t = Js.Json.t\n > end [@@platform js]\n > \n > include struct\n > type t = string\n > end [@@platform native]\n > EOF\n\nWith -js flag it picks the block with `[@@platform js]`\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = Js.Json.t\n end [@@platform js]\n\nWithout -js flag, it picks the block with `[@@platform native]`\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = string\n end [@@platform native]\n\nUse only one of the platforms\n\n $ cat > input.ml << EOF\n > include struct\n > type t = Js.Json.t\n > end [@@platform js]\n > \n > include struct\n > type t = string\n > end\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = string\n end\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n type t = Js.Json.t\n end [@@platform js]\n \n include struct\n type t = string\n end\n\nPstr_module\n\n $ cat > input_module.ml << EOF\n > module M = struct\n > let x = 42\n > end [@@platform js]\n > module M = struct\n > let x = 44\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_module.ml | ocamlformat - --enable-outside-detected-project --impl\n module M = struct\n let x = 44\n end\n [@@platform native]\n\n $ ./standalone.exe -impl input_module.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module M = struct\n let x = 42\n end\n [@@platform js]\n\nPstr_value\n\n $ cat > input_let.ml << EOF\n > let x = 42 [@@platform js]\n > let y = 44 [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_let.ml | ocamlformat - --enable-outside-detected-project --impl\n let y = 44 [@@platform native]\n\n $ ./standalone.exe -impl input_let.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let x = 42 [@@platform js]\n\nPstr_open\n\n $ cat > input_open.ml << EOF\n > open Printf [@@platform js]\n > open List [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_open.ml | ocamlformat - --enable-outside-detected-project --impl\n open List [@@platform native]\n\n $ ./standalone.exe -impl input_open.ml -js | ocamlformat - --enable-outside-detected-project --impl\n open Printf [@@platform js]\n\nPstr_exception\n\n $ cat > input_exception.ml << EOF\n > exception MyException of string [@@platform js]\n > exception AnotherException of int [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_exception.ml | ocamlformat - --enable-outside-detected-project --impl\n exception AnotherException of int [@@platform native]\n\n $ ./standalone.exe -impl input_exception.ml -js | ocamlformat - --enable-outside-detected-project --impl\n exception MyException of string [@@platform js]\n\nPstr_primitive\n\n $ cat > input_primitive.ml << EOF\n > external add : int -> int -> int = \"caml_add_int\" [@@platform js]\n > external subtract : int -> int -> int = \"caml_subtract_int\" [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_primitive.ml | ocamlformat - --enable-outside-detected-project --impl\n external subtract : int -> int -> int = \"caml_subtract_int\" [@@platform native]\n\n $ ./standalone.exe -impl input_primitive.ml -js | ocamlformat - --enable-outside-detected-project --impl\n external add : int -> int -> int = \"caml_add_int\" [@@platform js]\n\nPstr_eval (doesn't work)\n\n $ cat > input_primitive.ml << EOF\n > include struct\n > 2 [@@platform js]\n > end\n > \n > include struct\n > 3 [@@platform native]\n > end\n > EOF\n\n $ ./standalone.exe -impl input_primitive.ml | ocamlformat - --enable-outside-detected-project --impl\n include struct end\n \n include struct\n 3 [@@platform native]\n end\n\n $ ./standalone.exe -impl input_primitive.ml -js | ocamlformat - --enable-outside-detected-project --impl\n include struct\n 2 [@@platform js]\n end\n \n include struct end\n\nPstr_type\n\n $ cat > input_type.ml << EOF\n > type point = { x : int; y : int } [@@platform js]\n > type color = Red | Green | Blue [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_type.ml | ocamlformat - --enable-outside-detected-project --impl\n type color = Red | Green | Blue [@@platform native]\n\n $ ./standalone.exe -impl input_type.ml -js | ocamlformat - --enable-outside-detected-project --impl\n type point = { x : int; y : int } [@@platform js]\n\nPstr_recmodule\n\n $ cat > input_recmodule.ml << EOF\n > module rec M = struct\n > let x = 42\n > end [@@platform js]\n > module rec M = struct\n > let x = 44\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_recmodule.ml | ocamlformat - --enable-outside-detected-project --impl\n module rec M = struct\n let x = 44\n end\n [@@platform native]\n\n $ ./standalone.exe -impl input_recmodule.ml -js | ocamlformat - --enable-outside-detected-project --impl\n module rec M = struct\n let x = 42\n end\n [@@platform js]\n\nPstr_class\n\n $ cat > input_class.ml << EOF\n > class virtual ['a] base x = object\n > method get = x\n > end [@@platform js]\n > class derived = object\n > inherit base 42\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_class.ml | ocamlformat - --enable-outside-detected-project --impl\n class derived =\n object\n inherit base 42\n end [@@platform native]\n\n $ ./standalone.exe -impl input_class.ml -js | ocamlformat - --enable-outside-detected-project --impl\n class virtual ['a] base x =\n object\n method get = x\n end [@@platform js]\n\nPstr_class_type\n\n $ cat > input_class_type.ml << EOF\n > class type base = object\n > method get : int\n > end [@@platform js]\n > class type derived = object\n > inherit base\n > end [@@platform native]\n > EOF\n\n $ ./standalone.exe -impl input_class_type.ml | ocamlformat - --enable-outside-detected-project --impl\n class type derived = object\n inherit base\n end [@@platform native]\n\n $ ./standalone.exe -impl input_class_type.ml -js | ocamlformat - --enable-outside-detected-project --impl\n class type base = object\n method get : int\n end [@@platform js]\n"
},
{
"path": "packages/browser-ppx/tests/standalone.ml",
"content": "(* To run as a standalone binary, run the registered drivers *)\nlet () = Ppxlib.Driver.standalone ()\n"
},
{
"path": "packages/browser-ppx/tests/structure_item.t",
"content": " $ cat > input.ml << EOF\n > [%%browser_only let ( let+ ) = fun p f -> map f p]\n > \n > let%browser_only pexp_ident = Webapi__Dom__Element.asHtmlElement\n > \n > let%browser_only pexp_fun_1arg_structure_item evt =\n > Webapi.Dom.getElementById \"foo\"\n > \n > let%browser_only pexp_fun_2arg_structure_item evt moar_arguments =\n > let a = \"foo\" in\n > Webapi.Dom.getElementById a\n > \n > let%browser_only pexp_fun_2arg_structure_item evt moar_arguments =\n > let a = \"foo\" in\n > let a = \"foo\" in\n > Webapi.Dom.getElementById a\n > \n > let%browser_only perform ?abortController ?(base = defaultBase) (req : ('handler, 'a, 'i, 'o) Client.request) input =\n > Js.log abortController;\n > Js.log base;\n > Js.log req;\n > Js.log input\n > \n > EOF\n\nWith -js flag everything keeps as it is and browser_only extension disappears\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let ( let+ ) p f = map f p\n let pexp_ident = Webapi__Dom__Element.asHtmlElement\n let pexp_fun_1arg_structure_item evt = Webapi.Dom.getElementById \"foo\"\n \n let pexp_fun_2arg_structure_item evt moar_arguments =\n let a = \"foo\" in\n Webapi.Dom.getElementById a\n \n let pexp_fun_2arg_structure_item evt moar_arguments =\n let a = \"foo\" in\n let a = \"foo\" in\n Webapi.Dom.getElementById a\n \n let perform ?abortController ?(base = defaultBase)\n (req : ('handler, 'a, 'i, 'o) Client.request) input =\n Js.log abortController;\n Js.log base;\n Js.log req;\n Js.log input\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let (( let+ )\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun p ->\n Runtime.fail_impossible_action_in_ssr \"let+\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (pexp_ident\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n Obj.magic () [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (pexp_fun_1arg_structure_item\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun evt ->\n Runtime.fail_impossible_action_in_ssr \"pexp_fun_1arg_structure_item\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (pexp_fun_2arg_structure_item\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun evt ->\n Runtime.fail_impossible_action_in_ssr \"pexp_fun_2arg_structure_item\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (pexp_fun_2arg_structure_item\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun evt ->\n Runtime.fail_impossible_action_in_ssr \"pexp_fun_2arg_structure_item\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (perform\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun ?abortController ->\n Runtime.fail_impossible_action_in_ssr \"perform\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\nReplace Runtime.fail_impossible_action_in_ssr with print_endline so ocamlc can compile it without the Runtime module dependency\n $ echo \"module Runtime = struct\" >> output.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> output.ml\n $ echo \"end\" >> output.ml\n $ ocamlc -c output.ml\n"
},
{
"path": "packages/browser-ppx/tests/structure_item_re.t",
"content": " $ cat > input.re << EOF\n > let%browser_only valueFromEvent = evt => React.Event.Form.target(evt)##value;\n > let%browser_only getSortedWordCountsBrowserOnly = (words: array(string)): array((string, int)) => {\n > words->List.map->Js.log;\n > };\n > \n > let%browser_only renderToElementWithId = (~id=\"\", component) => {\n > switch (ReactDOM.querySelector(\"#\" ++ id)) {\n > | Some(node) =>\n > let root = ReactDOM.Client.createRoot(node);\n > ReactDOM.Client.render(root, component);\n > | None => Js.Console.error(\"RR.renderToElementWithId : no element of id '\" ++ id ++ \"' found in the HTML.\")\n > };\n > };\n > \n > let%browser_only getSortedWordCountsBrowserOnly = (words: array(string)): array((string, int)) => {\n > words |> Js.log |> List.map;\n > };\n > \n > let%browser_only getSortedWordCountsBrowserOnly = (words: array(string)): array((string, int)) => {\n > words\n > ->Js.Array2.reduce(\n > (acc, word) => {\n > Map.String.update(acc, word, count =>\n > switch (count) {\n > | Some(existingCount) => Some(existingCount + 1)\n > | None => Some(1)\n > }\n > )\n > },\n > Map.String.empty\n > )\n > ->Map.String.toArray\n > ->Js.Array2.sortInPlaceWith(((_, a), (_, b)) => b - a);\n > };\n > \n > EOF\n\n $ refmt --print ml input.re > input.ml\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let valueFromEvent evt = (React.Event.Form.target evt)##value\n \n let getSortedWordCountsBrowserOnly (words : string array) =\n (words |. List.map |. Js.log : (string * int) array)\n \n let renderToElementWithId ?(id = \"\") =\n fun component ->\n match ReactDOM.querySelector (\"#\" ^ id) with\n | ((Some node) [@explicit_arity]) ->\n let root = ReactDOM.Client.createRoot node in\n ReactDOM.Client.render root component\n | None ->\n Js.Console.error\n (\"RR.renderToElementWithId : no element of id '\" ^ id\n ^ \"' found in the HTML.\")\n \n let getSortedWordCountsBrowserOnly (words : string array) =\n (words |> Js.log |> List.map : (string * int) array)\n \n let getSortedWordCountsBrowserOnly (words : string array) =\n (((words |. Js.Array2.reduce)\n (fun acc ->\n fun word ->\n Map.String.update acc word (fun count ->\n match count with\n | ((Some existingCount) [@explicit_arity]) ->\n Some (existingCount + 1) [@explicit_arity]\n | None -> Some 1 [@explicit_arity]))\n Map.String.empty\n |. Map.String.toArray |. Js.Array2.sortInPlaceWith) (fun (_, a) ->\n fun (_, b) -> b - a)\n : (string * int) array)\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let (valueFromEvent\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun evt ->\n Runtime.fail_impossible_action_in_ssr \"valueFromEvent\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (getSortedWordCountsBrowserOnly\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun words ->\n Runtime.fail_impossible_action_in_ssr \"getSortedWordCountsBrowserOnly\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (renderToElementWithId\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun ?id component ->\n Runtime.fail_impossible_action_in_ssr \"renderToElementWithId\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (getSortedWordCountsBrowserOnly\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun words ->\n Runtime.fail_impossible_action_in_ssr \"getSortedWordCountsBrowserOnly\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n \n let (getSortedWordCountsBrowserOnly\n [@alert\n browser_only\n \"This expression is marked to only run on the browser where \\\n JavaScript can run. You can only use it inside a let%browser_only \\\n function.\"]) =\n (fun words ->\n Runtime.fail_impossible_action_in_ssr \"getSortedWordCountsBrowserOnly\")\n [@alert \"-browser_only\"]\n [@@warning \"-27-32\"]\n"
},
{
"path": "packages/browser-ppx/tests/switch-platform.t/input.re",
"content": "switch%platform (Runtime.platform) {\n| Runtime.Server => doServerSideLogic()\n| Client => doClientSideLogic()\n};\n\nlet value =\n switch%platform (Runtime.platform) {\n | Server => doServerSideLogic()\n | Client => doClientSideLogic()\n };\n\nlet universal_fn = () => {\n switch%platform (Runtime.platform) {\n | Server => doServerSideLogic()\n | Client => doClientSideLogic()\n };\n};\n\nlet universal_fn_with_arg1 = arg1 => {\n switch%platform (Runtime.platform) {\n | Server => doServerSideLogic(arg1)\n | Client => doClientSideLogic()\n };\n};\n"
},
{
"path": "packages/browser-ppx/tests/switch-platform.t/run.t",
"content": "With -js flag everything keeps as it is and effect extension disappears\n\n $ refmt --parse re --print ml input.re > input.re.ml\n\n $ ../standalone.exe -impl input.re.ml -js | ocamlformat - --enable-outside-detected-project --impl\n doClientSideLogic ();;\n \n let value = doClientSideLogic ()\n let universal_fn () = doClientSideLogic ()\n let universal_fn_with_arg1 arg1 = doClientSideLogic ()\n\nWithout -js flag, the compilation to native replaces the effect expression\nwith a no-op effect, raises in case of wrongly applied to other than an effect.\n\n $ ../standalone.exe -impl input.re.ml | ocamlformat - --enable-outside-detected-project --impl\n doServerSideLogic ();;\n \n let value = doServerSideLogic ()\n let universal_fn () = doServerSideLogic ()\n let universal_fn_with_arg1 arg1 = doServerSideLogic arg1\n"
},
{
"path": "packages/browser-ppx/tests/use_effect.t",
"content": " $ cat > input.re << EOF\n > [@react.component]\n > let make = () => {\n > let (state, dispatch) = React.useReducer(reducer, initialState);\n > \n > React.useEffect0(() => {\n > dispatch @@ UsersRequestStarted;\n > None;\n > });\n > \n > ;\n > };\n > EOF\n\n $ refmt --parse re --print ml input.re > input.ml\n\nWith -js flag everything keeps as it is\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let state, dispatch = React.useReducer reducer initialState in\n React.useEffect0 (fun () ->\n dispatch @@ UsersRequestStarted;\n None);\n div ~children:[] () [@JSX]\n [@@react.component]\n\nWithout -js flag, we add the browser_only transformation and browser_only applies the transformation to fail_impossible_action_in_ssr\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let state, dispatch = React.useReducer reducer initialState in\n React.useEffect0 (fun () ->\n Runtime.fail_impossible_action_in_ssr \"\");\n div ~children:[] () [@JSX]\n [@@react.component]\n\n $ cat > input.re << EOF\n > [@react.component]\n > let make = () => {\n > React.useEffect2(\n > () => {\n > if (uiState == Submitted) {\n > dispatch @@\n > CurrentPasswordUpdated(\n > switch (currentPassword) {\n > | WithValue(value) when value == \"\" => Empty\n > | _ => currentPassword\n > },\n > );\n > \n > switch (currentPassword, newPassword) {\n > | (WithValue(currentPassword), Valid(newPassword)) when currentPassword != \"\" =>\n > passwordReset({oldPassword: currentPassword, newPassword}, dispatch, onConfirmed)\n > | _ => dispatch @@ SubmitTriggered(Idle)\n > };\n > };\n > None;\n > },\n > (uiState, newPassword),\n > );\n > \n > ;\n > };\n > EOF\n\n $ refmt --parse re --print ml input.re > input.ml\n\nWithout -js flag, we add the browser_only transformation and browser_only applies the transformation to fail_impossible_action_in_ssr\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n React.useEffect2\n (fun () -> Runtime.fail_impossible_action_in_ssr \"\")\n (uiState, newPassword);\n div ~children:[] () [@JSX]\n [@@react.component]\n\n $ cat > input.re << EOF\n > [@react.component]\n > let make = () => {\n > let (state, dispatch) = React.useReducer(reducer, initialState);\n > \n > React.useEffect2(\n > [%browser_only\n > () => {\n > let handler = Js.Global.setTimeout(~f=_ => setDebouncedValue(focusedEntryText), delayInMs);\n > Some(_ => Js.Global.clearTimeout(handler));\n > }\n > ],\n > (focusedEntryText, delayInMs),\n > );\n > \n > ;\n > };\n > EOF\n\n $ refmt --parse re --print ml input.re > input.ml\n\nWith -js flag everything keeps as it is\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let state, dispatch = React.useReducer reducer initialState in\n React.useEffect2\n (fun () ->\n let handler =\n Js.Global.setTimeout\n ~f:(fun _ -> setDebouncedValue focusedEntryText)\n delayInMs\n in\n (Some (fun _ -> Js.Global.clearTimeout handler) [@explicit_arity]))\n (focusedEntryText, delayInMs);\n div ~children:[] () [@JSX]\n [@@react.component]\n\nWithout -js flag, we add the browser_only transformation and browser_only applies the transformation to fail_impossible_action_in_ssr\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let state, dispatch = React.useReducer reducer initialState in\n React.useEffect2\n (fun () -> Runtime.fail_impossible_action_in_ssr \"\")\n (focusedEntryText, delayInMs);\n div ~children:[] () [@JSX]\n [@@react.component]\n $ cat > input.re << EOF\n > [@react.component]\n > let make = () => {\n > let (state, dispatch) = React.useReducer(reducer, initialState);\n > \n > React.useEffect1(\n > () => {\n > isFocused ? onFocusedItemChange(domRef) : ();\n > None;\n > },\n > [|isFocused|],\n > );\n > \n > ;\n > };\n > EOF\n\n $ refmt --parse re --print ml input.re > input.ml\n\nWith -js flag everything keeps as it is\n\n $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let state, dispatch = React.useReducer reducer initialState in\n React.useEffect1\n (fun () ->\n (match isFocused with true -> onFocusedItemChange domRef | false -> ());\n None)\n [| isFocused |];\n div ~children:[] () [@JSX]\n [@@react.component]\n\nWithout -js flag, we add the browser_only transformation and browser_only applies the transformation to fail_impossible_action_in_ssr\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let make () =\n let state, dispatch = React.useReducer reducer initialState in\n React.useEffect1\n (fun () -> Runtime.fail_impossible_action_in_ssr \"\")\n [| isFocused |];\n div ~children:[] () [@JSX]\n [@@react.component]\n"
},
{
"path": "packages/esbuild-plugin/dune",
"content": "(executable\n (name extract_client_components)\n (public_name server-reason-react.extract_client_components)\n (libraries unix cmdliner))\n\n(install\n (section lib)\n (package server-reason-react)\n (files\n (plugin.mjs as esbuild-plugin/plugin.mjs)))\n"
},
{
"path": "packages/esbuild-plugin/extract_client_components.ml",
"content": "module List = ListLabels\n\nlet read_file path = try Some (In_channel.with_open_bin path In_channel.input_all) with _ -> None\n\ntype manifest_item =\n | Client_component of { original_path : string; compiled_js_path : string; module_name : string list option }\n | Server_function of {\n id : string;\n compiled_js_path : string;\n module_name : string list option;\n function_name : string;\n }\n\nlet parse_module_name str = String.split_on_char '.' str\nlet print_module_name str = String.concat \".\" str\n\nlet parse_client_component_line line =\n try\n Scanf.sscanf line \"// extract-client %s %s\" (fun filename module_name ->\n Ok (filename, if module_name = \"\" then None else Some (parse_module_name module_name)))\n with End_of_file | Scanf.Scan_failure _ -> Error \"Invalid `extract-client` command format\"\n\nlet parse_server_function_line line =\n try\n Scanf.sscanf line \"// extract-server-function %s %s %s\" (fun id function_name module_name ->\n Ok ((if module_name = \"\" then None else Some (parse_module_name module_name)), function_name, id))\n with End_of_file | Scanf.Scan_failure _ -> Error \"Invalid `extract-server-function` command format\"\n\nlet parse_manifest_item ~path line =\n match (parse_client_component_line (String.trim line), parse_server_function_line (String.trim line)) with\n | Ok (original_path, module_name), _ ->\n Some (Client_component { compiled_js_path = path; original_path; module_name })\n | _, Ok (module_name, function_name, id) ->\n Some (Server_function { compiled_js_path = path; module_name; function_name; id })\n | Error _, Error _ -> None\n\nlet parse_manifest_data ~path content : manifest_item list =\n content |> String.split_on_char '\\n' |> List.filter_map ~f:(parse_manifest_item ~path)\n\nlet render_manifest manifest =\n let register_client_modules =\n List.map manifest ~f:(function\n | Client_component { original_path; compiled_js_path; module_name } ->\n let original_path_with_submodule =\n match module_name with\n | Some name -> Printf.sprintf \"%s#%s\" original_path (print_module_name name)\n | None -> original_path\n in\n let export =\n match module_name with\n | Some name -> Printf.sprintf \"%s.make_client\" (print_module_name name)\n | None -> \"make_client\"\n in\n Printf.sprintf\n \"window.__client_manifest_map[\\\"%s\\\"] = React.lazy(() => import(\\\"%s\\\").then(module => {\\n\\\n \\ return { default: module.%s }\\n\\\n }).catch(err => { console.error(err); return { default: null }; }))\"\n original_path_with_submodule compiled_js_path export\n | Server_function { compiled_js_path; module_name; function_name; id } ->\n let export =\n match module_name with\n | Some name -> Printf.sprintf \"%s.%s\" (print_module_name name) function_name\n | None -> function_name\n in\n Printf.sprintf \"window.__server_functions_manifest_map[\\\"%s\\\"] = require(\\\"%s\\\").%s\" id compiled_js_path\n export)\n in\n Printf.sprintf\n {|import React from \"react\";\nwindow.__client_manifest_map = window.__client_manifest_map || {};\nwindow.__server_functions_manifest_map = window.__server_functions_manifest_map || {};\n%s|}\n (String.concat \"\\n\" register_client_modules)\n\n(* TODO: Add parameter to allow users to configure the extension of the files *)\nlet is_js_file path =\n let ext = Filename.extension path in\n ext = \".js\" || ext = \".bs.js\" || ext = \".jsx\"\n\n(* TODO: refactor path to be a Filepath, not a string *)\nlet capture_all_client_modules_files_in_target path =\n let rec traverse_fs path =\n try\n match Sys.is_directory path with\n | true ->\n let contents = Sys.readdir path in\n Array.fold_left\n (fun acc entry ->\n let full_path = Filename.concat path entry in\n match acc with\n | Ok files -> (\n match traverse_fs full_path with Ok new_files -> Ok (files @ new_files) | Error err -> Error err)\n | Error err -> Error err)\n (Ok []) contents\n | false ->\n if is_js_file path then\n match read_file path with\n | Some content -> Ok (parse_manifest_data ~path content)\n | None -> Error (Printf.sprintf \"Failed to read file: %s\" path)\n else Ok []\n with\n | Sys_error msg -> Error (Printf.sprintf \"System error: %s\" msg)\n | Unix.Unix_error (err, _, _) -> Error (Printf.sprintf \"Unix error: %s\" (Unix.error_message err))\n | e -> Error (Printf.sprintf \"Unexpected error: %s\" (Printexc.to_string e))\n in\n traverse_fs path\n\nlet melange_target =\n let doc = \"Path to the melange target directory (melange.emit (target xxx))\" in\n Cmdliner.Arg.(required & pos 0 (some string) None & info [] ~docv:\"MELANGE_TARGET\" ~doc)\n\nlet extract_modules target =\n let current_dir = Sys.getcwd () in\n let melange_target = Filename.concat current_dir target in\n match capture_all_client_modules_files_in_target melange_target with\n | Ok manifest ->\n print_endline (render_manifest manifest);\n Ok ()\n | Error msg -> Error (`Msg msg)\n\nlet extract_cmd =\n let open Cmdliner in\n let doc = \"Extract all client modules from a Melange target folder\" in\n let sdocs = Manpage.s_common_options in\n let info = Cmd.info \"extract-client-components\" ~version:\"1.0.0\" ~doc ~sdocs in\n let term = Term.(term_result (const extract_modules $ melange_target)) in\n Cmd.v info term\n\nlet () = exit (Cmdliner.Cmd.eval extract_cmd)\n"
},
{
"path": "packages/esbuild-plugin/package.json",
"content": "{\n \"name\": \"server-reason-react-esbuild-plugin\",\n \"description\": \"esbuild plugin to enable React server components with server-reason-react\",\n \"version\": \"0.1.0\",\n \"exports\": {\n \".\": \"./plugin.mjs\"\n },\n \"homepage\": \"https://github.com/ml-in-barcelona/server-reason-react\",\n \"bugs\": \"https://github.com/ml-in-barcelona/server-reason-react/issues\",\n \"license\": \"MIT\",\n \"repository\": {\n \"type\": \"git\",\n \"url\": \"https://github.com/ml-in-barcelona/server-reason-react.git\",\n \"directory\": \"packages/esbuild-plugin\"\n }\n}\n"
},
{
"path": "packages/esbuild-plugin/plugin.mjs",
"content": "import Fs from \"node:fs/promises\";\nimport Path from \"node:path\";\nimport { execSync } from \"node:child_process\";\n\nasync function writeFile(path, contents, cb) {\n\tawait Fs.mkdir(Path.dirname(path), { recursive: true })\n\tFs.writeFile(path, contents, cb);\n}\n\nasync function generateBootstrapFile(output, content) {\n\tlet previousContent = undefined;\n\ttry {\n\t\tpreviousContent = await Fs.readFile(output, \"utf8\");\n\t} catch (e) {\n\t\tif (e.code !== \"ENOENT\") {\n\t\t\tthrow e;\n\t\t}\n\t}\n\tconst contentHasChanged = previousContent !== content;\n\tif (contentHasChanged) {\n\t\tawait writeFile(output, content, \"utf8\");\n\t}\n}\n\nfunction escapeRegex(string) {\n\treturn string.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');\n}\n\nexport default function plugin(config) {\n\tconst entrypointFilter = new RegExp(config.entrypoints.map(escapeRegex).join(\"|\"));\n\n\treturn {\n\t\tname: \"extract-client-components\",\n\t\tsetup(build) {\n\t\t\tif (\n\t\t\t\tconfig.bootstrapOutput &&\n\t\t\t\ttypeof config.bootstrapOutput !== \"string\"\n\t\t\t) {\n\t\t\t\tconsole.error(\"bootstrapOutput must be a string\");\n\t\t\t\treturn;\n\t\t\t}\n\t\t\tconst bootstrapOutput = config.bootstrapOutput || \"./bootstrap.js\";\n\n\t\t\tif (!config.target) {\n\t\t\t\tconsole.error(\"target is required\");\n\t\t\t\treturn;\n\t\t\t}\n\t\t\tif (typeof config.target !== \"string\") {\n\t\t\t\tconsole.error(\"target must be a string\");\n\t\t\t\treturn;\n\t\t\t}\n\n\t\t\tbuild.onStart(async () => {\n\t\t\t\ttry {\n\t\t\t\t\t/* TODO: Make sure `server-reason-react.extract_client_components` is available in $PATH */\n\t\t\t\t\tconst bootstrapContent = execSync(\n\t\t\t\t\t\t`server-reason-react.extract_client_components ${config.target}`,\n\t\t\t\t\t\t{ encoding: \"utf8\" },\n\t\t\t\t\t);\n\t\t\t\t\tawait generateBootstrapFile(bootstrapOutput, bootstrapContent);\n\t\t\t\t} catch (e) {\n\t\t\t\t\tconsole.log(\"Extraction of client components failed:\");\n\t\t\t\t\tconsole.error(e);\n\t\t\t\t\treturn;\n\t\t\t\t}\n\t\t\t});\n\n\t\t\tbuild.onResolve({ filter: entrypointFilter }, (args) => {\n\t\t\t\tconst isEntryPoint = args.kind === \"entry-point\";\n\n\t\t\t\tif (isEntryPoint) {\n\t\t\t\t\treturn {\n\t\t\t\t\t\tpath: args.path,\n\t\t\t\t\t\tnamespace: \"entrypoint\",\n\t\t\t\t\t};\n\t\t\t\t}\n\t\t\t\treturn null;\n\t\t\t});\n\n\t\t\tbuild.onLoad({ filter: entrypointFilter, namespace: \"entrypoint\" }, async (args) => {\n\t\t\t\tconst filePath = args.path.replace(/^entrypoint:/, \"\");\n\t\t\t\tconst entryPointContents = await Fs.readFile(filePath, \"utf8\");\n\t\t\t\tconst relativeBootstrapOutput = Path.relative(\n\t\t\t\t\tPath.dirname(filePath),\n\t\t\t\t\tbootstrapOutput,\n\t\t\t\t);\n\n\t\t\t\tconst contents = `\nrequire(\"./${relativeBootstrapOutput}\");\n${entryPointContents}`;\n\n\t\t\t\treturn {\n\t\t\t\t\tloader: \"jsx\",\n\t\t\t\t\tcontents,\n\t\t\t\t\tresolveDir: Path.dirname(Path.resolve(process.cwd(), filePath)),\n\t\t\t\t};\n\t\t\t});\n\t\t},\n\t};\n}\n"
},
{
"path": "packages/esbuild-plugin/test/ClientComponent.js",
"content": "// extract-client demo/universal/native/shared/Button.re\nfunction make_client() { }\n\nexport {\n make_client\n}\n"
},
{
"path": "packages/esbuild-plugin/test/ClientComponentWithModule.js",
"content": "// extract-client demo/universal/native/shared/Button.re WithModule\nfunction make_client() { }\n\nconst WithModule = {\n make_client\n}\n\nexport {\n WithModule\n}\n"
},
{
"path": "packages/esbuild-plugin/test/ServerFunction.js",
"content": "// extract-server-function 1234-4567 serverFunction\nfunction serverFunction() { }\n\n// extract-server-function 7654-3210 serverFunctionWithModule WithModule\nfunction serverFunctionWithModule() { }\n\nconst WithModule = {\n serverFunctionWithModule\n};\n"
},
{
"path": "packages/esbuild-plugin/test/dune",
"content": "(cram\n (package server-reason-react)\n (deps\n (package server-reason-react)\n ClientComponent.js\n ClientComponentWithModule.js\n ServerFunction.js\n %{bin:server-reason-react.extract_client_components}))\n"
},
{
"path": "packages/esbuild-plugin/test/run.t",
"content": " $ server-reason-react.extract_client_components ./ClientComponent.js\n import React from \"react\";\n window.__client_manifest_map = window.__client_manifest_map || {};\n window.__server_functions_manifest_map = window.__server_functions_manifest_map || {};\n window.__client_manifest_map[\"demo/universal/native/shared/Button.re\"] = React.lazy(() => import(\"$TESTCASE_ROOT/./ClientComponent.js\").then(module => {\n return { default: module.make_client }\n }).catch(err => { console.error(err); return { default: null }; }))\n\n $ server-reason-react.extract_client_components ./ClientComponentWithModule.js\n import React from \"react\";\n window.__client_manifest_map = window.__client_manifest_map || {};\n window.__server_functions_manifest_map = window.__server_functions_manifest_map || {};\n window.__client_manifest_map[\"demo/universal/native/shared/Button.re#WithModule\"] = React.lazy(() => import(\"$TESTCASE_ROOT/./ClientComponentWithModule.js\").then(module => {\n return { default: module.WithModule.make_client }\n }).catch(err => { console.error(err); return { default: null }; }))\n\n $ server-reason-react.extract_client_components ./ServerFunction.js\n import React from \"react\";\n window.__client_manifest_map = window.__client_manifest_map || {};\n window.__server_functions_manifest_map = window.__server_functions_manifest_map || {};\n window.__server_functions_manifest_map[\"1234-4567\"] = require(\"$TESTCASE_ROOT/./ServerFunction.js\").serverFunction\n window.__server_functions_manifest_map[\"7654-3210\"] = require(\"$TESTCASE_ROOT/./ServerFunction.js\").WithModule.serverFunctionWithModule\n\n"
},
{
"path": "packages/expand-styles-attribute/dune",
"content": "(library\n (name expand_styles_attribute)\n (public_name server-reason-react.expand-styles-attribute)\n (libraries ppxlib ppxlib.astlib)\n (preprocess\n (pps ppxlib.metaquot)))\n"
},
{
"path": "packages/expand-styles-attribute/expand_styles_attribute.ml",
"content": "let make ~loc attributes =\n let merge_className current_className (label, expr) =\n match current_className with\n | Some (existing_label, existing_expr) ->\n let merged =\n match label with\n | Ppxlib.Optional \"className\" ->\n [%expr match [%e expr] with None -> [%e existing_expr] | Some x -> x ^ \" \" ^ [%e existing_expr]]\n | _ -> [%expr [%e expr] ^ \" \" ^ [%e existing_expr]]\n in\n Some (existing_label, merged)\n | None -> Some (label, expr)\n in\n let merge_style current_style (label, expr) =\n match current_style with\n | Some (existing_label, existing_expr) ->\n let merged =\n match label with\n | Ppxlib.Optional \"style\" ->\n [%expr\n match [%e expr] with\n | None -> [%e existing_expr]\n | Some x -> ReactDOM.Style.combine [%e existing_expr] x]\n | _ -> [%expr ReactDOM.Style.combine [%e existing_expr] [%e expr]]\n in\n Some (existing_label, merged)\n | None -> Some (label, expr)\n in\n let handle_styles className style label arg =\n let className_label, className_expr, style_label, style_expr =\n match label with\n | Ppxlib.Labelled \"styles\" ->\n (Ppxlib.Labelled \"className\", [%expr fst [%e arg]], Ppxlib.Labelled \"style\", [%expr snd [%e arg]])\n | _ ->\n ( Ppxlib.Optional \"className\",\n [%expr match [%e arg] with None -> None | Some x -> Some (fst x)],\n Ppxlib.Optional \"style\",\n [%expr match [%e arg] with None -> None | Some x -> Some (snd x)] )\n in\n (merge_className className (className_label, className_expr), merge_style style (style_label, style_expr))\n in\n let rec aux (className, style, other_args) args =\n match args with\n | [] ->\n let rest = List.rev other_args in\n ([ className; style ] |> List.filter_map Stdlib.Fun.id) @ rest\n | (label, arg) :: rest -> (\n match label with\n | Ppxlib.Labelled \"className\" | Ppxlib.Optional \"className\" ->\n aux (merge_className className (label, arg), style, other_args) rest\n | Ppxlib.Labelled \"style\" | Ppxlib.Optional \"style\" ->\n aux (className, merge_style style (label, arg), other_args) rest\n | Ppxlib.Labelled \"styles\" | Ppxlib.Optional \"styles\" ->\n let new_className, new_style = handle_styles className style label arg in\n aux (new_className, new_style, other_args) rest\n | _ -> aux (className, style, (label, arg) :: other_args) rest)\n in\n aux (None, None, []) attributes\n"
},
{
"path": "packages/expand-styles-attribute/test/dune",
"content": "(test\n (name test)\n (libraries\n ppxlib\n ppxlib.astlib\n alcotest\n server-reason-react.expand-styles-attribute)\n (preprocess\n (pps ppxlib.metaquot)))\n"
},
{
"path": "packages/expand-styles-attribute/test/test.ml",
"content": "let test_expand_styles () =\n let loc = Ppxlib.Location.none in\n let expr = [%expr \"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()] in\n let attributes = [ (Ppxlib.Labelled \"styles\", expr) ] in\n let expanded_attributes = Expand_styles_attribute.make ~loc:Ppxlib.Location.none attributes in\n\n List.iter\n (fun attribute ->\n match attribute with\n | ( Ppxlib.Labelled \"className\",\n [%expr fst (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ())] ) ->\n Alcotest.(check pass) \"className uses fst\" () ()\n | Ppxlib.Labelled \"style\", [%expr snd (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ())] ->\n Alcotest.(check pass) \"style uses snd\" () ()\n | _ -> Alcotest.fail \"Expanded attributes should be className and style\")\n expanded_attributes\n\nlet test_expand_styles_with_previous_className () =\n let loc = Ppxlib.Location.none in\n let expr = [%expr \"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()] in\n let attributes = [ (Ppxlib.Labelled \"className\", [%expr \"previous-class-name\"]); (Ppxlib.Labelled \"styles\", expr) ] in\n let expanded_attributes = Expand_styles_attribute.make ~loc:Ppxlib.Location.none attributes in\n List.iter\n (fun attribute ->\n match attribute with\n | ( Ppxlib.Labelled \"className\",\n [%expr\n fst (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()) ^ \" \" ^ \"previous-class-name\"]\n ) ->\n Alcotest.(check pass) \"className uses previous class name\" () ()\n | Ppxlib.Labelled \"style\", [%expr snd (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ())] ->\n Alcotest.(check pass) \"style uses combine\" () ()\n | _ -> Alcotest.fail \"Expanded attributes should be className and style\")\n expanded_attributes\n\nlet test_expand_styles_with_previous_style () =\n let loc = Ppxlib.Location.none in\n let expr = [%expr \"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()] in\n let attributes = [ (Ppxlib.Labelled \"style\", [%expr \"previous-style\"]); (Ppxlib.Labelled \"styles\", expr) ] in\n let expanded_attributes = Expand_styles_attribute.make ~loc:Ppxlib.Location.none attributes in\n List.iter\n (fun attribute ->\n match attribute with\n | ( Ppxlib.Labelled \"className\",\n [%expr fst (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ())] ) ->\n Alcotest.(check pass) \"className uses fst\" () ()\n | ( Ppxlib.Labelled \"style\",\n [%expr\n ReactDOM.Style.combine \"previous-style\"\n (snd (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()))] ) ->\n Alcotest.(check pass) \"style uses combine\" () ()\n | _ -> Alcotest.fail \"Expanded attributes should be className and style\")\n expanded_attributes\n\nlet test_expand_styles_optional () =\n let loc = Ppxlib.Location.none in\n let expr = [%expr Some (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ())] in\n let attributes = [ (Ppxlib.Optional \"styles\", expr) ] in\n let expanded_attributes = Expand_styles_attribute.make ~loc:Ppxlib.Location.none attributes in\n List.iter\n (fun attribute ->\n match attribute with\n | ( Ppxlib.Optional \"className\",\n [%expr\n match Some (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()) with\n | None -> None\n | Some x -> Some (fst x)] ) ->\n Alcotest.(check pass) \"className uses fst\" () ()\n | ( Ppxlib.Optional \"style\",\n [%expr\n match Some (\"some-class-name\", ReactDOM.Style.make ~backgroundColor:\"gainsboro\" ()) with\n | None -> None\n | Some x -> Some (snd x)] ) ->\n Alcotest.(check pass) \"style uses snd\" () ()\n | _ -> Alcotest.fail \"Expanded attributes should be className and style\")\n expanded_attributes\n\nlet test title fn = (title, [ Alcotest.test_case \"\" `Quick fn ])\n\nlet () =\n Alcotest.run \"expand_styles_attribute\"\n [\n test \"expand_styles_prop_on_attributes\" test_expand_styles;\n test \"expand_styles_with_previous_className\" test_expand_styles_with_previous_className;\n test \"expand_styles_with_previous_style\" test_expand_styles_with_previous_style;\n test \"expand_styles_optional\" test_expand_styles_optional;\n ]\n"
},
{
"path": "packages/fetch/Fetch.ml",
"content": "type body\ntype bodyInit\ntype headers = string Js.Dict.t\ntype headersInit\ntype response\ntype request\ntype requestInit\ntype signal = { aborted : bool; onabort : (unit -> unit) option; reason : string option }\ntype abortController = { signal : signal; abort : unit -> unit }\n\n(* external *)\ntype arrayBuffer (* TypedArray *)\ntype bufferSource (* Web IDL, either an arrayBuffer or arrayBufferView *)\ntype formData (* XMLHttpRequest *)\ntype readableStream (* Streams *)\ntype urlSearchParams (* URL *)\ntype blob\ntype file\n\nmodule AbortController = struct\n type t = abortController\n\n (* external signal : t -> signal = \"signal\" [@@mel.get] *)\n let signal controller = controller.signal\n\n (* external abort : unit = \"abort\" [@@mel.send.pipe: t] *)\n let abort controller = controller.abort ()\n\n (* external make : unit -> t = \"AbortController\" [@@mel.new] *)\n let make () = { signal = { aborted = false; onabort = None; reason = None }; abort = (fun _ -> ()) }\nend\n\ntype requestMethod = Get | Head | Post | Put | Delete | Connect | Options | Trace | Patch | Other of string\n\nlet encodeRequestMethod =\n (* internal *)\n function\n | Get -> \"GET\"\n | Head -> \"HEAD\"\n | Post -> \"POST\"\n | Put -> \"PUT\"\n | Delete -> \"DELETE\"\n | Connect -> \"CONNECT\"\n | Options -> \"OPTIONS\"\n | Trace -> \"TRACE\"\n | Patch -> \"PATCH\"\n | Other method_ -> method_\n\nlet decodeRequestMethod =\n (* internal *)\n function\n | \"GET\" -> Get\n | \"HEAD\" -> Head\n | \"POST\" -> Post\n | \"PUT\" -> Put\n | \"DELETE\" -> Delete\n | \"CONNECT\" -> Connect\n | \"OPTIONS\" -> Options\n | \"TRACE\" -> Trace\n | \"PATCH\" -> Patch\n | method_ -> Other method_\n\ntype referrerPolicy =\n | None\n | NoReferrer\n | NoReferrerWhenDowngrade\n | SameOrigin\n | Origin\n | StrictOrigin\n | OriginWhenCrossOrigin\n | StrictOriginWhenCrossOrigin\n | UnsafeUrl\n\nlet encodeReferrerPolicy =\n (* internal *)\n function\n | NoReferrer -> \"no-referrer\"\n | None -> \"\"\n | NoReferrerWhenDowngrade -> \"no-referrer-when-downgrade\"\n | SameOrigin -> \"same-origin\"\n | Origin -> \"origin\"\n | StrictOrigin -> \"strict-origin\"\n | OriginWhenCrossOrigin -> \"origin-when-cross-origin\"\n | StrictOriginWhenCrossOrigin -> \"strict-origin-when-cross-origin\"\n | UnsafeUrl -> \"unsafe-url\"\n\nlet decodeReferrerPolicy =\n (* internal *)\n function\n | \"no-referrer\" -> NoReferrer\n | \"\" -> None\n | \"no-referrer-when-downgrade\" -> NoReferrerWhenDowngrade\n | \"same-origin\" -> SameOrigin\n | \"origin\" -> Origin\n | \"strict-origin\" -> StrictOrigin\n | \"origin-when-cross-origin\" -> OriginWhenCrossOrigin\n | \"strict-origin-when-cross-origin\" -> StrictOriginWhenCrossOrigin\n | \"unsafe-url\" -> UnsafeUrl\n | e -> raise (Failure (\"Unknown referrerPolicy: \" ^ e))\n\ntype requestType =\n | None (* default? unknown? just empty string in spec *)\n | Audio\n | Font\n | Image\n | Script\n | Style\n | Track\n | Video\n\nlet decodeRequestType =\n (* internal *)\n function\n | \"audio\" -> Audio\n | \"\" -> None\n | \"font\" -> Font\n | \"image\" -> Image\n | \"script\" -> Script\n | \"style\" -> Style\n | \"track\" -> Track\n | \"video\" -> Video\n | e -> raise (Failure (\"Unknown requestType: \" ^ e))\n\ntype requestDestination =\n | None (* default? unknown? just empty string in spec *)\n | Document\n | Embed\n | Font\n | Image\n | Manifest\n | Media\n | Object\n | Report\n | Script\n | ServiceWorker\n | SharedWorker\n | Style\n | Worker\n | Xslt\n\nlet decodeRequestDestination =\n (* internal *)\n function\n | \"document\" -> Document\n | \"\" -> None\n | \"embed\" -> Embed\n | \"font\" -> Font\n | \"image\" -> Image\n | \"manifest\" -> Manifest\n | \"media\" -> Media\n | \"object\" -> Object\n | \"report\" -> Report\n | \"script\" -> Script\n | \"serviceworker\" -> ServiceWorker\n | \"sharedworder\" -> SharedWorker\n | \"style\" -> Style\n | \"worker\" -> Worker\n | \"xslt\" -> Xslt\n | e -> raise (Failure (\"Unknown requestDestination: \" ^ e))\n\ntype requestMode = Navigate | SameOrigin | NoCORS | CORS\n\nlet encodeRequestMode =\n (* internal *)\n function\n | Navigate -> \"navigate\"\n | SameOrigin -> \"same-origin\"\n | NoCORS -> \"no-cors\"\n | CORS -> \"cors\"\n\nlet decodeRequestMode =\n (* internal *)\n function\n | \"navigate\" -> Navigate\n | \"same-origin\" -> SameOrigin\n | \"no-cors\" -> NoCORS\n | \"cors\" -> CORS\n | e -> raise (Failure (\"Unknown requestMode: \" ^ e))\n\ntype requestCredentials = Omit | SameOrigin | Include\n\nlet encodeRequestCredentials =\n (* internal *)\n function\n | Omit -> \"omit\"\n | SameOrigin -> \"same-origin\"\n | Include -> \"include\"\n\nlet decodeRequestCredentials =\n (* internal *)\n function\n | \"omit\" -> Omit\n | \"same-origin\" -> SameOrigin\n | \"include\" -> Include\n | e -> raise (Failure (\"Unknown requestCredentials: \" ^ e))\n\ntype requestCache = Default | NoStore | Reload | NoCache | ForceCache | OnlyIfCached\n\nlet encodeRequestCache =\n (* internal *)\n function\n | Default -> \"default\"\n | NoStore -> \"no-store\"\n | Reload -> \"reload\"\n | NoCache -> \"no-cache\"\n | ForceCache -> \"force-cache\"\n | OnlyIfCached -> \"only-if-cached\"\n\nlet decodeRequestCache =\n (* internal *)\n function\n | \"default\" -> Default\n | \"no-store\" -> NoStore\n | \"reload\" -> Reload\n | \"no-cache\" -> NoCache\n | \"force-cache\" -> ForceCache\n | \"only-if-cached\" -> OnlyIfCached\n | e -> raise (Failure (\"Unknown requestCache: \" ^ e))\n\ntype requestRedirect = Follow | Error | Manual\n\nlet encodeRequestRedirect =\n (* internal *)\n function\n | Follow -> \"follow\"\n | Error -> \"error\"\n | Manual -> \"manual\"\n\nlet decodeRequestRedirect =\n (* internal *)\n function\n | \"follow\" -> Follow\n | \"error\" -> Error\n | \"manual\" -> Manual\n | e -> raise (Failure (\"Unknown requestRedirect: \" ^ e))\n\nmodule HeadersInit = struct\n type t = headersInit\n\n external make : < .. > Js.t -> t = \"%identity\"\n external makeWithDict : string Js.Dict.t -> t = \"%identity\"\n\n (* external makeWithArray : (string * string) array -> t = \"%identity\" *)\n let makeWithArray arr =\n let dict = Js.Dict.empty () in\n Array.iter (fun (k, v) -> Js.Dict.set dict k v) arr;\n makeWithDict dict\nend\n\nmodule Headers = struct\n type t = headers\n\n (* external make : t = \"Headers\" [@@mel.new] *)\n let make () = Js.Dict.empty ()\n\n (* external makeWithInit : headersInit -> t = \"Headers\" [@@mel.new] *)\n external makeWithInit : headersInit -> t = \"Headers\" [@@mel.new]\n external append : string -> string -> unit = \"append\" [@@mel.send.pipe: t]\n external delete : string -> unit = \"delete\" [@@mel.send.pipe: t]\n (* entries *)\n (* very experimental *)\n\n external get : string -> string option = \"get\" [@@mel.send.pipe: t] [@@mel.return { null_to_opt }]\n external has : string -> bool = \"has\" [@@mel.send.pipe: t]\n (* keys *)\n (* very experimental *)\n\n external set : string -> string -> unit = \"set\" [@@mel.send.pipe: t]\n (* values *)\n (* very experimental *)\nend\n\nmodule BodyInit = struct\n type t = bodyInit\n\n external make : string -> t = \"%identity\"\n external makeWithBlob : blob -> t = \"%identity\"\n external makeWithBufferSource : bufferSource -> t = \"%identity\"\n external makeWithFormData : formData -> t = \"%identity\"\n external makeWithUrlSearchParams : urlSearchParams -> t = \"%identity\"\nend\n\nmodule Body = struct\n module Impl (T : sig\n type t\n end) =\n struct\n external body : T.t -> readableStream = \"body\" [@@mel.get]\n external bodyUsed : T.t -> bool = \"bodyUsed\" [@@mel.get]\n external arrayBuffer : arrayBuffer Js.Promise.t = \"arrayBuffer\" [@@mel.send.pipe: T.t]\n external blob : blob Js.Promise.t = \"blob\" [@@mel.send.pipe: T.t]\n external formData : formData Js.Promise.t = \"formData\" [@@mel.send.pipe: T.t]\n external json : Js.Json.t Js.Promise.t = \"json\" [@@mel.send.pipe: T.t]\n external text : string Js.Promise.t = \"text\" [@@mel.send.pipe: T.t]\n end\n\n type t = body\n\n include Impl (struct\n type nonrec t = t\n end)\nend\n\nmodule RequestInit = struct\n type t = requestInit\n\n let map f = function\n (* internal *)\n | Some v -> Some (f v)\n | None -> None\n\n external make :\n ?_method:string ->\n ?headers:headersInit ->\n ?body:bodyInit ->\n ?referrer:string ->\n ?referrerPolicy:string ->\n ?mode:string ->\n ?credentials:string ->\n ?cache:string ->\n ?redirect:string ->\n ?integrity:string ->\n ?keepalive:bool ->\n ?signal:signal ->\n unit ->\n requestInit = \"\"\n [@@mel.obj]\n\n let make ?(method_ : requestMethod option) ?(headers : headersInit option) ?(body : bodyInit option)\n ?(referrer : string option) ?(referrerPolicy : referrerPolicy = None) ?(mode : requestMode option)\n ?(credentials : requestCredentials option) ?(cache : requestCache option) ?(redirect : requestRedirect option)\n ?(integrity : string = \"\") ?(keepalive : bool option) ?(signal : signal option) =\n make ?_method:(map encodeRequestMethod method_) ?headers ?body ?referrer\n ~referrerPolicy:(encodeReferrerPolicy referrerPolicy) ?mode:(map encodeRequestMode mode)\n ?credentials:(map encodeRequestCredentials credentials)\n ?cache:(map encodeRequestCache cache) ?redirect:(map encodeRequestRedirect redirect) ~integrity ?keepalive ?signal\nend\n\nmodule Request = struct\n type t = request\n\n include Body.Impl (struct\n type nonrec t = t\n end)\n\n external make : string -> t = \"Request\" [@@mel.new]\n external makeWithInit : string -> requestInit -> t = \"Request\" [@@mel.new]\n external makeWithRequest : t -> t = \"Request\" [@@mel.new]\n external makeWithRequestInit : t -> requestInit -> t = \"Request\" [@@mel.new]\n external method_ : t -> string = \"method\" [@@mel.get]\n\n let method_ : t -> requestMethod = fun self -> decodeRequestMethod (method_ self)\n\n external url : t -> string = \"url\" [@@mel.get]\n external headers : t -> headers = \"headers\" [@@mel.get]\n external type_ : t -> string = \"type\" [@@mel.get]\n\n let type_ : t -> requestType = fun self -> decodeRequestType (type_ self)\n\n external destination : t -> string = \"destination\" [@@mel.get]\n\n let destination : t -> requestDestination = fun self -> decodeRequestDestination (destination self)\n\n external referrer : t -> string = \"referrer\" [@@mel.get]\n external referrerPolicy : t -> string = \"referrerPolicy\" [@@mel.get]\n\n let referrerPolicy : t -> referrerPolicy = fun self -> decodeReferrerPolicy (referrerPolicy self)\n\n external mode : t -> string = \"mode\" [@@mel.get]\n\n let mode : t -> requestMode = fun self -> decodeRequestMode (mode self)\n\n external credentials : t -> string = \"credentials\" [@@mel.get]\n\n let credentials : t -> requestCredentials = fun self -> decodeRequestCredentials (credentials self)\n\n external cache : t -> string = \"cache\" [@@mel.get]\n\n let cache : t -> requestCache = fun self -> decodeRequestCache (cache self)\n\n external redirect : t -> string = \"redirect\" [@@mel.get]\n\n let redirect : t -> requestRedirect = fun self -> decodeRequestRedirect (redirect self)\n\n external integrity : t -> string = \"integrity\" [@@mel.get]\n external keepalive : t -> bool = \"keepalive\" [@@mel.get]\n external signal : t -> signal = \"signal\" [@@mel.get]\nend\n\nmodule Response = struct\n type t = response\n\n include Body.Impl (struct\n type nonrec t = t\n end)\n\n external error : unit -> t = \"error\"\n external redirect : string -> t = \"redirect\"\n external redirectWithStatus : string -> int (* enum-ish *) -> t = \"redirect\"\n external headers : t -> headers = \"headers\" [@@mel.get]\n external ok : t -> bool = \"ok\" [@@mel.get]\n external redirected : t -> bool = \"redirected\" [@@mel.get]\n external status : t -> int = \"status\" [@@mel.get]\n external statusText : t -> string = \"statusText\" [@@mel.get]\n external type_ : t -> string = \"type\" [@@mel.get]\n external url : t -> string = \"url\" [@@mel.get]\n external clone : t = \"clone\" [@@mel.send.pipe: t]\nend\n\nmodule FormData = struct\n module EntryValue = struct\n type t\n\n let%browser_only classify t = if Js.typeof t = \"string\" then `String (Obj.magic t) else `File (Obj.magic t)\n end\n\n module Iterator = struct\n module Next = struct\n type 'a t\n\n external done_ : _ t -> bool option = \"done\" [@@mel.get]\n external value : 'a t -> 'a option = \"value\" [@@mel.get] [@@mel.return nullable]\n end\n\n type 'a t\n\n external next : 'a t -> 'a Next.t = \"next\" [@@mel.send]\n\n let rec forEach ~f t =\n let item = next t in\n match Next.(done_ item, value item) with\n | Some true, Some value -> f value\n | Some true, None -> ()\n | (Some false | None), Some value ->\n f value;\n forEach ~f t\n | (Some false | None), None -> forEach ~f t\n end\n\n type t = formData\n\n external make : unit -> t = \"FormData\" [@@mel.new]\n external append : string -> string -> unit = \"append\" [@@mel.send.pipe: t]\n external delete : string -> unit = \"delete\" [@@mel.send.pipe: t]\n external get : string -> EntryValue.t option = \"get\" [@@mel.send.pipe: t]\n external getAll : string -> EntryValue.t array = \"getAll\" [@@mel.send.pipe: t]\n external set : string -> string -> unit = \"set\" [@@mel.send.pipe: t]\n external has : string -> bool = \"has\" [@@mel.send.pipe: t]\n external keys : t -> string Iterator.t = \"keys\" [@@mel.send]\n external values : t -> EntryValue.t Iterator.t = \"values\" [@@mel.send]\n external appendObject : string -> < .. > Js.t -> ?filename:string -> unit = \"append\" [@@mel.send.pipe: t]\n external appendBlob : string -> blob -> ?filename:string -> unit = \"append\" [@@mel.send.pipe: t]\n external appendFile : string -> file -> ?filename:string -> unit = \"append\" [@@mel.send.pipe: t]\n external setObject : string -> < .. > Js.t -> ?filename:string -> unit = \"set\" [@@mel.send.pipe: t]\n external setBlob : string -> blob -> ?filename:string -> unit = \"set\" [@@mel.send.pipe: t]\n external setFile : string -> file -> ?filename:string -> unit = \"set\" [@@mel.send.pipe: t]\n external entries : t -> (string * EntryValue.t) Iterator.t = \"entries\" [@@mel.send]\nend\n\nexternal fetch : string -> response Js.Promise.t = \"fetch\"\nexternal fetchWithInit : string -> requestInit -> response Js.Promise.t = \"fetch\"\nexternal fetchWithRequest : request -> response Js.Promise.t = \"fetch\"\nexternal fetchWithRequestInit : request -> requestInit -> response Js.Promise.t = \"fetch\"\n"
},
{
"path": "packages/fetch/dune",
"content": "(library\n (name fetch)\n (public_name server-reason-react.fetch)\n (libraries server-reason-react.js)\n (modules Fetch)\n (preprocess\n (pps melange_native_ppx browser_ppx)))\n"
},
{
"path": "packages/html/Html.ml",
"content": "let is_self_closing_tag = function\n (* Take the list from\n https://github.com/facebook/react/blob/97d75c9c8bcddb0daed1ed062101c7f5e9b825f4/packages/react-dom-bindings/src/shared/omittedCloseTags.js but found https://github.com/wooorm/html-void-elements to be more complete. *)\n | \"area\" | \"base\" | \"basefont\" | \"bgsound\" | \"br\" | \"col\" | \"command\" | \"embed\" | \"frame\" | \"hr\" | \"image\" | \"img\"\n | \"input\" | \"keygen\" | \"link\" (* | \"menuitem\" *) | \"meta\" | \"param\" | \"source\" | \"track\" | \"wbr\" ->\n true\n | _ -> false\n\nlet escape buf s =\n let length = String.length s in\n let exception First_char_to_escape of int in\n match\n for i = 0 to length - 1 do\n match String.unsafe_get s i with\n | '&' | '<' | '>' | '\\'' | '\"' -> raise_notrace (First_char_to_escape i)\n | _ -> ()\n done\n with\n | exception First_char_to_escape first ->\n if first > 0 then Buffer.add_substring buf s 0 first;\n for i = first to length - 1 do\n match String.unsafe_get s i with\n | '&' -> Buffer.add_string buf \"&\"\n | '<' -> Buffer.add_string buf \"<\"\n | '>' -> Buffer.add_string buf \">\"\n | '\\'' -> Buffer.add_string buf \"'\"\n | '\"' -> Buffer.add_string buf \""\"\n | c -> Buffer.add_char buf c\n done\n | () -> Buffer.add_string buf s\n\ntype attribute = [ `Present of string | `Value of string * string | `Omitted ]\ntype attribute_list = attribute list\n\nlet attribute name value = `Value (name, value)\nlet present name = `Present name\nlet omitted () = `Omitted\n\nlet write_attribute buf (attr : attribute) =\n match attr with\n | `Omitted -> ()\n | `Present name ->\n Buffer.add_char buf ' ';\n Buffer.add_string buf name\n | `Value (name, value) ->\n Buffer.add_char buf ' ';\n Buffer.add_string buf name;\n Buffer.add_string buf \"=\\\"\";\n escape buf value;\n Buffer.add_char buf '\"'\n\ntype element =\n | Null\n | String of string\n | Raw of string (* text without encoding *)\n | Node of node\n | Int of int\n | Float of float\n | List of (string * element list)\n | Array of element array\n\nand node = { tag : string; attributes : attribute_list; children : element list }\n\nlet string txt = String txt\nlet raw txt = Raw txt\nlet null = Null\nlet int i = Int i\nlet float f = Float f\nlet list ?(separator = \"\") list = List (separator, list)\nlet array arr = Array arr\nlet fragment arr = List arr\nlet node tag attributes children = Node { tag; attributes; children }\n\nlet to_string ?(add_separator_between_text_nodes = true) element =\n let out = Buffer.create 1024 in\n (* This ref is used to enable rendering comments between text nodes\n and can be disabled by `add_separator_between_text_nodes` *)\n let previous_node_was_text = ref false in\n let should_add_doctype_to_html = ref true in\n let rec write element =\n match element with\n | Null -> should_add_doctype_to_html.contents <- false\n | Int i -> Buffer.add_string out (Int.to_string i)\n | Float f -> Buffer.add_string out (Float.to_string f)\n | String text ->\n let is_previous_text_node = previous_node_was_text.contents in\n previous_node_was_text.contents <- true;\n if is_previous_text_node && add_separator_between_text_nodes then Buffer.add_string out \"\";\n escape out text;\n should_add_doctype_to_html.contents <- false\n | Raw text ->\n Buffer.add_string out text;\n should_add_doctype_to_html.contents <- false\n | Node { tag; attributes; _ } when is_self_closing_tag tag ->\n Buffer.add_char out '<';\n Buffer.add_string out tag;\n List.iter (write_attribute out) attributes;\n Buffer.add_string out \" />\";\n should_add_doctype_to_html.contents <- false\n | Node { tag; attributes; children } ->\n (* capturing the value of should_add_doctype_to_html before setting it to false, so the first thing is set to false and use the captured value *)\n let should_add_doctype = should_add_doctype_to_html.contents in\n should_add_doctype_to_html.contents <- false;\n (* If the previous node was text, but from another parent node, then the comment shouldn't be added.\n Check `separated_text_nodes_by_other_nodes` in test_renderToString.ml *)\n if add_separator_between_text_nodes then previous_node_was_text.contents <- false;\n if tag = \"html\" && should_add_doctype then Buffer.add_string out \"\";\n Buffer.add_char out '<';\n Buffer.add_string out tag;\n List.iter (write_attribute out) attributes;\n Buffer.add_char out '>';\n List.iter write children;\n Buffer.add_string out \"';\n if add_separator_between_text_nodes then previous_node_was_text.contents <- false\n | List (\"\", list) -> List.iter write list\n | List (separator, list) ->\n let rec iter = function\n | [] -> ()\n | [ one ] -> write one\n | [ first; second ] ->\n write first;\n Buffer.add_string out separator;\n write second\n | first :: rest ->\n write first;\n Buffer.add_string out separator;\n iter rest\n in\n iter list\n | Array elements -> Array.iter write elements\n in\n write element;\n Buffer.contents out\n\n(* The pretty print is used for debugging purposes *)\nlet pp element =\n let out = Buffer.create 1024 in\n let rec write element =\n match element with\n | Null -> ()\n | Int i -> Buffer.add_string out (Int.to_string i)\n | Float f -> Buffer.add_string out (Float.to_string f)\n | String text -> escape out text\n | Raw text -> Buffer.add_string out text\n | Node { tag; attributes; _ } when is_self_closing_tag tag ->\n Buffer.add_char out '<';\n Buffer.add_string out tag;\n List.iter (write_attribute out) attributes;\n Buffer.add_string out \" />\"\n | Node { tag; attributes; children } ->\n Buffer.add_char out '<';\n Buffer.add_string out tag;\n List.iter (write_attribute out) attributes;\n Buffer.add_char out '>';\n List.iter write children;\n Buffer.add_string out \"'\n | List (\"\", list) -> List.iter write list\n | List (separator, list) ->\n let rec iter = function\n | [] -> ()\n | [ one ] -> write one\n | [ first; second ] ->\n write first;\n Buffer.add_string out separator;\n write second\n | first :: rest ->\n write first;\n Buffer.add_string out separator;\n iter rest\n in\n iter list\n | Array elements -> Array.iter write elements\n in\n write element;\n Buffer.contents out\n\nlet add_attribute_escaped b s =\n let getc = String.unsafe_get s in\n let adds = Buffer.add_string in\n let len = String.length s in\n let max_idx = len - 1 in\n let flush b start i = if start < len then Buffer.add_substring b s start (i - start) in\n let rec loop start i =\n if i > max_idx then flush b start i\n else\n let next = i + 1 in\n match getc i with\n | '\\'' ->\n flush b start i;\n adds b \"'\";\n loop next next\n | '&' ->\n flush b start i;\n adds b \"&\";\n loop next next\n | _ -> loop start next\n in\n loop 0 0\n\nlet escape_attribute_value data =\n let buf = Buffer.create (String.length data) in\n add_attribute_escaped buf data;\n Buffer.contents buf\n"
},
{
"path": "packages/html/dune",
"content": "(library\n (name html)\n (wrapped false)\n (public_name server-reason-react.html))\n"
},
{
"path": "packages/melange.ppx/base32/LICENSES/ISC.txt",
"content": "ISC License:\n\nCopyright (c) 2004-2010 by Internet Systems Consortium, Inc. (\"ISC\")\nCopyright (c) 1995-2003 by Internet Software Consortium\n\nPermission to use, copy, modify, and/or distribute this software for any purpose\nwith or without fee is hereby granted, provided that the above copyright notice\nand this permission notice appear in all copies.\n\nTHE SOFTWARE IS PROVIDED \"AS IS\" AND ISC DISCLAIMS ALL WARRANTIES WITH REGARD\nTO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.\nIN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL\nDAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,\nWHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING\nOUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n"
},
{
"path": "packages/melange.ppx/base32/README.md",
"content": "This library was vendored for server-reason-react from https://codeberg.org/pukkamustard/ocaml-base32/src/commit/c08f37455b7ea67d8106c110af0efd501f1374ae.\n\n# Base32 for OCaml\n\nThis implements Base32 encoded as specified by [RFC 4648](https://tools.ietf.org/html/rfc4648) for OCaml.\n\nocaml-base32 is an adaptation of [ocaml-base64](https://github.com/mirage/ocaml-base64)\n\n## License\n\n[ISC](./LICENSES/ISC.txt)\n"
},
{
"path": "packages/melange.ppx/base32/lib/base32.ml",
"content": "(*\n * Copyright (c) 2006-2009 Citrix Systems Inc.\n * Copyright (c) 2010 Thomas Gazagnaire \n * Copyright (c) 2014-2016 Anil Madhavapeddy \n * Copyright (c) 2016 David Kaloper Meršinjak\n * Copyright (c) 2018 Romain Calascibetta \n * Copyright (c) 2021 pukkamustard \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *\n *)\n\ntype alphabet = { emap : int array; dmap : int array }\ntype sub = string * int * int\n\nlet ( // ) x y =\n if y < 1 then raise Division_by_zero;\n if x > 0 then 1 + ((x - 1) / y) else 0\n[@@inline]\n\nlet unsafe_get_uint8 input off = String.unsafe_get input off |> Char.code\nlet unsafe_set_uint8 input off v = v |> Char.chr |> Bytes.unsafe_set input off\nlet none = -1\n\n(* We mostly want to have an optional array for [dmap] (e.g. [int option\n array]). So we consider the [none] value as [-1]. *)\n\nlet make_alphabet alphabet =\n if String.length alphabet <> 32 then invalid_arg \"Length of alphabet must be 32\";\n if String.contains alphabet '=' then invalid_arg \"Alphabet can not contain padding character\";\n let emap = Array.init (String.length alphabet) (fun i -> Char.code alphabet.[i]) in\n let dmap = Array.make 256 none in\n String.iteri (fun idx chr -> dmap.(Char.code chr) <- idx) alphabet;\n { emap; dmap }\n\nlet length_alphabet { emap; _ } = Array.length emap\nlet alphabet { emap; _ } = emap\nlet default_alphabet = make_alphabet \"ABCDEFGHIJKLMNOPQRSTUVWXYZ234567\"\nlet padding = int_of_char '='\nlet error_msgf fmt = Format.ksprintf (fun err -> Error (`Msg err)) fmt\n\nlet encode_sub pad { emap; _ } ?(off = 0) ?len input =\n let len = match len with Some len -> len | None -> String.length input - off in\n\n if len < 0 || off < 0 || off > String.length input - len then error_msgf \"Invalid bounds\"\n else\n let n = len in\n let n' = n // 5 * 8 in\n let res = Bytes.make n' (Char.chr 0) in\n\n let emap i = Array.unsafe_get emap i in\n\n (* the bit magic - takes 5 bytes and reads 5-bits at a time *)\n let emit b1 b2 b3 b4 b5 i =\n unsafe_set_uint8 res i (emap ((0b11111000 land b1) lsr 3));\n unsafe_set_uint8 res (i + 1) (emap (((0b00000111 land b1) lsl 2) lor ((0b11000000 land b2) lsr 6)));\n unsafe_set_uint8 res (i + 2) (emap ((0b00111110 land b2) lsr 1));\n unsafe_set_uint8 res (i + 3) (emap (((0b00000001 land b2) lsl 4) lor ((0b11110000 land b3) lsr 4)));\n unsafe_set_uint8 res (i + 4) (emap (((0b00001111 land b3) lsl 1) lor ((0b10000000 land b4) lsr 7)));\n unsafe_set_uint8 res (i + 5) (emap ((0b01111100 land b4) lsr 2));\n unsafe_set_uint8 res (i + 6) (emap (((0b00000011 land b4) lsl 3) lor ((0b11100000 land b5) lsr 5)));\n unsafe_set_uint8 res (i + 7) (emap (0b00011111 land b5))\n in\n\n let rec enc j i =\n if i = len then ()\n else if i = n - 1 then emit (unsafe_get_uint8 input (off + i)) 0 0 0 0 j\n else if i = n - 2 then emit (unsafe_get_uint8 input (off + i)) (unsafe_get_uint8 input (off + i + 1)) 0 0 0 j\n else if i = n - 3 then\n emit\n (unsafe_get_uint8 input (off + i))\n (unsafe_get_uint8 input (off + i + 1))\n (unsafe_get_uint8 input (off + i + 2))\n 0 0 j\n else if i = n - 4 then\n emit\n (unsafe_get_uint8 input (off + i))\n (unsafe_get_uint8 input (off + i + 1))\n (unsafe_get_uint8 input (off + i + 2))\n (unsafe_get_uint8 input (off + i + 3))\n 0 j\n else (\n emit\n (unsafe_get_uint8 input (off + i))\n (unsafe_get_uint8 input (off + i + 1))\n (unsafe_get_uint8 input (off + i + 2))\n (unsafe_get_uint8 input (off + i + 3))\n (unsafe_get_uint8 input (off + i + 4))\n j;\n enc (j + 8) (i + 5))\n in\n\n let rec unsafe_fix = function\n | 0 -> ()\n | i ->\n unsafe_set_uint8 res (n' - i) padding;\n unsafe_fix (i - 1)\n in\n\n enc 0 0;\n\n (* amount of padding required *)\n let pad_to_write = match n mod 5 with 0 -> 0 | 1 -> 6 | 2 -> 4 | 3 -> 3 | 4 -> 1 | _ -> 0 in\n\n if pad then (\n unsafe_fix pad_to_write;\n Ok (Bytes.unsafe_to_string res, 0, n'))\n else Ok (Bytes.unsafe_to_string res, 0, n' - pad_to_write)\n\nlet encode ?(pad = true) ?(alphabet = default_alphabet) ?off ?len input =\n match encode_sub pad alphabet ?off ?len input with\n | Ok (res, off, len) -> Ok (String.sub res off len)\n | Error _ as err -> err\n\nlet encode_string ?pad ?alphabet input =\n match encode ?pad ?alphabet input with Ok res -> res | Error _ -> assert false\n\nlet encode_sub ?(pad = true) ?(alphabet = default_alphabet) ?off ?len input = encode_sub pad alphabet ?off ?len input\n\nlet encode_exn ?pad ?alphabet ?off ?len input =\n match encode ?pad ?alphabet ?off ?len input with Ok v -> v | Error (`Msg err) -> invalid_arg err\n\nlet decode_sub { dmap; _ } ?(off = 0) ?len input =\n let len = match len with Some len -> len | None -> String.length input - off in\n\n if len < 0 || off < 0 || off > String.length input - len then error_msgf \"Invalid bounds\"\n else\n let n = len // 8 * 8 in\n let n' = n // 8 * 5 in\n let res = Bytes.create n' in\n\n let get_uint8 t i = if i < len then Char.code (String.unsafe_get t (off + i)) else padding in\n\n let set_uint8 t off v =\n (* Format.printf \"set_uint8 %d\\n\" (v land 0xff); *)\n if off < 0 || off >= Bytes.length t then () else unsafe_set_uint8 t off (v land 0xff)\n in\n\n let emit b0 b1 b2 b3 b4 b5 b6 b7 j =\n set_uint8 res j ((b0 lsl 3) lor (b1 lsr 2));\n set_uint8 res (j + 1) ((b1 lsl 6) lor (b2 lsl 1) lor (b3 lsr 4));\n set_uint8 res (j + 2) ((b3 lsl 4) lor (b4 lsr 1));\n set_uint8 res (j + 3) ((b4 lsl 7) lor (b5 lsl 2) lor (b6 lsr 3));\n set_uint8 res (j + 4) ((b6 lsl 5) lor b7)\n in\n\n let dmap i = Array.unsafe_get dmap i in\n\n let get_uint8_with_padding t i padding =\n let x = get_uint8 t i in\n if x = 61 then (0, padding)\n else\n let v = dmap x in\n if v >= 0 then (v, 0) else raise Not_found\n in\n\n let rec dec j i =\n if i = n then 0\n else\n let b0, pad0 = get_uint8_with_padding input i 5 in\n let b1, pad1 = get_uint8_with_padding input (i + 1) 5 in\n let b2, pad2 = get_uint8_with_padding input (i + 2) 4 in\n let b3, pad3 = get_uint8_with_padding input (i + 3) 4 in\n let b4, pad4 = get_uint8_with_padding input (i + 4) 3 in\n let b5, pad5 = get_uint8_with_padding input (i + 5) 2 in\n let b6, pad6 = get_uint8_with_padding input (i + 6) 2 in\n let b7, pad7 = get_uint8_with_padding input (i + 7) 1 in\n let pad = List.fold_left max 0 [ pad0; pad1; pad2; pad3; pad4; pad5; pad6; pad7 ] in\n\n (* Format.printf \"emit %d %d %d %d %d %d %d %d\\n\" b0 b1 b2 b3 b4 b5 b6 b7; *)\n emit b0 b1 b2 b3 b4 b5 b6 b7 j;\n if pad == 0 then dec (j + 5) (i + 8) else pad\n in\n\n match dec 0 0 with\n | pad -> Ok (Bytes.unsafe_to_string res, 0, n' - pad)\n | exception Not_found -> error_msgf \"Malformed input\"\n\nlet decode ?(alphabet = default_alphabet) ?off ?len input =\n match decode_sub alphabet ?off ?len input with\n | Ok (res, off, len) -> Ok (String.sub res off len)\n | Error _ as err -> err\n\nlet decode_sub ?(alphabet = default_alphabet) ?off ?len input = decode_sub alphabet ?off ?len input\n\nlet decode_exn ?alphabet ?off ?len input =\n match decode ?alphabet ?off ?len input with Ok res -> res | Error (`Msg err) -> invalid_arg err\n"
},
{
"path": "packages/melange.ppx/base32/lib/base32.mli",
"content": "(*\n * Copyright (c) 2006-2009 Citrix Systems Inc.\n * Copyright (c) 2010 Thomas Gazagnaire \n * Copyright (c) 2014-2016 Anil Madhavapeddy \n * Copyright (c) 2016 David Kaloper Meršinjak\n * Copyright (c) 2018 Romain Calascibetta \n * Copyright (c) 2021 pukkamustard \n *\n * Permission to use, copy, modify, and distribute this software for any\n * purpose with or without fee is hereby granted, provided that the above\n * copyright notice and this permission notice appear in all copies.\n *\n * THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES\n * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF\n * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR\n * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES\n * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN\n * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF\n * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.\n *\n *)\n\n(** Base32 RFC4648 implementation.\n\n Base32 is a group of similar binary-to-text encoding schemes that represent binary data in an ASCII string format by\n translating it into a radix-32 representation. It is specified in RFC 4648.\n\n {e Release %%VERSION%% - %%PKG_HOMEPAGE%%} *)\n\ntype alphabet\n(** Type of alphabet. *)\n\ntype sub = string * int * int\n(** Type of sub-string: [str, off, len]. *)\n\nval default_alphabet : alphabet\n(** A 32-character alphabet specifying the regular Base32 alphabet. *)\n\nval make_alphabet : string -> alphabet\n(** Make a new alphabet. *)\n\nval length_alphabet : alphabet -> int\n(** Returns length of the alphabet, should be 64. *)\n\nval alphabet : alphabet -> int array\n(** Returns the alphabet. *)\n\nval decode_exn : ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string\n(** [decode_exn ?off ?len s] decodes [len] bytes (defaults to [String.length s - off]) of the string [s] starting from\n [off] (defaults to [0]) that is encoded in Base32 format. Will leave trailing NULLs on the string, padding it out to\n a multiple of 3 characters. [alphabet] defaults to {!default_alphabet}. [pad = true] specifies to check if [s] is\n padded or not, otherwise, it raises an exception.\n\n Decoder can fail when character of [s] is not a part of [alphabet] or is not [padding] character. If input is not\n padded correctly, decoder does the best-effort but it does not ensure [decode_exn (encode ~pad:false x) = x].\n\n @raise if Invalid_argument [s] is not a valid Base32 string. *)\n\nval decode_sub : ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (sub, [> `Msg of string ]) result\n(** Same as {!decode_exn} but it returns a result type instead to raise an exception. Then, it returns a {!sub} string.\n Decoded input [(str, off, len)] will starting to [off] and will have [len] bytes - by this way, we ensure to\n allocate only one time result. *)\n\nval decode : ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (string, [> `Msg of string ]) result\n(** Same as {!decode_exn}, but returns an explicit error message {!result} if it fails. *)\n\nval encode : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (string, [> `Msg of string ]) result\n(** [encode s] encodes the string [s] into base32. If [pad] is false, no trailing padding is added. [pad] defaults to\n [true], and [alphabet] to {!default_alphabet}.\n\n [encode] fails when [off] and [len] do not designate a valid range of [s]. *)\n\nval encode_string : ?pad:bool -> ?alphabet:alphabet -> string -> string\n(** [encode_string s] encodes the string [s] into base32. If [pad] is false, no trailing padding is added. [pad]\n defaults to [true], and [alphabet] to {!default_alphabet}. *)\n\nval encode_sub : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> (sub, [> `Msg of string ]) result\n(** Same as {!encode} but return a {!sub}-string instead a plain result. By this way, we ensure to allocate only one\n time result. *)\n\nval encode_exn : ?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string\n(** Same as {!encode} but raises an invalid argument exception if we retrieve an error. *)\n"
},
{
"path": "packages/melange.ppx/base32/lib/dune",
"content": "(library\n (name base32)\n (public_name server-reason-react.base32))\n"
},
{
"path": "packages/melange.ppx/derive_util.ml",
"content": "(** Shared utilities for record type derivers (jsProperties, getSet).\n\n These helpers handle common operations like checking for optional attributes and extracting type information from\n type declarations. *)\n\nopen Ppxlib\nmodule Builder = Ast_builder.Default\n\n(** Returns [true] if the attribute list contains [[@mel.optional]] or [[@bs.optional]]. *)\nlet has_mel_optional attrs =\n List.exists (fun { attr_name = { txt; _ }; _ } -> txt = \"mel.optional\" || txt = \"bs.optional\") attrs\n\n(** Extracts the inner type from an optional field.\n\n For fields marked with [[@mel.optional]], this unwraps the [option] type to get the inner type. For example,\n [int option] becomes [int].\n\n Raises an error if [[@mel.optional]] is used on a non-option type. *)\nlet get_pld_type pld_type ~attrs =\n let is_optional = has_mel_optional attrs in\n match is_optional with\n | true -> (\n match pld_type.ptyp_desc with\n | Ptyp_constr ({ txt = Lident \"option\"; _ }, [ inner_type ]) -> inner_type\n | _ -> Location.raise_errorf ~loc:pld_type.ptyp_loc \"`[@mel.optional]' must appear on an option type (`_ option')\"\n )\n | false -> pld_type\n\n(** Constructs a core type from a type declaration.\n\n Given [type 'a t = ...], this returns the core type ['a t] that can be used in function signatures. Handles type\n parameters correctly. *)\nlet core_type_of_type_declaration (tdcl : type_declaration) =\n match tdcl with\n | { ptype_name = { txt; loc }; ptype_params; _ } ->\n Builder.ptyp_constr ~loc { txt = Lident txt; loc } (List.map fst ptype_params)\n"
},
{
"path": "packages/melange.ppx/double_hash.ml",
"content": "open Ppxlib\nmodule Builder = Ast_builder.Default\n\nlet expander e =\n let loc = e.pexp_loc in\n match e.pexp_desc with\n | Pexp_apply\n ( { pexp_desc = Pexp_ident { txt = Lident \"##\"; _ }; pexp_loc_stack = _; pexp_loc = _; pexp_attributes = _ },\n [ (Nolabel, objectArg); (Nolabel, methodArg) ] ) -> (\n match methodArg with\n | { pexp_desc = Pexp_ident { txt = Lident li; _ }; _ } ->\n Some (Builder.pexp_send ~loc objectArg { txt = li; loc })\n | _ -> None)\n | _ -> None\n\nlet rule = Context_free.Rule.special_function \"##\" expander\n"
},
{
"path": "packages/melange.ppx/dune",
"content": "(library\n (name melange_native_ppx)\n (public_name server-reason-react.melange_ppx)\n (ppx_runtime_libraries server-reason-react.runtime)\n (flags :standard -w -9)\n (libraries base32 ppxlib ppxlib.astlib str quickjs xxhash)\n (preprocess\n (pps ppxlib.metaquot))\n (kind ppx_rewriter))\n"
},
{
"path": "packages/melange.ppx/get_set.ml",
"content": "(** [[@\\@deriving getSet]] generates getter and setter functions for record fields.\n\n This is a native OCaml implementation compatible with melange's getSet deriver.\n\n {2 Basic usage}\n\n {[\n type person = { name : string; age : int } [@@deriving getSet]\n\n (* Generates: *)\n let nameGet x = x.name\n let ageGet x = x.age\n ]}\n\n {2 Mutable fields}\n\n Mutable fields also generate setter functions:\n\n {[\n type person = { name : string; mutable age : int } [@@deriving getSet]\n\n (* Generates: *)\n let nameGet x = x.name\n let ageGet x = x.age\n let ageSet x v = x.age <- v\n ]}\n\n {2 Light mode}\n\n With [{ light }], getters are named after the field (without \"Get\" suffix):\n\n {[\n type person = { name : string; mutable age : int } [@@deriving getSet { light }]\n\n (* Generates: *)\n let name x = x.name\n let age x = x.age\n let ageSet x v = x.age <- v\n ]} *)\n\nopen Ppxlib\nmodule Builder = Ast_builder.Default\n\nlet derive_str ~light tdcls =\n List.concat_map\n (fun tdcl ->\n match tdcl.ptype_kind with\n | Ptype_record label_declarations ->\n List.concat_map\n (fun { pld_name; pld_mutable; pld_loc; _ } ->\n let getter_name = if light then pld_name.txt else pld_name.txt ^ \"Get\" in\n let getter_expr =\n Builder.pexp_fun ~loc:pld_loc Nolabel None\n (Builder.ppat_var ~loc:pld_loc { loc = pld_loc; txt = \"x\" })\n (Builder.pexp_field ~loc:pld_loc\n (Builder.pexp_ident ~loc:pld_loc { loc = pld_loc; txt = Lident \"x\" })\n { loc = pld_loc; txt = Lident pld_name.txt })\n in\n let getter_vb =\n Builder.value_binding ~loc:pld_loc ~pat:(Builder.pvar ~loc:pld_loc getter_name) ~expr:getter_expr\n in\n let getter = Builder.pstr_value ~loc:pld_loc Nonrecursive [ getter_vb ] in\n let setter =\n match pld_mutable with\n | Mutable ->\n let setter_name = pld_name.txt ^ \"Set\" in\n let setter_expr =\n Builder.pexp_fun ~loc:pld_loc Nolabel None\n (Builder.ppat_var ~loc:pld_loc { loc = pld_loc; txt = \"x\" })\n (Builder.pexp_fun ~loc:pld_loc Nolabel None\n (Builder.ppat_var ~loc:pld_loc { loc = pld_loc; txt = \"v\" })\n (Builder.pexp_setfield ~loc:pld_loc\n (Builder.pexp_ident ~loc:pld_loc { loc = pld_loc; txt = Lident \"x\" })\n { loc = pld_loc; txt = Lident pld_name.txt }\n (Builder.pexp_ident ~loc:pld_loc { loc = pld_loc; txt = Lident \"v\" })))\n in\n let setter_vb =\n Builder.value_binding ~loc:pld_loc ~pat:(Builder.pvar ~loc:pld_loc setter_name) ~expr:setter_expr\n in\n [ Builder.pstr_value ~loc:pld_loc Nonrecursive [ setter_vb ] ]\n | Immutable -> []\n in\n [ getter ] @ setter)\n label_declarations\n | Ptype_abstract | Ptype_variant _ | Ptype_open ->\n let loc = tdcl.ptype_loc in\n Location.raise_errorf ~loc \"[@@deriving getSet] can only be used on record types\")\n tdcls\n\nlet derive_sig ~light tdcls =\n List.concat_map\n (fun tdcl ->\n match tdcl.ptype_kind with\n | Ptype_record label_declarations ->\n let core_type = Derive_util.core_type_of_type_declaration tdcl in\n List.concat_map\n (fun { pld_name; pld_type; pld_mutable; pld_attributes; pld_loc; _ } ->\n let is_optional = Derive_util.has_mel_optional pld_attributes in\n let getter_name = if light then pld_name.txt else pld_name.txt ^ \"Get\" in\n let getter_type = Builder.ptyp_arrow ~loc:pld_loc Nolabel core_type pld_type in\n let getter =\n Builder.psig_value ~loc:pld_loc\n (Builder.value_description ~loc:pld_loc ~name:{ loc = pld_loc; txt = getter_name } ~type_:getter_type\n ~prim:[])\n in\n let setter =\n match pld_mutable with\n | Mutable ->\n let pld_type_inner =\n if is_optional then Derive_util.get_pld_type pld_type ~attrs:pld_attributes else pld_type\n in\n let setter_name = pld_name.txt ^ \"Set\" in\n let setter_type =\n Builder.ptyp_arrow ~loc:pld_loc Nolabel core_type\n (Builder.ptyp_arrow ~loc:pld_loc Nolabel pld_type_inner\n (Builder.ptyp_constr ~loc:pld_loc { loc = pld_loc; txt = Lident \"unit\" } []))\n in\n [\n Builder.psig_value ~loc:pld_loc\n (Builder.value_description ~loc:pld_loc ~name:{ loc = pld_loc; txt = setter_name }\n ~type_:setter_type ~prim:[]);\n ]\n | Immutable -> []\n in\n [ getter ] @ setter)\n label_declarations\n | Ptype_abstract | Ptype_variant _ | Ptype_open ->\n let loc = tdcl.ptype_loc in\n Location.raise_errorf ~loc \"[@@deriving getSet] can only be used on record types\")\n tdcls\n\nlet str_type_decl =\n let args = Deriving.Args.(empty +> flag \"light\") in\n Deriving.Generator.V2.make args (fun ~ctxt:_ (_, type_decls) light -> derive_str ~light type_decls)\n\nlet sig_type_decl =\n let args = Deriving.Args.(empty +> flag \"light\") in\n Deriving.Generator.V2.make args (fun ~ctxt:_ (_, type_decls) light -> derive_sig ~light type_decls)\n\nlet deriver = Deriving.add \"getSet\" ~str_type_decl ~sig_type_decl\n"
},
{
"path": "packages/melange.ppx/js_converter.ml",
"content": "open Ppxlib\nmodule Builder = Ast_builder.Default\n\nlet is_mel_as_attr txt = txt = \"mel.as\"\n\nlet get_mel_as_int attrs =\n List.find_map\n (fun { attr_name = { txt; _ }; attr_payload; _ } ->\n if is_mel_as_attr txt then\n match attr_payload with\n | PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_integer (s, _)); _ }, _); _ } ] ->\n Some (int_of_string s)\n | _ -> None\n else None)\n attrs\n\nlet get_mel_as_string attrs =\n List.find_map\n (fun { attr_name = { txt; _ }; attr_payload; _ } ->\n if is_mel_as_attr txt then\n match attr_payload with\n | PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _ }, _); _ } ] ->\n Some s\n | _ -> None\n else None)\n attrs\n\ntype variant_info = { name : string; js_value : int }\ntype poly_variant_info = { name : string; js_string : string }\n\nlet check_duplicate_values ~loc mappings =\n let values = List.map (fun { js_value; _ } -> js_value) mappings in\n let rec check seen = function\n | [] -> ()\n | v :: rest ->\n if List.mem v seen then\n Location.raise_errorf ~loc\n \"[@@deriving jsConverter] has duplicate value %d - each constructor must map to a unique integer\" v\n else check (v :: seen) rest\n in\n check [] values\n\nlet check_duplicate_strings ~loc mappings =\n let strings = List.map (fun { js_string; _ } -> js_string) mappings in\n let rec check seen = function\n | [] -> ()\n | s :: rest ->\n if List.mem s seen then\n Location.raise_errorf ~loc\n \"[@@deriving jsConverter] has duplicate value %S - each constructor must map to a unique string\" s\n else check (s :: seen) rest\n in\n check [] strings\n\nlet compute_variant_mappings ~loc constrs =\n if constrs = [] then Location.raise_errorf ~loc \"[@@deriving jsConverter] cannot be used on empty variant types\";\n let explicit_values =\n List.filter_map (fun { pcd_name = _; pcd_attributes; _ } -> get_mel_as_int pcd_attributes) constrs\n in\n let next_available all_used current =\n let rec find n = if List.mem n all_used then find (n + 1) else n in\n find current\n in\n let _, _, mappings =\n List.fold_left\n (fun (current, all_used, acc) { pcd_name; pcd_attributes; pcd_args; pcd_loc; _ } ->\n match pcd_args with\n | Pcstr_tuple [] | Pcstr_record [] ->\n let js_value, next =\n match get_mel_as_int pcd_attributes with\n | Some v -> (v, max current (v + 1))\n | None ->\n let v = next_available (all_used @ explicit_values) current in\n (v, v + 1)\n in\n let new_all_used = js_value :: all_used in\n (next, new_all_used, { name = pcd_name.txt; js_value } :: acc)\n | _ ->\n Location.raise_errorf ~loc:pcd_loc\n \"[@@deriving jsConverter] does not support variant constructors with payloads\")\n (0, [], []) constrs\n in\n let result = List.rev mappings in\n check_duplicate_values ~loc result;\n result\n\nlet compute_poly_variant_mappings ~loc row_fields =\n if row_fields = [] then\n Location.raise_errorf ~loc \"[@@deriving jsConverter] cannot be used on empty polymorphic variant types\";\n let mappings =\n List.map\n (fun row_field ->\n match row_field.prf_desc with\n | Rtag ({ txt = name; _ }, true, []) ->\n let js_string = match get_mel_as_string row_field.prf_attributes with Some s -> s | None -> name in\n { name; js_string }\n | Rtag (_, _, _ :: _) ->\n Location.raise_errorf ~loc:row_field.prf_loc\n \"[@@deriving jsConverter] does not support polymorphic variant constructors with payloads\"\n | Rtag (_, false, []) ->\n Location.raise_errorf ~loc:row_field.prf_loc\n \"[@@deriving jsConverter] does not support polymorphic variant constructors with payloads\"\n | Rinherit _ ->\n Location.raise_errorf ~loc:row_field.prf_loc\n \"[@@deriving jsConverter] does not support inherited polymorphic variants\")\n row_fields\n in\n check_duplicate_strings ~loc mappings;\n mappings\n\nlet generate_to_js_variant ~loc type_name mappings =\n let cases =\n List.map\n (fun { name; js_value } ->\n let pattern = Builder.ppat_construct ~loc { loc; txt = Lident name } None in\n let expr = Builder.pexp_constant ~loc (Pconst_integer (string_of_int js_value, None)) in\n Builder.case ~lhs:pattern ~guard:None ~rhs:expr)\n mappings\n in\n let func_name = type_name ^ \"ToJs\" in\n let param_name = \"x\" in\n let func_expr =\n Builder.pexp_fun ~loc Nolabel None\n (Builder.ppat_var ~loc { loc; txt = param_name })\n (Builder.pexp_match ~loc (Builder.pexp_ident ~loc { loc; txt = Lident param_name }) cases)\n in\n Builder.value_binding ~loc ~pat:(Builder.pvar ~loc func_name) ~expr:func_expr\n\nlet generate_from_js_variant ~loc type_name mappings ~new_type =\n let cases =\n List.map\n (fun { name; js_value } ->\n let pattern = Builder.ppat_constant ~loc (Pconst_integer (string_of_int js_value, None)) in\n let constr = Builder.pexp_construct ~loc { loc; txt = Lident name } None in\n let rhs = if new_type then constr else Builder.pexp_construct ~loc { loc; txt = Lident \"Some\" } (Some constr) in\n Builder.case ~lhs:pattern ~guard:None ~rhs)\n mappings\n in\n let default_case =\n if new_type then None\n else\n Some\n (Builder.case ~lhs:(Builder.ppat_any ~loc) ~guard:None\n ~rhs:(Builder.pexp_construct ~loc { loc; txt = Lident \"None\" } None))\n in\n let all_cases = cases @ Option.to_list default_case in\n let func_name = type_name ^ \"FromJs\" in\n let param_name = \"x\" in\n let func_expr =\n Builder.pexp_fun ~loc Nolabel None\n (Builder.ppat_var ~loc { loc; txt = param_name })\n (Builder.pexp_match ~loc (Builder.pexp_ident ~loc { loc; txt = Lident param_name }) all_cases)\n in\n Builder.value_binding ~loc ~pat:(Builder.pvar ~loc func_name) ~expr:func_expr\n\nlet generate_to_js_poly ~loc type_name mappings =\n let cases =\n List.map\n (fun { name; js_string } ->\n let pattern = Builder.ppat_variant ~loc name None in\n let expr = Builder.pexp_constant ~loc (Pconst_string (js_string, loc, None)) in\n Builder.case ~lhs:pattern ~guard:None ~rhs:expr)\n mappings\n in\n let func_name = type_name ^ \"ToJs\" in\n let param_name = \"x\" in\n let func_expr =\n Builder.pexp_fun ~loc Nolabel None\n (Builder.ppat_var ~loc { loc; txt = param_name })\n (Builder.pexp_match ~loc (Builder.pexp_ident ~loc { loc; txt = Lident param_name }) cases)\n in\n Builder.value_binding ~loc ~pat:(Builder.pvar ~loc func_name) ~expr:func_expr\n\nlet generate_from_js_poly ~loc type_name mappings ~new_type =\n let cases =\n List.map\n (fun { name; js_string } ->\n let pattern = Builder.ppat_constant ~loc (Pconst_string (js_string, loc, None)) in\n let variant = Builder.pexp_variant ~loc name None in\n let rhs =\n if new_type then variant else Builder.pexp_construct ~loc { loc; txt = Lident \"Some\" } (Some variant)\n in\n Builder.case ~lhs:pattern ~guard:None ~rhs)\n mappings\n in\n let default_case =\n if new_type then None\n else\n Some\n (Builder.case ~lhs:(Builder.ppat_any ~loc) ~guard:None\n ~rhs:(Builder.pexp_construct ~loc { loc; txt = Lident \"None\" } None))\n in\n let all_cases = cases @ Option.to_list default_case in\n let func_name = type_name ^ \"FromJs\" in\n let param_name = \"x\" in\n let func_expr =\n Builder.pexp_fun ~loc Nolabel None\n (Builder.ppat_var ~loc { loc; txt = param_name })\n (Builder.pexp_match ~loc (Builder.pexp_ident ~loc { loc; txt = Lident param_name }) all_cases)\n in\n Builder.value_binding ~loc ~pat:(Builder.pvar ~loc func_name) ~expr:func_expr\n\nlet generate_abstract_type ~loc type_name ~is_poly =\n let abs_type_name = \"abs_\" ^ type_name in\n let manifest =\n if is_poly then Some (Builder.ptyp_constr ~loc { loc; txt = Lident \"string\" } [])\n else Some (Builder.ptyp_constr ~loc { loc; txt = Lident \"int\" } [])\n in\n Builder.type_declaration ~loc ~name:{ loc; txt = abs_type_name } ~params:[] ~cstrs:[] ~kind:Ptype_abstract\n ~private_:Public ~manifest\n\nlet str_gen ~loc ~path:_ (rec_flag, type_decls) new_type =\n let _ = rec_flag in\n List.concat_map\n (fun { ptype_name; ptype_kind; ptype_manifest; ptype_loc; _ } ->\n let type_name = ptype_name.txt in\n match (ptype_kind, ptype_manifest) with\n | Ptype_variant constrs, _ ->\n let mappings = compute_variant_mappings ~loc:ptype_loc constrs in\n let to_js = generate_to_js_variant ~loc:ptype_loc type_name mappings in\n let from_js = generate_from_js_variant ~loc:ptype_loc type_name mappings ~new_type in\n let abs_type =\n if new_type then\n [ Builder.pstr_type ~loc Nonrecursive [ generate_abstract_type ~loc type_name ~is_poly:false ] ]\n else []\n in\n abs_type\n @ [ Builder.pstr_value ~loc Nonrecursive [ to_js ]; Builder.pstr_value ~loc Nonrecursive [ from_js ] ]\n | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (row_fields, Closed, None); ptyp_loc; _ } ->\n let mappings = compute_poly_variant_mappings ~loc:ptyp_loc row_fields in\n let to_js = generate_to_js_poly ~loc:ptype_loc type_name mappings in\n let from_js = generate_from_js_poly ~loc:ptype_loc type_name mappings ~new_type in\n let abs_type =\n if new_type then\n [ Builder.pstr_type ~loc Nonrecursive [ generate_abstract_type ~loc type_name ~is_poly:true ] ]\n else []\n in\n abs_type\n @ [ Builder.pstr_value ~loc Nonrecursive [ to_js ]; Builder.pstr_value ~loc Nonrecursive [ from_js ] ]\n | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (_, Open, _); ptyp_loc; _ } ->\n Location.raise_errorf ~loc:ptyp_loc \"[@@deriving jsConverter] does not support open polymorphic variants\"\n | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (_, _, Some _); ptyp_loc; _ } ->\n Location.raise_errorf ~loc:ptyp_loc\n \"[@@deriving jsConverter] does not support polymorphic variants with row variables\"\n | _ ->\n Location.raise_errorf ~loc:ptype_loc\n \"[@@deriving jsConverter] only supports variant types and polymorphic variant types\")\n type_decls\n\nlet sig_gen ~loc ~path:_ (_rec_flag, type_decls) new_type =\n List.concat_map\n (fun { ptype_name; ptype_kind; ptype_manifest; ptype_loc; _ } ->\n let type_name = ptype_name.txt in\n let type_lid = { loc; txt = Lident type_name } in\n match (ptype_kind, ptype_manifest) with\n | Ptype_variant _, _ ->\n let to_js_name = type_name ^ \"ToJs\" in\n let from_js_name = type_name ^ \"FromJs\" in\n let abs_type_name = \"abs_\" ^ type_name in\n let abs_type_lid = { loc; txt = Lident abs_type_name } in\n let type_t = Builder.ptyp_constr ~loc type_lid [] in\n let int_t = Builder.ptyp_constr ~loc { loc; txt = Lident \"int\" } [] in\n let abs_t = Builder.ptyp_constr ~loc abs_type_lid [] in\n let return_t, from_input_t = if new_type then (abs_t, abs_t) else (int_t, int_t) in\n let to_js_type = Builder.ptyp_arrow ~loc Nolabel type_t return_t in\n let from_js_return =\n if new_type then type_t else Builder.ptyp_constr ~loc { loc; txt = Lident \"option\" } [ type_t ]\n in\n let from_js_type = Builder.ptyp_arrow ~loc Nolabel from_input_t from_js_return in\n let abs_type_decl =\n if new_type then\n [\n Builder.psig_type ~loc Nonrecursive\n [\n Builder.type_declaration ~loc ~name:{ loc; txt = abs_type_name } ~params:[] ~cstrs:[]\n ~kind:Ptype_abstract ~private_:Public ~manifest:None;\n ];\n ]\n else []\n in\n abs_type_decl\n @ [\n Builder.psig_value ~loc\n (Builder.value_description ~loc ~name:{ loc; txt = to_js_name } ~type_:to_js_type ~prim:[]);\n Builder.psig_value ~loc\n (Builder.value_description ~loc ~name:{ loc; txt = from_js_name } ~type_:from_js_type ~prim:[]);\n ]\n | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (_, Closed, None); _ } ->\n let to_js_name = type_name ^ \"ToJs\" in\n let from_js_name = type_name ^ \"FromJs\" in\n let abs_type_name = \"abs_\" ^ type_name in\n let abs_type_lid = { loc; txt = Lident abs_type_name } in\n let type_t = Builder.ptyp_constr ~loc type_lid [] in\n let string_t = Builder.ptyp_constr ~loc { loc; txt = Lident \"string\" } [] in\n let abs_t = Builder.ptyp_constr ~loc abs_type_lid [] in\n let return_t, from_input_t = if new_type then (abs_t, abs_t) else (string_t, string_t) in\n let to_js_type = Builder.ptyp_arrow ~loc Nolabel type_t return_t in\n let from_js_return =\n if new_type then type_t else Builder.ptyp_constr ~loc { loc; txt = Lident \"option\" } [ type_t ]\n in\n let from_js_type = Builder.ptyp_arrow ~loc Nolabel from_input_t from_js_return in\n let abs_type_decl =\n if new_type then\n [\n Builder.psig_type ~loc Nonrecursive\n [\n Builder.type_declaration ~loc ~name:{ loc; txt = abs_type_name } ~params:[] ~cstrs:[]\n ~kind:Ptype_abstract ~private_:Public ~manifest:None;\n ];\n ]\n else []\n in\n abs_type_decl\n @ [\n Builder.psig_value ~loc\n (Builder.value_description ~loc ~name:{ loc; txt = to_js_name } ~type_:to_js_type ~prim:[]);\n Builder.psig_value ~loc\n (Builder.value_description ~loc ~name:{ loc; txt = from_js_name } ~type_:from_js_type ~prim:[]);\n ]\n | _ ->\n Location.raise_errorf ~loc:ptype_loc\n \"[@@deriving jsConverter] only supports variant types and polymorphic variant types\")\n type_decls\n\nlet str_type_decl =\n let args = Deriving.Args.(empty +> flag \"newType\") in\n Deriving.Generator.V2.make args (fun ~ctxt (rec_flag, type_decls) new_type ->\n let loc = Expansion_context.Deriver.derived_item_loc ctxt in\n str_gen ~loc ~path:[] (rec_flag, type_decls) new_type)\n\nlet sig_type_decl =\n let args = Deriving.Args.(empty +> flag \"newType\") in\n Deriving.Generator.V2.make args (fun ~ctxt (rec_flag, type_decls) new_type ->\n let loc = Expansion_context.Deriver.derived_item_loc ctxt in\n sig_gen ~loc ~path:[] (rec_flag, type_decls) new_type)\n\nlet deriver = Deriving.add \"jsConverter\" ~str_type_decl ~sig_type_decl\n"
},
{
"path": "packages/melange.ppx/js_properties.ml",
"content": "(** [[@\\@deriving jsProperties]] generates a constructor function for record types.\n\n This is a native OCaml implementation compatible with melange's jsProperties deriver.\n\n {2 Basic usage}\n\n {[\n type person = { name : string; age : int } [@@deriving jsProperties]\n\n (* Generates: *)\n let person ~name ~age = { name; age }\n ]}\n\n {2 Optional fields}\n\n Fields marked with [[@mel.optional]] become optional labeled arguments. When any optional field exists, a trailing\n [unit] argument is added:\n\n {[\n type config = { host : string; port : int option [@mel.optional] } [@@deriving jsProperties]\n\n (* Generates: *)\n let config ~host ?port () = { host; port }\n ]}\n\n {2 Private types}\n\n Private types do not generate a constructor (the type cannot be constructed outside the module). *)\n\nopen Ppxlib\nmodule Builder = Ast_builder.Default\n\nlet derive_str tdcls =\n List.concat_map\n (fun tdcl ->\n match tdcl.ptype_kind with\n | Ptype_record label_declarations -> (\n match tdcl.ptype_private with\n | Private -> []\n | Public ->\n let loc = tdcl.ptype_loc in\n let has_optional_field =\n List.exists\n (fun (x : label_declaration) -> Derive_util.has_mel_optional x.pld_attributes)\n label_declarations\n in\n let record_fields =\n List.map\n (fun { pld_name; _ } ->\n ({ loc; txt = Lident pld_name.txt }, Builder.pexp_ident ~loc { loc; txt = Lident pld_name.txt }))\n label_declarations\n in\n let record_expr = Builder.pexp_record ~loc record_fields None in\n let body_with_unit =\n if has_optional_field then Builder.pexp_fun ~loc Nolabel None (Builder.punit ~loc) record_expr\n else record_expr\n in\n let func_expr =\n List.fold_right\n (fun { pld_name; pld_attributes; pld_loc; _ } acc ->\n let is_optional = Derive_util.has_mel_optional pld_attributes in\n let label = if is_optional then Optional pld_name.txt else Labelled pld_name.txt in\n Builder.pexp_fun ~loc:pld_loc label None\n (Builder.ppat_var ~loc:pld_loc { loc = pld_loc; txt = pld_name.txt })\n acc)\n label_declarations body_with_unit\n in\n let pat = Builder.pvar ~loc tdcl.ptype_name.txt in\n let vb = Builder.value_binding ~loc ~pat ~expr:func_expr in\n [ Builder.pstr_value ~loc Nonrecursive [ vb ] ])\n | Ptype_abstract | Ptype_variant _ | Ptype_open ->\n let loc = tdcl.ptype_loc in\n Location.raise_errorf ~loc \"[@@deriving jsProperties] can only be used on record types\")\n tdcls\n\nlet derive_sig tdcls =\n List.concat_map\n (fun tdcl ->\n match tdcl.ptype_kind with\n | Ptype_record label_declarations -> (\n match tdcl.ptype_private with\n | Private -> []\n | Public ->\n let loc = tdcl.ptype_loc in\n let has_optional_field =\n List.exists\n (fun (x : label_declaration) -> Derive_util.has_mel_optional x.pld_attributes)\n label_declarations\n in\n let core_type = Derive_util.core_type_of_type_declaration tdcl in\n let make_type =\n List.fold_right\n (fun { pld_name; pld_type; pld_attributes; pld_loc; _ } acc ->\n let is_optional = Derive_util.has_mel_optional pld_attributes in\n let label = if is_optional then Optional pld_name.txt else Labelled pld_name.txt in\n let pld_type_inner =\n if is_optional then Derive_util.get_pld_type pld_type ~attrs:pld_attributes else pld_type\n in\n Builder.ptyp_arrow ~loc:pld_loc label pld_type_inner acc)\n label_declarations\n (if has_optional_field then\n Builder.ptyp_arrow ~loc Nolabel\n (Builder.ptyp_constr ~loc { loc; txt = Lident \"unit\" } [])\n core_type\n else core_type)\n in\n [\n Builder.psig_value ~loc\n (Builder.value_description ~loc ~name:{ loc; txt = tdcl.ptype_name.txt } ~type_:make_type ~prim:[]);\n ])\n | Ptype_abstract | Ptype_variant _ | Ptype_open ->\n let loc = tdcl.ptype_loc in\n Location.raise_errorf ~loc \"[@@deriving jsProperties] can only be used on record types\")\n tdcls\n\nlet str_type_decl =\n Deriving.Generator.V2.make Deriving.Args.empty (fun ~ctxt:_ (_, type_decls) -> derive_str type_decls)\n\nlet sig_type_decl =\n Deriving.Generator.V2.make Deriving.Args.empty (fun ~ctxt:_ (_, type_decls) -> derive_sig type_decls)\n\nlet deriver = Deriving.add \"jsProperties\" ~str_type_decl ~sig_type_decl\n"
},
{
"path": "packages/melange.ppx/pipe_first.ml",
"content": "(* Based on https://github.com/jaredly/belt/blob/master/belt_ppx/Belt_ppx.ml,\n rewriten in ppxlib register and Context_free.Rule.special_function *)\n\nopen Ppxlib\n\nlet expander e =\n let rec expander' e =\n let loc = e.pexp_loc in\n match e.pexp_desc with\n | Pexp_apply\n ( { pexp_desc = Pexp_ident { txt = Lident \"|.\"; _ }; pexp_loc_stack; pexp_loc = _; pexp_attributes = _ },\n [ (Nolabel, arg); (Nolabel, fn) ] ) -> (\n let fn = Option.value ~default:fn (expander' fn) in\n let arg = Option.value ~default:arg (expander' arg) in\n match fn with\n | { pexp_desc = Pexp_apply (fn, args); pexp_loc; _ } ->\n let args =\n List.filter_map\n (fun (lab, exp) -> match expander' exp with Some e -> Some (lab, e) | None -> Some (lab, exp))\n args\n in\n Some { pexp_desc = Pexp_apply (fn, (Nolabel, arg) :: args); pexp_attributes = []; pexp_loc; pexp_loc_stack }\n | { pexp_desc = Pexp_construct (lident, None); pexp_loc; pexp_loc_stack; pexp_attributes = _ } ->\n Some { pexp_desc = Pexp_construct (lident, Some arg); pexp_attributes = []; pexp_loc; pexp_loc_stack }\n | _ -> Some (Ast_builder.Default.pexp_apply ~loc fn [ (Nolabel, arg) ]))\n | _ -> None\n in\n expander' e\n\nlet rule = Context_free.Rule.special_function \"( |. )\" expander\n"
},
{
"path": "packages/melange.ppx/ppx.ml",
"content": "open Ppxlib\nmodule Builder = Ast_builder.Default\n\nmodule Private = struct\n module Typemod_hide = struct\n let no_type_defined (x : structure_item) =\n match x.pstr_desc with\n | Pstr_eval _ | Pstr_value _ | Pstr_primitive _ | Pstr_typext _ | Pstr_exception _\n (* | Pstr_module {pmb_expr = {pmod_desc = Pmod_ident _} } *) ->\n true\n | Pstr_include\n {\n pincl_mod =\n {\n pmod_desc =\n Pmod_constraint ({ pmod_desc = Pmod_structure [ { pstr_desc = Pstr_primitive _; _ } ]; _ }, _);\n _;\n };\n _;\n } ->\n true\n (* FIX https://github.com/rescript-lang/rescript/issues/4881\n generated code from:\n {[\n external %private x : int -> int = \"x\"\n [@@mel.module \"./x\"]\n ]}\n *)\n | _ -> false\n\n let check (x : structure) =\n List.iter\n (fun x ->\n if not (no_type_defined x) then\n Location.raise_errorf ~loc:x.pstr_loc \"the structure is not supported in local extension\")\n x\n end\n\n let rule =\n let expand (stru : structure) =\n Typemod_hide.check stru;\n let last_loc = (List.hd stru).pstr_loc in\n let first_loc = (List.hd stru).pstr_loc in\n let loc = { first_loc with loc_end = last_loc.loc_end } in\n Ast_helper.[ Str.open_ (Opn.mk ~override:Override (Mod.structure ~loc stru)) ] |> List.hd\n in\n let rule label =\n let extractor = Ast_pattern.__' in\n let handler ~ctxt:_ { txt = payload; loc } =\n match payload with\n | PStr work -> expand work\n | PSig _ | PTyp _ | PPat _ -> Location.raise_errorf ~loc \"private extension is not support\"\n in\n\n let extender = Extension.V3.declare label Structure_item extractor handler in\n Context_free.Rule.extension extender\n in\n rule \"private\"\nend\n\nmodule Mel_module = struct\n type bundler = Webpack | Esbuild\n\n let bundler = ref Webpack\n let prefix = ref \"/\"\n let is_melange_attr { attr_name = { txt = attr } } = \"mel.module\" = attr\n let has_attr attrs = List.exists is_melange_attr attrs\n\n let asset_payload attrs =\n let attr =\n (* we use `find` directly even if it can raise, assuming `has_attr` has been called before *)\n List.find is_melange_attr attrs\n in\n match attr.attr_payload with\n | PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (str, _, _)) }, _) } ]\n when String.length (Filename.extension str) > 0 ->\n Some str\n | _ -> None\n\n module Esbuild = struct\n (* This code is adapted from Esbuild hashing algorithm:\n base32: https://github.com/evanw/esbuild/blob/efa3dd2d8e895f7f9a9bef0d588560bbae7d776e/internal/bundler/bundler.go#L1174\n sum function: https://github.com/evanw/esbuild/blob/efa3dd2d8e895f7f9a9bef0d588560bbae7d776e/internal/xxhash/xxhash.go#L104\n the internal xxhash that esbuild uses is adapted from https://github.com/cespare/xxhash\n *)\n let hash_for_filename bytes = String.sub (Base32.encode_string (Bytes.to_string bytes)) 0 8\n\n let sum hex_str =\n (* Convert hexadecimal string to Int64 *)\n let int64_value = Int64.of_string (\"0x\" ^ hex_str) in\n\n (* Create an 8-byte buffer *)\n let bytes = Bytes.create 8 in\n\n (* Fill the buffer with the bytes of the Int64 value *)\n for i = 0 to 7 do\n let byte = Int64.(to_int (shift_right_logical int64_value (8 * (7 - i)))) land 0xFF in\n Bytes.set bytes i (char_of_int byte)\n done;\n\n bytes\n\n let hash content =\n let hash = XXH64.hash content in\n let b = sum (XXH64.to_hex hash) in\n hash_for_filename b\n\n let filename ~base content = Filename.(chop_extension base ^ \"-\" ^ hash content ^ extension base)\n end\n\n (*\n (* For now, rspack doesn't support real content hashes, see https://github.com/web-infra-dev/rspack/issues/6606 *)\n module Rspack = struct\n (* This code is adapted from Rspack hashing algorithm:\n https://github.com/web-infra-dev/rspack/blob/0a5cf0ddf38d41c2cad58c95ee9c1d3bd95e377f/crates/rspack_hash/src/lib.rs\n *)\n let hex_to_little_endian hex_str =\n (* Split the hex string into byte pairs *)\n let rec split_into_bytes acc i =\n if i >= String.length hex_str then List.rev acc\n else\n let byte = String.sub hex_str i 2 in\n split_into_bytes (byte :: acc) (i + 2)\n in\n (* Join byte pairs into a single string *)\n let join_bytes bytes = String.concat \"\" bytes in\n (* Perform the transformation *)\n let bytes = split_into_bytes [] 0 in\n let reversed_bytes = List.rev bytes in\n join_bytes reversed_bytes\n\n let hash content =\n let open XXHash in\n let hash = XXH3_64.hash content in\n hex_to_little_endian (XXH3_64.to_hex hash)\n end *)\n module Webpack = struct\n (* Needs following config in webpack.config.js, see https://webpack.js.org/configuration/output/#outputhashfunction\n ```\n module.exports = {\n //...\n output: {\n hashFunction: 'xxhash64',\n },\n };\n ```\n Also needs to set `realContentHash` for it to work in dev mode (see https://webpack.js.org/configuration/optimization/#optimizationrealcontenthash):\n ```\n module.exports = {\n //...\n optimization: {\n realContentHash: false,\n },\n };\n ```\n *)\n let hash content =\n let hash = XXH64.hash content in\n XXH64.to_hex hash\n\n let filename ~base content = hash content ^ Filename.extension base\n end\nend\n\nmodule String_interpolation = struct\n (* https://github.com/melange-re/melange/blob/fb1466fed7d6e5aafd3ee266bbd4ec70c8fb857a/ppx/string_interp.ml *)\n module Utf8_string = struct\n type byte = Single of int | Cont of int | Leading of int * int | Invalid\n\n (** [classify chr] returns the {!byte} corresponding to [chr] *)\n let classify chr =\n let c = int_of_char chr in\n (* Classify byte according to leftmost 0 bit *)\n if c land 0b1000_0000 = 0 then Single c\n else if\n (* c 0b0____*)\n c land 0b0100_0000 = 0\n then Cont (c land 0b0011_1111)\n else if\n (* c 0b10___*)\n c land 0b0010_0000 = 0\n then Leading (1, c land 0b0001_1111)\n else if\n (* c 0b110__*)\n c land 0b0001_0000 = 0\n then Leading (2, c land 0b0000_1111)\n else if\n (* c 0b1110_ *)\n c land 0b0000_1000 = 0\n then Leading (3, c land 0b0000_0111)\n else if\n (* c 0b1111_0___*)\n c land 0b0000_0100 = 0\n then Leading (4, c land 0b0000_0011)\n else if\n (* c 0b1111_10__*)\n c land 0b0000_0010 = 0\n then Leading (5, c land 0b0000_0001) (* c 0b1111_110__ *)\n else Invalid\n end\n\n type error =\n | Invalid_code_point\n | Unterminated_backslash\n | Unterminated_variable\n | Unmatched_paren\n | Invalid_syntax_of_var of string\n\n type kind = String | Var of int * int\n (* [Var (loffset, roffset)]\n For parens it used to be (2,-1)\n for non-parens it used to be (1,0) *)\n\n (* Note the position is about code point *)\n type pos = {\n lnum : int;\n offset : int;\n byte_bol : int; (* Note it actually needs to be in sync with OCaml's lexing semantics *)\n }\n\n type segment = { start : pos; finish : pos; kind : kind; content : string }\n\n type cxt = {\n mutable segment_start : pos;\n buf : Buffer.t;\n s_len : int;\n mutable segments : segment list;\n pos_bol : int; (* record the abs position of current beginning line *)\n byte_bol : int;\n pos_lnum : int; (* record the line number *)\n }\n\n exception Error of pos * pos * error\n\n let pp_error fmt err =\n Format.pp_print_string fmt\n @@\n match err with\n | Invalid_code_point -> \"Invalid code point\"\n | Unterminated_backslash -> \"\\\\ ended unexpectedly\"\n | Unterminated_variable -> \"$ unterminated\"\n | Unmatched_paren -> \"Unmatched paren\"\n | Invalid_syntax_of_var s -> \"`\" ^ s ^ \"' is not a valid syntax of interpolated identifer\"\n\n let valid_lead_identifier_char x = match x with 'a' .. 'z' | '_' -> true | _ -> false\n let valid_identifier_char x = match x with 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\\'' -> true | _ -> false\n\n (* Invariant: [valid_lead_identifier] has to be [valid_identifier] *)\n let valid_identifier =\n let for_all_from =\n let rec unsafe_for_all_range s ~start ~finish p =\n start > finish || (p (String.unsafe_get s start) && unsafe_for_all_range s ~start:(start + 1) ~finish p)\n in\n fun s start p ->\n let len = String.length s in\n if start < 0 then invalid_arg \"for_all_from\" else unsafe_for_all_range s ~start ~finish:(len - 1) p\n in\n fun s ->\n let s_len = String.length s in\n if s_len = 0 then false else valid_lead_identifier_char s.[0] && for_all_from s 1 valid_identifier_char\n\n (* FIXME: multiple line offset\n if there is no line offset. Note {|{j||} border will never trigger a new\n line *)\n let update_position border { lnum; offset; byte_bol } (pos : Lexing.position) =\n if lnum = 0 then { pos with pos_cnum = pos.pos_cnum + border + offset }\n (* When no newline, the column number is [border + offset] *)\n else\n {\n pos with\n pos_lnum = pos.pos_lnum + lnum;\n pos_bol = pos.pos_cnum + border + byte_bol;\n pos_cnum = pos.pos_cnum + border + byte_bol + offset;\n (* when newline, the column number is [offset] *)\n }\n\n let update border start finish (loc : Location.t) =\n let start_pos = loc.loc_start in\n { loc with loc_start = update_position border start start_pos; loc_end = update_position border finish start_pos }\n\n let pos_error cxt ~loc error =\n raise\n (Error (cxt.segment_start, { lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol }, error))\n\n let add_var_segment cxt loc loffset roffset =\n let content = Buffer.contents cxt.buf in\n Buffer.clear cxt.buf;\n let next_loc = { lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol } in\n if valid_identifier content then (\n cxt.segments <-\n { start = cxt.segment_start; finish = next_loc; kind = Var (loffset, roffset); content } :: cxt.segments;\n cxt.segment_start <- next_loc)\n else\n let cxt =\n match String.trim content with\n | \"\" ->\n (* Move the position back 2 characters \"$(\" if this is the empty\n interpolation. *)\n {\n cxt with\n segment_start =\n {\n cxt.segment_start with\n offset = (match cxt.segment_start.offset with 0 -> 0 | n -> n - 3);\n byte_bol = (match cxt.segment_start.byte_bol with 0 -> 0 | n -> n - 3);\n };\n pos_bol = cxt.pos_bol + 3;\n byte_bol = cxt.byte_bol + 3;\n }\n | _ -> cxt\n in\n pos_error cxt ~loc (Invalid_syntax_of_var content)\n\n let add_str_segment cxt loc =\n let content = Buffer.contents cxt.buf in\n Buffer.clear cxt.buf;\n let next_loc = { lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol } in\n cxt.segments <- { start = cxt.segment_start; finish = next_loc; kind = String; content } :: cxt.segments;\n cxt.segment_start <- next_loc\n\n let rec check_and_transform loc s byte_offset ({ s_len; buf; _ } as cxt) =\n if byte_offset = s_len then add_str_segment cxt loc\n else\n let current_char = s.[byte_offset] in\n match Utf8_string.classify current_char with\n | Single 92 (* '\\\\' *) ->\n let loc = loc + 1 in\n let offset = byte_offset + 1 in\n if offset >= s_len then pos_error cxt ~loc Unterminated_backslash else Buffer.add_char buf '\\\\';\n let cur_char = s.[offset] in\n Buffer.add_char buf cur_char;\n check_and_transform (loc + 1) s (offset + 1) cxt\n | Single 36 ->\n (* $ *)\n add_str_segment cxt loc;\n let offset = byte_offset + 1 in\n if offset >= s_len then pos_error ~loc cxt Unterminated_variable\n else\n let cur_char = s.[offset] in\n if cur_char = '(' then expect_var_paren (loc + 2) s (offset + 1) cxt\n else expect_simple_var (loc + 1) s offset cxt\n | Single _ | Leading _ | Cont _ ->\n Buffer.add_char buf current_char;\n check_and_transform (loc + 1) s (byte_offset + 1) cxt\n | Invalid -> pos_error ~loc cxt Invalid_code_point\n\n (* Lets keep identifier simple, so that we could generating a function easier\n in the future for example\n let f = [%fn{| $x + $y = $x_add_y |}] *)\n and expect_simple_var loc s offset ({ buf; s_len; _ } as cxt) =\n let v = ref offset in\n if not (offset < s_len && valid_lead_identifier_char s.[offset]) then\n pos_error cxt ~loc (Invalid_syntax_of_var String.empty)\n else (\n while !v < s_len && valid_identifier_char s.[!v] do\n (* TODO *)\n let cur_char = s.[!v] in\n Buffer.add_char buf cur_char;\n incr v\n done;\n let added_length = !v - offset in\n let loc = added_length + loc in\n add_var_segment cxt loc 1 0;\n check_and_transform loc s (added_length + offset) cxt)\n\n and expect_var_paren loc s offset ({ buf; s_len; _ } as cxt) =\n let v = ref offset in\n while !v < s_len && s.[!v] <> ')' do\n let cur_char = s.[!v] in\n Buffer.add_char buf cur_char;\n incr v\n done;\n let added_length = !v - offset in\n let loc = added_length + 1 + loc in\n if !v < s_len && s.[!v] = ')' then (\n add_var_segment cxt loc 2 (-1);\n check_and_transform loc s (added_length + 1 + offset) cxt)\n else pos_error cxt ~loc Unmatched_paren\n\n (* TODO: Allow identifers x.A.y *)\n\n let border = String.length \"{j|\"\n\n let rec handle_segments =\n let module Exp = Ast_helper.Exp in\n let concat_ident : Longident.t = Ldot (Lident \"Stdlib\", \"^\") in\n let escaped_js_delimiter =\n (* syntax not allowed at the user level *)\n let unescaped_js_delimiter = \"js\" in\n Some unescaped_js_delimiter\n in\n let merge_loc (l : Location.t) (r : Location.t) =\n if l.loc_ghost then r\n else if r.loc_ghost then l\n else\n match (l, r) with\n | { loc_start; _ }, { loc_end; _ } (* TODO: improve*) -> { loc_start; loc_end; loc_ghost = false }\n in\n let aux loc segment =\n match segment with\n | { start; finish; kind; content } -> (\n match kind with\n | String ->\n let loc = update border start finish loc in\n Exp.constant (Pconst_string (content, loc, escaped_js_delimiter))\n | Var (soffset, foffset) ->\n let loc =\n {\n loc with\n loc_start = update_position (soffset + border) start loc.loc_start;\n loc_end = update_position (foffset + border) finish loc.loc_start;\n }\n in\n Exp.ident ~loc { loc; txt = Lident content })\n in\n let concat_exp a_loc x ~(lhs : expression) =\n let loc = merge_loc a_loc lhs.pexp_loc in\n Exp.apply (Exp.ident { txt = concat_ident; loc }) [ (Nolabel, lhs); (Nolabel, aux loc x) ]\n in\n fun loc rev_segments ->\n match rev_segments with\n | [] -> Exp.constant (Pconst_string (\"\", loc, escaped_js_delimiter))\n | [ segment ] -> aux loc segment (* string literal *)\n | { content = \"\"; _ } :: rest -> handle_segments loc rest\n | a :: rest -> concat_exp loc a ~lhs:(handle_segments loc rest)\n\n let transform =\n let transform (e : expression) s =\n let s_len = String.length s in\n let buf = Buffer.create (s_len * 2) in\n let cxt =\n {\n segment_start = { lnum = 0; offset = 0; byte_bol = 0 };\n buf;\n s_len;\n segments = [];\n pos_lnum = 0;\n byte_bol = 0;\n pos_bol = 0;\n }\n in\n check_and_transform 0 s 0 cxt;\n handle_segments e.pexp_loc cxt.segments\n in\n fun ~loc expr s ->\n try transform expr s\n with Error (start, pos, error) ->\n let loc = update border start pos loc in\n Location.raise_errorf ~loc \"%a\" pp_error error\nend\n\nlet is_send_pipe pval_attributes =\n List.exists (fun { attr_name = { txt = attr } } -> String.equal attr \"mel.send.pipe\") pval_attributes\n\nlet has_browser_ppx_attribute attrs =\n List.exists\n (fun { attr_name = { txt = attr }; attr_payload; _ } ->\n match (attr, attr_payload) with\n | \"browser_only\", _ -> true\n | \"platform\", PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident \"js\" } }, _); _ } ] -> true\n | _ -> false)\n attrs\n\nlet has_attribute attrs name = List.exists (fun { attr_name = { txt; _ }; _ } -> String.equal txt name) attrs\n\n(* Keep this keyword list and translate_mel_obj_label in sync with Melange's\n Lam_methname.translate implementation:\n https://github.com/melange-re/melange/blob/main/jscomp/common/lam_methname.ml *)\nlet mel_obj_keywords =\n [\n \"and\";\n \"as\";\n \"assert\";\n \"begin\";\n \"class\";\n \"constraint\";\n \"do\";\n \"done\";\n \"downto\";\n \"else\";\n \"end\";\n \"exception\";\n \"external\";\n \"false\";\n \"for\";\n \"fun\";\n \"function\";\n \"functor\";\n \"if\";\n \"in\";\n \"include\";\n \"inherit\";\n \"initializer\";\n \"lazy\";\n \"let\";\n \"match\";\n \"method\";\n \"module\";\n \"mutable\";\n \"new\";\n \"nonrec\";\n \"object\";\n \"of\";\n \"open\";\n \"or\";\n \"private\";\n \"rec\";\n \"sig\";\n \"struct\";\n \"then\";\n \"to\";\n \"true\";\n \"try\";\n \"type\";\n \"val\";\n \"virtual\";\n \"when\";\n \"while\";\n \"with\";\n \"mod\";\n \"land\";\n \"lor\";\n \"lxor\";\n \"lsl\";\n \"lsr\";\n \"asr\";\n ]\n\nlet find_double_underscore name =\n let rec go index =\n if index < 0 then -1\n else if index + 1 < String.length name && name.[index] = '_' && name.[index + 1] = '_' then index\n else go (index - 1)\n in\n go (String.length name - 2)\n\nlet translate_mel_obj_label name =\n let valid_start_char = function '_' | 'a' .. 'z' -> true | _ -> false in\n let double_underscore_index = find_double_underscore name in\n if double_underscore_index = 0 then name\n else if double_underscore_index > 0 then String.sub name 0 double_underscore_index\n else\n match name.[0] with\n | '_' when String.length name > 1 ->\n let candidate = String.sub name 1 (String.length name - 1) in\n if (not (valid_start_char candidate.[0])) || List.mem candidate mel_obj_keywords then candidate else name\n | _ -> name\n\ntype js_object_field = { method_name : string; js_name : string; present_expr : expression; value_expr : expression }\n\nlet option_is_some_expr ~loc expr = [%expr match [%e expr] with None -> false | Some _ -> true]\n\nlet js_obj_internal_expression ~loc name =\n Builder.pexp_ident ~loc { txt = Ldot (Ldot (Ldot (Lident \"Js\", \"Obj\"), \"Internal\"), name); loc }\n\nlet build_registered_js_object_expression ?as_type ?(register_name = \"register_structural\") ~loc fields =\n let generated_fields =\n List.mapi\n (fun index { method_name; js_name; present_expr; value_expr } ->\n let cell_name = Printf.sprintf \"__js_obj_cell_%d\" index in\n let entry_name = Printf.sprintf \"__js_obj_entry_%d\" index in\n let slot_call =\n Builder.pexp_apply ~loc\n (js_obj_internal_expression ~loc \"slot_ref\")\n [\n (Labelled \"method_name\", Builder.estring ~loc method_name);\n (Labelled \"js_name\", Builder.estring ~loc js_name);\n (Labelled \"present\", present_expr);\n (Nolabel, value_expr);\n ]\n in\n let slot_binding =\n Builder.value_binding ~loc\n ~pat:\n (Builder.ppat_tuple ~loc\n [ Builder.ppat_var ~loc { loc; txt = cell_name }; Builder.ppat_var ~loc { loc; txt = entry_name } ])\n ~expr:slot_call\n in\n let method_body = Builder.pexp_apply ~loc (Builder.evar ~loc \"!\") [ (Nolabel, Builder.evar ~loc cell_name) ] in\n let method_ =\n Builder.pcf_method ~loc (Builder.Located.mk method_name ~loc, Public, Cfk_concrete (Fresh, method_body))\n in\n (slot_binding, Builder.evar ~loc entry_name, method_))\n fields\n in\n let slot_bindings, entry_exprs, methods =\n List.fold_right\n (fun (slot_binding, entry_expr, method_) (slot_bindings, entry_exprs, methods) ->\n (slot_binding :: slot_bindings, entry_expr :: entry_exprs, method_ :: methods))\n generated_fields ([], [], [])\n in\n let object_name = \"__js_obj\" in\n let object_binding =\n Builder.value_binding ~loc\n ~pat:(Builder.ppat_var ~loc { loc; txt = object_name })\n ~expr:(Builder.pexp_object ~loc (Builder.class_structure ~self:(Builder.ppat_any ~loc) ~fields:methods))\n in\n let register_call =\n Builder.pexp_apply ~loc\n (js_obj_internal_expression ~loc register_name)\n [ (Nolabel, Builder.evar ~loc object_name); (Nolabel, Builder.elist ~loc entry_exprs) ]\n in\n let register_call =\n match as_type with None -> register_call | Some core_type -> Builder.pexp_constraint ~loc register_call core_type\n in\n List.fold_right\n (fun binding acc -> Builder.pexp_let ~loc Nonrecursive [ binding ] acc)\n (slot_bindings @ [ object_binding ]) register_call\n\nlet rec get_return_core_type = function\n | { ptyp_desc = Ptyp_arrow (_, _, rest); _ } -> get_return_core_type rest\n | core_type -> core_type\n\nlet get_function_name pattern =\n let rec go pattern =\n match pattern with\n | Ppat_var { txt = name; _ } -> Some name\n | Ppat_constraint (pattern, _) -> go pattern.ppat_desc\n | _ -> None\n in\n go pattern\n\nlet get_label = function Ptyp_constr ({ txt = Lident label; _ }, _) -> Some label | _ -> None\n\n(* Extract the `t` from [@mel.send.pipe: t] *)\nlet get_send_pipe pval_attributes =\n if is_send_pipe pval_attributes then\n let first_attribute = List.hd pval_attributes in\n match first_attribute.attr_payload with PTyp core_type -> Some core_type | _ -> None\n else None\n\nlet has_ptyp_attribute ptyp_attributes attribute =\n List.exists (fun { attr_name = { txt = attr } } -> attr = attribute) ptyp_attributes\n\nlet is_mel_as core_type =\n match core_type with\n | { ptyp_desc = Ptyp_any; ptyp_attributes; _ } -> has_ptyp_attribute ptyp_attributes \"mel.as\"\n | _ -> false\n\nlet extract_args_labels_types acc pval_type =\n let rec go acc = function\n (* In case of being mel.as, ignore those *)\n | { ptyp_desc = Ptyp_arrow (_label, t1, _t2); _ } when is_mel_as t1 -> acc\n | { ptyp_desc = Ptyp_arrow (_label, _t1, t2); _ } when is_mel_as t2 -> acc\n | { ptyp_desc = Ptyp_arrow (_label, t1, t2); _ } when is_mel_as t1 && is_mel_as t2 -> acc\n | { ptyp_desc = Ptyp_arrow (label, t1, t2); _ } ->\n let pattern = Builder.ppat_var ~loc:t1.ptyp_loc { loc = t1.ptyp_loc; txt = \"_\" } in\n go ((label, pattern, t1) :: acc) t2\n | _ -> acc\n in\n go acc pval_type\n\n(* Insert send_pipe_core_type as a last argument of the function, but not the return type *)\nlet construct_pval_with_send_pipe send_pipe_core_type pval_type =\n let rec insert_core_type_in_arrow core_type =\n match core_type with\n (* Handle only ptyp and constr.\n Missing `| Ptyp_any | Ptyp_var | Ptyp_arrow | Ptyp_tuple | Ptyp_constr\n | Ptyp_object | Ptyp_class | Ptyp_alias | Ptyp_variant\n | Ptyp_poly | Ptyp_package | Ptyp_extension`\n The aren't used in most bindings.\n *)\n | { ptyp_desc = Ptyp_arrow (label, t1, t2); _ } -> (\n match (t1.ptyp_desc, t2.ptyp_desc) with\n (* `constr -> arrow (constr -> constr)` gets transformed into\n `constr -> constr -> t -> constr` *)\n | Ptyp_constr _, Ptyp_arrow (_inner_label, _p1, _p2) ->\n Builder.ptyp_arrow ~loc:t1.ptyp_loc label t1 (insert_core_type_in_arrow t2)\n (* `constr -> constr` gets transformed into `constr -> t -> constr` *)\n (* `arrow (constr -> constr) -> constr` gets transformed into,\n `arrow (constr -> constr) -> t -> constr` *)\n | _, _ ->\n Builder.ptyp_arrow ~loc:t2.ptyp_loc label t1\n (Builder.ptyp_arrow ~loc:t2.ptyp_loc Nolabel send_pipe_core_type t2))\n (* In case of being a single ptyp_* turn into ptyp_* -> t *)\n | { ptyp_desc = Ptyp_constr ({ txt = _; loc }, _); _ } | { ptyp_desc = Ptyp_var _; ptyp_loc = loc; _ } ->\n Builder.ptyp_arrow ~loc Nolabel core_type send_pipe_core_type\n (* Here we ignore the Ptyp_any *)\n | _ -> core_type\n in\n insert_core_type_in_arrow pval_type\n\nlet inject_send_pipe_as_last_argument pipe_type args_labels =\n match pipe_type with None -> args_labels | Some pipe_core_type -> pipe_core_type :: args_labels\n\nlet is_mel_raw expr = match expr with Pexp_extension ({ txt = \"mel.raw\"; _ }, _) -> true | _ -> false\n\nlet capture_payload expr =\n match expr with\n | PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (payload, _, _)); _ }, _); _ } ] ->\n payload\n | _ -> \"...\"\n\nlet get_payload_from_mel_raw expr =\n let rec go expr =\n match expr with\n | Pexp_extension ({ txt = \"mel.raw\"; _ }, pstr) -> capture_payload pstr\n | Pexp_constraint (expr, _) -> go expr.pexp_desc\n | Pexp_function (_, _, Pfunction_body expr) -> go expr.pexp_desc\n | _ -> \"...\"\n in\n go expr\n\nlet expression_has_mel_raw expr =\n let rec go expr =\n match expr with\n | Pexp_extension ({ txt = \"mel.raw\"; _ }, _) as pexp_desc -> is_mel_raw pexp_desc\n | Pexp_constraint (expr, _) -> is_mel_raw expr.pexp_desc\n | Pexp_function (_, _, Pfunction_body expr) -> go expr.pexp_desc\n | _ -> false\n in\n go expr\n\nlet raise_failure ~loc name =\n [%expr\n let () =\n Printf.printf\n {|\nThere is a Melange's external (for example: [@mel.get]) call from native code.\n\nMelange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n|}\n in\n raise (Runtime.fail_impossible_action_in_ssr [%e Builder.pexp_constant ~loc (Pconst_string (name, loc, None))])]\n\nlet validate_mel_obj_primitive ~loc pval_prim =\n match pval_prim with\n | [] -> ()\n | prims when List.for_all (String.equal \"\") prims -> ()\n | _ ->\n Location.raise_errorf ~loc\n \"[server-reason-react.melange_ppx] [@@mel.obj] requires its external payload to be the empty string\"\n\nlet transform_external_obj ~loc pval_name pval_type =\n let function_core_type = Builder.ppat_var ~loc:pval_name.loc { loc = pval_name.loc; txt = pval_name.txt } in\n let pat =\n Builder.ppat_constraint ~loc:pval_type.ptyp_loc function_core_type\n (Builder.ptyp_poly ~loc:pval_type.ptyp_loc [] pval_type)\n in\n let rec collect_arguments function_args fields = function\n | { ptyp_desc = Ptyp_arrow (label, core_type, rest); _ } -> (\n if is_mel_as core_type then\n Location.raise_errorf ~loc:core_type.ptyp_loc\n \"[server-reason-react.melange_ppx] [@mel.as] is not supported in native [@@mel.obj] externals yet\";\n match label with\n | Nolabel ->\n let pattern =\n match core_type.ptyp_desc with\n | Ptyp_constr ({ txt = Lident \"unit\"; _ }, []) -> Builder.ppat_any ~loc:core_type.ptyp_loc\n | _ ->\n Location.raise_errorf ~loc:core_type.ptyp_loc\n \"[server-reason-react.melange_ppx] [@@mel.obj] externals in native only support labelled \\\n arguments, optionally labelled arguments, and a final unit argument\"\n in\n collect_arguments ((label, pattern, core_type.ptyp_loc) :: function_args) fields rest\n | Labelled name | Optional name ->\n let ident = { loc = core_type.ptyp_loc; txt = name } in\n let pattern = Builder.ppat_var ~loc:core_type.ptyp_loc ident in\n let value = Builder.pexp_ident ~loc:core_type.ptyp_loc { loc = core_type.ptyp_loc; txt = Lident name } in\n let present_expr =\n match label with\n | Labelled _ -> Builder.ebool ~loc:core_type.ptyp_loc true\n | Optional _ -> option_is_some_expr ~loc:core_type.ptyp_loc value\n | Nolabel -> assert false\n in\n let field =\n { method_name = name; js_name = translate_mel_obj_label name; present_expr; value_expr = value }\n in\n collect_arguments ((label, pattern, core_type.ptyp_loc) :: function_args) (field :: fields) rest)\n | _ -> (List.rev function_args, List.rev fields)\n in\n let function_args, fields = collect_arguments [] [] pval_type in\n let object_expression =\n build_registered_js_object_expression ~loc ~register_name:\"register_abstract\"\n ~as_type:(get_return_core_type pval_type) fields\n in\n let function_expression =\n List.fold_right\n (fun (label, arg_pat, arg_loc) acc -> Builder.pexp_fun ~loc:arg_loc label None arg_pat acc)\n function_args object_expression\n in\n let vb = Builder.value_binding ~loc ~pat ~expr:function_expression in\n Ast_helper.Str.value Nonrecursive [ vb ]\n\nlet mel_raw_found_in_native_message ~loc payload =\n let msg =\n Printf.sprintf\n \"[server-reason-react.melange_ppx] There's a [%%mel.raw \\\"%s\\\"] expression in native, which should only happen \\\n in JavaScript. You need to conditionally run it via let%%browser_only or switch%%platform. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"\n payload\n in\n Builder.pexp_constant ~loc (Pconst_string (msg, loc, None))\n\nlet mel_module_found_in_native_message ~loc =\n let msg =\n Printf.sprintf\n \"[server-reason-react.melange_ppx] There's an external with [%%mel.module \\\"...\\\"] in native, which should only \\\n happen in JavaScript. You need to conditionally discard it from the native build, either by moving the external \\\n in a module only available in native, or annotating it with [@platform js]. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"\n in\n Builder.pexp_constant ~loc (Pconst_string (msg, loc, None))\n\nlet external_found_in_native_message ~loc =\n let msg =\n Printf.sprintf\n \"[server-reason-react.melange_ppx] There's an external in native, which should only happen in JavaScript. You \\\n need to conditionally discard it from the native build, either by moving the external in a module only \\\n available in native, or annotating it with [@platform js]. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"\n in\n Builder.pexp_constant ~loc (Pconst_string (msg, loc, None))\n\nlet get_function_arity pattern =\n let rec go arity params body =\n match params with\n | _ :: rest -> go (arity + 1) rest body\n | [] -> (\n match body with\n | Pfunction_body { pexp_desc = Pexp_function (more_params, _, inner_body); _ } ->\n go arity more_params inner_body\n | _ -> arity)\n in\n match pattern with Pexp_function (params, _, body) -> go 0 params body | _ -> 0\n\nlet transform_external_arrow ~loc pval_name pval_attributes pval_type =\n let pipe_type =\n match get_send_pipe pval_attributes with\n | Some core_type ->\n let pattern = Builder.ppat_var ~loc:core_type.ptyp_loc { loc = core_type.ptyp_loc; txt = \"_\" } in\n Some (Nolabel, pattern, core_type)\n | None -> None\n in\n let args_labels_types = extract_args_labels_types [] pval_type in\n let function_core_type = Builder.ppat_var ~loc:pval_name.loc { loc = pval_name.loc; txt = pval_name.txt } in\n let pval_type_piped =\n match pipe_type with\n | None -> pval_type\n | Some (_, _, pipe_type) -> construct_pval_with_send_pipe pipe_type pval_type\n in\n let pat =\n Builder.ppat_constraint ~loc:pval_type.ptyp_loc function_core_type\n (Builder.ptyp_poly ~loc:pval_type.ptyp_loc [] pval_type_piped)\n in\n let arg_labels = inject_send_pipe_as_last_argument pipe_type args_labels_types in\n let function_expression =\n List.fold_left\n (fun acc (label, arg_pat, arg_type) -> Builder.pexp_fun ~loc:arg_type.ptyp_loc label None arg_pat acc)\n (raise_failure ~loc:pval_type.ptyp_loc pval_name.txt)\n arg_labels\n in\n let vb = Builder.value_binding ~loc ~pat ~expr:function_expression in\n Ast_helper.Str.value Nonrecursive [ vb ]\n\nlet ptyp_humanize = function\n | Ptyp_tuple _ -> \"Tuples\"\n | Ptyp_object _ -> \"Objects\"\n | Ptyp_class _ -> \"Classes\"\n | Ptyp_variant _ -> \"Variants\"\n | Ptyp_extension _ -> \"Extensions\"\n | Ptyp_alias _ -> \"Alias\"\n | Ptyp_poly _ -> \"Polyvariants\"\n | Ptyp_package _ -> \"Packages\"\n | Ptyp_any -> \"Any\"\n | Ptyp_var _ -> \"Var\"\n | Ptyp_arrow _ -> \"Arrow\"\n | Ptyp_constr _ -> \"Constr\"\n | Ptyp_open _ -> \"Open\"\n\nlet transform_external ~module_path pval_name pval_attributes pval_loc pval_type pval_prim =\n let loc = pval_loc in\n match pval_type.ptyp_desc with\n | Ptyp_arrow _ ->\n if has_attribute pval_attributes \"mel.obj\" then (\n validate_mel_obj_primitive ~loc pval_prim;\n transform_external_obj ~loc pval_name pval_type)\n else transform_external_arrow ~loc pval_name pval_attributes pval_type\n | Ptyp_var _ | Ptyp_any | Ptyp_constr _ ->\n (* When mel.send.pipe is used, it's treated as a funcion *)\n if Option.is_some (get_send_pipe pval_attributes) then\n transform_external_arrow ~loc pval_name pval_attributes pval_type\n else if Mel_module.has_attr pval_attributes then\n match Mel_module.asset_payload pval_attributes with\n | None ->\n (* If it doesn't have asset payload, we error out as it must be some .js module or package being imported *)\n [%stri [%%ocaml.error [%e mel_module_found_in_native_message ~loc]]]\n | Some str ->\n (* If it has asset payload (file with extension), calculate hash and replace external *)\n let name = Builder.pvar ~loc:pval_name.loc pval_name.txt in\n let path =\n let asset_path = Filename.(concat (dirname module_path) str) in\n let s = In_channel.with_open_bin asset_path In_channel.input_all in\n let filename_fn =\n match !Mel_module.bundler with\n | Webpack -> Mel_module.Webpack.filename\n | Esbuild -> Mel_module.Esbuild.filename\n in\n let prefix = !Mel_module.prefix in\n Builder.estring ~loc Filename.(concat prefix (filename_fn ~base:(Filename.basename str) s))\n in\n [%stri let [%p name] = [%e path]]\n else [%stri [%%ocaml.error [%e external_found_in_native_message ~loc]]]\n | _ ->\n [%stri\n [%%ocaml.error\n \"[server-reason-react.melange_ppx] %s are not supported in native externals the same way as melange.ppx \\\n support them.\"\n (ptyp_humanize pval_type.ptyp_desc)]]\n\nlet validate_record_labels ~loc record =\n List.fold_left\n (fun acc (longident, expression) ->\n match acc with\n | Error _ as error -> error\n | Ok acc -> (\n match longident.txt with\n | Lident label ->\n Ok\n ({\n method_name = label;\n js_name = translate_mel_obj_label label;\n present_expr = Builder.ebool ~loc:expression.pexp_loc true;\n value_expr = expression;\n }\n :: acc)\n | Ldot _ | Lapply _ ->\n Error\n (Location.error_extensionf ~loc\n \"[server-reason-react.melange_ppx] Js.t objects only support labels as keys\")))\n (Ok []) record\n |> Result.map List.rev\n\nclass raise_exception_mapper (module_path : string) =\n object (_self)\n inherit Ast_traverse.map as super\n\n method! expression expr =\n let expr = super#expression expr in\n match expr.pexp_desc with\n | Pexp_extension\n ( { txt = \"mel.obj\"; _ },\n PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (record, None); pexp_loc }, _); _ } ] ) -> (\n match validate_record_labels ~loc:pexp_loc record with\n | Ok record -> build_registered_js_object_expression ~loc:pexp_loc record\n | Error extension -> Builder.pexp_extension ~loc:pexp_loc extension)\n | Pexp_extension ({ txt = \"mel.obj\"; loc }, _) ->\n Builder.pexp_extension ~loc\n (Location.error_extensionf ~loc:expr.pexp_loc\n \"[server-reason-react.melange_ppx] Js.t objects requires a record literal\")\n | Pexp_constant (Pconst_string (s, loc, Some \"j\")) -> String_interpolation.transform ~loc expr s\n | _ -> expr\n\n method! structure_item item =\n match item.pstr_desc with\n (* [%%mel.raw ...] *)\n | Pstr_extension (({ txt = \"mel.raw\"; _ }, pstr), _) ->\n let loc = item.pstr_loc in\n let payload = capture_payload pstr in\n [%stri [%%ocaml.error [%e mel_raw_found_in_native_message ~loc payload]]]\n (* let a _ = [%mel.raw ...] *)\n | Pstr_value\n ( Nonrecursive,\n [\n {\n pvb_expr = { pexp_desc = Pexp_function (_ :: _, _, Pfunction_body expression); _ };\n pvb_pat = { ppat_desc = Ppat_var { txt = _function_name; _ } };\n pvb_attributes = _;\n pvb_loc;\n };\n ] )\n when expression_has_mel_raw expression.pexp_desc ->\n let loc = item.pstr_loc in\n let payload = get_payload_from_mel_raw expression.pexp_desc in\n [%stri [%error [%e mel_raw_found_in_native_message ~loc:pvb_loc payload]]]\n (* let a = [%mel.raw ...] *)\n | Pstr_value\n ( Nonrecursive,\n [\n {\n pvb_expr = expression;\n pvb_pat = { ppat_desc = Ppat_var { txt = _function_name; _ } };\n pvb_attributes = _;\n pvb_loc;\n };\n ] )\n when expression_has_mel_raw expression.pexp_desc ->\n let loc = item.pstr_loc in\n let payload = get_payload_from_mel_raw expression.pexp_desc in\n [%stri [%error [%e mel_raw_found_in_native_message ~loc:pvb_loc payload]]]\n (* let a: t = [%mel.raw ...] *)\n | Pstr_value\n (Nonrecursive, [ { pvb_expr = expression; pvb_pat = { ppat_desc = _ }; pvb_attributes = _; pvb_loc } ])\n when expression_has_mel_raw expression.pexp_desc ->\n let loc = item.pstr_loc in\n let payload = get_payload_from_mel_raw expression.pexp_desc in\n [%stri [%error [%e mel_raw_found_in_native_message ~loc:pvb_loc payload]]]\n (* %mel. *)\n (* external foo: t = \"{{JavaScript}}\" *)\n | Pstr_primitive { pval_name; pval_attributes; pval_loc; pval_type; pval_prim } ->\n (* Detects [@browser_only] or [@platform js] attributes. When present on an external, we pass it through unchanged so browser_ppx can filter it out in native mode. *)\n if has_browser_ppx_attribute pval_attributes then item\n else transform_external ~module_path pval_name pval_attributes pval_loc pval_type pval_prim\n | _ -> super#structure_item item\n end\n\nlet structure_mapper ctxt s =\n let module_path = Code_path.file_path (Expansion_context.Base.code_path ctxt) in\n (new raise_exception_mapper module_path)#structure s\n\nmodule Debug = struct\n let rule =\n let extractor = Ast_pattern.(__') in\n let handler ~ctxt:_ { loc } = [%expr ()] in\n Context_free.Rule.extension (Extension.V3.declare \"debug\" Extension.Context.expression extractor handler)\nend\n\nlet () =\n Driver.add_arg \"-bundler\"\n (String\n (fun str ->\n match str with\n | \"webpack\" -> Mel_module.bundler := Webpack\n | \"esbuild\" -> Mel_module.bundler := Esbuild\n | _ ->\n failwith\n (Printf.sprintf\n {|Unknown value %S passed as -bundler flag in melange.ppx, valid values: \"webpack\", \"esbuild\"|} str)))\n ~doc:\"generate paths to assets in mel.module using the file name scheme of the bundler of choice\";\n Driver.add_arg \"-prefix\"\n (String (fun str -> Mel_module.prefix := str))\n ~doc:\"the paths to the generated assets will include the given prefix before the filename (default: \\\"/\\\")\";\n Driver.V2.register_transformation ~impl:structure_mapper\n ~rules:[ Pipe_first.rule; Regex.rule; Double_hash.rule; Debug.rule; Private.rule ]\n \"melange-native-ppx\"\n"
},
{
"path": "packages/melange.ppx/regex.ml",
"content": "open Ppxlib\nmodule Builder = Ast_builder.Default\n\nlet parse_re str =\n try\n let _ = Str.search_forward (Str.regexp \"/\\\\(.*\\\\)/\\\\(.*\\\\)\") str 0 in\n let first = Str.matched_group 1 str in\n let second = Str.matched_group 2 str in\n match String.length second with 0 -> Ok (first, None) | _ -> Ok (first, Some second)\n with Not_found -> Error \"invalid regex\"\n\nlet extractor = Ast_pattern.(__')\n\nlet handler ~ctxt:_ ({ txt = payload; loc } : Ppxlib.Parsetree.payload loc) =\n match payload with\n | PStr [ { pstr_desc = Pstr_eval (expression, _); _ } ] -> (\n match expression.pexp_desc with\n | Pexp_constant (Pconst_string (str, location, _delimiter)) -> (\n match parse_re str with\n | Ok (regex, flags) -> (\n let regex = Builder.estring ~loc:location regex in\n match flags with\n | None -> [%expr Js.Re.fromString [%e regex]]\n | Some flags' ->\n let flags = Builder.estring ~loc:location flags' in\n [%expr Js.Re.fromStringWithFlags ~flags:[%e flags] [%e regex]])\n | Error err ->\n Builder.pexp_extension ~loc\n (Location.error_extensionf ~loc:location \"[server-reason-react.melange_ppx] invalid regex: %s,\\n%s\" err\n str))\n | _ ->\n Builder.pexp_extension ~loc\n (Location.error_extensionf ~loc \"[server-reason-react.melange_ppx] payload should be a string literal\"))\n | _ ->\n Builder.pexp_extension ~loc\n (Location.error_extensionf ~loc\n \"[server-reason-react.melange_ppx] [%%re] extension should have an expression as payload\")\n\nlet rule =\n let extension = Extension.V3.declare \"mel.re\" Extension.Context.expression extractor handler in\n Context_free.Rule.extension extension\n"
},
{
"path": "packages/melange.ppx/tests/dune",
"content": "(cram\n (package server-reason-react)\n (enabled_if\n (>= %{ocaml_version} 5.2.0))\n (deps %{bin:ocamlformat} standalone.exe))\n\n(executable\n (name standalone)\n (libraries ppxlib melange_native_ppx))\n"
},
{
"path": "packages/melange.ppx/tests/external.t",
"content": "An external without platform attribute errors\n\n $ cat > input.ml << EOF\n > type t\n > external document: t = \"document\"\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type t\n \n [%%ocaml.error\n \"[server-reason-react.melange_ppx] There's an external in native, which should \\\n only happen in JavaScript. You need to conditionally discard it from the \\\n native build, either by moving the external in a module only available in \\\n native, or annotating it with [@platform js]. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n File \"main.ml\", line 26, characters 3-14:\n 26 | [%%ocaml.error\n ^^^^^^^^^^^\n Error: [server-reason-react.melange_ppx] There's an external in native, which\n should only happen in JavaScript. You need to conditionally discard it\n from the native build, either by moving the external in a module only\n available in native, or annotating it with [@platform js]. More info\n at\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\n [2]\n\nAn external with [@platform js] is passed through (browser_ppx will filter it)\n\n $ cat > input.ml << EOF\n > type t\n > external document: t = \"document\" [@@platform js]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type t\n \n external document : t = \"document\" [@@platform js]\n\nAn external with [@browser_only] is passed through (browser_ppx will filter it)\n\n $ cat > input.ml << EOF\n > type t\n > external document: t = \"document\" [@@browser_only]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type t\n \n external document : t = \"document\" [@@browser_only]\n"
},
{
"path": "packages/melange.ppx/tests/input.ml",
"content": "type action = Click | Submit | Cancel [@@deriving jsConverter]\n"
},
{
"path": "packages/melange.ppx/tests/jsConverter.t",
"content": "Basic regular variant\n $ cat > input.ml << EOF\n > type action = Click | Submit | Cancel [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type action = Click | Submit | Cancel [@@deriving jsConverter]\n \n include struct\n let _ = fun (_ : action) -> ()\n let actionToJs x = match x with Click -> 0 | Submit -> 1 | Cancel -> 2\n let _ = actionToJs\n \n let actionFromJs x =\n match x with\n | 0 -> Some Click\n | 1 -> Some Submit\n | 2 -> Some Cancel\n | _ -> None\n \n let _ = actionFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nRegular variant with @mel.as\n $ cat > input.ml << EOF\n > type action = Click | Submit [@mel.as 3] | Cancel [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type action = Click | Submit [@mel.as 3] | Cancel [@@deriving jsConverter]\n \n include struct\n let _ = fun (_ : action) -> ()\n let actionToJs x = match x with Click -> 0 | Submit -> 3 | Cancel -> 4\n let _ = actionToJs\n \n let actionFromJs x =\n match x with\n | 0 -> Some Click\n | 3 -> Some Submit\n | 4 -> Some Cancel\n | _ -> None\n \n let _ = actionFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nBasic polymorphic variant\n $ cat > input.ml << EOF\n > type state = [\\`Idle | \\`Loading | \\`Error] [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type state = [ `Idle | `Loading | `Error ] [@@deriving jsConverter]\n \n include struct\n let _ = fun (_ : state) -> ()\n \n let stateToJs x =\n match x with `Idle -> \"Idle\" | `Loading -> \"Loading\" | `Error -> \"Error\"\n \n let _ = stateToJs\n \n let stateFromJs x =\n match x with\n | \"Idle\" -> Some `Idle\n | \"Loading\" -> Some `Loading\n | \"Error\" -> Some `Error\n | _ -> None\n \n let _ = stateFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nPolymorphic variant with @mel.as\n $ cat > input.ml << EOF\n > type state = [\\`Idle | \\`Loading [@mel.as \"loading\"] | \\`Error] [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type state = [ `Idle | `Loading [@mel.as \"loading\"] | `Error ]\n [@@deriving jsConverter]\n \n include struct\n let _ = fun (_ : state) -> ()\n \n let stateToJs x =\n match x with `Idle -> \"Idle\" | `Loading -> \"loading\" | `Error -> \"Error\"\n \n let _ = stateToJs\n \n let stateFromJs x =\n match x with\n | \"Idle\" -> Some `Idle\n | \"loading\" -> Some `Loading\n | \"Error\" -> Some `Error\n | _ -> None\n \n let _ = stateFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nRegular variant with newType\n $ cat > input.ml << EOF\n > type action = Click | Submit [@@deriving jsConverter { newType }]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type action = Click | Submit [@@deriving jsConverter { newType }]\n \n include struct\n let _ = fun (_ : action) -> ()\n \n type nonrec abs_action = int\n \n let actionToJs x = match x with Click -> 0 | Submit -> 1\n let _ = actionToJs\n let actionFromJs x = match x with 0 -> Click | 1 -> Submit\n let _ = actionFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nPolymorphic variant with newType\n $ cat > input.ml << EOF\n > type state = [\\`Idle | \\`Loading] [@@deriving jsConverter { newType }]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type state = [ `Idle | `Loading ] [@@deriving jsConverter { newType }]\n \n include struct\n let _ = fun (_ : state) -> ()\n \n type nonrec abs_state = string\n \n let stateToJs x = match x with `Idle -> \"Idle\" | `Loading -> \"Loading\"\n let _ = stateToJs\n let stateFromJs x = match x with \"Idle\" -> `Idle | \"Loading\" -> `Loading\n let _ = stateFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nError: variant with payload\n $ cat > input.ml << EOF\n > type action = Click | Submit of int [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 20-35:\n 1 | type action = Click | Submit of int [@@deriving jsConverter]\n ^^^^^^^^^^^^^^^\n Error: [@deriving jsConverter] does not support variant constructors with payloads\n [1]\n\nError: polymorphic variant with payload\n $ cat > input.ml << EOF\n > type state = [\\`Idle | \\`Loading of int] [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 22-37:\n 1 | type state = [`Idle | `Loading of int] [@@deriving jsConverter]\n ^^^^^^^^^^^^^^^\n Error: [@deriving jsConverter] does not support polymorphic variant constructors with payloads\n [1]\n\nSignature generation for regular variant\n $ cat > input.mli << EOF\n > type action = Click | Submit | Cancel [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type action = Click | Submit | Cancel [@@deriving jsConverter]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val actionToJs : action -> int\n val actionFromJs : int -> action option\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation for polymorphic variant\n $ cat > input.mli << EOF\n > type state = [\\`Idle | \\`Loading] [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type state = [ `Idle | `Loading ] [@@deriving jsConverter]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val stateToJs : state -> string\n val stateFromJs : string -> state option\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation with newType\n $ cat > input.mli << EOF\n > type action = Click | Submit [@@deriving jsConverter { newType }]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type action = Click | Submit [@@deriving jsConverter { newType }]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n type nonrec abs_action\n \n val actionToJs : action -> abs_action\n val actionFromJs : abs_action -> action\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nBackwards compatibility: @bs.as attribute\n $ cat > input.ml << EOF\n > type legacy = A | B [@bs.as 5] | C [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type legacy = A | B [@bs.as 5] | C [@@deriving jsConverter]\n \n include struct\n let _ = fun (_ : legacy) -> ()\n let legacyToJs x = match x with A -> 0 | B -> 1 | C -> 2\n let _ = legacyToJs\n \n let legacyFromJs x =\n match x with 0 -> Some A | 1 -> Some B | 2 -> Some C | _ -> None\n \n let _ = legacyFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nMultiple type declarations with 'and'\n $ cat > input.ml << EOF\n > type a = A1 | A2\n > and b = B1 | B2 [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type a = A1 | A2\n and b = B1 | B2 [@@deriving jsConverter]\n \n include struct\n let _ = fun (_ : a) -> ()\n let _ = fun (_ : b) -> ()\n let aToJs x = match x with A1 -> 0 | A2 -> 1\n let _ = aToJs\n let aFromJs x = match x with 0 -> Some A1 | 1 -> Some A2 | _ -> None\n let _ = aFromJs\n let bToJs x = match x with B1 -> 0 | B2 -> 1\n let _ = bToJs\n let bFromJs x = match x with 0 -> Some B1 | 1 -> Some B2 | _ -> None\n let _ = bFromJs\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nError: empty variant\n $ cat > input.ml << EOF\n > type empty = | [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 0-39:\n 1 | type empty = | [@@deriving jsConverter]\n ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n Error: [@deriving jsConverter] cannot be used on empty variant types\n [1]\n\nError: duplicate @mel.as values\n $ cat > input.ml << EOF\n > type dup = A [@mel.as 1] | B [@mel.as 1] [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 0-65:\n 1 | type dup = A [@mel.as 1] | B [@mel.as 1] [@@deriving jsConverter]\n ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n Error: [@deriving jsConverter] has duplicate value 1 - each constructor must map to a unique integer\n [1]\n\nError: open polymorphic variant\n $ cat > input.ml << EOF\n > type open_poly = [> \\`A | \\`B] [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 17-28:\n 1 | type open_poly = [> `A | `B] [@@deriving jsConverter]\n ^^^^^^^^^^^\n Error: [@deriving jsConverter] does not support open polymorphic variants\n [1]\n\nError: record type\n $ cat > input.ml << EOF\n > type person = { name: string; age: int } [@@deriving jsConverter]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 0-65:\n 1 | type person = { name: string; age: int } [@@deriving jsConverter]\n ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n Error: [@deriving jsConverter] only supports variant types and polymorphic variant types\n [1]\n"
},
{
"path": "packages/melange.ppx/tests/jsProperties.t",
"content": "Basic jsProperties\n $ cat > input.ml << EOF\n > type person = { name: string; age: int } [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = { name : string; age : int } [@@deriving jsProperties]\n \n include struct\n let _ = fun (_ : person) -> ()\n let person ~name ~age = { name; age }\n let _ = person\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\njsProperties with @mel.optional\n $ cat > input.ml << EOF\n > type person = { name: string; age: int option [@mel.optional] } [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = { name : string; age : int option [@mel.optional] }\n [@@deriving jsProperties]\n \n include struct\n let _ = fun (_ : person) -> ()\n let person ~name ?age () = { name; age }\n let _ = person\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\njsProperties with multiple optional fields\n $ cat > input.ml << EOF\n > type config = { \n > host: string;\n > port: int option [@mel.optional];\n > debug: bool option [@mel.optional]\n > } [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type config = {\n host : string;\n port : int option; [@mel.optional]\n debug : bool option; [@mel.optional]\n }\n [@@deriving jsProperties]\n \n include struct\n let _ = fun (_ : config) -> ()\n let config ~host ?port ?debug () = { host; port; debug }\n let _ = config\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nBasic getSet\n $ cat > input.ml << EOF\n > type person = { name: string; age: int } [@@deriving getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = { name : string; age : int } [@@deriving getSet]\n \n include struct\n let _ = fun (_ : person) -> ()\n let nameGet x = x.name\n let _ = nameGet\n let ageGet x = x.age\n let _ = ageGet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\ngetSet with mutable fields\n $ cat > input.ml << EOF\n > type person = { name: string; mutable age: int } [@@deriving getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = { name : string; mutable age : int } [@@deriving getSet]\n \n include struct\n let _ = fun (_ : person) -> ()\n let nameGet x = x.name\n let _ = nameGet\n let ageGet x = x.age\n let _ = ageGet\n let ageSet x v = x.age <- v\n let _ = ageSet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\ngetSet with light mode\n $ cat > input.ml << EOF\n > type person = { name: string; mutable age: int } [@@deriving getSet { light }]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = { name : string; mutable age : int } [@@deriving getSet { light }]\n \n include struct\n let _ = fun (_ : person) -> ()\n let name x = x.name\n let _ = name\n let age x = x.age\n let _ = age\n let ageSet x v = x.age <- v\n let _ = ageSet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nCombined jsProperties and getSet\n $ cat > input.ml << EOF\n > type person = { name: string; mutable age: int } [@@deriving jsProperties, getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = { name : string; mutable age : int }\n [@@deriving jsProperties, getSet]\n \n include struct\n let _ = fun (_ : person) -> ()\n let person ~name ~age = { name; age }\n let _ = person\n let nameGet x = x.name\n let _ = nameGet\n let ageGet x = x.age\n let _ = ageGet\n let ageSet x v = x.age <- v\n let _ = ageSet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nCombined jsProperties and getSet with optional and light\n $ cat > input.ml << EOF\n > type config = { \n > host: string;\n > mutable port: int option [@mel.optional]\n > } [@@deriving jsProperties, getSet { light }]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type config = { host : string; mutable port : int option [@mel.optional] }\n [@@deriving jsProperties, getSet { light }]\n \n include struct\n let _ = fun (_ : config) -> ()\n let config ~host ?port () = { host; port }\n let _ = config\n let host x = x.host\n let _ = host\n let port x = x.port\n let _ = port\n let portSet x v = x.port <- v\n let _ = portSet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation for jsProperties\n $ cat > input.mli << EOF\n > type person = { name: string; age: int } [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type person = { name : string; age : int } [@@deriving jsProperties]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val person : name:string -> age:int -> person\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation for jsProperties with optional\n $ cat > input.mli << EOF\n > type person = { name: string; age: int option [@mel.optional] } [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type person = { name : string; age : int option [@mel.optional] }\n [@@deriving jsProperties]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val person : name:string -> ?age:int -> unit -> person\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation for getSet\n $ cat > input.mli << EOF\n > type person = { name: string; mutable age: int } [@@deriving getSet]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type person = { name : string; mutable age : int } [@@deriving getSet]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val nameGet : person -> string\n val ageGet : person -> int\n val ageSet : person -> int -> unit\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation for getSet with light mode\n $ cat > input.mli << EOF\n > type person = { name: string; mutable age: int } [@@deriving getSet { light }]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type person = { name : string; mutable age : int } [@@deriving getSet { light }]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val name : person -> string\n val age : person -> int\n val ageSet : person -> int -> unit\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSignature generation for record with type parameter\n $ cat > input.mli << EOF\n > type 'a container = { value: 'a } [@@deriving jsProperties, getSet]\n > EOF\n\n $ ./standalone.exe -intf input.mli | ocamlformat - --enable-outside-detected-project --intf\n type 'a container = { value : 'a } [@@deriving jsProperties, getSet]\n \n include sig\n [@@@ocaml.warning \"-32\"]\n \n val container : value:'a -> 'a container\n val valueGet : 'a container -> 'a\n end\n [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nError: jsProperties on variant type\n $ cat > input.ml << EOF\n > type action = Click | Submit [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 0-54:\n 1 | type action = Click | Submit [@@deriving jsProperties]\n ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n Error: [@deriving jsProperties] can only be used on record types\n [1]\n\nError: getSet on variant type\n $ cat > input.ml << EOF\n > type action = Click | Submit [@@deriving getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml 2>&1\n File \"input.ml\", line 1, characters 0-48:\n 1 | type action = Click | Submit [@@deriving getSet]\n ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n Error: [@deriving getSet] can only be used on record types\n [1]\n\nPrivate types should not generate jsProperties constructor\n $ cat > input.ml << EOF\n > type person = private { name: string; age: int } [@@deriving jsProperties]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type person = private { name : string; age : int } [@@deriving jsProperties]\n \n include struct\n let _ = fun (_ : person) -> ()\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nSingle field record\n $ cat > input.ml << EOF\n > type single = { value: int } [@@deriving jsProperties, getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type single = { value : int } [@@deriving jsProperties, getSet]\n \n include struct\n let _ = fun (_ : single) -> ()\n let single ~value = { value }\n let _ = single\n let valueGet x = x.value\n let _ = valueGet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nRecord with type parameter\n $ cat > input.ml << EOF\n > type 'a container = { value: 'a } [@@deriving jsProperties, getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type 'a container = { value : 'a } [@@deriving jsProperties, getSet]\n \n include struct\n let _ = fun (_ : 'a container) -> ()\n let container ~value = { value }\n let _ = container\n let valueGet x = x.value\n let _ = valueGet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n\nMutually recursive types (generates shadowing bindings, matching melange behavior)\n $ cat > input.ml << EOF\n > type a = { x: int; b_ref: b option [@mel.optional] } [@@deriving jsProperties, getSet]\n > and b = { y: string; a_ref: a option [@mel.optional] } [@@deriving jsProperties, getSet]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n type a = { x : int; b_ref : b option [@mel.optional] }\n [@@deriving jsProperties, getSet]\n \n and b = { y : string; a_ref : a option [@mel.optional] }\n [@@deriving jsProperties, getSet]\n \n include struct\n let _ = fun (_ : a) -> ()\n let _ = fun (_ : b) -> ()\n let a ~x ?b_ref () = { x; b_ref }\n let _ = a\n let b ~y ?a_ref () = { y; a_ref }\n let _ = b\n let xGet x = x.x\n let _ = xGet\n let b_refGet x = x.b_ref\n let _ = b_refGet\n let yGet x = x.y\n let _ = yGet\n let a_refGet x = x.a_ref\n let _ = a_refGet\n let a ~x ?b_ref () = { x; b_ref }\n let _ = a\n let b ~y ?a_ref () = { y; a_ref }\n let _ = b\n let xGet x = x.x\n let _ = xGet\n let b_refGet x = x.b_ref\n let _ = b_refGet\n let yGet x = x.y\n let _ = yGet\n let a_refGet x = x.a_ref\n let _ = a_refGet\n end [@@ocaml.doc \"@inline\"] [@@merlin.hide]\n"
},
{
"path": "packages/melange.ppx/tests/mel_as.t",
"content": "mel.as attribute\n $ cat > input.ml << EOF\n > external get : t -> (_[@mel.as {json|{}|json}]) -> t = \"get\" [@@mel.send]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let get : t -> (_[@mel.as {json|{}|json}]) -> t =\n fun _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"get\")\n"
},
{
"path": "packages/melange.ppx/tests/mel_module.t",
"content": " $ cat > input.ml << EOF\n > type keycloak\n > external keycloak : string -> keycloak = \"default\" [@@mel.module]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type keycloak\n \n let keycloak : string -> keycloak =\n fun _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"keycloak\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nMultiple args with optional\n\n $ cat > input.ml << EOF\n > type keycloak\n > external keycloak : ?z:int -> int -> foo:string -> keycloak = \"default\" [@@mel.module]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type keycloak\n \n let keycloak : ?z:int -> int -> foo:string -> keycloak =\n fun ?z:_ _ ~foo:_ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"keycloak\")\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nSingle type (invalid OCaml, but valid in Melange)\n\n $ cat > input.ml << EOF\n > type keycloak\n > external keycloak : keycloak = \"default\" [@@mel.module \"keycloak-js\"]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type keycloak\n \n [%%ocaml.error\n \"[server-reason-react.melange_ppx] There's an external with [%mel.module \\\n \\\"...\\\"] in native, which should only happen in JavaScript. You need to \\\n conditionally discard it from the native build, either by moving the external \\\n in a module only available in native, or annotating it with [@platform js]. \\\n More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n File \"main.ml\", line 26, characters 3-14:\n 26 | [%%ocaml.error\n ^^^^^^^^^^^\n Error: [server-reason-react.melange_ppx] There's an external with\n [%mel.module \"...\"] in native, which should only happen in JavaScript.\n You need to conditionally discard it from the native build, either by\n moving the external in a module only available in native, or\n annotating it with [@platform js]. More info at\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\n [2]\n\nAssets with file not found\n\n $ cat > input.ml << EOF\n > external img : string = \"default\" [@@mel.module \"does-not-exist.svg\"]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n File \"input.ml\", line 1:\n Error: I/O error: ./does-not-exist.svg: No such file or directory\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nWebpack: assets like svg or images (payload to mel.module includes file extension)\n\n $ cat > input.ml << EOF\n > external img : string = \"default\" [@@mel.module \"./image.svg\"]\n > EOF\n\n $ cat > image.svg << EOF\n > \n > EOF\n\n $ ./standalone.exe -impl input.ml -bundler webpack | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let img = \"/1d876c8887ac1038.svg\"\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nCreate folder for following tests\n\n $ mkdir foo\n\nWebpack: assets like svg or images with paths outside current folder\n\n $ cat > foo/input.ml << EOF\n > external img : string = \"default\" [@@mel.module \"../image.svg\"]\n > EOF\n\n $ cat > image.svg << EOF\n > \n > EOF\n\n $ ./standalone.exe -impl $(pwd)/foo/input.ml -bundler webpack | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let img = \"/1d876c8887ac1038.svg\"\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nEsbuild: assets like svg or images (payload to mel.module includes file extension)\n\n $ cat > input.ml << EOF\n > external img : string = \"default\" [@@mel.module \"./image.svg\"]\n > EOF\n\n $ cat > image.svg << EOF\n > \n > EOF\n\n $ ./standalone.exe -impl input.ml -bundler esbuild | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let img = \"/image-DWDWZCEH.svg\"\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nEsbuild: assets like svg or images with paths outside current folder\n\n $ cat > foo/input.ml << EOF\n > external img : string = \"default\" [@@mel.module \"../image.svg\"]\n > EOF\n\n $ cat > image.svg << EOF\n > \n > EOF\n\n $ ./standalone.exe -impl $(pwd)/foo/input.ml -bundler esbuild | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let img = \"/image-DWDWZCEH.svg\"\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nWith prefix\n\n $ cat > foo/input.ml << EOF\n > external img : string = \"default\" [@@mel.module \"../demo.txt\"]\n > EOF\n\n $ cat > demo.txt << EOF\n > hello\n > EOF\n\n $ ./standalone.exe -impl $(pwd)/foo/input.ml -bundler esbuild -prefix /foo/bar | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let img = \"/foo/bar/demo-4TAZDUER.txt\"\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n"
},
{
"path": "packages/melange.ppx/tests/mel_obj.t",
"content": "Transform mel.obj into OCaml object literals\n\n $ cat > input.ml << EOF\n > let a = [%mel.obj { lola = 33; cositas = \"hola\"}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let a =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"lola\" ~js_name:\"lola\" ~present:true\n 33\n in\n let __js_obj_cell_1, __js_obj_entry_1 =\n Js.Obj.Internal.slot_ref ~method_name:\"cositas\" ~js_name:\"cositas\"\n ~present:true \"hola\"\n in\n let __js_obj =\n object\n method lola = !__js_obj_cell_0\n method cositas = !__js_obj_cell_1\n end\n in\n Js.Obj.Internal.register_structural __js_obj\n [ __js_obj_entry_0; __js_obj_entry_1 ]\n\n $ cat > main.ml << EOF\n > module Js = struct\n > module Obj = struct\n > module Internal = struct\n > type entry = unit\n > let slot_ref ~method_name:_ ~js_name:_ ~present:_ value = (ref value, ())\n > let register_structural obj _ = obj\n > end\n > end\n > end\n > EOF\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nTransform nested mel.obj into OCaml object literals\n\n $ cat > input.ml << EOF\n > let a = [%mel.obj { lola = 33; cositas = [%mel.obj { value = \"hola\" }]}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let a =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"lola\" ~js_name:\"lola\" ~present:true\n 33\n in\n let __js_obj_cell_1, __js_obj_entry_1 =\n Js.Obj.Internal.slot_ref ~method_name:\"cositas\" ~js_name:\"cositas\"\n ~present:true\n (let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"value\" ~js_name:\"value\"\n ~present:true \"hola\"\n in\n let __js_obj =\n object\n method value = !__js_obj_cell_0\n end\n in\n Js.Obj.Internal.register_structural __js_obj [ __js_obj_entry_0 ])\n in\n let __js_obj =\n object\n method lola = !__js_obj_cell_0\n method cositas = !__js_obj_cell_1\n end\n in\n Js.Obj.Internal.register_structural __js_obj\n [ __js_obj_entry_0; __js_obj_entry_1 ]\n\n $ cat > main.ml << EOF\n > module Js = struct\n > module Obj = struct\n > module Internal = struct\n > type entry = unit\n > let slot_ref ~method_name:_ ~js_name:_ ~present:_ value = (ref value, ())\n > let register_structural obj _ = obj\n > end\n > end\n > end\n > EOF\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\n\nFail if the object is not a record\n\n $ cat > input.ml << EOF\n > let a = [%mel.obj \"hola\"]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let a =\n [%ocaml.error\n \"[server-reason-react.melange_ppx] Js.t objects requires a record literal\"]\n\n $ ocamlc -c output.ml\n File \"output.ml\", line 2, characters 4-15:\n 2 | [%ocaml.error\n ^^^^^^^^^^^\n Error: [server-reason-react.melange_ppx] Js.t objects requires a record\n literal\n [2]\n\nFail if the object is not a record\n\n $ cat > input.ml << EOF\n > let a = [%mel.obj { Lola.cositas = \"hola\"}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let a =\n [%ocaml.error\n \"[server-reason-react.melange_ppx] Js.t objects only support labels as keys\"]\n\n $ ocamlc -c output.ml\n File \"output.ml\", line 2, characters 4-15:\n 2 | [%ocaml.error\n ^^^^^^^^^^^\n Error: [server-reason-react.melange_ppx] Js.t objects only support labels as\n keys\n [2]\n"
},
{
"path": "packages/melange.ppx/tests/mel_raw.t",
"content": "mel.raw as a value\n\n $ cat > input.ml << EOF\n > let value = [%mel.raw {| function(element) { return element.ownerDocument; } |}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n [%error\n \"[server-reason-react.melange_ppx] There's a [%mel.raw \\\" function(element) \\\n { return element.ownerDocument; } \\\"] expression in native, which should \\\n only happen in JavaScript. You need to conditionally run it via \\\n let%browser_only or switch%platform. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n\nmel.raw as an unary function\n\n $ cat > input.ml << EOF\n > let unary_function element = [%mel.raw {| function(element) { return element.ownerDocument; } |}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n [%error\n \"[server-reason-react.melange_ppx] There's a [%mel.raw \\\" function(element) \\\n { return element.ownerDocument; } \\\"] expression in native, which should \\\n only happen in JavaScript. You need to conditionally run it via \\\n let%browser_only or switch%platform. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n\nmel.raw as an binary function\n\n $ cat > input.ml << EOF\n > let binary_function element count = [%mel.raw {| function(element, number) {\n > console.log(number);\n > return element.ownerDocument;\n > } |}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n [%error\n \"[server-reason-react.melange_ppx] There's a [%mel.raw \\\" function(element, \\\n number) {\\n\\\n \\ console.log(number);\\n\\\n \\ return element.ownerDocument;\\n\\\n } \\\"] expression in native, which should only happen in JavaScript. You \\\n need to conditionally run it via let%browser_only or switch%platform. More \\\n info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n\nmel.raw with type\n\n $ cat > input.ml << EOF\n > type t\n > let global: t = [%mel.raw \"window\"]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type t;;\n \n [%error\n \"[server-reason-react.melange_ppx] There's a [%mel.raw \\\"window\\\"] \\\n expression in native, which should only happen in JavaScript. You need to \\\n conditionally run it via let%browser_only or switch%platform. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n File \"main.ml\", line 26, characters 2-7:\n 26 | [%error\n ^^^^^\n Error: [server-reason-react.melange_ppx] There's a [%mel.raw \"window\"]\n expression in native, which should only happen in JavaScript. You need\n to conditionally run it via let%browser_only or switch%platform. More\n info at\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\n [2]\n\nmel.raw as a value\n\n $ cat > input.ml << EOF\n > [%%mel.raw {| console.log(\"running in JS\"); |}]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n [%%ocaml.error\n \"[server-reason-react.melange_ppx] There's a [%mel.raw \\\" \\\n console.log(\\\"running in JS\\\"); \\\"] expression in native, which should only \\\n happen in JavaScript. You need to conditionally run it via let%browser_only \\\n or switch%platform. More info at \\\n https://ml-in-barcelona.github.io/server-reason-react/server-reason-react/browser_ppx.html\"]\n"
},
{
"path": "packages/melange.ppx/tests/mel_send.t",
"content": "Labelled args with @@mel.send\n $ cat > input.ml << EOF\n > external init : string -> param:int -> string = \"init\" [@@mel.send]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let init : string -> param:int -> string =\n fun _ ~param:_ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"init\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nLabelled and unlabelled args with @@mel.obj\n\n $ cat > input.ml << EOF\n > external makeInitParam : onLoad:string -> unit -> < onLoad : string > = \"\" [@@mel.obj]\n > let onLoad = (makeInitParam ~onLoad:\"ready\" ())##onLoad\n > external makeOptional : ?retries:int -> unit -> < retries : int option > = \"\" [@@mel.obj]\n > let retries = (makeOptional ())##retries\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let makeInitParam : onLoad:string -> unit -> < onLoad : string > =\n fun ~onLoad _ ->\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"onLoad\" ~js_name:\"onLoad\"\n ~present:true onLoad\n in\n let __js_obj =\n object\n method onLoad = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < onLoad : string >)\n \n let onLoad = (makeInitParam ~onLoad:\"ready\" ())#onLoad\n \n let makeOptional : ?retries:int -> unit -> < retries : int option > =\n fun ?retries _ ->\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"retries\" ~js_name:\"retries\"\n ~present:(match retries with None -> false | Some _ -> true)\n retries\n in\n let __js_obj =\n object\n method retries = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < retries : int option >)\n \n let retries = (makeOptional ())#retries\n\n $ cat > main.ml << EOF\n > module Js = struct\n > module Obj = struct\n > module Internal = struct\n > type entry = unit\n > let slot_ref ~method_name:_ ~js_name:_ ~present:_ value = (ref value, ())\n > let register_abstract obj _ = obj\n > end\n > end\n > end\n > EOF\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\n\nmel.send\n\n $ cat > input.ml << EOF\n > type t\n > external fillStyle : t -> 'a = \"fillStyle\" [@@mel.send]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type t\n \n let fillStyle : t -> 'a =\n fun _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"fillStyle\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n"
},
{
"path": "packages/melange.ppx/tests/mel_send_pipe.t",
"content": "[@@mel.send.pipe: t] should generate a function with the piped argument,\nboth on the type annotation, also on the function expression.\n $ cat > input.ml << EOF\n > external getPropertyPriority: string -> string = \"getPropertyPriority\" [@@mel.send.pipe: t]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let getPropertyPriority : string -> t -> string =\n fun _ _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"getPropertyPriority\")\n\n $ echo \"module Runtime = struct\" >> main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ ocamlc -c main.ml\n\nMake sure is placed correctly\n $ cat > input.ml << EOF\n > external createDocumentType : qualifiedName:string -> publicId:string -> systemId:string -> Dom.documentType = \"createDocumentType\" [@@mel.send.pipe: t]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let createDocumentType :\n qualifiedName:string ->\n publicId:string ->\n systemId:string ->\n t ->\n Dom.documentType =\n fun ~qualifiedName:_ ~publicId:_ ~systemId:_ _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"createDocumentType\")\n\n $ echo \"type t\" > main.ml\n $ echo \"module Dom = struct type documentType end\" >> main.ml\n $ echo \"module Runtime = struct\" >> main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nSingle argument (Ptyp_constr)\n $ cat > input.ml << EOF\n > external arrayBuffer : arrayBuffer Js.Promise.t = \"arrayBuffer\" [@@mel.send.pipe: T.t]\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let arrayBuffer : arrayBuffer Js.Promise.t -> T.t =\n fun _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"arrayBuffer\")\n\nLabelled arguments\n $ cat > input.ml << EOF\n > type t\n > external scale : x:float -> y:float -> unit = \"scale\"[@@mel.send.pipe : t]\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type t\n \n let scale : x:float -> y:float -> t -> unit =\n fun ~x:_ ~y:_ _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"scale\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nNonlabelled arguments as functions\n $ cat > input.ml << EOF\n > type t\n > external forEach : (string -> int -> unit) -> unit = \"forEach\" [@@mel.send.pipe : t]\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type t\n \n let forEach : (string -> int -> unit) -> t -> unit =\n fun _ _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"forEach\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\n'a\n $ cat > input.ml << EOF\n > external postMessage : 'a -> string -> unit = \"postMessage\" [@@mel.send]\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let postMessage : 'a -> string -> unit =\n fun _ _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"postMessage\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n\nSend pipe with 'a\n $ cat > input.ml << EOF\n > type t_window\n > external postMessage : 'a -> string -> unit = \"postMessage\" [@@mel.send.pipe : t_window]\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n type t_window\n \n let postMessage : 'a -> t_window -> string -> unit =\n fun _ _ _ ->\n let () =\n Printf.printf\n {|\n There is a Melange's external (for example: [@mel.get]) call from native code.\n \n Melange externals are bindings to JavaScript code, which can't run on the server and should be wrapped with browser_only ppx or only run it only on the client side. If there's any issue, try wrapping the expression with a try/catch as a workaround.\n |}\n in\n raise (Runtime.fail_impossible_action_in_ssr \"postMessage\")\n\n $ echo \"module Runtime = struct\" > main.ml\n $ cat $INSIDE_DUNE/packages/runtime/Runtime.ml >> main.ml\n $ echo \"end\" >> main.ml\n $ cat output.ml >> main.ml\n $ ocamlc -c main.ml\n"
},
{
"path": "packages/melange.ppx/tests/pipe_first.t/input.ml",
"content": "let f1 : int -> int = fun x -> x + 1\nlet f2 : int -> int -> int = fun a b -> a + b\nlet f3 : int -> b:int -> c:int -> int = fun a ~b ~c -> a + b + c\nlet f4 : int -> int -> int = fun a b -> a + b\nlet f5 : int -> int -> int -> int = fun a b c -> a + b + c\n\nlet () =\n let x : int option = 1 |. Some in\n match x with Some 1 -> assert true | _ -> assert false\n\nlet () =\n let x : int option option = 1 |. Some |. Some in\n match x with Some (Some 1) -> assert true | _ -> assert false\n\nlet x : int = (1, 2) |. fun (a, b) -> a + b\n\nlet () =\n let f : int -> int = fun x -> x + 1 in\n let x : int * int * int = 1 |. (f, f, f) in\n match x with 2, 2, 2 -> assert true | _ -> assert false\n\nlet () =\n let f : int -> a:int -> b:int -> int = fun x ~a ~b -> x + a + b in\n let x : int * int * int = 1 |. (f ~a:2 ~b:3, f ~a:2 ~b:3, f ~a:2 ~b:3) in\n match x with 6, 6, 6 -> assert true | _ -> assert false\n\nlet () =\n let x : int option * int option * int option = 1 |. (Some, Some, Some) in\n match x with Some 1, Some 1, Some 1 -> assert true | _ -> assert false\n\nlet () =\n let x =\n (1, 2) |. ((fun (a, b) -> a + b), (fun (a, b) -> a + b), fun (a, b) -> a + b)\n in\n match x with 3, 3, 3 -> assert true | _ -> assert false\n\nlet fn1 ?foo () = 1 + match foo with Some x -> x | None -> 2\n\nlet fn2 ?bar x =\n let bar = match bar with Some bar -> bar | None -> 4 in\n 2 + bar + x\n\ntype field = { send : int -> int }\n\nlet self = { send = (fun a -> a + 1) }\nlet adder a b = a + b\nlet addFive = 5 |. adder\nlet ten1 = 5 |. addFive\nlet ten2 = 5 |. (5 |. adder)\n\nlet _ =\n Lwt_js.sleep 1.\n |.\n let open Lwt in\n bind (fun () ->\n print_endline \"foo\";\n return ())\n"
},
{
"path": "packages/melange.ppx/tests/pipe_first.t/run.t",
"content": " $ ../standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let f1 : int -> int = fun x -> x + 1\n let f2 : int -> int -> int = fun a b -> a + b\n let f3 : int -> b:int -> c:int -> int = fun a ~b ~c -> a + b + c\n let f4 : int -> int -> int = fun a b -> a + b\n let f5 : int -> int -> int -> int = fun a b c -> a + b + c\n \n let () =\n let x : int option = Some 1 in\n match x with Some 1 -> assert true | _ -> assert false\n \n let () =\n let x : int option option = Some (Some 1) in\n match x with Some (Some 1) -> assert true | _ -> assert false\n \n let x : int = (fun (a, b) -> a + b) (1, 2)\n \n let () =\n let f : int -> int = fun x -> x + 1 in\n let x : int * int * int = (f, f, f) 1 in\n match x with 2, 2, 2 -> assert true | _ -> assert false\n \n let () =\n let f : int -> a:int -> b:int -> int = fun x ~a ~b -> x + a + b in\n let x : int * int * int = (f ~a:2 ~b:3, f ~a:2 ~b:3, f ~a:2 ~b:3) 1 in\n match x with 6, 6, 6 -> assert true | _ -> assert false\n \n let () =\n let x : int option * int option * int option = (Some, Some, Some) 1 in\n match x with Some 1, Some 1, Some 1 -> assert true | _ -> assert false\n \n let () =\n let x =\n ((fun (a, b) -> a + b), (fun (a, b) -> a + b), fun (a, b) -> a + b) (1, 2)\n in\n match x with 3, 3, 3 -> assert true | _ -> assert false\n \n let fn1 ?foo () = 1 + match foo with Some x -> x | None -> 2\n \n let fn2 ?bar x =\n let bar = match bar with Some bar -> bar | None -> 4 in\n 2 + bar + x\n \n type field = { send : int -> int }\n \n let self = { send = (fun a -> a + 1) }\n let adder a b = a + b\n let addFive = adder 5\n let ten1 = addFive 5\n let ten2 = adder 5 5\n \n let _ =\n (let open Lwt in\n bind (fun () ->\n print_endline \"foo\";\n return ()))\n (Lwt_js.sleep 1.)\n"
},
{
"path": "packages/melange.ppx/tests/private.t",
"content": "let%private attribute\n $ cat > input.ml << EOF\n > [%%private let privi = 22]\n > let print () = Js.log privi\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n open! struct\n let privi = 22\n end\n \n let print () = Js.log privi\n\n $ cat > input.ml << EOF\n > [%%private module Lol = struct let x = 22 end]\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n File \"input.ml\", line 1, characters 11-45:\n 1 | [%%private module Lol = struct let x = 22 end]\n ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n Error: the structure is not supported in local extension\n"
},
{
"path": "packages/melange.ppx/tests/regex.t/input.ml",
"content": "let basic = [%re \"/foo/\"]\nlet flag_global = [%re \"/foo/g\"]\nlet flags_global_multiline_insensitive = [%re \"/foo/gim\"]\nlet scape_digis_with_global = [%re \"/(\\\\d+)/g\"]\nlet payload_should_be_a_string = [%re apply]\n"
},
{
"path": "packages/melange.ppx/tests/regex.t/run.t",
"content": " $ ../standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl\n let basic = Js.Re.fromString \"foo\"\n let flag_global = Js.Re.fromStringWithFlags ~flags:\"g\" \"foo\"\n \n let flags_global_multiline_insensitive =\n Js.Re.fromStringWithFlags ~flags:\"gim\" \"foo\"\n \n let scape_digis_with_global = Js.Re.fromStringWithFlags ~flags:\"g\" \"(\\\\d+)\"\n \n let payload_should_be_a_string =\n [%ocaml.error\n \"[server-reason-react.melange_ppx] payload should be a string literal\"]\n"
},
{
"path": "packages/melange.ppx/tests/standalone.ml",
"content": "(* To run as a standalone binary, run the registered drivers *)\nlet () = Ppxlib.Driver.standalone ()\n"
},
{
"path": "packages/melange.ppx/tests/string_interpolation.t",
"content": "Test cases on string interpolation, most of them imported from\nhttps://github.com/melange-re/melange/blob/fb1466fed7d6e5aafd3ee266bbd4ec70c8fb857a/test/blackbox-tests/utf8-string-interp.t\n\n $ export OCAML_COLOR=always\n\n $ cat > input.ml < let lola = \"flores\"\n > let () = print_endline {j| Hello, \\$(lola)|j}\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let lola = \"flores\"\n let () = print_endline (Stdlib.( ^ ) {js| Hello, |js} lola)\n\n $ ocaml output.ml\n Hello, flores\n\nVariable that doesn't exist\n\n $ cat > input.ml < let x = {j| Hello, \\$(lola)|j}\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let x = Stdlib.( ^ ) {js| Hello, |js} lola\n\n $ ocaml output.ml\n File \"./output.ml\", line 1, characters 38-42:\n 1 | let x = Stdlib.( ^ ) {js| Hello, |js} lola\n ^^^^\n Error: Unbound value lola\n [2]\n\nUsing invalid identifiers\n\n $ cat > input.ml < let x = {j| Hello, \\$()|j}\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n File \"input.ml\", line 1, characters 19-22:\n 1 | let x = {j| Hello, $()|j}\n ^^^\n Error: `' is not a valid syntax of interpolated identifer\n\n $ cat > input.ml < let x = {j| Hello, \\$( )|j}\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n File \"input.ml\", line 1, characters 19-25:\n 1 | let x = {j| Hello, $( )|j}\n ^^^^^^\n Error: ` ' is not a valid syntax of interpolated identifer\n\n`{j| .. |j}` interpolation is strict about string arguments\n\n $ cat > input.ml < let x =\n > let y = 3 in\n > {j| Hello, \\$(y)|j}\n > EOF\n\n $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl | tee output.ml\n let x =\n let y = 3 in\n Stdlib.( ^ ) {js| Hello, |js} y\n\n $ ocaml output.ml\n File \"./output.ml\", line 3, characters 32-33:\n 3 | Stdlib.( ^ ) {js| Hello, |js} y\n ^\n Error: The value y has type int but an expression was expected of type string\n [2]\n"
},
{
"path": "packages/melange.ppx/xxhash/XXH64.ml",
"content": "(* https://github.com/Cyan4973/xxHash/blob/dev/doc/xxhash_spec.md#xxh64-algorithm-description *)\n\nmodule UInt64 = Unsigned.UInt64\n\nlet ( += ) r v = r := !r + v\nlet ( -= ) r v = r := !r - v\n\nlet ( <<< ) x n =\n let a = UInt64.shift_left x n in\n let b = UInt64.shift_right x (64 - n) in\n UInt64.logor a b\n\nlet ( >> ) = UInt64.shift_right\nlet ( + ) = UInt64.add\nlet ( * ) = UInt64.mul\nlet ( - ) = UInt64.sub\nlet logxor = UInt64.logxor\nlet prime64_1 = UInt64.of_int64 0x9E3779B185EBCA87L\n(* 0b1001111000110111011110011011000110000101111010111100101010000111 *)\n\nlet prime64_2 = UInt64.of_int64 0xC2B2AE3D27D4EB4FL\n(* 0b1100001010110010101011100011110100100111110101001110101101001111 *)\n\nlet prime64_3 = UInt64.of_int64 0x165667B19E3779F9L\n(* 0b0001011001010110011001111011000110011110001101110111100111111001 *)\n\nlet prime64_4 = UInt64.of_int64 0x85EBCA77C2B2AE63L\n(* 0b1000010111101011110010100111011111000010101100101010111001100011 *)\n\nlet prime64_5 = UInt64.of_int64 0x27D4EB2F165667C5L\n(* 0b0010011111010100111010110010111100010110010101100110011111000101 *)\n\n(*\nround(accN,laneN):\n accN = accN + (laneN * PRIME64_2);\n accN = accN <<< 31;\n return accN * PRIME64_1;\n*)\nlet round acc lane = (acc + (lane * prime64_2) <<< 31) * prime64_1\nlet get_int64_le str i = UInt64.of_int64 (String.get_int64_le str i)\n\n(* mergeAccumulator(acc,accN):\n acc = acc xor round(0, accN);\n acc = acc * PRIME64_1;\n return acc + PRIME64_4; *)\nlet merge accN acc = (logxor acc (round UInt64.zero !accN) * prime64_1) + prime64_4\n\nlet hash ?(seed = Int64.zero) input =\n let seed = UInt64.of_int64 seed in\n let len = String.length input in\n let pos = ref 0 in\n let have n = Int.add !pos n <= len in\n let acc =\n if len < 32 then seed + prime64_5\n else\n let acc1 = ref @@ (seed + prime64_1 + prime64_2) in\n let acc2 = ref @@ (seed + prime64_2) in\n let acc3 = ref @@ seed in\n let acc4 = ref @@ (seed - prime64_1) in\n\n while have 32 do\n acc1 := round !acc1 (get_int64_le input !pos);\n pos += 8;\n acc2 := round !acc2 (get_int64_le input !pos);\n pos += 8;\n acc3 := round !acc3 (get_int64_le input !pos);\n pos += 8;\n acc4 := round !acc4 (get_int64_le input !pos);\n pos += 8\n done;\n\n (*\n acc = (acc1 <<< 1) + (acc2 <<< 7) + (acc3 <<< 12) + (acc4 <<< 18);\n acc = mergeAccumulator(acc, acc1);\n acc = mergeAccumulator(acc, acc2);\n acc = mergeAccumulator(acc, acc3);\n acc = mergeAccumulator(acc, acc4);\n *)\n let acc = (!acc1 <<< 1) + (!acc2 <<< 7) + (!acc3 <<< 12) + (!acc4 <<< 18) in\n acc |> merge acc1 |> merge acc2 |> merge acc3 |> merge acc4\n in\n\n let acc = ref @@ (acc + UInt64.of_int len) in\n\n while have 8 do\n let lane = get_int64_le input !pos in\n acc := ((logxor !acc (round UInt64.zero lane) <<< 27) * prime64_1) + prime64_4;\n pos += 8\n done;\n\n if have 4 then (\n let lane =\n UInt64.logand (UInt64.of_int64 0xFF_FF_FF_FFL)\n @@ (String.get_int32_le input !pos |> Int64.of_int32 |> UInt64.of_int64)\n in\n acc := ((logxor !acc (lane * prime64_1) <<< 23) * prime64_2) + prime64_3;\n pos += 4)\n else ();\n\n while have 1 do\n let lane = UInt64.of_int @@ Char.code @@ String.get input !pos in\n acc := (logxor !acc (lane * prime64_5) <<< 11) * prime64_1;\n pos += 1\n done;\n\n let acc = logxor !acc (!acc >> 33) in\n let acc = acc * prime64_2 in\n let acc = logxor acc (acc >> 29) in\n let acc = acc * prime64_3 in\n UInt64.to_int64 (logxor acc (acc >> 32))\n\nlet to_hex hash = Printf.sprintf \"%Lx\" hash\n"
},
{
"path": "packages/melange.ppx/xxhash/dune",
"content": "(library\n (name xxhash)\n (modules XXH64)\n (public_name server-reason-react.xxhash)\n (wrapped false)\n (libraries integers base32))\n\n(test\n (name test_xxh64)\n (modules test_xxh64)\n (libraries xxhash fmt alcotest integers))\n"
},
{
"path": "packages/melange.ppx/xxhash/test_xxh64.ml",
"content": "let check_int64 = Alcotest.(check int64)\n\nlet data =\n [\n (\"\", 0xef46db3751d8e999L);\n (\"a\", 0xd24ec4f1a98c6e5bL);\n (\"as\", 0x1c330fb2d66be179L);\n (\"asd\", 0x631c37ce72a97393L);\n (\"asdf\", 0x415872f599cea71eL);\n (\"abc\", 0x44bc2cf5ad770999L);\n (\"abc\", 0x44bc2cf5ad770999L);\n (\"abcd\", 0xde0327b0d25d92ccL);\n (\"abcde\", 0x07e3670c0c8dc7ebL);\n (\"abcdef\", 0xfa8afd82c423144dL);\n (\"abcdefg\", 0x1860940e2902822dL);\n (\"abcdefgh\", 0x3ad351775b4634b7L);\n (\"abcdefghi\", 0x27f1a34fdbb95e13L);\n (\"abcdefghij\", 0xd6287a1de5498bb2L);\n (\"abcdefghijklmnopqrstuvwxyz012345\", 0xbf2cd639b4143b80L);\n (\"abcdefghijklmnopqrstuvwxyz0123456789\", 0x64f23ecf1609b766L);\n (* Exactly 63 characters, which exercises all code paths *)\n (\"Call me Ishmael. Some years ago--never mind how long precisely-\", 0x02a2e85470d6fd96L);\n ( \"Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore \\\n magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo \\\n consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla \\\n pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est \\\n laborum.\",\n 0xc5a8b11443765630L );\n ]\n\nlet hash_test_cases =\n List.map\n (fun (input, expected) ->\n let test () = check_int64 input expected (XXH64.hash input) in\n (Printf.sprintf \"%S\" input, `Quick, test))\n data\n\nlet data = [ (\"I want an unsigned 64-bit seed!\", \"d4cb0a70a2b8c7c1\") ]\n\nlet hex_test_cases =\n List.map\n (fun (input, expected) ->\n let test () =\n let output = input |> XXH64.hash |> XXH64.to_hex in\n Alcotest.(check string) input expected output\n in\n (Printf.sprintf \"%S\" input, `Quick, test))\n data\n\nlet () = Alcotest.run \"XXH64\" [ (\"hash\", hash_test_cases); (\"hash · to_hex\", hex_test_cases) ]\n"
},
{
"path": "packages/promise/js/dune",
"content": "(library\n (name promise_js)\n (public_name server-reason-react.promise-js)\n (modes melange)\n (modules promise)\n (wrapped false)\n (libraries melange.belt melange.js)\n (preprocess\n (pps melange.ppx)))\n"
},
{
"path": "packages/promise/js/promise.re",
"content": "/* This file is part of reason-promise, released under the MIT license. See\n LICENSE.md for details, or visit\n https://github.com/aantron/promise/blob/master/LICENSE.md. */\n\ntype rejectable(+'a, +'e);\ntype never;\n\ntype promise(+'a) = rejectable('a, never);\ntype t(+'a) = promise('a);\n\nlet onUnhandledException =\n ref(exn => {\n prerr_endline(\"Unhandled exception in promise callback:\");\n Js.Console.error(exn);\n });\n\n[%%mel.raw\n {|\nfunction PromiseBox(p) {\n this.nested = p;\n};\n\nfunction unbox(value) {\n if (value instanceof PromiseBox)\n return value.nested;\n else\n return value;\n}\n\nfunction box(value) {\n if (value != null && typeof value.then === 'function')\n return new PromiseBox(value);\n else\n return value;\n}\n\nfunction make(executor) {\n return new Promise(function (resolve, reject) {\n var boxingResolve = function(value) {\n resolve(box(value));\n };\n executor(boxingResolve, reject);\n });\n};\n\nfunction resolved(value) {\n return Promise.resolve(box(value));\n};\n\nfunction then(promise, callback) {\n return promise.then(function (value) {\n try {\n return callback(unbox(value));\n }\n catch (exception) {\n onUnhandledException.contents(exception);\n return new Promise(function() {});\n }\n });\n};\n\nfunction catch_(promise, callback) {\n var safeCallback = function (error) {\n try {\n return callback(error);\n }\n catch (exception) {\n onUnhandledException.contents(exception);\n return new Promise(function() {});\n }\n };\n\n return promise.catch(safeCallback);\n};\n|}\n];\n\nmodule Js_ = {\n type t('a, 'e) = rejectable('a, 'e);\n\n external relax: promise('a) => rejectable('a, _) = \"%identity\";\n\n external jsNew: (('a => unit, 'e => unit) => unit) => rejectable('a, 'e) =\n \"make\";\n\n let pending = () => {\n let resolve = ref(ignore);\n let reject = ref(ignore);\n let p =\n jsNew((resolve', reject') => {\n resolve := resolve';\n reject := reject';\n });\n (p, resolve^, reject^);\n };\n\n external resolved: 'a => rejectable('a, _) = \"resolved\";\n\n external flatMap:\n (rejectable('a, 'e), 'a => rejectable('b, 'e)) => rejectable('b, 'e) =\n \"then\";\n\n let map = (promise, callback) =>\n flatMap(promise, v => resolved(callback(v)));\n\n let get = (promise, callback) => ignore(map(promise, callback));\n\n let tap = (promise, callback) =>\n map(\n promise,\n v => {\n callback(v);\n v;\n },\n );\n\n [@mel.scope \"Promise\"]\n external rejected: 'e => rejectable(_, 'e) = \"reject\";\n\n external catch:\n (rejectable('a, 'e), 'e => rejectable('a, 'e2)) => rejectable('a, 'e2) =\n \"catch_\";\n\n external unbox: 'a => 'a = \"unbox\";\n\n [@mel.scope \"Promise\"] external jsAll: 'a => 'b = \"all\";\n\n let allArray = promises =>\n map(jsAll(promises), promises => Belt.Array.map(promises, unbox));\n\n let all = promises =>\n map(allArray(Belt.List.toArray(promises)), Belt.List.fromArray);\n\n let all2 = (p1, p2) => jsAll((p1, p2));\n\n let all3 = (p1, p2, p3) => jsAll((p1, p2, p3));\n\n let all4 = (p1, p2, p3, p4) => jsAll((p1, p2, p3, p4));\n\n let all5 = (p1, p2, p3, p4, p5) => jsAll((p1, p2, p3, p4, p5));\n\n let all6 = (p1, p2, p3, p4, p5, p6) => jsAll((p1, p2, p3, p4, p5, p6));\n\n [@mel.scope \"Promise\"]\n external jsRace: array(rejectable('a, 'e)) => rejectable('a, 'e) = \"race\";\n\n let race = promises =>\n if (promises == []) {\n raise(Invalid_argument(\"Promise.race([]) would be pending forever\"));\n } else {\n jsRace(Belt.List.toArray(promises));\n };\n\n let toResult = promise =>\n catch(map(promise, v => Ok(v)), e => resolved(Error(e)));\n\n let fromResult = promise =>\n flatMap(\n relax(promise),\n fun\n | Ok(v) => resolved(v)\n | Error(e) => rejected(e),\n );\n\n external fromBsPromise:\n Js.Promise.t('a) => rejectable('a, Js.Promise.error) =\n \"%identity\";\n\n external toBsPromise: rejectable('a, _) => Js.Promise.t('a) = \"%identity\";\n};\n\nlet pending = () => {\n let (p, resolve, _) = Js_.pending();\n (p, resolve);\n};\n\nlet exec = executor => {\n let (p, resolve) = pending();\n executor(resolve);\n p;\n};\n\nlet resolved = Js_.resolved;\nlet flatMap = Js_.flatMap;\nlet map = Js_.map;\nlet get = Js_.get;\nlet tap = Js_.tap;\nlet all = Js_.all;\nlet all2 = Js_.all2;\nlet all3 = Js_.all3;\nlet all4 = Js_.all4;\nlet all5 = Js_.all5;\nlet all6 = Js_.all6;\nlet allArray = Js_.allArray;\nlet race = Js_.race;\n\nlet flatMapOk = (promise, callback) =>\n flatMap(promise, result =>\n switch (result) {\n | Ok(v) => callback(v)\n | Error(_) as error => resolved(error)\n }\n );\n\nlet flatMapError = (promise, callback) =>\n flatMap(promise, result =>\n switch (result) {\n | Ok(_) as ok => resolved(ok)\n | Error(e) => callback(e)\n }\n );\n\nlet mapOk = (promise, callback) =>\n map(promise, result =>\n switch (result) {\n | Ok(v) => Ok(callback(v))\n | Error(_) as error => error\n }\n );\n\nlet mapError = (promise, callback) =>\n map(promise, result =>\n switch (result) {\n | Ok(_) as ok => ok\n | Error(e) => Error(callback(e))\n }\n );\n\nlet getOk = (promise, callback) =>\n get(promise, result =>\n switch (result) {\n | Ok(v) => callback(v)\n | Error(_) => ()\n }\n );\n\nlet getError = (promise, callback) =>\n get(promise, result =>\n switch (result) {\n | Ok(_) => ()\n | Error(e) => callback(e)\n }\n );\n\nlet tapOk = (promise, callback) => {\n getOk(promise, callback);\n promise;\n};\n\nlet tapError = (promise, callback) => {\n getError(promise, callback);\n promise;\n};\n\nlet allOkArray = promises => {\n let promiseCount = Belt.Array.length(promises);\n\n if (promiseCount == 0) {\n resolved(Ok([||]));\n } else {\n let resultValues = Belt.Array.make(promiseCount, None);\n let resultCount = ref(0);\n let (resultPromise, resolve) = pending();\n\n let (callbackRemover, removeCallbacks) = pending();\n\n promises->Belt.Array.forEachWithIndex((index, promise)\n /* Because callbacks are added to the user's promises through calls to the\n JS runtime's Promise.race, this function leaks memory if and only if\n the JS runtime's Promise functions leak memory. In particular, if one\n of the promises resolves with Error(_), the callbacks on the other\n promises should be removed. If not done, and long-pending promises are\n repeatedly passed to allOk in a loop, they will gradually accumulate\n huge lists of stale callbacks. This is also true of Promise.race, so we\n rely on the quality of the runtime's Promise.race implementation to\n proactively remove these callbacks. */\n =>\n race([promise, callbackRemover])\n |> (\n wrapped =>\n get(wrapped, result =>\n switch (result) {\n | Ok(v) =>\n resultValues->Belt.Array.setExn(index, Some(v));\n incr(resultCount);\n if (resultCount^ >= promiseCount) {\n resultValues->Belt.Array.map(v =>\n switch (v) {\n | Some(v) => v\n | None => assert(false)\n }\n )\n |> (values => resolve(Ok(values)));\n };\n | Error(e) =>\n resolve(Error(e));\n removeCallbacks(Error(e));\n }\n )\n )\n );\n\n resultPromise;\n };\n};\n\nlet allOk = promises =>\n mapOk(allOkArray(Belt.List.toArray(promises)), Belt.List.fromArray);\n\nlet allOk2 =\n (p1: promise(result('a, 'err)), p2: promise(result('b, 'err)))\n : promise(result(('a, 'b), 'err)) =>\n Obj.magic(allOkArray, (p1, p2));\n\nlet allOk3 =\n (\n p1: promise(result('a, 'err)),\n p2: promise(result('b, 'err)),\n p3: promise(result('c, 'err)),\n )\n : promise(result(('a, 'b, 'c), 'err)) =>\n Obj.magic(allOkArray, (p1, p2, p3));\n\nlet allOk4 =\n (\n p1: promise(result('a, 'err)),\n p2: promise(result('b, 'err)),\n p3: promise(result('c, 'err)),\n p4: promise(result('d, 'err)),\n )\n : promise(result(('a, 'b, 'c, 'd), 'err)) =>\n Obj.magic(allOkArray, (p1, p2, p3, p4));\n\nlet allOk5 =\n (\n p1: promise(result('a, 'err)),\n p2: promise(result('b, 'err)),\n p3: promise(result('c, 'err)),\n p4: promise(result('d, 'err)),\n p5: promise(result('e, 'err)),\n )\n : promise(result(('a, 'b, 'c, 'd, 'e), 'err)) =>\n Obj.magic(allOkArray, (p1, p2, p3, p4, p5));\n\nlet allOk6 =\n (\n p1: promise(result('a, 'err)),\n p2: promise(result('b, 'err)),\n p3: promise(result('c, 'err)),\n p4: promise(result('d, 'err)),\n p5: promise(result('e, 'err)),\n p6: promise(result('f, 'err)),\n )\n : promise(result(('a, 'b, 'c, 'd, 'e, 'f), 'err)) =>\n Obj.magic(allOkArray, (p1, p2, p3, p4, p5, p6));\n\nmodule Operators = {\n let (>|=) = mapOk;\n let (>>=) = flatMapOk;\n};\n\nlet flatMapSome = (promise, callback) =>\n flatMap(promise, option =>\n switch (option) {\n | Some(v) => callback(v)\n | None => resolved(None)\n }\n );\n\nlet mapSome = (promise, callback) =>\n map(promise, option =>\n switch (option) {\n | Some(v) => Some(callback(v))\n | None => None\n }\n );\n\nlet getSome = (promise, callback) =>\n get(promise, option =>\n switch (option) {\n | Some(v) => callback(v)\n | None => ()\n }\n );\n\nlet tapSome = (promise, callback) => {\n getSome(promise, callback);\n promise;\n};\n\nmodule PipeFirst = {};\n\nmodule Js = Js_;\n"
},
{
"path": "packages/promise/js/promise.rei",
"content": "/* This file is part of reason-promise, released under the MIT license. See\n LICENSE.md for details, or visit\n https://github.com/aantron/promise/blob/master/LICENSE.md. */\n\n/* Internal type names; don't use these. Instead, use Promise.t and Promise.Js.t\n from outside this library. */\ntype rejectable(+'a, +'e); /* Internal; use Promise.Js.t. */\ntype never;\ntype promise(+'a) = rejectable('a, never); /* Internal; use Promise.t. */\n\n/* The main, public promise type (Promise.t). */\ntype t(+'a) = promise('a);\n\n/* Making promises. */\nlet pending: unit => (promise('a), 'a => unit);\n\nlet resolved: 'a => promise('a);\n\nlet exec: (('a => unit) => unit) => promise('a);\n\n/* Using promises. */\nlet get: (promise('a), 'a => unit) => unit;\n\nlet tap: (promise('a), 'a => unit) => promise('a);\n\nlet map: (promise('a), 'a => 'b) => promise('b);\n\nlet flatMap: (promise('a), 'a => promise('b)) => promise('b);\n\n/* Results. */\nlet getOk: (promise(result('a, 'e)), 'a => unit) => unit;\n\nlet tapOk:\n (promise(result('a, 'e)), 'a => unit) => promise(result('a, 'e));\n\nlet mapOk: (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e));\n\nlet flatMapOk:\n (promise(result('a, 'e)), 'a => promise(result('b, 'e))) =>\n promise(result('b, 'e));\n\nlet getError: (promise(result('a, 'e)), 'e => unit) => unit;\n\nlet tapError:\n (promise(result('a, 'e)), 'e => unit) => promise(result('a, 'e));\n\nlet mapError:\n (promise(result('a, 'e)), 'e => 'e2) => promise(result('a, 'e2));\n\nlet flatMapError:\n (promise(result('a, 'e)), 'e => promise(result('a, 'e2))) =>\n promise(result('a, 'e2));\n\nmodule Operators: {\n [@ocaml.deprecated \"Use bs-let\"]\n let (>|=):\n (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e));\n\n [@ocaml.deprecated \"Use bs-let\"]\n let (>>=):\n (promise(result('a, 'e)), 'a => promise(result('b, 'e))) =>\n promise(result('b, 'e));\n};\n\n/* Options. */\nlet getSome: (promise(option('a)), 'a => unit) => unit;\n\nlet tapSome: (promise(option('a)), 'a => unit) => promise(option('a));\n\nlet mapSome: (promise(option('a)), 'a => 'b) => promise(option('b));\n\nlet flatMapSome:\n (promise(option('a)), 'a => promise(option('b))) => promise(option('b));\n\n/* Combining promises. */\nlet race: list(promise('a)) => promise('a);\n\nlet all: list(promise('a)) => promise(list('a));\n\nlet allArray: array(promise('a)) => promise(array('a));\n\nlet all2: (promise('a), promise('b)) => promise(('a, 'b));\n\nlet all3:\n (promise('a), promise('b), promise('c)) => promise(('a, 'b, 'c));\n\nlet all4:\n (promise('a), promise('b), promise('c), promise('d)) =>\n promise(('a, 'b, 'c, 'd));\n\nlet all5:\n (promise('a), promise('b), promise('c), promise('d), promise('e)) =>\n promise(('a, 'b, 'c, 'd, 'e));\n\nlet all6:\n (\n promise('a),\n promise('b),\n promise('c),\n promise('d),\n promise('e),\n promise('f)\n ) =>\n promise(('a, 'b, 'c, 'd, 'e, 'f));\n\nlet allOk:\n list(promise(result('a, 'e))) => promise(result(list('a), 'e));\n\nlet allOkArray:\n array(promise(result('a, 'e))) => promise(result(array('a), 'e));\n\nlet allOk2:\n (promise(result('a, 'err)), promise(result('b, 'err))) =>\n promise(result(('a, 'b), 'err));\n\nlet allOk3:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err))\n ) =>\n promise(result(('a, 'b, 'c), 'err));\n\nlet allOk4:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err)),\n promise(result('d, 'err))\n ) =>\n promise(result(('a, 'b, 'c, 'd), 'err));\n\nlet allOk5:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err)),\n promise(result('d, 'err)),\n promise(result('e, 'err))\n ) =>\n promise(result(('a, 'b, 'c, 'd, 'e), 'err));\n\nlet allOk6:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err)),\n promise(result('d, 'err)),\n promise(result('e, 'err)),\n promise(result('f, 'err))\n ) =>\n promise(result(('a, 'b, 'c, 'd, 'e, 'f), 'err));\n\n/* For writing bindings. */\nmodule Js: {\n type t(+'a, +'e) = rejectable('a, 'e);\n\n /* Making. */\n let pending: unit => (rejectable('a, 'e), 'a => unit, 'e => unit);\n\n let resolved: 'a => rejectable('a, 'e);\n\n let rejected: 'e => rejectable('a, 'e);\n\n /* Handling fulfillment. */\n let get: (rejectable('a, 'e), 'a => unit) => unit;\n\n let tap: (rejectable('a, 'e), 'a => unit) => rejectable('a, 'e);\n\n let map: (rejectable('a, 'e), 'a => 'b) => rejectable('b, 'e);\n\n let flatMap:\n (rejectable('a, 'e), 'a => rejectable('b, 'e)) => rejectable('b, 'e);\n\n /* Handling rejection. */\n let catch:\n (rejectable('a, 'e), 'e => rejectable('a, 'e2)) => rejectable('a, 'e2);\n\n /* Combining. */\n let all: list(rejectable('a, 'e)) => rejectable(list('a), 'e);\n\n let race: list(rejectable('a, 'e)) => rejectable('a, 'e);\n\n /* Conversions. */\n let relax: promise('a) => rejectable('a, 'e);\n\n let toResult: rejectable('a, 'e) => promise(result('a, 'e));\n\n let fromResult: promise(result('a, 'e)) => rejectable('a, 'e);\n\n let fromBsPromise: Js.Promise.t('a) => rejectable('a, Js.Promise.error);\n\n let toBsPromise: rejectable('a, _) => Js.Promise.t('a);\n};\n\nmodule PipeFirst: {};\n\nlet onUnhandledException: ref(exn => unit);\n"
},
{
"path": "packages/promise/native/dune",
"content": "(library\n (name promise_native)\n (public_name server-reason-react.promise-native)\n (wrapped false)\n (modules promise)\n (libraries lwt server-reason-react.belt)\n (preprocess\n (pps lwt_ppx)))\n"
},
{
"path": "packages/promise/native/promise.re",
"content": "/* This file is part of reason-promise, released under the MIT license. See\n LICENSE.md for details, or visit\n https://github.com/aantron/promise/blob/master/LICENSE.md. */\n\nmodule type MutableList = {\n /* Mutable doubly-linked lists, like in a typical imperative language. These are\n used for callback lists, because reason-promise needs fast append and fast\n deletion of any node in the list, when the reference to the target node is\n already be held by the deleting code. */\n\n type list('a);\n type node('a);\n\n let create: unit => list('a);\n let isEmpty: list(_) => bool;\n let append: (list('a), 'a) => node('a);\n let iter: ('a => unit, list('a)) => unit;\n let remove: (list('a), node('a)) => unit;\n\n /* Concatenates list1 and list2. Afterwards, the reference list1 has a correct\n internal list structure, and the reference list2 should not be used\n anymore. */\n let concatenate: (list('a), list('a)) => unit;\n};\n\nmodule MutableList: MutableList = {\n /* This file is part of reason-promise, released under the MIT license. See\n LICENSE.md for details, or visit\n https://github.com/aantron/promise/blob/master/LICENSE.md. */\n\n type node('a) = {\n mutable previous: option(node('a)),\n mutable next: option(node('a)),\n content: 'a,\n };\n\n type listEnds('a) = {\n mutable first: node('a),\n mutable last: node('a),\n };\n\n type list('a) =\n ref(\n [\n | `Empty\n | `NonEmpty(listEnds('a))\n ],\n );\n\n let create = () => ref(`Empty);\n\n let isEmpty = list => list^ == `Empty;\n\n let append = (list, value) =>\n switch (list^) {\n | `Empty =>\n let node = {\n previous: None,\n next: None,\n content: value,\n };\n list :=\n `NonEmpty({\n first: node,\n last: node,\n });\n node;\n\n | `NonEmpty(ends) =>\n let node = {\n previous: Some(ends.last),\n next: None,\n content: value,\n };\n ends.last.next = Some(node);\n ends.last = node;\n node;\n };\n\n let concatenate = (list1, list2) =>\n switch (list2^) {\n | `Empty =>\n /* If the second list is empty, we can just return the first list, because\n it already has the correct final structure, and there is nothing to\n do. */\n ()\n\n | `NonEmpty(list2Ends) =>\n switch (list1^) {\n | `Empty =>\n /* If the second list is non-empty, but the first list is empty, we need\n to change the end-of-list references in the first list to point to the\n structure of the second list. This is because the caller depends on the\n first list having the correct structure after the call. */\n list1 := list2^\n\n | `NonEmpty(list1Ends) =>\n /* Otherwise, we have to splice the ending nodes of the two lists. */\n\n list1Ends.last.next = Some(list2Ends.first);\n list2Ends.first.previous = Some(list1Ends.last);\n list1Ends.last = list2Ends.last;\n }\n };\n\n let iter = (callback, list) =>\n switch (list^) {\n | `Empty => ()\n\n | `NonEmpty(ends) =>\n let rec loop = node => {\n callback(node.content);\n switch (node.next) {\n | None => ()\n | Some(nextNode) => loop(nextNode)\n };\n };\n\n loop(ends.first);\n };\n\n let remove = (list, node) => {\n /* This function is difficult enough to implement and use that it is\n probably time to switch representations for callback lists soon. */\n switch (list^) {\n | `Empty => ()\n\n | `NonEmpty(ends) =>\n switch (node.previous) {\n | None =>\n if (ends.first === node) {\n switch (node.next) {\n | None => list := `Empty\n | Some(secondNode) => ends.first = secondNode\n };\n }\n\n | Some(previousNode) => previousNode.next = node.next\n };\n\n switch (node.next) {\n | None =>\n if (ends.last === node) {\n switch (node.previous) {\n | None => list := `Empty\n | Some(secondToLastNode) => ends.last = secondToLastNode\n };\n }\n\n | Some(nextNode) => nextNode.previous = node.previous\n };\n };\n\n node.previous = None;\n node.next = None;\n };\n};\n\ntype callbacks('a, 'e) = {\n onResolve: MutableList.list('a => unit),\n onReject: MutableList.list('e => unit),\n};\n\ntype rejectable('a, 'e) =\n ref(\n [\n | `Fulfilled('a)\n | `Rejected('e)\n | `Pending(callbacks('a, 'e))\n | `Merged(rejectable('a, 'e))\n ],\n );\n\ntype never;\n\ntype promise('a) = rejectable('a, never);\ntype t('a) = promise('a);\n\n/* The `Merged constructor and this function, underlying, are used to avoid a\n memory leak that arises when flatMap is called on promises in a loop. See the\n description in the associated test \"promise loop memory leak\". The rest of\n this comment is based on that description.\n\n The solution to the memory leak is to merge nested promises created on the\n second and subsequent iterations of loops into the outer promise created on\n the first iteration. This is performed by the internal helper\n makePromiseBehaveAs, below.\n\n When promises are merged, the callback lists of the nested promise are\n merged into the callback lists of the outer promise, and afterwards the\n nested promise object becomes just a proxy that refers to the outer promise.\n As a result, most internal operations on promises have to first call\n underlying, in order to find the true merged (outer) promise on which\n operations should be performed, rather than working directly on proxies. */\nlet rec underlying = p =>\n switch (p^) {\n | `Fulfilled(_)\n | `Rejected(_)\n | `Pending(_) => p\n\n | `Merged(p') =>\n let p'' = underlying(p');\n if (p'' !== p') {\n p := `Merged(p'');\n };\n p'';\n };\n\nlet onUnhandledException =\n ref(exn => {\n prerr_endline(\"Unhandled exception in promise callback:\");\n prerr_endline(Printexc.to_string(exn));\n Printexc.print_backtrace(stderr);\n });\n\nmodule ReadyCallbacks = {\n let callbacks: ref(MutableList.list(unit => unit)) =\n ref(MutableList.create());\n\n let callbacksPending = () => !MutableList.isEmpty(callbacks^);\n\n let defer = (callback, value) =>\n MutableList.append(callbacks^, () => callback(value)) |> ignore;\n\n let deferMultiple = (newCallbacks, value) =>\n newCallbacks |> MutableList.iter(callback => defer(callback, value));\n\n type snapshot = MutableList.list(unit => unit);\n\n let snapshot = () => {\n let theSnapshot = callbacks^;\n callbacks := MutableList.create();\n theSnapshot;\n };\n\n let isEmpty = snapshot => MutableList.isEmpty(snapshot);\n\n let call = snapshot => snapshot |> MutableList.iter(callback => callback());\n};\n\nlet newInternal = () =>\n ref(\n `Pending({\n onResolve: MutableList.create(),\n onReject: MutableList.create(),\n }),\n );\n\nlet resolveInternal = (p, value) =>\n switch ((underlying(p))^) {\n | `Fulfilled(_)\n | `Rejected(_) => ()\n | `Pending(callbacks) =>\n ReadyCallbacks.deferMultiple(callbacks.onResolve, value);\n p := `Fulfilled(value);\n | `Merged(_) =>\n /* This case is impossible, because we called underyling on the promise,\n above. */\n assert(false)\n };\n\nlet rejectInternal = (p, error) =>\n switch ((underlying(p))^) {\n | `Fulfilled(_)\n | `Rejected(_) => ()\n | `Pending(callbacks) =>\n ReadyCallbacks.deferMultiple(callbacks.onReject, error);\n p := `Rejected(error);\n | `Merged(_) =>\n /* This case is impossible, because we called underyling on the promise,\n above. */\n assert(false)\n };\n\nlet resolved = value => ref(`Fulfilled(value));\n\nlet rejected = error => ref(`Rejected(error));\n\nlet makePromiseBehaveAs = (outerPromise, nestedPromise) => {\n let underlyingNested = underlying(nestedPromise);\n\n switch (underlyingNested^) {\n | `Fulfilled(value) => resolveInternal(outerPromise, value)\n | `Rejected(error) => rejectInternal(outerPromise, error)\n\n | `Pending(callbacks) =>\n let underlyingOuter = underlying(outerPromise);\n switch (underlyingOuter^) {\n | `Fulfilled(_)\n | `Rejected(_) =>\n /* These two cases are impossible, because if makePromiseBehaveAs is\n called, flatMap or catch_ called the callback that was passed to it, so\n the outer promise is still pending. It is this function which resolves\n the outer promise. */\n assert(false)\n\n | `Pending(outerCallbacks) =>\n MutableList.concatenate(outerCallbacks.onResolve, callbacks.onResolve);\n MutableList.concatenate(outerCallbacks.onReject, callbacks.onReject);\n underlyingNested := `Merged(underlyingOuter);\n\n | `Merged(_) =>\n /* This case is impossible, because we called underlying above. */\n assert(false)\n };\n\n | `Merged(_) =>\n /* Impossible because we are working on the underlying promise. */\n assert(false)\n };\n};\n\nlet flatMap = (promise, callback) => {\n let outerPromise = newInternal();\n\n let onResolve = value =>\n switch (callback(value)) {\n | exception exn => ignore(onUnhandledException^(exn))\n | nestedPromise => makePromiseBehaveAs(outerPromise, nestedPromise)\n };\n\n switch ((underlying(promise))^) {\n | `Fulfilled(value) => ReadyCallbacks.defer(onResolve, value)\n | `Rejected(error) => rejectInternal(outerPromise, error)\n\n | `Pending(callbacks) =>\n MutableList.append(callbacks.onResolve, onResolve) |> ignore;\n MutableList.append(callbacks.onReject, rejectInternal(outerPromise))\n |> ignore;\n\n | `Merged(_) =>\n /* This case is impossible, cause of the call to underlying above. */\n assert(false)\n };\n\n outerPromise;\n};\n\nlet map = (promise, mapper) =>\n flatMap(promise, value => resolved(mapper(value)));\n\nlet get = (promise, callback) => ignore(map(promise, callback));\n\nlet tap = (promise, callback) => {\n get(promise, callback);\n promise;\n};\n\nlet catch = (promise, callback) => {\n let outerPromise = newInternal();\n\n let onReject = error =>\n switch (callback(error)) {\n | exception exn => ignore(onUnhandledException^(exn))\n | nestedPromise => makePromiseBehaveAs(outerPromise, nestedPromise)\n };\n\n switch ((underlying(promise))^) {\n | `Fulfilled(value) => resolveInternal(outerPromise, value)\n | `Rejected(error) => ReadyCallbacks.defer(onReject, error)\n\n | `Pending(callbacks) =>\n MutableList.append(callbacks.onResolve, resolveInternal(outerPromise))\n |> ignore;\n MutableList.append(callbacks.onReject, onReject) |> ignore;\n\n | `Merged(_) =>\n /* This case is impossible, because of the call to underlying above. */\n assert(false)\n };\n\n outerPromise;\n};\n\n/* Promise.all and Promise.race have to remove callbacks in some circumstances;\n see test/native/test_ffi.re for details. */\nmodule CallbackRemovers = {\n let empty = () => ref([]);\n\n let call = removers => {\n removers^ |> List.iter(remover => remover());\n removers := [];\n };\n\n let add = (removers, promise, whichList, callbackNode) => {\n let remover = () =>\n switch ((underlying(promise))^) {\n | `Pending(callbacks) =>\n MutableList.remove(whichList(callbacks), callbackNode)\n | _ => ()\n };\n\n removers := [remover, ...removers^];\n };\n};\n\nlet all = promises => {\n let callbackRemovers = CallbackRemovers.empty();\n\n let finalPromise = newInternal();\n let unresolvedPromiseCount = ref(List.length(promises));\n let results = ref([]);\n\n let onResolve = (cell, value) => {\n cell := Some(value);\n unresolvedPromiseCount := unresolvedPromiseCount^ - 1;\n if (unresolvedPromiseCount^ == 0) {\n results^\n |> List.map(cell =>\n switch (cell^) {\n | None => assert(false)\n | Some(value) => value\n }\n )\n |> resolveInternal(finalPromise);\n };\n };\n\n let rejectFinalPromise = error => {\n CallbackRemovers.call(callbackRemovers);\n rejectInternal(finalPromise, error);\n };\n\n results :=\n promises\n |> List.map(promise => {\n let cell = ref(None);\n\n switch ((underlying(promise))^) {\n | `Fulfilled(value) =>\n /* It's very important to defer here instead of resolving the final\n promise immediately. Doing the latter will cause the callback removal\n mechanism to forget about removing callbacks which will be added later\n in the iteration over the promise list. It is possible to resolve\n immediately but then the code has to be changed, probably to perform\n two passes over the promise list. */\n ReadyCallbacks.defer(onResolve(cell), value)\n | `Rejected(error) =>\n ReadyCallbacks.defer(rejectFinalPromise, error)\n\n | `Pending(callbacks) =>\n let callbackNode =\n MutableList.append(callbacks.onResolve, onResolve(cell));\n CallbackRemovers.add(\n callbackRemovers,\n promise,\n callbacks => callbacks.onResolve,\n callbackNode,\n );\n\n let callbackNode =\n MutableList.append(callbacks.onReject, rejectFinalPromise);\n CallbackRemovers.add(\n callbackRemovers,\n promise,\n callbacks => callbacks.onReject,\n callbackNode,\n );\n\n | `Merged(_) =>\n /* Impossible because of the call to underlying above. */\n assert(false)\n };\n\n cell;\n });\n\n finalPromise;\n};\n\nlet allArray = promises => map(all(Array.to_list(promises)), Array.of_list);\n\n/* Not a \"legitimate\" implementation. To get a legitimate one, the tricky parts\n of \"all,\" above, should be factoed out. */\nlet all2 = (p1, p2) => {\n let promises = [Obj.magic(p1), Obj.magic(p2)];\n map(\n all(promises),\n fun\n | [v1, v2] => (Obj.magic(v1), Obj.magic(v2))\n | _ => assert(false),\n );\n};\n\nlet all3 = (p1, p2, p3) => {\n let promises = [Obj.magic(p1), Obj.magic(p2), Obj.magic(p3)];\n map(\n all(promises),\n fun\n | [v1, v2, v3] => (Obj.magic(v1), Obj.magic(v2), Obj.magic(v3))\n | _ => assert(false),\n );\n};\n\nlet all4 = (p1, p2, p3, p4) => {\n let promises = [\n Obj.magic(p1),\n Obj.magic(p2),\n Obj.magic(p3),\n Obj.magic(p4),\n ];\n map(\n all(promises),\n fun\n | [v1, v2, v3, v4] => (\n Obj.magic(v1),\n Obj.magic(v2),\n Obj.magic(v3),\n Obj.magic(v4),\n )\n | _ => assert(false),\n );\n};\n\nlet all5 = (p1, p2, p3, p4, p5) => {\n let promises = [\n Obj.magic(p1),\n Obj.magic(p2),\n Obj.magic(p3),\n Obj.magic(p4),\n Obj.magic(p5),\n ];\n map(\n all(promises),\n fun\n | [v1, v2, v3, v4, v5] => (\n Obj.magic(v1),\n Obj.magic(v2),\n Obj.magic(v3),\n Obj.magic(v4),\n Obj.magic(v5),\n )\n | _ => assert(false),\n );\n};\n\nlet all6 = (p1, p2, p3, p4, p5, p6) => {\n let promises = [\n Obj.magic(p1),\n Obj.magic(p2),\n Obj.magic(p3),\n Obj.magic(p4),\n Obj.magic(p5),\n Obj.magic(p6),\n ];\n map(\n all(promises),\n fun\n | [v1, v2, v3, v4, v5, v6] => (\n Obj.magic(v1),\n Obj.magic(v2),\n Obj.magic(v3),\n Obj.magic(v4),\n Obj.magic(v5),\n Obj.magic(v6),\n )\n | _ => assert(false),\n );\n};\n\nlet race = promises => {\n if (promises == []) {\n raise(Invalid_argument(\"Promise.race([]) would be pending forever\"));\n };\n\n let callbackRemovers = CallbackRemovers.empty();\n\n let finalPromise = newInternal();\n let resolveFinalPromise = value => {\n CallbackRemovers.call(callbackRemovers);\n resolveInternal(finalPromise, value);\n };\n let rejectFinalPromise = error => {\n CallbackRemovers.call(callbackRemovers);\n rejectInternal(finalPromise, error);\n };\n\n promises\n |> List.iter(promise =>\n switch ((underlying(promise))^) {\n | `Fulfilled(value) =>\n ReadyCallbacks.defer(resolveFinalPromise, value)\n | `Rejected(error) => ReadyCallbacks.defer(rejectFinalPromise, error)\n\n | `Pending(callbacks) =>\n let callbackNode =\n MutableList.append(callbacks.onResolve, resolveFinalPromise);\n CallbackRemovers.add(\n callbackRemovers,\n promise,\n callbacks => callbacks.onResolve,\n callbackNode,\n );\n\n let callbackNode =\n MutableList.append(callbacks.onReject, rejectFinalPromise);\n CallbackRemovers.add(\n callbackRemovers,\n promise,\n callbacks => callbacks.onReject,\n callbackNode,\n );\n\n | `Merged(_) =>\n /* Impossible, because of the call to underlying above. */\n assert(false)\n }\n );\n\n finalPromise;\n};\n\nlet flatMapOk = (promise, callback) =>\n flatMap(\n promise,\n fun\n | Result.Ok(value) => callback(value)\n | Result.Error(_) as error => resolved(error),\n );\n\nlet flatMapError = (promise, callback) =>\n flatMap(\n promise,\n fun\n | Result.Ok(_) as ok => resolved(ok)\n | Result.Error(error) => callback(error),\n );\n\nlet mapOk = (promise, callback) =>\n map(\n promise,\n fun\n | Result.Ok(value) => Result.Ok(callback(value))\n | Result.Error(_) as error => error,\n );\n\nlet mapError = (promise, callback) =>\n map(\n promise,\n fun\n | Result.Ok(_) as ok => ok\n | Result.Error(error) => Result.Error(callback(error)),\n );\n\nlet getOk = (promise, callback) =>\n get(\n promise,\n fun\n | Result.Ok(value) => callback(value)\n | Result.Error(_) => (),\n );\n\nlet getError = (promise, callback) =>\n get(\n promise,\n fun\n | Result.Ok(_) => ()\n | Result.Error(error) => callback(error),\n );\n\nlet tapOk = (promise, callback) => {\n getOk(promise, callback);\n promise;\n};\n\nlet tapError = (promise, callback) => {\n getError(promise, callback);\n promise;\n};\n\nmodule Operators = {\n let (>|=) = mapOk;\n let (>>=) = flatMapOk;\n};\n\nlet flatMapSome = (promise, callback) =>\n flatMap(\n promise,\n fun\n | Some(value) => callback(value)\n | None => resolved(None),\n );\n\nlet mapSome = (promise, callback) =>\n map(\n promise,\n fun\n | Some(value) => Some(callback(value))\n | None => None,\n );\n\nlet getSome = (promise, callback) =>\n get(\n promise,\n fun\n | Some(value) => callback(value)\n | None => (),\n );\n\nlet tapSome = (promise, callback) => {\n getSome(promise, callback);\n promise;\n};\n\nmodule Js = {\n type t('a, 'e) = rejectable('a, 'e);\n\n external relax: promise('a) => rejectable('a, _) = \"%identity\";\n\n let pending = () => {\n let p = newInternal();\n let resolve = resolveInternal(p);\n let reject = rejectInternal(p);\n (p, resolve, reject);\n };\n\n let resolved = resolved;\n let rejected = rejected;\n let flatMap = flatMap;\n let map = map;\n let get = get;\n let tap = tap;\n let catch = catch;\n let all = all;\n let race = race;\n\n let toResult = promise =>\n catch(map(promise, v => Result.Ok(v)), e => resolved(Result.Error(e)));\n\n let fromResult = promise =>\n flatMap(\n relax(promise),\n fun\n | Result.Ok(v) => resolved(v)\n | Result.Error(e) => rejected(e),\n );\n};\n\nlet pending = () => {\n let (p, resolve, _) = Js.pending();\n (p, resolve);\n};\n\nlet exec = executor => {\n let (p, resolve) = pending();\n executor(resolve);\n p;\n};\n\nlet allOkArray = promises => {\n let promiseCount = Array.length(promises);\n\n if (promiseCount == 0) {\n resolved(Result.Ok([||]));\n } else {\n let resultValues = Array.make(promiseCount, None);\n let resultCount = ref(0);\n let (resultPromise, resolve) = pending();\n\n let (callbackRemover, removeCallbacks) = pending();\n\n promises\n |> Array.iteri((index, promise)\n /* Because callbacks are added to the user's promises through calls to the\n JS runtime's Promise.race, this function leaks memory if and only if\n the JS runtime's Promise functions leak memory. In particular, if one\n of the promises resolves with Error(_), the callbacks on the other\n promises should be removed. If not done, and long-pending promises are\n repeatedly passed to allOk in a loop, they will gradually accumulate\n huge lists of stale callbacks. This is also true of Promise.race, so we\n rely on the quality of the runtime's Promise.race implementation to\n proactively remove these callbacks. */\n =>\n race([promise, callbackRemover])\n |> (\n wrapped =>\n get(wrapped, result =>\n switch (result) {\n | Result.Ok(v) =>\n resultValues[index] = Some(v);\n incr(resultCount);\n if (resultCount^ >= promiseCount) {\n resultValues\n |> Array.map(v =>\n switch (v) {\n | Some(v) => v\n | None => assert(false)\n }\n )\n |> (values => resolve(Result.Ok(values)));\n };\n | Result.Error(e) =>\n resolve(Result.Error(e));\n removeCallbacks(Result.Error(e));\n }\n )\n )\n );\n\n resultPromise;\n };\n};\n\nlet allOk = promises =>\n mapOk(allOkArray(Array.of_list(promises)), Array.to_list);\n\nlet allOk2 = (p1, p2) => {\n let promises = [|Obj.magic(p1), Obj.magic(p2)|];\n mapOk(\n allOkArray(promises),\n fun\n | [|v1, v2|] => (Obj.magic(v1), Obj.magic(v2))\n | _ => assert(false),\n );\n};\n\nlet allOk3 = (p1, p2, p3) => {\n let promises = [|Obj.magic(p1), Obj.magic(p2), Obj.magic(p3)|];\n mapOk(\n allOkArray(promises),\n fun\n | [|v1, v2, v3|] => (Obj.magic(v1), Obj.magic(v2), Obj.magic(v3))\n | _ => assert(false),\n );\n};\n\nlet allOk4 = (p1, p2, p3, p4) => {\n let promises = [|\n Obj.magic(p1),\n Obj.magic(p2),\n Obj.magic(p3),\n Obj.magic(p4),\n |];\n mapOk(\n allOkArray(promises),\n fun\n | [|v1, v2, v3, v4|] => (\n Obj.magic(v1),\n Obj.magic(v2),\n Obj.magic(v3),\n Obj.magic(v4),\n )\n | _ => assert(false),\n );\n};\n\nlet allOk5 = (p1, p2, p3, p4, p5) => {\n let promises = [|\n Obj.magic(p1),\n Obj.magic(p2),\n Obj.magic(p3),\n Obj.magic(p4),\n Obj.magic(p5),\n |];\n mapOk(\n allOkArray(promises),\n fun\n | [|v1, v2, v3, v4, v5|] => (\n Obj.magic(v1),\n Obj.magic(v2),\n Obj.magic(v3),\n Obj.magic(v4),\n Obj.magic(v5),\n )\n | _ => assert(false),\n );\n};\n\nlet allOk6 = (p1, p2, p3, p4, p5, p6) => {\n let promises = [|\n Obj.magic(p1),\n Obj.magic(p2),\n Obj.magic(p3),\n Obj.magic(p4),\n Obj.magic(p5),\n Obj.magic(p6),\n |];\n mapOk(\n allOkArray(promises),\n fun\n | [|v1, v2, v3, v4, v5, v6|] => (\n Obj.magic(v1),\n Obj.magic(v2),\n Obj.magic(v3),\n Obj.magic(v4),\n Obj.magic(v5),\n Obj.magic(v6),\n )\n | _ => assert(false),\n );\n};\n\nmodule PipeFirst = {\n let (|.) = (v, f) => f(v);\n};\n"
},
{
"path": "packages/promise/native/promise.rei",
"content": "/* This file is part of reason-promise, released under the MIT license. See\n LICENSE.md for details, or visit\n https://github.com/aantron/promise/blob/master/LICENSE.md. */\n\n/* Internal type names; don't use these. Instead, use Promise.t and Promise.Js.t\n from outside this library. */\ntype rejectable('a, 'e); /* Internal; use Promise.Js.t. */\ntype never;\ntype promise('a) = rejectable('a, never); /* Internal; use Promise.t. */\n\n/* The main, public promise type (Promise.t). */\ntype t('a) = promise('a);\n\n/* Making promises. */\nlet pending: unit => (promise('a), 'a => unit);\n\nlet resolved: 'a => promise('a);\n\nlet exec: (('a => unit) => unit) => promise('a);\n\n/* Using promises. */\nlet get: (promise('a), 'a => unit) => unit;\n\nlet tap: (promise('a), 'a => unit) => promise('a);\n\nlet map: (promise('a), 'a => 'b) => promise('b);\n\nlet flatMap: (promise('a), 'a => promise('b)) => promise('b);\n\n/* Results. */\nlet getOk: (promise(result('a, 'e)), 'a => unit) => unit;\n\nlet tapOk:\n (promise(result('a, 'e)), 'a => unit) => promise(result('a, 'e));\n\nlet mapOk: (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e));\n\nlet flatMapOk:\n (promise(result('a, 'e)), 'a => promise(result('b, 'e))) =>\n promise(result('b, 'e));\n\nlet getError: (promise(result('a, 'e)), 'e => unit) => unit;\n\nlet tapError:\n (promise(result('a, 'e)), 'e => unit) => promise(result('a, 'e));\n\nlet mapError:\n (promise(result('a, 'e)), 'e => 'e2) => promise(result('a, 'e2));\n\nlet flatMapError:\n (promise(result('a, 'e)), 'e => promise(result('a, 'e2))) =>\n promise(result('a, 'e2));\n\nmodule Operators: {\n [@ocaml.deprecated \"Use the let* syntax\"]\n let (>|=):\n (promise(result('a, 'e)), 'a => 'b) => promise(result('b, 'e));\n\n [@ocaml.deprecated \"Use the let* syntax\"]\n let (>>=):\n (promise(result('a, 'e)), 'a => promise(result('b, 'e))) =>\n promise(result('b, 'e));\n};\n\n/* Options. */\nlet getSome: (promise(option('a)), 'a => unit) => unit;\n\nlet tapSome: (promise(option('a)), 'a => unit) => promise(option('a));\n\nlet mapSome: (promise(option('a)), 'a => 'b) => promise(option('b));\n\nlet flatMapSome:\n (promise(option('a)), 'a => promise(option('b))) => promise(option('b));\n\n/* Combining promises. */\nlet race: list(promise('a)) => promise('a);\n\nlet all: list(promise('a)) => promise(list('a));\n\nlet allArray: array(promise('a)) => promise(array('a));\n\nlet all2: (promise('a), promise('b)) => promise(('a, 'b));\n\nlet all3:\n (promise('a), promise('b), promise('c)) => promise(('a, 'b, 'c));\n\nlet all4:\n (promise('a), promise('b), promise('c), promise('d)) =>\n promise(('a, 'b, 'c, 'd));\n\nlet all5:\n (promise('a), promise('b), promise('c), promise('d), promise('e)) =>\n promise(('a, 'b, 'c, 'd, 'e));\n\nlet all6:\n (\n promise('a),\n promise('b),\n promise('c),\n promise('d),\n promise('e),\n promise('f)\n ) =>\n promise(('a, 'b, 'c, 'd, 'e, 'f));\n\nlet allOk:\n list(promise(result('a, 'e))) => promise(result(list('a), 'e));\n\nlet allOkArray:\n array(promise(result('a, 'e))) => promise(result(array('a), 'e));\n\nlet allOk2:\n (promise(result('a, 'err)), promise(result('b, 'err))) =>\n promise(result(('a, 'b), 'err));\n\nlet allOk3:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err))\n ) =>\n promise(result(('a, 'b, 'c), 'err));\n\nlet allOk4:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err)),\n promise(result('d, 'err))\n ) =>\n promise(result(('a, 'b, 'c, 'd), 'err));\n\nlet allOk5:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err)),\n promise(result('d, 'err)),\n promise(result('e, 'err))\n ) =>\n promise(result(('a, 'b, 'c, 'd, 'e), 'err));\n\nlet allOk6:\n (\n promise(result('a, 'err)),\n promise(result('b, 'err)),\n promise(result('c, 'err)),\n promise(result('d, 'err)),\n promise(result('e, 'err)),\n promise(result('f, 'err))\n ) =>\n promise(result(('a, 'b, 'c, 'd, 'e, 'f), 'err));\n\n/* Shouldn't be used; provided for compatibility with Js. */\nmodule Js: {\n type t('a, 'e) = rejectable('a, 'e);\n\n /* Making. */\n let pending: unit => (rejectable('a, 'e), 'a => unit, 'e => unit);\n\n let resolved: 'a => rejectable('a, 'e);\n\n let rejected: 'e => rejectable('a, 'e);\n\n /* Handling fulfillment. */\n let get: (rejectable('a, 'e), 'a => unit) => unit;\n\n let tap: (rejectable('a, 'e), 'a => unit) => rejectable('a, 'e);\n\n let map: (rejectable('a, 'e), 'a => 'b) => rejectable('b, 'e);\n\n let flatMap:\n (rejectable('a, 'e), 'a => rejectable('b, 'e)) => rejectable('b, 'e);\n\n /* Handling rejection. */\n let catch:\n (rejectable('a, 'e), 'e => rejectable('a, 'e2)) => rejectable('a, 'e2);\n\n /* Combining. */\n let all: list(rejectable('a, 'e)) => rejectable(list('a), 'e);\n\n let race: list(rejectable('a, 'e)) => rejectable('a, 'e);\n\n /* Conversions. */\n let relax: promise('a) => rejectable('a, 'e);\n\n let toResult: rejectable('a, 'e) => promise(result('a, 'e));\n\n let fromResult: promise(result('a, 'e)) => rejectable('a, 'e);\n};\n\nmodule PipeFirst: {\n let (|.): ('a, 'a => 'b) => 'b;\n};\n\nlet onUnhandledException: ref(exn => unit);\n\n/* This is not part of the public API. It is used by I/O libraries to drive\n native promise callbacks on each tick. */\n\nmodule ReadyCallbacks: {\n let callbacksPending: unit => bool;\n\n /* When about to iterate over the ready callbacks, reason-promise first takes\n a snapshot of them, and iterates over the snapshot. This is to prevent new\n ready callbacks, that may be created by the processing of the current ones,\n from being processed immediately. That could lead to I/O loop starvation\n and other problems. */\n type snapshot;\n\n let snapshot: unit => snapshot;\n let isEmpty: snapshot => bool;\n let call: snapshot => unit;\n};\n"
},
{
"path": "packages/react/src/React.ml",
"content": "type 'value ref = { mutable current : 'value }\ntype domRef = CallbackDomRef of (Dom.element Js.nullable -> unit) | CurrentDomRef of Dom.element Js.nullable ref\n\nmodule Ref = struct\n type t = domRef\n type currentDomRef = Dom.element Js.nullable ref\n type callbackDomRef = Dom.element Js.nullable -> unit\n\n let domRef (v : currentDomRef) = CurrentDomRef v\n let callbackDomRef (v : callbackDomRef) = CallbackDomRef v\nend\n\nlet createRef () = { current = None }\nlet useRef value = { current = value }\nlet forwardRef f = f ()\n\nmodule Event = struct\n type 'a synthetic\n\n type target_like =\n < checked : bool\n ; className : string\n ; id : string\n ; innerHTML : string\n ; name : string\n ; tagName : string\n ; textContent : string\n ; value : string >\n\n let fail name = Runtime.fail_impossible_action_in_ssr (\"React.Event.\" ^ name)\n\n module MakeEventWithType (Type : sig\n type t\n end) =\n struct\n let bubbles : Type.t -> bool = fun _ -> fail \"bubbles\"\n let cancelable : Type.t -> bool = fun _ -> fail \"cancelable\"\n let currentTarget : Type.t -> target_like = fun _ -> fail \"currentTarget\"\n let defaultPrevented : Type.t -> bool = fun _ -> fail \"defaultPrevented\"\n let eventPhase : Type.t -> int = fun _ -> fail \"eventPhase\"\n let isTrusted : Type.t -> bool = fun _ -> fail \"isTrusted\"\n let nativeEvent : Type.t -> target_like = fun _ -> fail \"nativeEvent\"\n let preventDefault : Type.t -> unit = fun _ -> fail \"preventDefault\"\n let isDefaultPrevented : Type.t -> bool = fun _ -> fail \"isDefaultPrevented\"\n let stopPropagation : Type.t -> unit = fun _ -> fail \"stopPropagation\"\n let isPropagationStopped : Type.t -> bool = fun _ -> fail \"isPropagationStopped\"\n let target : Type.t -> target_like = fun _ -> fail \"target\"\n let timeStamp : Type.t -> float = fun _ -> fail \"timeStamp\"\n let type_ : Type.t -> string = fun _ -> fail \"type_\"\n let persist : Type.t -> unit = fun _ -> fail \"persist\"\n end\n\n module Synthetic = struct\n type tag\n type t = tag synthetic\n\n let bubbles : 'a synthetic -> bool = fun _ -> fail \"Synthetic.bubbles\"\n let cancelable : 'a synthetic -> bool = fun _ -> fail \"Synthetic.cancelable\"\n let currentTarget : 'a synthetic -> target_like = fun _ -> fail \"Synthetic.currentTarget\"\n let defaultPrevented : 'a synthetic -> bool = fun _ -> fail \"Synthetic.defaultPrevented\"\n let eventPhase : 'a synthetic -> int = fun _ -> fail \"Synthetic.eventPhase\"\n let isTrusted : 'a synthetic -> bool = fun _ -> fail \"Synthetic.isTrusted\"\n let nativeEvent : 'a synthetic -> target_like = fun _ -> fail \"Synthetic.nativeEvent\"\n let preventDefault : 'a synthetic -> unit = fun _ -> fail \"Synthetic.preventDefault\"\n let isDefaultPrevented : 'a synthetic -> bool = fun _ -> fail \"Synthetic.isDefaultPrevented\"\n let stopPropagation : 'a synthetic -> unit = fun _ -> fail \"Synthetic.stopPropagation\"\n let isPropagationStopped : 'a synthetic -> bool = fun _ -> fail \"Synthetic.isPropagationStopped\"\n let target : 'a synthetic -> target_like = fun _ -> fail \"Synthetic.target\"\n let timeStamp : 'a synthetic -> float = fun _ -> fail \"Synthetic.timeStamp\"\n let type_ : 'a synthetic -> string = fun _ -> fail \"Synthetic.type_\"\n let persist : 'a synthetic -> unit = fun _ -> fail \"Synthetic.persist\"\n end\n\n (* let toSyntheticEvent : 'a synthetic -> Synthetic.t = i -> i *)\n\n module Clipboard = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let clipboardData : t -> target_like = fun _ -> fail \"Clipboard.clipboardData\"\n end\n\n module Composition = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let data : t -> string = fun _ -> fail \"Composition.data\"\n end\n\n module Keyboard = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let altKey : t -> bool = fun _ -> fail \"Keyboard.altKey\"\n let charCode : t -> int = fun _ -> fail \"Keyboard.charCode\"\n let ctrlKey : t -> bool = fun _ -> fail \"Keyboard.ctrlKey\"\n let getModifierState : t -> string -> bool = fun _ _ -> fail \"Keyboard.getModifierState\"\n let key : t -> string = fun _ -> fail \"Keyboard.key\"\n let keyCode : t -> int = fun _ -> fail \"Keyboard.keyCode\"\n let locale : t -> string = fun _ -> fail \"Keyboard.locale\"\n let location : t -> int = fun _ -> fail \"Keyboard.location\"\n let metaKey : t -> bool = fun _ -> fail \"Keyboard.metaKey\"\n let repeat : t -> bool = fun _ -> fail \"Keyboard.repeat\"\n let shiftKey : t -> bool = fun _ -> fail \"Keyboard.shiftKey\"\n let which : t -> int = fun _ -> fail \"Keyboard.which\"\n end\n\n module Focus = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let relatedTarget : t -> target_like option = fun _ -> fail \"Focus.relatedTarget\"\n end\n\n module Form = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n end\n\n module Mouse = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let altKey : t -> bool = fun _ -> fail \"Mouse.altKey\"\n let button : t -> int = fun _ -> fail \"Mouse.button\"\n let buttons : t -> int = fun _ -> fail \"Mouse.buttons\"\n let clientX : t -> int = fun _ -> fail \"Mouse.clientX\"\n let clientY : t -> int = fun _ -> fail \"Mouse.clientY\"\n let ctrlKey : t -> bool = fun _ -> fail \"Mouse.ctrlKey\"\n let getModifierState : t -> string -> bool = fun _ _ -> fail \"Mouse.getModifierState\"\n let metaKey : t -> bool = fun _ -> fail \"Mouse.metaKey\"\n let movementX : t -> int = fun _ -> fail \"Mouse.movementX\"\n let movementY : t -> int = fun _ -> fail \"Mouse.movementY\"\n let pageX : t -> int = fun _ -> fail \"Mouse.pageX\"\n let pageY : t -> int = fun _ -> fail \"Mouse.pageY\"\n let relatedTarget : t -> target_like option = fun _ -> fail \"Mouse.relatedTarget\"\n let screenX : t -> int = fun _ -> fail \"Mouse.screenX\"\n let screenY : t -> int = fun _ -> fail \"Mouse.screenY\"\n let shiftKey : t -> bool = fun _ -> fail \"Mouse.shiftKey\"\n end\n\n module Pointer = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let detail : t -> int = fun _ -> fail \"Pointer.detail\"\n\n (* let view : t -> Dom.window *)\n let screenX : t -> int = fun _ -> fail \"Pointer.screenX\"\n let screenY : t -> int = fun _ -> fail \"Pointer.screenY\"\n let clientX : t -> int = fun _ -> fail \"Pointer.clientX\"\n let clientY : t -> int = fun _ -> fail \"Pointer.clientY\"\n let pageX : t -> int = fun _ -> fail \"Pointer.pageX\"\n let pageY : t -> int = fun _ -> fail \"Pointer.pageY\"\n let movementX : t -> int = fun _ -> fail \"Pointer.movementX\"\n let movementY : t -> int = fun _ -> fail \"Pointer.movementY\"\n let ctrlKey : t -> bool = fun _ -> fail \"Pointer.ctrlKey\"\n let shiftKey : t -> bool = fun _ -> fail \"Pointer.shiftKey\"\n let altKey : t -> bool = fun _ -> fail \"Pointer.altKey\"\n let metaKey : t -> bool = fun _ -> fail \"Pointer.metaKey\"\n let getModifierState : t -> string -> bool = fun _ _ -> fail \"Pointer.getModifierState\"\n let button : t -> int = fun _ -> fail \"Pointer.button\"\n let buttons : t -> int = fun _ -> fail \"Pointer.buttons\"\n let relatedTarget : t -> target_like option = fun _ -> fail \"Pointer.relatedTarget\"\n\n (* let pointerId : t -> Dom.eventPointerId *)\n let width : t -> float = fun _ -> fail \"Pointer.width\"\n let height : t -> float = fun _ -> fail \"Pointer.height\"\n let pressure : t -> float = fun _ -> fail \"Pointer.pressure\"\n let tangentialPressure : t -> float = fun _ -> fail \"Pointer.tangentialPressure\"\n let tiltX : t -> int = fun _ -> fail \"Pointer.tiltX\"\n let tiltY : t -> int = fun _ -> fail \"Pointer.tiltY\"\n let twist : t -> int = fun _ -> fail \"Pointer.twist\"\n let pointerType : t -> string = fun _ -> fail \"Pointer.pointerType\"\n let isPrimary : t -> bool = fun _ -> fail \"Pointer.isPrimary\"\n end\n\n module Selection = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n end\n\n module Touch = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let altKey : t -> bool = fun _ -> fail \"Touch.altKey\"\n let changedTouches : t -> target_like = fun _ -> fail \"Touch.changedTouches\"\n let ctrlKey : t -> bool = fun _ -> fail \"Touch.ctrlKey\"\n let getModifierState : t -> string -> bool = fun _ _ -> fail \"Touch.getModifierState\"\n let metaKey : t -> bool = fun _ -> fail \"Touch.metaKey\"\n let shiftKey : t -> bool = fun _ -> fail \"Touch.shiftKey\"\n let targetTouches : t -> target_like = fun _ -> fail \"Touch.targetTouches\"\n let touches : t -> target_like = fun _ -> fail \"Touch.touches\"\n end\n\n module UI = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let detail : t -> int = fun _ -> fail \"UI.detail\"\n (* let view : t -> Dom.window *)\n end\n\n module Wheel = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let deltaMode : t -> int = fun _ -> fail \"Wheel.deltaMode\"\n let deltaX : t -> float = fun _ -> fail \"Wheel.deltaX\"\n let deltaY : t -> float = fun _ -> fail \"Wheel.deltaY\"\n let deltaZ : t -> float = fun _ -> fail \"Wheel.deltaZ\"\n end\n\n module Media = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n end\n\n module Image = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n end\n\n module Animation = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let animationName : t -> string = fun _ -> fail \"Animation.animationName\"\n let pseudoElement : t -> string = fun _ -> fail \"Animation.pseudoElement\"\n let elapsedTime : t -> float = fun _ -> fail \"Animation.elapsedTime\"\n end\n\n module Transition = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let propertyName : t -> string = fun _ -> fail \"Transition.propertyName\"\n let pseudoElement : t -> string = fun _ -> fail \"Transition.pseudoElement\"\n let elapsedTime : t -> float = fun _ -> fail \"Transition.elapsedTime\"\n end\n\n module Drag = struct\n type tag\n type t = tag synthetic\n\n include MakeEventWithType (struct\n type nonrec t = t [@@nonrec]\n end)\n\n let altKey : t -> bool = fun _ -> fail \"Drag.altKey\"\n let button : t -> int = fun _ -> fail \"Drag.button\"\n let buttons : t -> int = fun _ -> fail \"Drag.buttons\"\n let clientX : t -> int = fun _ -> fail \"Drag.clientX\"\n let clientY : t -> int = fun _ -> fail \"Drag.clientY\"\n let ctrlKey : t -> bool = fun _ -> fail \"Drag.ctrlKey\"\n let getModifierState : t -> string -> bool = fun _ _ -> fail \"Drag.getModifierState\"\n let metaKey : t -> bool = fun _ -> fail \"Drag.metaKey\"\n let movementX : t -> int = fun _ -> fail \"Drag.movementX\"\n let movementY : t -> int = fun _ -> fail \"Drag.movementY\"\n let pageX : t -> int = fun _ -> fail \"Drag.pageX\"\n let pageY : t -> int = fun _ -> fail \"Drag.pageY\"\n let relatedTarget : t -> target_like option = fun _ -> fail \"Drag.relatedTarget\"\n let screenX : t -> int = fun _ -> fail \"Drag.screenX\"\n let screenY : t -> int = fun _ -> fail \"Drag.screenY\"\n let shiftKey : t -> bool = fun _ -> fail \"Drag.shiftKey\"\n let dataTransfer : t -> target_like = fun _ -> fail \"Drag.dataTransfer\"\n end\nend\n\nmodule JSX = struct\n type event =\n | Drag of (Event.Drag.t -> unit)\n | Mouse of (Event.Mouse.t -> unit)\n | Selection of (Event.Selection.t -> unit)\n | Touch of (Event.Touch.t -> unit)\n | UI of (Event.UI.t -> unit)\n | Wheel of (Event.Wheel.t -> unit)\n | Clipboard of (Event.Clipboard.t -> unit)\n | Composition of (Event.Composition.t -> unit)\n | Transition of (Event.Transition.t -> unit)\n | Animation of (Event.Animation.t -> unit)\n | Pointer of (Event.Pointer.t -> unit)\n | Keyboard of (Event.Keyboard.t -> unit)\n | Focus of (Event.Focus.t -> unit)\n | Form of (Event.Form.t -> unit)\n | Media of (Event.Media.t -> unit)\n | Inline of string\n\n type prop =\n | Action : (string * string * _ Runtime.server_function) -> prop\n | Bool of (string * string * bool)\n | String of (string * string * string)\n | Style of (string * string * string) list\n | DangerouslyInnerHtml of string\n | Ref of Ref.t\n | Event of string * event\n\n let bool name jsxName value = Bool (name, jsxName, value)\n let string name jsxName value = String (name, jsxName, value)\n let style value = Style value\n let int name jsxName value = String (name, jsxName, Int.to_string value)\n let float name jsxName value = String (name, jsxName, Float.to_string value)\n let dangerouslyInnerHtml value = DangerouslyInnerHtml value#__html\n let ref value = Ref value\n let event key value = Event (key, value)\n\n module Event = struct\n let drag key value = event key (Drag value)\n let mouse key value = event key (Mouse value)\n let selection key value = event key (Selection value)\n let touch key value = event key (Touch value)\n let ui key value = event key (UI value)\n let wheel key value = event key (Wheel value)\n let clipboard key value = event key (Clipboard value)\n let composition key value = event key (Composition value)\n let transition key value = event key (Transition value)\n let animation key value = event key (Animation value)\n let pointer key value = event key (Pointer value)\n let keyboard key value = event key (Keyboard value)\n let focus key value = event key (Focus value)\n let form key value = event key (Form value)\n let media key value = event key (Media value)\n end\nend\n\ntype error = { message : string; stack : Yojson.Basic.t; env : string; digest : string }\n\nmodule Model = struct\n type 'element t =\n | Function : 'server_function Runtime.server_function -> 'element t\n | List : 'element t list -> 'element t\n | Assoc : (string * 'element t) list -> 'element t\n | Json : Yojson.Basic.t -> 'element t\n | Error : error -> 'element t\n | Element : 'element -> 'element t\n | Promise : 'a Js.Promise.t * ('a -> 'element t) -> 'element t\nend\n\ntype ('props, 'return) componentLike = ?key:string -> 'props -> 'return\n\nand element =\n | Lower_case_element of lower_case_element\n | Upper_case_component of string * (unit -> element)\n | Async_component of string * (unit -> element Lwt.t)\n | Client_component of {\n key : string option;\n props : client_props;\n client : element;\n import_module : string;\n import_name : string;\n }\n | List of element list\n | Array of element array\n | Text of string\n | Static of { prerendered : string; original : element }\n | Writer of { emit : Buffer.t -> unit; original : unit -> element }\n (** Like [Static] but writes directly into the caller's buffer. Used by the PPX for subtrees with static skeleton\n \\+ dynamic string/int/float holes (the [Needs_string_concat] and [Needs_buffer] tiers).\n\n [original] is a thunk that rebuilds the variant-tree form on-demand for [cloneElement] and RSC consumers. Same\n name as [Static.original] for symmetry; [Writer]'s version is lazy so the render-to-string fast path pays no\n allocation for the fallback. *)\n | Fragment of element\n | Empty\n | Provider of { children : element; push : unit -> unit -> unit; async_key : Obj.t Lwt.key; async_value : Obj.t }\n | Consumer of element\n | Suspense of { key : string option; children : element; fallback : element }\n\nand lower_case_element = { key : string option; tag : string; attributes : JSX.prop list; children : element list }\nand client_props = (string * element Model.t) list\nand model_value = element Model.t\n\nexception Invalid_children of string\n\nlet compare_attribute (left : JSX.prop) (right : JSX.prop) =\n match (left, right) with\n | Bool (left_key, _, _), Bool (right_key, _, _) | String (left_key, _, _), String (right_key, _, _) ->\n String.compare left_key right_key\n | Style left_styles, Style right_styles ->\n List.compare\n (fun (left_property, _, left_value) (right_property, _, right_value) ->\n Int.compare (String.compare left_property right_property) (String.compare left_value right_value))\n left_styles right_styles\n | _ -> 0\n\nlet clone_attribute acc (attr : JSX.prop) (new_attr : JSX.prop) =\n match (attr, new_attr) with\n | Bool (left, _, _), Bool (right, _, _) when left == right -> new_attr :: acc\n | String (left, _, _), String (right, _, _) when left == right -> new_attr :: acc\n | _ -> new_attr :: acc\n\nmodule StringMap = Map.Make (String)\n\nlet attributes_to_map attributes =\n List.fold_left\n (fun acc (attr : JSX.prop) ->\n match attr with\n | (Bool (key, _, _) | String (key, _, _)) as prop -> acc |> StringMap.add key prop\n (* The following constructors shoudn't be part of the StringMap *)\n | DangerouslyInnerHtml _ -> acc\n | Ref _ -> acc\n | Event _ -> acc\n | Action _ -> acc\n | Style _ -> acc)\n StringMap.empty attributes\n\nlet clone_attributes attributes new_attributes =\n let attribute_map = attributes_to_map attributes in\n let new_attribute_map = attributes_to_map new_attributes in\n StringMap.merge\n (fun _key attr new_attr ->\n match (attr, new_attr) with\n | Some attr, Some new_attr -> Some (clone_attribute [] attr new_attr)\n | Some attr, None -> Some [ attr ]\n | None, Some new_attr -> Some [ new_attr ]\n | None, None -> None)\n attribute_map new_attribute_map\n |> StringMap.bindings\n |> List.map (fun (_, attrs) -> attrs)\n |> List.flatten |> List.rev |> List.sort compare_attribute\n\nlet create_element_with_key ?key tag attributes children =\n match Html.is_self_closing_tag tag with\n | true when List.length children > 0 ->\n raise (Invalid_children (Printf.sprintf {|\"%s\" is a self-closing tag and must not have \"children\".\\n|} tag))\n | true when List.exists (function JSX.DangerouslyInnerHtml _ -> true | _ -> false) attributes ->\n raise\n (Invalid_children\n (Printf.sprintf {|\"%s\" is a self-closing tag and must not have \"dangerouslySetInnerHTML\".\\n|} tag))\n | true -> Lower_case_element { key; tag; attributes; children = [] }\n | false -> Lower_case_element { key; tag; attributes; children }\n\nlet createElement = create_element_with_key ?key:None\nlet createElementWithKey = create_element_with_key\n\nlet clone_component_error name =\n Printf.sprintf\n \"React.cloneElement: cannot clone '%s'. In server-reason-react, component props are compile-time labelled \\\n arguments (and extending them with new props at runtime is not supported). React.cloneElement only works with \\\n lowercase DOM elements.\"\n name\n\nlet rec cloneElement element new_attributes =\n match element with\n | Lower_case_element { key; tag; attributes; children } ->\n Lower_case_element { key; tag; attributes = clone_attributes attributes new_attributes; children }\n | Upper_case_component (name, _) -> raise (Invalid_argument (clone_component_error name))\n | Async_component (name, _) -> raise (Invalid_argument (clone_component_error name))\n | Client_component { import_name; _ } -> raise (Invalid_argument (clone_component_error import_name))\n | Static { original; prerendered = _ } -> cloneElement original new_attributes\n | Writer { original; emit = _ } -> cloneElement (original ()) new_attributes\n | Fragment _ -> raise (Invalid_argument \"React.cloneElement: cannot clone a Fragment\")\n | Text _ -> raise (Invalid_argument \"React.cloneElement: cannot clone a Text element\")\n | Empty -> raise (Invalid_argument \"React.cloneElement: cannot clone a null element\")\n | List _ -> raise (Invalid_argument \"React.cloneElement: cannot clone a List\")\n | Array _ -> raise (Invalid_argument \"React.cloneElement: cannot clone an Array\")\n | Provider _ -> raise (Invalid_argument \"React.cloneElement: cannot clone a Provider\")\n | Consumer _ -> raise (Invalid_argument \"React.cloneElement: cannot clone a Consumer\")\n | Suspense _ -> raise (Invalid_argument \"React.cloneElement: cannot clone a Suspense\")\n\nmodule Fragment = struct\n let makeProps ~children () : < children : element > Js.t =\n object\n method children = children\n end\n\n let make ?key:_ props = Fragment props#children\nend\n\nlet fragment children = Fragment.make (Fragment.makeProps ~children ())\n\n(* ReasonReact APIs *)\nlet string txt = Text txt\nlet null = Empty\nlet int i = Text (string_of_int i)\n\n(* FIXME: float_of_string might be different from the browser *)\nlet float f = Text (string_of_float f)\nlet array arr = Array arr\nlet list l = List l\n\ntype 'a provider = value:'a -> children:element -> unit -> element\n\nmodule Context = struct\n type 'a t = {\n current_value : 'a ref;\n async_key : Obj.t Lwt.key;\n provider : 'a provider;\n consumer : children:element -> element;\n }\n\n let makeProps ~value ~children () : < value : 'a ; children : element > Js.t =\n object\n method value = value\n method children = children\n end\n\n let provider ctx ?key:_ props = ctx.provider ~value:props#value ~children:props#children ()\nend\n\nlet createContext (initial_value : 'a) : 'a Context.t =\n let ref_value = { current = initial_value } in\n let async_key = Lwt.new_key () in\n let provider ~value ~children () =\n Provider\n {\n children;\n push =\n (fun () ->\n let prev = ref_value.current in\n ref_value.current <- value;\n fun () -> ref_value.current <- prev);\n async_key;\n async_value = Obj.repr value;\n }\n in\n let consumer ~children = Consumer children in\n { current_value = ref_value; async_key; provider; consumer }\n\nmodule Suspense = struct\n let or_react_null = function None -> null | Some x -> x\n\n let makeProps ?fallback ?children () : < fallback : element option ; children : element option > Js.t =\n object\n method fallback = fallback\n method children = children\n end\n\n let make ?key props =\n Suspense { key; fallback = or_react_null props#fallback; children = or_react_null props#children }\nend\n\nmodule Cache = struct\n type cache_entry = Ok of Obj.t | Error of exn\n type fn_cache = (Obj.t, cache_entry) Hashtbl.t\n type request_cache = (int, fn_cache) Hashtbl.t\n\n let async_key : request_cache Lwt.key = Lwt.new_key ()\n let fn_id_counter : int Stdlib.ref = Stdlib.ref 0\n\n let with_request_cache f =\n let cache = Hashtbl.create 16 in\n Lwt.with_value async_key (Some cache) f\n\n let with_request_cache_async f =\n let cache = Hashtbl.create 16 in\n Lwt.with_value async_key (Some cache) f\nend\n\nlet memo f _component = f\nlet memoCustomCompareProps f _compare _component = f\n\nlet cache fn =\n let fn_id = !Cache.fn_id_counter in\n Cache.fn_id_counter := fn_id + 1;\n fun arg ->\n match Lwt.get Cache.async_key with\n | None -> fn arg\n | Some cache_map -> (\n let fn_cache =\n match Hashtbl.find_opt cache_map fn_id with\n | Some cache -> cache\n | None ->\n let cache = Hashtbl.create 8 in\n Hashtbl.add cache_map fn_id cache;\n cache\n in\n let arg_key = Obj.repr arg in\n match Hashtbl.find_opt fn_cache arg_key with\n | Some (Cache.Ok value) -> Obj.obj value\n | Some (Cache.Error error) -> raise error\n | None -> (\n try\n let result = fn arg in\n Hashtbl.add fn_cache arg_key (Cache.Ok (Obj.repr result));\n result\n with exn ->\n Hashtbl.add fn_cache arg_key (Cache.Error exn);\n raise exn))\n\nlet useContext (context : 'a Context.t) =\n match Lwt.get context.async_key with Some v -> (Obj.obj v : 'a) | None -> context.current_value.current\n\nlet useState (make_initial_value : unit -> 'state) =\n let initial_value : 'state = make_initial_value () in\n let setState (fn : 'state -> 'state) =\n let _ = fn initial_value in\n ()\n in\n (initial_value, setState)\n\ntype ('input, 'output) callback = 'input -> 'output\n\nlet useSyncExternalStore ~subscribe:_ ~getSnapshot = getSnapshot ()\nlet useSyncExternalStoreWithServer ~subscribe:_ ~getSnapshot:_ ~getServerSnapshot = getServerSnapshot ()\n\n(* Tree context for useId — implements the same bit-packing algorithm as React's\n ReactFizzTree_context.js to produce hydration-compatible IDs.\n\n IDs are base-32 strings whose binary representation corresponds to the\n position of a node in a tree. Every time the tree forks into multiple\n children, additional bits encode the position of the child within the\n current level of children. *)\nmodule Tree_context = struct\n type t = { id : int; overflow : string }\n\n let empty = { id = 1; overflow = \"\" }\n\n (* Count leading zeros in a 32-bit representation.\n Uses the same algorithm as Math.clz32 in JavaScript. *)\n let clz32 x =\n if x = 0 then 32\n else\n let n = Stdlib.ref 0 in\n let v = Stdlib.ref x in\n if !v land 0xFFFF0000 = 0 then (\n n := !n + 16;\n v := !v lsl 16);\n if !v land 0xFF000000 = 0 then (\n n := !n + 8;\n v := !v lsl 8);\n if !v land 0xF0000000 = 0 then (\n n := !n + 4;\n v := !v lsl 4);\n if !v land 0xC0000000 = 0 then (\n n := !n + 2;\n v := !v lsl 2);\n if !v land 0x80000000 = 0 then n := !n + 1;\n !n\n\n let get_bit_length n = 32 - clz32 n\n let get_leading_bit id = 1 lsl (get_bit_length id - 1)\n\n (* Convert a non-negative integer to a base-32 string (digits: 0-9, a-v).\n Matches JavaScript's Number.prototype.toString(32). *)\n let int_to_base32 n =\n if n = 0 then \"0\"\n else\n let digits = \"0123456789abcdefghijklmnopqrstuv\" in\n let buf = Buffer.create 8 in\n let rec go n =\n if n > 0 then begin\n go (n / 32);\n Buffer.add_char buf (String.get digits (n mod 32))\n end\n in\n go n;\n Buffer.contents buf\n\n let get_tree_id ctx =\n let overflow = ctx.overflow in\n let id_with_leading_bit = ctx.id in\n let id = id_with_leading_bit land lnot (get_leading_bit id_with_leading_bit) in\n int_to_base32 id ^ overflow\n\n let push base_ctx ~total_children ~index =\n let base_id_with_leading_bit = base_ctx.id in\n let base_overflow = base_ctx.overflow in\n let base_length = get_bit_length base_id_with_leading_bit - 1 in\n let base_id = base_id_with_leading_bit land lnot (1 lsl base_length) in\n let slot = index + 1 in\n let length = get_bit_length total_children + base_length in\n if length > 30 then begin\n (* Overflow: convert some bits to base-32 string *)\n let number_of_overflow_bits = base_length - (base_length mod 5) in\n let new_overflow_bits = (1 lsl number_of_overflow_bits) - 1 in\n let new_overflow = int_to_base32 (base_id land new_overflow_bits) in\n let rest_of_base_id = base_id asr number_of_overflow_bits in\n let rest_of_base_length = base_length - number_of_overflow_bits in\n let rest_of_length = get_bit_length total_children + rest_of_base_length in\n let rest_of_new_bits = slot lsl rest_of_base_length in\n let id = rest_of_new_bits lor rest_of_base_id in\n let overflow = new_overflow ^ base_overflow in\n { id = (1 lsl rest_of_length) lor id; overflow }\n end\n else\n (* Normal path *)\n let new_bits = slot lsl base_length in\n let id = new_bits lor base_id in\n { id = (1 lsl length) lor id; overflow = base_overflow }\nend\n\n(* Rendering hook context — mutable state set by the renderer (ReactDOM) and\n read by hooks (useId). This mirrors React's currentlyRenderingTask pattern\n in ReactFizzHooks.js. *)\nlet current_tree_context : Tree_context.t Stdlib.ref = Stdlib.ref Tree_context.empty\nlet local_id_counter : int Stdlib.ref = Stdlib.ref 0\nlet did_render_id_hook : bool Stdlib.ref = Stdlib.ref false\nlet identifier_prefix : string option Stdlib.ref = Stdlib.ref None\n\nlet reset_component_id_state (ctx : Tree_context.t) =\n current_tree_context := ctx;\n local_id_counter := 0;\n did_render_id_hook := false\n\nlet check_did_render_id_hook () = !did_render_id_hook\n\nlet reset_id_rendering ?prefix () =\n current_tree_context := Tree_context.empty;\n local_id_counter := 0;\n did_render_id_hook := false;\n identifier_prefix := prefix\n\n(* React 19 uses \\u00ab (LEFT-POINTING DOUBLE ANGLE QUOTATION MARK) and\n \\u00bb (RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK) as ID delimiters. *)\nlet id_start = \"\\xc2\\xab\"\nlet id_end = \"\\xc2\\xbb\"\n\nlet useId () =\n let tree_id = Tree_context.get_tree_id !current_tree_context in\n let local_id = !local_id_counter in\n local_id_counter := local_id + 1;\n did_render_id_hook := true;\n match (!identifier_prefix, local_id > 0) with\n | None, false -> Printf.sprintf \"%sR%s%s\" id_start tree_id id_end\n | None, true -> Printf.sprintf \"%sR%sH%s%s\" id_start tree_id (Tree_context.int_to_base32 local_id) id_end\n | Some prefix, false -> Printf.sprintf \"%s%sR%s%s\" id_start prefix tree_id id_end\n | Some prefix, true ->\n Printf.sprintf \"%s%sR%sH%s%s\" id_start prefix tree_id (Tree_context.int_to_base32 local_id) id_end\n\nlet useMemo fn = fn ()\nlet useMemo0 fn = fn ()\nlet useMemo1 fn _ = fn ()\nlet useMemo2 fn _ = fn ()\nlet useMemo3 fn _ = fn ()\nlet useMemo4 fn _ = fn ()\nlet useMemo5 fn _ = fn ()\nlet useMemo6 fn _ = fn ()\nlet useCallback fn = fn\nlet useCallback0 fn = fn\nlet useCallback1 fn _ = fn\nlet useCallback2 fn _ = fn\nlet useCallback3 fn _ = fn\nlet useCallback4 fn _ = fn\nlet useCallback5 fn _ = fn\nlet useCallback6 fn _ = fn\nlet useReducer _ s = (s, fun _ -> ())\nlet useReducerWithMapState _ s mapper = (mapper s, fun _ -> ())\nlet useEffect _ = ()\nlet useEffect0 _ = ()\nlet useEffect1 _ _ = ()\nlet useEffect2 _ _ = ()\nlet useEffect3 _ _ = ()\nlet useEffect4 _ _ = ()\nlet useEffect5 _ _ = ()\nlet useEffect6 _ _ = ()\nlet useLayoutEffect0 _ = ()\nlet useLayoutEffect1 _ _ = ()\nlet useLayoutEffect2 _ _ = ()\nlet useLayoutEffect3 _ _ = ()\nlet useLayoutEffect4 _ _ = ()\nlet useLayoutEffect5 _ _ = ()\nlet useLayoutEffect6 _ _ = ()\n\nmodule Children = struct\n let map element fn =\n match element with\n | List children -> List.map fn children |> list\n | Array children -> Array.map fn children |> array\n | _ -> fn element\n\n let mapWithIndex element fn =\n match element with\n | List children -> List.mapi (fun index element -> fn element index) children |> list\n | Array children -> Array.mapi (fun index element -> fn element index) children |> array\n | _ -> fn element 0\n\n let forEach element fn =\n match element with\n | List children -> List.iter fn children\n | Array children -> Array.iter fn children\n | _ ->\n let _ = fn element in\n ()\n\n let forEachWithIndex element fn =\n match element with\n | List children -> List.iteri (fun index element -> fn element index) children\n | Array children -> Array.iteri (fun index element -> fn element index) children\n | _ ->\n let _ = fn element 0 in\n ()\n\n let count element =\n match element with\n | List children -> List.length children\n | Array children -> Array.length children\n | Empty -> 0\n | _ -> 1\n\n let only element =\n match element with\n | List (child :: _) -> child\n | List [] -> raise (Invalid_argument \"Expected at least one child\")\n | Array children ->\n if Array.length children >= 1 then Array.get children 0\n else raise (Invalid_argument \"Expected at least one child\")\n | _ -> element\n\n (* TODO: silly way to convert children to array, but isn't necessary in most cases *)\n let toArray element = [| element |]\nend\n\nlet setDisplayName _ _ = ()\nlet useTransition () = (false, fun (_cb : unit -> unit) -> ())\nlet useDebugValue : 'value -> ?format:('value -> string) -> unit = fun[@warning \"-16\"] _ ?format:_ -> ()\nlet useDeferredValue value = value\n\n(* `exception Suspend of 'a Lwt`\n exceptions can't have type params, this is called existential wrapper *)\ntype any_promise = Any_promise : 'a Lwt.t -> any_promise\n\nexception Suspend of any_promise\n\nlet suspend promise = raise (Suspend (Any_promise promise))\n\nmodule Experimental = struct\n let usePromise promise =\n match Lwt.state promise with\n | Sleep -> suspend promise\n (* TODO: Fail should raise a FailedSupense and catch at renderTo*? *)\n | Fail e -> raise e\n | Return v -> v\n\n let useActionState ?permalink:_ _action state = (state, (), false)\nend\n"
},
{
"path": "packages/react/src/React.mli",
"content": "(** The React library *)\n\ntype domRef\ntype 'value ref = { mutable current : 'value }\n\nmodule Ref : sig\n type t = domRef\n type currentDomRef = Dom.element Js.nullable ref\n type callbackDomRef = Dom.element Js.nullable -> unit\n\n val domRef : currentDomRef -> t\n val callbackDomRef : callbackDomRef -> t\nend\n\nval createRef : unit -> 'a option ref\nval useRef : 'a -> 'a ref\nval forwardRef : (unit -> 'a) -> 'a\n\nmodule Event : sig\n type 'a synthetic\n\n type target_like =\n < checked : bool\n ; className : string\n ; id : string\n ; innerHTML : string\n ; name : string\n ; tagName : string\n ; textContent : string\n ; value : string >\n\n module MakeEventWithType : functor\n (Type : sig\n type t\n end)\n -> sig\n val bubbles : Type.t -> bool\n val cancelable : Type.t -> bool\n val currentTarget : Type.t -> target_like\n val defaultPrevented : Type.t -> bool\n val eventPhase : Type.t -> int\n val isTrusted : Type.t -> bool\n val nativeEvent : Type.t -> target_like\n val preventDefault : Type.t -> unit\n val isDefaultPrevented : Type.t -> bool\n val stopPropagation : Type.t -> unit\n val isPropagationStopped : Type.t -> bool\n val target : Type.t -> target_like\n val timeStamp : Type.t -> float\n val type_ : Type.t -> string\n val persist : Type.t -> unit\n end\n\n module Synthetic : sig\n type tag\n type t = tag synthetic\n\n val bubbles : 'a synthetic -> bool\n val cancelable : 'a synthetic -> bool\n val currentTarget : 'a synthetic -> target_like\n val defaultPrevented : 'a synthetic -> bool\n val eventPhase : 'a synthetic -> int\n val isTrusted : 'a synthetic -> bool\n val nativeEvent : 'a synthetic -> target_like\n val preventDefault : 'a synthetic -> unit\n val isDefaultPrevented : 'a synthetic -> bool\n val stopPropagation : 'a synthetic -> unit\n val isPropagationStopped : 'a synthetic -> bool\n val target : 'a synthetic -> target_like\n val timeStamp : 'a synthetic -> float\n val type_ : 'a synthetic -> string\n val persist : 'a synthetic -> unit\n end\n\n module Clipboard : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val clipboardData : t -> target_like\n end\n\n module Composition : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val data : t -> string\n end\n\n module Keyboard : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val altKey : t -> bool\n val charCode : t -> int\n val ctrlKey : t -> bool\n val getModifierState : t -> string -> bool\n val key : t -> string\n val keyCode : t -> int\n val locale : t -> string\n val location : t -> int\n val metaKey : t -> bool\n val repeat : t -> bool\n val shiftKey : t -> bool\n val which : t -> int\n end\n\n module Focus : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val relatedTarget : t -> target_like option\n end\n\n module Form : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n end\n\n module Mouse : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val altKey : t -> bool\n val button : t -> int\n val buttons : t -> int\n val clientX : t -> int\n val clientY : t -> int\n val ctrlKey : t -> bool\n val getModifierState : t -> string -> bool\n val metaKey : t -> bool\n val movementX : t -> int\n val movementY : t -> int\n val pageX : t -> int\n val pageY : t -> int\n val relatedTarget : t -> target_like option\n val screenX : t -> int\n val screenY : t -> int\n val shiftKey : t -> bool\n end\n\n module Pointer : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val detail : t -> int\n val screenX : t -> int\n val screenY : t -> int\n val clientX : t -> int\n val clientY : t -> int\n val pageX : t -> int\n val pageY : t -> int\n val movementX : t -> int\n val movementY : t -> int\n val ctrlKey : t -> bool\n val shiftKey : t -> bool\n val altKey : t -> bool\n val metaKey : t -> bool\n val getModifierState : t -> string -> bool\n val button : t -> int\n val buttons : t -> int\n val relatedTarget : t -> target_like option\n val width : t -> float\n val height : t -> float\n val pressure : t -> float\n val tangentialPressure : t -> float\n val tiltX : t -> int\n val tiltY : t -> int\n val twist : t -> int\n val pointerType : t -> string\n val isPrimary : t -> bool\n end\n\n module Selection : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n end\n\n module Touch : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val altKey : t -> bool\n val changedTouches : t -> target_like\n val ctrlKey : t -> bool\n val getModifierState : t -> string -> bool\n val metaKey : t -> bool\n val shiftKey : t -> bool\n val targetTouches : t -> target_like\n val touches : t -> target_like\n end\n\n module UI : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val detail : t -> int\n end\n\n module Wheel : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val deltaMode : t -> int\n val deltaX : t -> float\n val deltaY : t -> float\n val deltaZ : t -> float\n end\n\n module Media : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n end\n\n module Image : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n end\n\n module Animation : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val animationName : t -> string\n val pseudoElement : t -> string\n val elapsedTime : t -> float\n end\n\n module Transition : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val propertyName : t -> string\n val pseudoElement : t -> string\n val elapsedTime : t -> float\n end\n\n module Drag : sig\n type tag\n type t = tag synthetic\n\n val bubbles : t -> bool\n val cancelable : t -> bool\n val currentTarget : t -> target_like\n val defaultPrevented : t -> bool\n val eventPhase : t -> int\n val isTrusted : t -> bool\n val nativeEvent : t -> target_like\n val preventDefault : t -> unit\n val isDefaultPrevented : t -> bool\n val stopPropagation : t -> unit\n val isPropagationStopped : t -> bool\n val target : t -> target_like\n val timeStamp : t -> float\n val type_ : t -> string\n val persist : t -> unit\n val altKey : t -> bool\n val button : t -> int\n val buttons : t -> int\n val clientX : t -> int\n val clientY : t -> int\n val ctrlKey : t -> bool\n val getModifierState : t -> string -> bool\n val metaKey : t -> bool\n val movementX : t -> int\n val movementY : t -> int\n val pageX : t -> int\n val pageY : t -> int\n val relatedTarget : t -> target_like option\n val screenX : t -> int\n val screenY : t -> int\n val shiftKey : t -> bool\n val dataTransfer : t -> target_like\n end\nend\n\n(** All of those types are used by the server-reason-react.ppx internally to represent valid React code from the server.\n It currently different from reason-react-ppx due to a need for knowing the types since ReactDOM needs to render\n differently depending on the type. *)\nmodule JSX : sig\n (** All event callbacks *)\n type event =\n | Drag of (Event.Drag.t -> unit)\n | Mouse of (Event.Mouse.t -> unit)\n | Selection of (Event.Selection.t -> unit)\n | Touch of (Event.Touch.t -> unit)\n | UI of (Event.UI.t -> unit)\n | Wheel of (Event.Wheel.t -> unit)\n | Clipboard of (Event.Clipboard.t -> unit)\n | Composition of (Event.Composition.t -> unit)\n | Transition of (Event.Transition.t -> unit)\n | Animation of (Event.Animation.t -> unit)\n | Pointer of (Event.Pointer.t -> unit)\n | Keyboard of (Event.Keyboard.t -> unit)\n | Focus of (Event.Focus.t -> unit)\n | Form of (Event.Form.t -> unit)\n | Media of (Event.Media.t -> unit)\n | Inline of string\n\n (** JSX.prop is the representation of HTML/SVG attributes and DOM events *)\n type prop =\n | Action : (string * string * _ Runtime.server_function) -> prop\n | Bool of (string * string * bool)\n | String of (string * string * string)\n | Style of (string * string * string) list\n | DangerouslyInnerHtml of string\n | Ref of domRef\n | Event of string * event\n\n (** Helpers to create JSX.prop without variants, helpful for function application *)\n\n val bool : string -> string -> bool -> prop\n val string : string -> string -> string -> prop\n val style : (string * string * string) list -> prop\n val dangerouslyInnerHtml : < __html : string ; .. > -> prop\n val int : string -> string -> int -> prop\n val float : string -> string -> float -> prop\n val ref : domRef -> prop\n val event : string -> event -> prop\n\n module Event : sig\n val drag : string -> (Event.Drag.t -> unit) -> prop\n val mouse : string -> (Event.Mouse.t -> unit) -> prop\n val selection : string -> (Event.Selection.t -> unit) -> prop\n val touch : string -> (Event.Touch.t -> unit) -> prop\n val ui : string -> (Event.UI.t -> unit) -> prop\n val wheel : string -> (Event.Wheel.t -> unit) -> prop\n val clipboard : string -> (Event.Clipboard.t -> unit) -> prop\n val composition : string -> (Event.Composition.t -> unit) -> prop\n val transition : string -> (Event.Transition.t -> unit) -> prop\n val animation : string -> (Event.Animation.t -> unit) -> prop\n val pointer : string -> (Event.Pointer.t -> unit) -> prop\n val keyboard : string -> (Event.Keyboard.t -> unit) -> prop\n val focus : string -> (Event.Focus.t -> unit) -> prop\n val form : string -> (Event.Form.t -> unit) -> prop\n val media : string -> (Event.Media.t -> unit) -> prop\n end\nend\n\ntype error = { message : string; stack : Yojson.Basic.t; env : string; digest : string }\n\nmodule Model : sig\n type 'element t =\n | Function : 'server_function Runtime.server_function -> 'element t\n | List : 'element t list -> 'element t\n | Assoc : (string * 'element t) list -> 'element t\n | Json : Yojson.Basic.t -> 'element t\n | Error : error -> 'element t\n | Element : 'element -> 'element t\n | Promise : 'a Js.Promise.t * ('a -> 'element t) -> 'element t\nend\n\ntype ('props, 'return) componentLike = ?key:string -> 'props -> 'return\n\nand element =\n | Lower_case_element of lower_case_element\n | Upper_case_component of string * (unit -> element)\n | Async_component of string * (unit -> element Lwt.t)\n | Client_component of {\n key : string option;\n props : client_props;\n client : element;\n import_module : string;\n import_name : string;\n }\n | List of element list\n | Array of element array\n | Text of string\n | Static of { prerendered : string; original : element }\n | Writer of { emit : Buffer.t -> unit; original : unit -> element }\n (** Subtree with static skeleton + dynamic string/int/float/element holes. [emit] writes directly into the\n caller's buffer, avoiding the intermediate buffer + Buffer.contents allocation that a [Static] wrapping would\n require.\n\n [original] is a thunk that rebuilds the variant-tree form on-demand for [cloneElement] / RSC consumers. Same\n name as [Static.original] for symmetry; this variant's version is lazy. Emitted by the PPX for the\n [Needs_string_concat] and [Needs_buffer] analysis tiers. *)\n | Fragment of element\n | Empty\n | Provider of { children : element; push : unit -> unit -> unit; async_key : Obj.t Lwt.key; async_value : Obj.t }\n | Consumer of element\n | Suspense of { key : string option; children : element; fallback : element }\n\nand lower_case_element = { key : string option; tag : string; attributes : JSX.prop list; children : element list }\nand client_props = (string * element Model.t) list\nand model_value = element Model.t\n\nexception Invalid_children of string\n\nmodule Fragment : sig\n val makeProps : children:element -> unit -> < children : element > Js.t\n val make : (< children : element > Js.t, element) componentLike\nend\n\nval createElement : string -> JSX.prop list -> element list -> element\nval createElementWithKey : ?key:string -> string -> JSX.prop list -> element list -> element\nval fragment : element -> element\nval cloneElement : element -> JSX.prop list -> element\nval string : string -> element\nval null : element\nval int : int -> element\nval float : float -> element\nval array : element array -> element\nval list : element list -> element\n\ntype 'a provider = value:'a -> children:element -> unit -> element\n\nmodule Context : sig\n type 'a t = {\n current_value : 'a ref;\n async_key : Obj.t Lwt.key;\n provider : 'a provider;\n consumer : children:element -> element;\n }\n\n val makeProps : value:'a -> children:element -> unit -> < value : 'a ; children : element > Js.t\n val provider : 'a t -> (< value : 'a ; children : element > Js.t, element) componentLike\nend\n\nval createContext : 'a -> 'a Context.t\n\nmodule Suspense : sig\n val makeProps :\n ?fallback:element -> ?children:element -> unit -> < fallback : element option ; children : element option > Js.t\n\n val make : (< fallback : element option ; children : element option > Js.t, element) componentLike\nend\n\nmodule Cache : sig\n val with_request_cache : (unit -> 'a) -> 'a\n val with_request_cache_async : (unit -> 'a Lwt.t) -> 'a Lwt.t\nend\n\ntype any_promise = Any_promise : 'a Lwt.t -> any_promise\n\nexception Suspend of any_promise\n\nval memo : ('props * 'props -> bool) -> 'a -> 'props * 'props -> bool\nval memoCustomCompareProps : ('props * 'props -> bool) -> ('props * 'props -> bool) -> 'a -> 'props * 'props -> bool\nval cache : ('a -> 'b) -> 'a -> 'b\nval useContext : 'a Context.t -> 'a\nval useState : (unit -> 'state) -> 'state * (('state -> 'state) -> unit)\nval useMemo : (unit -> 'a) -> 'a\nval useMemo0 : (unit -> 'a) -> 'a\nval useMemo1 : (unit -> 'a) -> 'b -> 'a\nval useMemo2 : (unit -> 'a) -> 'b -> 'a\nval useMemo3 : (unit -> 'a) -> 'b -> 'a\nval useMemo4 : (unit -> 'a) -> 'b -> 'a\nval useMemo5 : (unit -> 'a) -> 'b -> 'a\nval useMemo6 : (unit -> 'a) -> 'b -> 'a\nval useCallback : 'a -> 'a\nval useCallback0 : 'a -> 'a\nval useCallback1 : 'a -> 'b -> 'a\nval useCallback2 : 'a -> 'b -> 'a\nval useCallback3 : 'a -> 'b -> 'a\nval useCallback4 : 'a -> 'b -> 'a\nval useCallback5 : 'a -> 'b -> 'a\nval useCallback6 : 'a -> 'b -> 'a\n\nmodule Tree_context : sig\n type t\n\n val empty : t\n val push : t -> total_children:int -> index:int -> t\nend\n\nval current_tree_context : Tree_context.t Stdlib.ref\n(** Rendering hook context — called by the renderer before/after rendering each function component. *)\n\nval reset_component_id_state : Tree_context.t -> unit\nval check_did_render_id_hook : unit -> bool\nval reset_id_rendering : ?prefix:string -> unit -> unit\nval useId : unit -> string\n\ntype ('input, 'output) callback = 'input -> 'output\n\nval useSyncExternalStore :\n subscribe:((unit -> unit) -> (unit, unit) callback) -> getSnapshot:(unit -> 'snapshot) -> 'snapshot\n[@@deprecated \"Use useSyncExternalStoreWithServer instead\"]\n\nval useSyncExternalStoreWithServer :\n subscribe:((unit -> unit) -> (unit, unit) callback) ->\n getSnapshot:(unit -> 'snapshot) ->\n getServerSnapshot:(unit -> 'snapshot) ->\n 'snapshot\n\nval useReducer : ('state -> 'action -> 'state) -> 'state -> 'state * ('action -> unit)\n\nval useReducerWithMapState :\n ('state -> 'action -> 'initialState) -> 'initialState -> ('initialState -> 'state) -> 'state * ('action -> unit)\n\nval useEffect : (unit -> (unit -> unit) option) -> unit\nval useEffect0 : (unit -> (unit -> unit) option) -> unit\nval useEffect1 : (unit -> (unit -> unit) option) -> 'dependency array -> unit\nval useEffect2 : (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 -> unit\nval useEffect3 : (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 * 'dependency3 -> unit\nval useEffect4 : (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 * 'dependency3 * 'dependency4 -> unit\n\nval useEffect5 :\n (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 * 'dependency3 * 'dependency4 * 'dependency5 -> unit\n\nval useEffect6 :\n (unit -> (unit -> unit) option) ->\n 'dependency1 * 'dependency2 * 'dependency3 * 'dependency4 * 'dependency5 * 'dependency6 ->\n unit\n\nval useLayoutEffect0 : (unit -> (unit -> unit) option) -> unit\nval useLayoutEffect1 : (unit -> (unit -> unit) option) -> 'dependency array -> unit\nval useLayoutEffect2 : (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 -> unit\nval useLayoutEffect3 : (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 * 'dependency3 -> unit\n\nval useLayoutEffect4 :\n (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 * 'dependency3 * 'dependency4 -> unit\n\nval useLayoutEffect5 :\n (unit -> (unit -> unit) option) -> 'dependency1 * 'dependency2 * 'dependency3 * 'dependency4 * 'dependency5 -> unit\n\nval useLayoutEffect6 :\n (unit -> (unit -> unit) option) ->\n 'dependency1 * 'dependency2 * 'dependency3 * 'dependency4 * 'dependency5 * 'dependency6 ->\n unit\n\nval setDisplayName : 'component -> string -> unit\n\nmodule Children : sig\n val map : element -> (element -> element) -> element\n val mapWithIndex : element -> (element -> int -> element) -> element\n val forEach : element -> (element -> unit) -> unit\n val forEachWithIndex : element -> (element -> int -> unit) -> unit\n val count : element -> int\n val only : element -> element\n val toArray : element -> element array\nend\n\nval suspend : 'a Lwt.t -> unit\n\nmodule Experimental : sig\n val usePromise : 'a Lwt.t -> 'a\n val useActionState : ?permalink:string -> 'action -> 'state -> 'state * unit * bool\nend\n\nval useTransition : unit -> bool * ((unit -> unit) -> unit)\nval useDebugValue : 'value -> ?format:('value -> string) -> unit\nval useDeferredValue : 'value -> 'value\n"
},
{
"path": "packages/react/src/ReactEvent.ml",
"content": "include React.Event\n"
},
{
"path": "packages/react/src/ReasonReactRouter.ml",
"content": "let hash _location = \"\"\n\n(* TODO: Maybe this should be implemented? *)\nlet path ?serverUrlString:_ () = []\n\n(* TODO: Maybe this should be implemented? *)\nlet search ?serverUrlString:_ () = \"\"\nlet push (_path : string) = ()\nlet replace (_path : string) = ()\n\ntype url = { path : string list; hash : string; search : string }\ntype watcherID = unit -> unit\n\nlet url ?serverUrlString () = { path = path ?serverUrlString (); hash = hash (); search = search ?serverUrlString () }\nlet dangerouslyGetInitialUrl = url\nlet watchUrl _callback () = ()\nlet unwatchUrl _watcherID = ()\nlet useUrl ?(serverUrl : url option) () = match serverUrl with Some serverUrl -> serverUrl | None -> url ()\n"
},
{
"path": "packages/react/src/ReasonReactRouter.mli",
"content": "val push : string -> unit\n(** update the url with the string path. Example: `push(\"/book/1\")`, `push(\"/books#title\")` *)\n\nval replace : string -> unit\n(** update the url with the string path. modifies the current history entry instead of creating a new one. Example:\n `replace(\"/book/1\")`, `replace(\"/books#title\")` *)\n\ntype watcherID\n\ntype url = {\n (* path takes window.location.path, like \"/book/title/edit\" and turns it into `[\"book\", \"title\", \"edit\"]` *)\n path : string list;\n (* the url's hash, if any. The # symbol is stripped out for you *)\n hash : string;\n (* the url's query params, if any. The ? symbol is stripped out for you *)\n search : string;\n}\n\nval watchUrl : (url -> unit) -> watcherID\n(** start watching for URL changes. Returns a subscription token. Upon url change, calls the callback and passes it the\n url record *)\n\n(** stop watching for URL changes *)\nval unwatchUrl : watcherID -> unit\n(** this is marked as \"dangerous\" because you technically shouldn't be accessing the URL outside of watchUrl's callback\n you'd read a potentially stale url, instead of the fresh one inside watchUrl.\n\n But this helper is sometimes needed, if you'd like to initialize a page whose display/state depends on the URL,\n instead of reading from it in watchUrl's callback, which you'd probably have put inside didMount (aka too late, the\n page's already rendered).\n\n So, the correct (and idiomatic) usage of this helper is to only use it in a component that's also subscribed to\n watchUrl. Please see https://github.com/reasonml-community/reason-react-example/blob/master/src/todomvc/TodoItem.re\n for an example. *)\n\nval dangerouslyGetInitialUrl : ?serverUrlString:string -> unit -> url\n\nval useUrl : ?serverUrl:url -> unit -> url\n(** hook for watching url changes. * serverUrl is used for ssr. it allows you to specify the url without relying on\n browser apis existing/working as expected *)\n"
},
{
"path": "packages/react/src/dune",
"content": "(library\n (name react)\n (wrapped false)\n (public_name server-reason-react.react)\n (libraries\n server-reason-react.runtime\n server-reason-react.js\n server-reason-react.html\n server-reason-react.dom\n lwt\n yojson))\n"
},
{
"path": "packages/react/test/dune",
"content": "(test\n (name test)\n (modules :standard)\n (libraries\n alcotest\n fmt\n lwt\n lwt.unix\n server-reason-react.react\n server-reason-react.reactDom)\n (preprocess\n (pps server-reason-react.ppx lwt_ppx)))\n"
},
{
"path": "packages/react/test/test.ml",
"content": "let () = Alcotest.run \"React\" [ Test_cloneElement.tests; Test_react.tests ]\n"
},
{
"path": "packages/react/test/test_cloneElement.ml",
"content": "let equal_attrs (a1 : React.JSX.prop) (a2 : React.JSX.prop) =\n match (a1, a2) with\n | Bool (k1, x1, v1), Bool (k2, x2, v2) -> k1 == k2 && x1 == x2 && v1 = v2\n | String (k1, x1, v1), String (k2, x2, v2) -> k1 == k2 && x1 == x2 && v1 == v2\n | Style s1, Style s2 -> s1 == s2\n | DangerouslyInnerHtml s1, DangerouslyInnerHtml s2 -> s1 == s2\n | Event (k1, _v1), Event (k2, _v2) -> k1 == k2\n | _ -> false\n\nlet equal_elements (c1 : React.element) (c2 : React.element) =\n let rec equal_rec (c1 : React.element) (c2 : React.element) =\n match (c1, c2) with\n | Lower_case_element lc1, Lower_case_element lc2 ->\n lc1.tag == lc2.tag\n && List.for_all2 equal_rec lc1.children lc2.children\n && List.for_all2 equal_attrs lc1.attributes lc2.attributes\n | Upper_case_component (name1, cf1), Upper_case_component (name2, cf2) ->\n name1 == name2 && equal_rec (cf1 ()) (cf2 ())\n | List cl1, List cl2 -> List.for_all2 equal_rec cl1 cl2\n | Array cl1, Array cl2 -> Array.for_all2 equal_rec cl1 cl2\n | Text t1, Text t2 -> t1 == t2\n | Fragment fl1, Fragment fl2 -> equal_rec fl1 fl2\n | Empty, Empty -> true\n | Static { original = original1; prerendered = _ }, Static { original = original2; prerendered = _ } ->\n equal_rec original1 original2\n | Writer { original = original1; emit = _ }, Writer { original = original2; emit = _ } ->\n equal_rec (original1 ()) (original2 ())\n | _, _ -> false\n in\n equal_rec c1 c2\n\nlet assert_element left right = Alcotest.(check bool) \"should be equal\" true (equal_elements left right)\n\nlet clone_empty () =\n let element = React.createElement \"div\" [ React.JSX.Bool (\"hidden\", \"hidden\", true) ] [] in\n assert_element element (React.cloneElement element [])\n\nlet clone_attributes () =\n let element = React.createElement \"div\" [ React.JSX.String (\"val\", \"val\", \"33\") ] [] in\n let expected =\n React.createElement \"div\" [ React.JSX.String (\"val\", \"val\", \"31\"); React.JSX.Bool (\"lola\", \"lola\", true) ] []\n in\n let cloned =\n React.cloneElement element [ React.JSX.Bool (\"lola\", \"lola\", true); React.JSX.String (\"val\", \"val\", \"31\") ]\n in\n assert_element cloned expected\n\nlet clone_order_attributes () =\n let element = React.createElement \"div\" [] [] in\n let expected =\n React.createElement \"div\" [ React.JSX.String (\"val\", \"val\", \"31\"); React.JSX.Bool (\"lola\", \"lola\", true) ] []\n in\n let cloned =\n React.cloneElement element [ React.JSX.Bool (\"lola\", \"lola\", true); React.JSX.String (\"val\", \"val\", \"31\") ]\n in\n assert_element cloned expected\n\nlet clone_uppercase_component_raises () =\n let element = React.Upper_case_component (\"MyComponent\", fun () -> React.null) in\n Alcotest.check_raises \"cloneElement with uppercase component raises Invalid_argument\"\n (Invalid_argument\n \"React.cloneElement: cannot clone 'MyComponent'. In server-reason-react, component props are compile-time \\\n labelled arguments (and extending them with new props at runtime is not supported). React.cloneElement only \\\n works with lowercase DOM elements.\") (fun () -> ignore (React.cloneElement element []))\n\nlet clone_async_component_raises () =\n let element = React.Async_component (\"AsyncComponent\", fun () -> Lwt.return React.null) in\n Alcotest.check_raises \"cloneElement with async component raises Invalid_argument\"\n (Invalid_argument\n \"React.cloneElement: cannot clone 'AsyncComponent'. In server-reason-react, component props are compile-time \\\n labelled arguments (and extending them with new props at runtime is not supported). React.cloneElement only \\\n works with lowercase DOM elements.\") (fun () -> ignore (React.cloneElement element []))\n\nlet clone_client_component_raises () =\n let element =\n React.Client_component\n {\n key = None;\n props = [];\n client = React.null;\n import_module = \"./MyClient.js\";\n import_name = \"MyClientComponent\";\n }\n in\n Alcotest.check_raises \"cloneElement with client component raises Invalid_argument\"\n (Invalid_argument\n \"React.cloneElement: cannot clone 'MyClientComponent'. In server-reason-react, component props are compile-time \\\n labelled arguments (and extending them with new props at runtime is not supported). React.cloneElement only \\\n works with lowercase DOM elements.\") (fun () -> ignore (React.cloneElement element []))\n\nlet clone_static_unwraps () =\n let original = React.createElement \"div\" [ React.JSX.Bool (\"hidden\", \"hidden\", true) ] [] in\n let static_element = React.Static { prerendered = {||}; original } in\n let cloned = React.cloneElement static_element [] in\n assert_element cloned original\n\nlet clone_static_with_new_attributes () =\n let original = React.createElement \"div\" [ React.JSX.String (\"id\", \"id\", \"root\") ] [] in\n let static_element = React.Static { prerendered = {||}; original } in\n let cloned = React.cloneElement static_element [ React.JSX.String (\"class\", \"className\", \"container\") ] in\n let expected =\n React.createElement \"div\"\n [ React.JSX.String (\"class\", \"className\", \"container\"); React.JSX.String (\"id\", \"id\", \"root\") ]\n []\n in\n assert_element cloned expected\n\nlet clone_static_overrides_attributes () =\n let original = React.createElement \"span\" [ React.JSX.String (\"id\", \"id\", \"old\") ] [] in\n let static_element = React.Static { prerendered = {||}; original } in\n let cloned = React.cloneElement static_element [ React.JSX.String (\"id\", \"id\", \"new\") ] in\n let expected = React.createElement \"span\" [ React.JSX.String (\"id\", \"id\", \"new\") ] [] in\n assert_element cloned expected\n\nlet clone_static_result_is_not_static () =\n let original = React.createElement \"div\" [] [] in\n let static_element = React.Static { prerendered = \"\"; original } in\n let cloned = React.cloneElement static_element [] in\n match cloned with\n | React.Lower_case_element _ -> ()\n | React.Static _ -> Alcotest.fail \"cloneElement on Static should return a Lower_case_element, not Static\"\n | _ -> Alcotest.fail \"cloneElement on Static should return a Lower_case_element\"\n\nlet clone_static_preserves_children () =\n let children = [ React.createElement \"span\" [] []; React.string \"hello\" ] in\n let original = React.createElement \"div\" [ React.JSX.String (\"id\", \"id\", \"parent\") ] children in\n let static_element = React.Static { prerendered = {|
|}; original = outer_original } in\n let cloned = React.cloneElement outer_static [ React.JSX.Bool (\"hidden\", \"hidden\", true) ] in\n let expected = React.createElement \"div\" [ React.JSX.Bool (\"hidden\", \"hidden\", true) ] [ inner_static ] in\n assert_element cloned expected\n\nlet case title fn = Alcotest.test_case title `Quick fn\n\nlet tests =\n ( \"cloneElement\",\n [\n case \"empty component\" clone_empty;\n case \"attributes component\" clone_attributes;\n case \"ordered attributes component\" clone_order_attributes;\n case \"uppercase component raises\" clone_uppercase_component_raises;\n case \"async component raises\" clone_async_component_raises;\n case \"client component raises\" clone_client_component_raises;\n case \"static unwraps to original\" clone_static_unwraps;\n case \"static adds new attributes\" clone_static_with_new_attributes;\n case \"static overrides existing attributes\" clone_static_overrides_attributes;\n case \"static result is Lower_case_element not Static\" clone_static_result_is_not_static;\n case \"static preserves children\" clone_static_preserves_children;\n case \"static nested static unwraps outer only\" clone_nested_static;\n ] )\n"
},
{
"path": "packages/react/test/test_react.ml",
"content": "let test title fn = Alcotest.test_case title `Quick fn\nlet assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\nlet assert_int left right = Alcotest.check Alcotest.int \"should be equal\" right left\n\nlet use_state_doesnt_fire () =\n let app =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n let state, setState = React.useState (fun () -> \"foo\") in\n (* You wouldn't have this code in prod, but just for testing purposes *)\n setState (fun _prev -> \"bar\");\n React.createElement \"div\" [] [ React.string state ] )\n in\n assert_string (ReactDOM.renderToStaticMarkup app) \"
foo
\"\n\nlet use_sync_external_store_with_server () =\n let app =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n let value =\n React.useSyncExternalStoreWithServer\n ~getServerSnapshot:(fun () -> \"foo\")\n ~subscribe:(fun _ () -> ())\n ~getSnapshot:(fun _ -> \"bar\")\n in\n React.createElement \"div\" [] [ React.string value ] )\n in\n assert_string (ReactDOM.renderToStaticMarkup app) \"
\"\n\nmodule Gap = struct\n let make ~children =\n React.Children.map children (fun element ->\n if element = React.null then React.null\n else React.createElement \"div\" [ React.JSX.String (\"class\", \"className\", \"divider\") ] [ element ])\nend\n\nlet children_map_one_element () =\n let app = React.Upper_case_component (\"app\", fun () -> Gap.make ~children:(React.string \"foo\")) in\n assert_string (ReactDOM.renderToStaticMarkup app) \"
\"\n\nlet use_ref_works () =\n let app =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n let isLive = React.useRef true in\n React.useEffect0 (fun () ->\n isLive.current <- false;\n None);\n React.createElement \"span\" [] [ React.string (string_of_bool isLive.current) ] )\n in\n assert_string (ReactDOM.renderToStaticMarkup app) \"true\"\n\nlet invalid_children () =\n let raises () =\n let _ = React.createElement \"input\" [ React.JSX.String (\"type\", \"type\", \"text\") ] [ React.string \"Hellow\" ] in\n ()\n in\n Alcotest.check_raises \"Expected invalid argument\"\n (React.Invalid_children {|\"input\" is a self-closing tag and must not have \"children\".\\n|})\n raises\n\nlet invalid_dangerouslySetInnerHtml () =\n let raises () =\n let _ =\n React.createElement \"meta\"\n [ React.JSX.String (\"char-set\", \"charSet\", \"utf-8\"); React.JSX.DangerouslyInnerHtml \"Hellow\" ]\n []\n in\n ()\n in\n Alcotest.check_raises \"Expected invalid argument\"\n (React.Invalid_children {|\"meta\" is a self-closing tag and must not have \"dangerouslySetInnerHTML\".\\n|})\n raises\n\nlet raw_element () =\n let original = React.createElement \"div\" [] [ React.string \"Hello\" ] in\n let app = React.Upper_case_component (\"app\", fun () -> React.Static { prerendered = \"
Hello
\"; original }) in\n assert_string (ReactDOM.renderToStaticMarkup app) \"
Hello
\"\n\nlet cache_hits_within_request () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n calls := !calls + 1;\n value ^ \"-ok\")\n in\n React.Cache.with_request_cache (fun () ->\n assert_string (cached \"a\") \"a-ok\";\n assert_string (cached \"a\") \"a-ok\");\n assert_int !calls 1\n\nlet cache_error_is_cached () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n calls := !calls + 1;\n if value = \"boom\" then raise (Failure \"boom\");\n \"ok\")\n in\n let raises () =\n let _ = cached \"boom\" in\n ()\n in\n React.Cache.with_request_cache (fun () ->\n Alcotest.check_raises \"cache error\" (Failure \"boom\") raises;\n Alcotest.check_raises \"cache error\" (Failure \"boom\") raises);\n assert_int !calls 1\n\nlet cache_separate_per_call () =\n let calls = ref 0 in\n let make_cached () =\n React.cache (fun value ->\n calls := !calls + 1;\n value + 1)\n in\n let cached1 = make_cached () in\n let cached2 = make_cached () in\n React.Cache.with_request_cache (fun () ->\n ignore (cached1 1);\n ignore (cached1 1);\n ignore (cached2 1));\n assert_int !calls 2\n\nlet cache_resets_between_requests () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n calls := !calls + 1;\n value)\n in\n React.Cache.with_request_cache (fun () ->\n ignore (cached \"a\");\n ignore (cached \"a\"));\n React.Cache.with_request_cache (fun () -> ignore (cached \"a\"));\n assert_int !calls 2\n\nlet cache_error_different_args () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n calls := !calls + 1;\n if value = \"boom1\" then raise (Failure \"boom1\");\n if value = \"boom2\" then raise (Failure \"boom2\");\n \"ok\")\n in\n let raises1 () = ignore (cached \"boom1\") in\n let raises2 () = ignore (cached \"boom2\") in\n React.Cache.with_request_cache (fun () ->\n Alcotest.check_raises \"first error\" (Failure \"boom1\") raises1;\n Alcotest.check_raises \"second error\" (Failure \"boom2\") raises2;\n Alcotest.check_raises \"first error cached\" (Failure \"boom1\") raises1;\n Alcotest.check_raises \"second error cached\" (Failure \"boom2\") raises2);\n assert_int !calls 2\n\nlet cache_error_mixed_with_success () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n calls := !calls + 1;\n if value = \"boom\" then raise (Failure \"boom\");\n value ^ \"-ok\")\n in\n let raises () = ignore (cached \"boom\") in\n React.Cache.with_request_cache (fun () ->\n assert_string (cached \"good\") \"good-ok\";\n Alcotest.check_raises \"error\" (Failure \"boom\") raises;\n assert_string (cached \"good\") \"good-ok\";\n Alcotest.check_raises \"error cached\" (Failure \"boom\") raises);\n assert_int !calls 2\n\nlet cache_error_resets_between_requests () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n calls := !calls + 1;\n if value = \"boom\" then raise (Failure \"boom\");\n \"ok\")\n in\n let raises () = ignore (cached \"boom\") in\n React.Cache.with_request_cache (fun () ->\n Alcotest.check_raises \"first request error\" (Failure \"boom\") raises;\n Alcotest.check_raises \"first request error cached\" (Failure \"boom\") raises);\n React.Cache.with_request_cache (fun () -> Alcotest.check_raises \"second request error\" (Failure \"boom\") raises);\n assert_int !calls 2\n\nlet cache_error_same_instance () =\n let original_exn = Failure \"unique\" in\n let cached_exn = ref None in\n let cached = React.cache (fun () -> raise original_exn) in\n let capture_exn () = try ignore (cached ()) with exn -> cached_exn := Some exn in\n React.Cache.with_request_cache (fun () ->\n capture_exn ();\n let first = !cached_exn in\n cached_exn := None;\n capture_exn ();\n let second = !cached_exn in\n match (first, second) with\n | Some e1, Some e2 ->\n Alcotest.(check bool) \"same exception instance\" true (e1 == e2);\n Alcotest.(check bool) \"is original exception\" true (e1 == original_exn)\n | _ -> Alcotest.fail \"expected exceptions to be captured\")\n\nlet lwt_test title fn = Alcotest.test_case title `Quick (fun () -> Lwt_main.run (fn ()))\n\nlet cache_async_hits_within_request () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n incr calls;\n value ^ \"-ok\")\n in\n React.Cache.with_request_cache_async (fun () ->\n assert_string (cached \"a\") \"a-ok\";\n let%lwt () = Lwt.pause () in\n assert_string (cached \"a\") \"a-ok\";\n Lwt.return ());%lwt\n assert_int !calls 1;\n Lwt.return ()\n\nlet cache_async_resets_between_requests () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n incr calls;\n value)\n in\n React.Cache.with_request_cache_async (fun () ->\n ignore (cached \"a\");\n ignore (cached \"a\");\n Lwt.return ());%lwt\n React.Cache.with_request_cache_async (fun () ->\n ignore (cached \"a\");\n Lwt.return ());%lwt\n assert_int !calls 2;\n Lwt.return ()\n\nlet cache_async_concurrent_isolation () =\n let calls = ref 0 in\n let cached =\n React.cache (fun value ->\n incr calls;\n value ^ \"-ok\")\n in\n let p1 =\n React.Cache.with_request_cache_async (fun () ->\n assert_string (cached \"a\") \"a-ok\";\n (* Yield to scheduler — lets p2 run and install its own cache *)\n let%lwt () = Lwt.pause () in\n (* Must still hit p1's cache, not p2's *)\n assert_string (cached \"a\") \"a-ok\";\n Lwt.return ())\n in\n let p2 =\n React.Cache.with_request_cache_async (fun () ->\n (* Independent cache — fresh call even though p1 already cached \"a\" *)\n assert_string (cached \"a\") \"a-ok\";\n Lwt.return ())\n in\n Lwt.join [ p1; p2 ];%lwt\n (* 2 calls total: one per request, each caching \"a\" independently *)\n assert_int !calls 2;\n Lwt.return ()\n\nlet cache_async_no_cross_request_leaking () =\n let cached = React.cache (fun value -> value ^ \"-ok\") in\n let seen_in_p2 = ref \"\" in\n let p1 =\n React.Cache.with_request_cache_async (fun () ->\n ignore (cached \"from-p1\");\n let%lwt () = Lwt.pause () in\n Lwt.return ())\n in\n let p2 =\n React.Cache.with_request_cache_async (fun () ->\n (* p2 should compute its own value, not see p1's cached result *)\n seen_in_p2 := cached \"from-p2\";\n Lwt.return ())\n in\n Lwt.join [ p1; p2 ];%lwt\n assert_string !seen_in_p2 \"from-p2-ok\";\n Lwt.return ()\n\nlet tests =\n ( \"React\",\n [\n test \"useState\" use_state_doesnt_fire;\n test \"useSyncExternalStoreWithServer\" use_sync_external_store_with_server;\n test \"useEffect\" use_effect_doesnt_fire;\n test \"Children.map\" children_map_one_element;\n test \"Children.map\" children_map_list_element;\n test \"useRef\" use_ref_works;\n test \"invalid_children\" invalid_children;\n test \"invalid_dangerouslySetInnerHtml\" invalid_dangerouslySetInnerHtml;\n test \"raw_element\" raw_element;\n test \"cache hits within request\" cache_hits_within_request;\n test \"cache errors are cached\" cache_error_is_cached;\n test \"cache is separate per call\" cache_separate_per_call;\n test \"cache resets between requests\" cache_resets_between_requests;\n test \"cache errors different args\" cache_error_different_args;\n test \"cache errors mixed with success\" cache_error_mixed_with_success;\n test \"cache errors reset between requests\" cache_error_resets_between_requests;\n test \"cache errors same instance\" cache_error_same_instance;\n lwt_test \"cache async hits within request\" cache_async_hits_within_request;\n lwt_test \"cache async resets between requests\" cache_async_resets_between_requests;\n lwt_test \"cache async concurrent isolation\" cache_async_concurrent_isolation;\n lwt_test \"cache async no cross-request leaking\" cache_async_no_cross_request_leaking;\n ] )\n"
},
{
"path": "packages/react-server-dom-esbuild/ReactServerDOMEsbuild.js",
"content": "/*\n * This file is a bundler integration between react (react-client/flight), esbuild and server-reason-react.\n *\n * React's Flight client (`react-client/flight`) is a factory function that accepts a `$$$config`\n * object with bundler-specific implementations. Each official React integration (webpack, parcel, etc.)\n * provides its own config. This file is the esbuild-specific config for server-reason-react.\n *\n * The `$$$config` object is composed from three groups of options plus renderer metadata:\n * 1. **Stream config** — how to decode binary chunks from the RSC stream into strings.\n * 2. **Console config** — how to replay server-side console logs on the client (dev only).\n * 3. **Bundler config** — how to resolve and load client/server modules at runtime.\n * 4. **Renderer metadata** — version and package name for React DevTools integration.\n *\n * Similar resources:\n * - **react-server-dom-webpack**: https://github.com/facebook/react/blob/5c56b873efb300b4d1afc4ba6f16acf17e4e5800/packages/react-server-dom-webpack/src/ReactFlightWebpackPlugin.js#L156-L194\n * - **react-server-dom-parcel**: https://github.com/facebook/react/pull/31725\n *\n * ## Why `@pedrobslisboa/react-client`?\n *\n * React's `react-client` package (which provides the Flight protocol deserializer)\n * is an internal package that is NOT published to npm by the React team.\n * It is only consumed internally by React's own bundler integrations (webpack, parcel, esm).\n *\n * Since server-reason-react needs a custom esbuild integration, and `react-client`\n * is the intended extension point (via the `$$$config` injection pattern), Pedro\n * (a core contributor to server-reason-react) republished the package under\n * `@pedrobslisboa/react-client` so this project can use the Flight client factory directly.\n */\n\nimport ReactClientFlight from \"@pedrobslisboa/react-client/flight\";\n\nconst isDebug = false;\n\nconst debug = (...args) => {\n if (isDebug && process.env.NODE_ENV === \"development\") {\n console.log(...args);\n }\n};\n\n/*\n * Stream config — tells the Flight client how to decode binary chunks into strings.\n *\n * These three functions are called during `processBinaryChunk` to turn raw\n * `Uint8Array` buffers from the ReadableStream into string content that the\n * Flight protocol parser can process.\n */\nconst ReactFlightClientStreamConfigWeb = {\n /*\n * Creates a TextDecoder instance used for all subsequent string decoding.\n * Stored as `response._stringDecoder` on the Flight response object.\n */\n createStringDecoder() {\n return new TextDecoder();\n },\n\n /*\n * Decodes a partial binary chunk in streaming mode (`{ stream: true }`).\n * Called for every buffer segment except the last one in a row.\n * The `stream: true` option prevents the decoder from flushing incomplete\n * multi-byte characters, allowing them to be completed by subsequent chunks.\n */\n readPartialStringChunk(decoder, buffer) {\n return decoder.decode(buffer, { stream: true });\n },\n\n /*\n * Decodes the final binary chunk of a row (without `stream: true`).\n * This flushes any remaining bytes in the decoder's internal buffer.\n */\n readFinalStringChunk(decoder, buffer) {\n return decoder.decode(buffer);\n },\n};\n\nconst badgeFormat = \"%c%s%c \";\n\n// Same badge styling as DevTools.\nconst badgeStyle =\n // We use a fixed background if light-dark is not supported, otherwise\n // we use a transparent background.\n \"background: #e6e6e6;\" +\n \"background: light-dark(rgba(0,0,0,0.1), rgba(255,255,255,0.25));\" +\n \"color: #000000;\" +\n \"color: light-dark(#000000, #ffffff);\" +\n \"border-radius: 2px\";\n\nconst resetStyle = \"\";\nconst pad = \" \";\n\nconst bind = Function.prototype.bind;\n\n/*\n * Console config — tells the Flight client how to replay server-side console\n * logs on the client with a badge indicating the server environment.\n *\n * In production builds, `bindToConsole` is extracted from the config but\n * never actually called (dead code). In development, it is called for each\n * replayed server console message with the method name, args, and environment\n * badge name.\n */\nconst ReactClientConsoleConfigBrowser = {\n /*\n * Wraps a console method call with badge formatting so that replayed\n * server logs appear with a visual tag (e.g., \"[Server]\") in the browser console.\n *\n * @param methodName - The console method (e.g., \"log\", \"warn\", \"error\", \"assert\")\n * @param args - The original arguments passed to the console method on the server\n * @param badgeName - The environment name to display as a badge (e.g., \"Server\")\n * @returns A bound console function ready to be called\n */\n bindToConsole(methodName, args, badgeName) {\n let offset = 0;\n switch (methodName) {\n case \"dir\":\n case \"dirxml\":\n case \"groupEnd\":\n case \"table\": {\n // These methods cannot be colorized because they don't take a formatting string.\n return bind.apply(console[methodName], [console].concat(args));\n }\n case \"assert\": {\n // assert takes formatting options as the second argument.\n offset = 1;\n }\n }\n\n const newArgs = args.slice(0);\n if (typeof newArgs[offset] === \"string\") {\n newArgs.splice(\n offset,\n 1,\n badgeFormat + newArgs[offset],\n badgeStyle,\n pad + badgeName + pad,\n resetStyle\n );\n } else {\n newArgs.splice(\n offset,\n 0,\n badgeFormat,\n badgeStyle,\n pad + badgeName + pad,\n resetStyle\n );\n }\n\n // The \"this\" binding in the \"bind\";\n newArgs.unshift(console);\n\n return bind.apply(console[methodName], newArgs);\n },\n};\n\n/* Indices into the metadata tuple returned by the RSC stream for client component references. */\nconst ID = 0;\nconst NAME = 1;\nconst BUNDLES = 2;\n\n/*\n * Bundler config — tells the Flight client how to resolve and load modules.\n *\n * These functions bridge between the abstract module references in the RSC\n * stream and the actual runtime modules available in the browser. In the\n * esbuild integration, client components and server functions are registered\n * in global manifest maps (`window.__client_manifest_map` and\n * `window.__server_functions_manifest_map`) by the esbuild build plugin.\n */\nconst ReactFlightClientConfigBundlerEsbuild = {\n /*\n * Called when the Flight client encounters a client module reference in the stream.\n * Allows the integration to initiate loading of scripts/stylesheets needed by the module.\n *\n * In the esbuild integration this is a no-op because all client bundles are\n * already loaded via script tags — there's no dynamic chunk loading.\n *\n * @param moduleLoading - The `moduleLoading` config passed to `createResponse` (null for esbuild)\n * @param nonce - CSP nonce for script injection (undefined for esbuild)\n * @param metadata - The parsed module metadata from the RSC stream\n */\n prepareDestinationForModule(moduleLoading, nonce, metadata) {\n debug(\"prepareDestinationForModule\", moduleLoading, nonce, metadata);\n return;\n },\n\n /*\n * Called to resolve a client component reference from the RSC stream into\n * a bundler-specific reference object. The returned object is later passed\n * to `preloadModule` and `requireModule`.\n *\n * In the esbuild integration, metadata comes as a tuple [id, name, bundles]\n * and we restructure it into a typed object.\n *\n * @param bundlerConfig - The `bundlerConfig` passed to `createResponse` (null for esbuild)\n * @param metadata - The serialized module reference from the RSC stream [id, name, bundles]\n * @returns An object with { type, id, name, bundles } used by `requireModule`\n */\n resolveClientReference(bundlerConfig, metadata) {\n debug(\"resolveClientReference\", bundlerConfig, metadata);\n // Reference is already resolved during the build\n return {\n type: \"ClientComponent\",\n id: metadata[ID],\n name: metadata[NAME],\n bundles: metadata[BUNDLES],\n };\n },\n\n /*\n * Called to resolve a server function reference from the RSC stream.\n * Only called when `serverReferenceConfig` (second arg to `createResponse`)\n * is truthy. When falsy, server references fall back to `createBoundServerReference`\n * which uses `callServer` directly.\n *\n * @param bundlerConfig - The `serverReferenceConfig` passed to `createResponse` ({} for esbuild)\n * @param ref - The server reference ID string from the RSC stream\n * @returns An object with { type, id } used by `requireModule`\n */\n resolveServerReference(bundlerConfig, ref) {\n debug(\"resolveServerReference\", bundlerConfig, ref);\n\n return {\n type: \"ServerFunction\",\n id: ref,\n };\n },\n\n /*\n * Called to optionally preload a module before it's required. Should return\n * a thenable/promise if async loading is needed, or a falsy value if the\n * module is already available synchronously.\n *\n * In the esbuild integration this always returns undefined because all modules\n * are pre-loaded via the global manifest maps.\n *\n * @param metadata - The resolved reference from `resolveClientReference` or `resolveServerReference`\n * @returns undefined (no preloading needed)\n */\n preloadModule(metadata) {\n debug(\"preloadModule\", metadata);\n /* TODO: Does it make sense to preload a module in esbuild? */\n return undefined;\n },\n\n /*\n * Called to synchronously obtain the actual module export (component or function).\n * This is the final step — the returned value is what React will render or invoke.\n *\n * Looks up modules from two global manifest maps populated by the esbuild build plugin:\n * - `window.__client_manifest_map` — maps client component IDs to their React components\n * - `window.__server_functions_manifest_map` — maps server function IDs to their callable functions\n *\n * @param metadata - The resolved reference with { type, id } from resolve*Reference\n * @returns The actual React component or server function\n * @throws If the module is not found in the manifest\n */\n requireModule(metadata) {\n const getModule = (type, id) => {\n switch (type) {\n case \"ServerFunction\":\n const fn = window.__server_functions_manifest_map[id];\n\n return fn;\n case \"ClientComponent\":\n const component = window.__client_manifest_map[id];\n\n return component\n }\n }\n\n const module = getModule(metadata.type, metadata.id);\n if (!module) {\n throw new Error(`Could not find module of type ${metadata.type} with id: ${metadata.id}`);\n }\n\n return module\n },\n};\n\n/*\n * The assembled config object passed to `ReactClientFlight($$$config)`.\n *\n * Combines all three config groups plus renderer metadata. The Flight client\n * destructures this to extract each function/value at module initialization time.\n *\n * TODO: Can we use the real thing, instead of mocks/vendored code here?\n */\nconst ReactServerDOMEsbuildConfig = {\n ...ReactFlightClientStreamConfigWeb,\n ...ReactClientConsoleConfigBrowser,\n ...ReactFlightClientConfigBundlerEsbuild,\n\n /* Reported to React DevTools via `__REACT_DEVTOOLS_GLOBAL_HOOK__` for identification. */\n rendererVersion: \"19.1.0\",\n\n /* Reported to React DevTools via `__REACT_DEVTOOLS_GLOBAL_HOOK__` for identification. */\n rendererPackageName: \"react-server-dom-esbuild\",\n\n /*\n * Indicates this Flight client is used with SSR. Currently extracted from the config\n * but NOT read by the `react-client/flight` internals — it has no runtime effect.\n * May be a forward-looking property for future React versions.\n */\n usedWithSSR: true,\n};\n\n/*\n * Initialize the Flight client with our esbuild-specific config.\n * This returns an object with the core Flight protocol functions.\n */\nconst {\n /* Creates a new Flight response object that accumulates streamed RSC data. */\n createResponse,\n /* Creates a reference to a server function that can be called from the client. */\n createServerReference: createServerReferenceImpl,\n /* Serializes a value (e.g., server action arguments) into a format suitable for sending to the server. */\n processReply,\n /* Returns the root promise of a Flight response — resolves to the React element tree. */\n getRoot,\n /* Reports a top-level error to all pending chunks in the response. */\n reportGlobalError,\n /* Processes a binary chunk from the ReadableStream into the Flight response. */\n processBinaryChunk,\n /* Creates a stream state object used to track binary chunk processing. */\n createStreamState,\n /* Signals that the stream is complete and no more chunks will arrive. */\n close,\n} = ReactClientFlight(ReactServerDOMEsbuildConfig);\n\n/*\n * Reads from a ReadableStream and feeds binary chunks into the Flight response.\n * Continues reading until the stream is done, then closes the response.\n */\nfunction startReadingFromStream(response, stream) {\n const streamState = createStreamState();\n const reader = stream.getReader();\n function progress({\n done,\n value,\n }) {\n if (done) {\n close(response);\n return;\n }\n const buffer = value;\n processBinaryChunk(response, streamState, buffer);\n return reader.read().then(progress).catch(error);\n }\n function error(e) {\n reportGlobalError(response, e);\n }\n reader.read().then(progress).catch(error);\n}\n\n/*\n * Wraps `callServer` to provide a helpful error if no callback was registered.\n * The returned function is passed as the `callServer` parameter to `createResponse`.\n */\nfunction callCurrentServerCallback(callServer) {\n return function (id, args) {\n if (!callServer) {\n throw new Error(\n \"No server callback has been registered. Call setServerCallback to register one.\"\n );\n }\n return callServer(id, args);\n };\n}\n\n/*\n * Public API: Creates a Flight response from a ReadableStream.\n * Returns a thenable that resolves to the deserialized React element tree.\n *\n * @param stream - A ReadableStream containing the RSC payload\n * @param options - Optional config: { callServer, temporaryReferences }\n */\nexport function createFromReadableStream(stream, options) {\n const response = createResponseFromOptions(options);\n startReadingFromStream(response, stream);\n return getRoot(response);\n}\n\n/*\n * Internal helper to create a Flight response object from user-provided options.\n *\n * Maps the public API options to the internal `createResponse` parameters.\n *\n * Parameters to `createResponse`:\n * 1. bundlerConfig — null: client references are pre-resolved at build time by esbuild\n * 2. serverReferenceConfig — {}: truthy but empty, forces the `resolveServerReference` code path\n * (when null/falsy, server refs fall back to `createBoundServerReference` using only `callServer`)\n * 3. moduleLoading — null: no dynamic module loading config needed (scripts are pre-loaded)\n * 4. callServer — callback invoked when a server action is called from the client\n * 5. encodeFormAction — undefined: no custom form action encoding (uses default)\n * 6. nonce — undefined: no CSP nonce needed for script injection\n * 7. temporaryReferences — allows objects to be passed by reference between server/client\n * 8. findSourceMapURL — undefined: no source map resolution (DEV only)\n * 9. replayConsoleLogs — false: server console log replay is disabled\n * 10. environmentName — undefined: no custom environment badge name (DEV only, defaults to \"Server\")\n */\nfunction createResponseFromOptions(options) {\n let response = createResponse(\n null, // bundlerConfig\n {}, // serverReferenceConfig, this is the manifest that can contain configs related to server functions. It requires it to not be null, to run resolveServerReference\n null, // moduleLoading\n callCurrentServerCallback(options ? options.callServer : undefined),\n undefined, // encodeFormAction\n undefined, // nonce\n options && options.temporaryReferences\n ? options.temporaryReferences\n : undefined,\n undefined, // TODO: findSourceMapUrl\n false /* __DEV__ ? (options ? options.replayConsoleLogs !== false : true) */,\n undefined /* __DEV__ && options && options.environmentName\n ? options.environmentName\n : undefined */\n );\n\n return response;\n}\n\n/*\n * Public API: Creates a Flight response from a fetch() promise.\n * Waits for the fetch to resolve, then reads the response body as a stream.\n *\n * @param promise - A Promise (e.g., from `fetch(\"/rsc\")`)\n * @param options - Optional config: { callServer, temporaryReferences }\n */\nexport function createFromFetch(promise, options) {\n const response = createResponseFromOptions(options);\n promise.then(\n function (r) {\n startReadingFromStream(response, r.body);\n },\n function (e) {\n reportGlobalError(response, e);\n }\n );\n return getRoot(response);\n}\n\n/*\n * Public API: Re-export of `createServerReference` from the Flight client.\n * Creates a callable reference to a server function identified by its ID.\n */\nexport const createServerReference = createServerReferenceImpl;\n\n/*\n * Public API: Serializes a value into a format the server can decode.\n * Used to encode arguments when calling server actions.\n *\n * @param value - The value to serialize (can include React elements, FormData, etc.)\n * @param options.temporaryReferences - Optional map for temporary references\n * @param options.signal - Optional AbortSignal to cancel the encoding\n * @returns A Promise that resolves to the serialized form (string or FormData)\n */\nexport const encodeReply = (\n value,\n options = { temporaryReferences: undefined, signal: undefined }\n) => {\n return new Promise((resolve, reject) => {\n const abort = processReply(\n value,\n \"\",\n options && options.temporaryReferences\n ? options.temporaryReferences\n : undefined,\n resolve,\n reject\n );\n if (options && options.signal) {\n const signal = options.signal;\n if (signal.aborted) {\n abort(signal.reason);\n } else {\n const listener = () => {\n abort(signal.reason);\n signal.removeEventListener(\"abort\", listener);\n };\n signal.addEventListener(\"abort\", listener);\n }\n }\n });\n};\n"
},
{
"path": "packages/react-server-dom-esbuild/ReactServerDOMEsbuild.re",
"content": "type arg;\ntype callServer = (string, list(arg)) => Js.Promise.t(React.element);\n\ntype options = {callServer};\n\n[@mel.module \"./ReactServerDOMEsbuild.js\"]\nexternal createFromReadableStreamImpl:\n (Webapi.ReadableStream.t, ~options: options=?, unit) => Js.Promise.t('a) =\n \"createFromReadableStream\";\n\n[@mel.module \"./ReactServerDOMEsbuild.js\"]\nexternal createFromFetchImpl:\n (Js.Promise.t(Fetch.response), ~options: options=?, unit) =>\n Js.Promise.t('a) =\n \"createFromFetch\";\n\n[@mel.module \"./ReactServerDOMEsbuild.js\"]\nexternal createServerReferenceImpl:\n (\n string, // ServerReferenceId\n callServer,\n // EncodeFormActionCallback (optional) (We're not using this right now)\n option('encodeFormActionCallback),\n // FindSourceMapURLCallback (optional, DEV-only) (We're not using this right now)\n option('findSourceMapURLCallback),\n // functionName (optional)\n option(string)\n ) =>\n // actionCallback is a function that takes N arguments and returns a promise\n // As we don't have control over the number of arguments, we need to pass it as 'actionCallback\n 'action =\n \"createServerReference\";\n\n[@mel.module \"./ReactServerDOMEsbuild.js\"]\nexternal encodeReply: list('arg) => Js.Promise.t(string) = \"encodeReply\";\n\n/* let callServerRef: ref(option(callServer('arg, 'result))) = ref(None); */\nlet callServerRef: ref(option(callServer)) = ref(None);\nlet setCallServer = callServer => {\n callServerRef := Some(callServer);\n};\nlet getCallServer = () => {\n callServerRef^;\n};\n\nlet createFromReadableStream = (~callServer=?, stream): Js.Promise.t('a) => {\n switch (callServer) {\n | Some(callServer) =>\n setCallServer(callServer);\n createFromReadableStreamImpl(\n stream,\n ~options={ callServer: callServer },\n (),\n );\n | None => createFromReadableStreamImpl(stream, ())\n };\n};\n\nlet createFromFetch = (~callServer=?, promise) => {\n switch (callServer) {\n | Some(callServer) =>\n setCallServer(callServer);\n createFromFetchImpl(promise, ~options={ callServer: callServer }, ());\n | None => createFromFetchImpl(promise, ())\n };\n};\n\nlet createServerReference = serverReferenceId => {\n let callServer =\n switch (getCallServer()) {\n | Some(callServer) => callServer\n | None =>\n raise(\n Invalid_argument(\n \"No callServer has been set, you are trying to create a server function without passing callServer to createFromFetch or createFromReadableStream\",\n ),\n )\n };\n createServerReferenceImpl(serverReferenceId, callServer, None, None, None);\n};\n"
},
{
"path": "packages/react-server-dom-esbuild/dune",
"content": "(library\n (name ReactServerDOMEsbuild)\n (modules ReactServerDOMEsbuild)\n (modes melange)\n (public_name server-reason-react.react-server-dom-esbuild)\n (libraries reason-react melange-webapi melange-fetch)\n (melange.runtime_deps ReactServerDOMEsbuild.js)\n (preprocess\n (pps melange.ppx)))\n"
},
{
"path": "packages/react-server-dom-esbuild/package.json",
"content": "{\n \"name\": \"server-reason-react-server-dom-esbuild\",\n \"description\": \"React Server DOM with esbuild. This is intended to be integrated with server-reason-react.\",\n \"version\": \"0.1.0\",\n \"exports\": {\n \".\": \"./ReactServerDOMEsbuild.js\"\n },\n \"homepage\": \"https://github.com/ml-in-barcelona/server-reason-react\",\n \"bugs\": \"https://github.com/ml-in-barcelona/server-reason-react/issues\",\n \"license\": \"MIT\",\n \"repository\": {\n \"type\": \"git\",\n \"url\": \"https://github.com/ml-in-barcelona/server-reason-react.git\",\n \"directory\": \"packages/react-server-dom-esbuild\"\n },\n \"dependencies\": {\n \"@pedrobslisboa/react-client\": \"^19.1.0\",\n \"esbuild\": \"^0.21.4\"\n }\n}\n"
},
{
"path": "packages/reactDom/src/Push_stream.ml",
"content": "let make () =\n let stream, push_to_stream = Lwt_stream.create () in\n let push v = push_to_stream (Some v) in\n let close () = push_to_stream None in\n (stream, push, close)\n\nlet subscribe ~fn stream = Lwt_stream.iter_s fn stream\n"
},
{
"path": "packages/reactDom/src/ReactDOM.ml",
"content": "module Style = ReactDOMStyle\nmodule Ref = React.Ref\n\ntype domRef = Ref.t\n\nlet is_react_custom_attribute attr =\n match attr with\n | \"dangerouslySetInnerHTML\" | \"ref\" | \"key\" | \"suppressContentEditableWarning\" | \"suppressHydrationWarning\" -> true\n | _ -> false\n\nlet write_attribute_to_buffer buf (attr : React.JSX.prop) =\n match attr with\n (* ignores \"ref\" prop *)\n | Ref _ -> ()\n (* react custom attributes are not rendered *)\n | Bool (name, _, _) when is_react_custom_attribute name -> ()\n (* false attributes don't get rendered *)\n | Bool (_name, _, false) -> ()\n (* true attributes render solely the attribute name *)\n | Bool (name, _, true) ->\n Buffer.add_char buf ' ';\n Buffer.add_string buf name\n | Action (_, _, _) -> ()\n | Style styles ->\n Buffer.add_string buf \" style=\\\"\";\n Style.write_to_buffer buf styles;\n Buffer.add_char buf '\"'\n | String (name, _, _value) when is_react_custom_attribute name -> ()\n | String (name, _, value) ->\n Buffer.add_char buf ' ';\n Buffer.add_string buf name;\n Buffer.add_string buf \"=\\\"\";\n Html.escape buf value;\n Buffer.add_char buf '\"'\n (* Events don't get rendered on SSR *)\n | Event _ -> ()\n (* Since we extracted the attribute as children, we are sure there's nothing to render here *)\n | DangerouslyInnerHtml _ -> ()\n\nlet write_attributes_and_extract_inner_html buf attrs =\n let inner_html = ref None in\n List.iter\n (fun (attr : React.JSX.prop) ->\n match attr with DangerouslyInnerHtml str -> inner_html := Some str | _ -> write_attribute_to_buffer buf attr)\n attrs;\n !inner_html\n\nlet attribute_to_html (attr : React.JSX.prop) =\n match attr with\n (* ignores \"ref\" prop *)\n | Ref _ -> Html.omitted ()\n (* react custom attributes are not rendered *)\n | Bool (name, _, _) when is_react_custom_attribute name -> Html.omitted ()\n (* false attributes don't get rendered *)\n | Bool (_name, _, false) -> Html.omitted ()\n (* true attributes render solely the attribute name *)\n | Bool (name, _, true) -> Html.present name\n | Action (_, _, _) -> Html.omitted ()\n | Style styles -> Html.attribute \"style\" (ReactDOMStyle.to_string styles)\n | String (name, _, _value) when is_react_custom_attribute name -> Html.omitted ()\n | String (name, _, value) -> Html.attribute name value\n (* Events don't get rendered on SSR *)\n | Event _ -> Html.omitted ()\n (* Since we extracted the attribute as children, we are sure there's nothing to render here *)\n | DangerouslyInnerHtml _ -> Html.omitted ()\n\nlet attributes_to_html attrs = List.map attribute_to_html attrs\n\nlet getDangerouslyInnerHtml attributes =\n List.find_map (function React.JSX.DangerouslyInnerHtml str -> Some str | _ -> None) attributes\n\nlet render_upper_case_component render_element component =\n let saved_ctx = !React.current_tree_context in\n React.reset_component_id_state saved_ctx;\n match component () with\n | result -> (\n let did_use_id = React.check_did_render_id_hook () in\n if did_use_id then React.current_tree_context := React.Tree_context.push saved_ctx ~total_children:1 ~index:0;\n match render_element result with\n | () -> React.current_tree_context := saved_ctx\n | exception exn ->\n React.current_tree_context := saved_ctx;\n raise exn)\n | exception exn ->\n React.current_tree_context := saved_ctx;\n raise exn\n\nlet render_children_list render_element list =\n match list with\n | [] -> ()\n | [ single ] -> render_element single\n | _ -> (\n let saved_ctx = !React.current_tree_context in\n match\n let total = List.length list in\n List.iteri\n (fun i el ->\n React.current_tree_context := React.Tree_context.push saved_ctx ~total_children:total ~index:i;\n render_element el)\n list\n with\n | () -> React.current_tree_context := saved_ctx\n | exception exn ->\n React.current_tree_context := saved_ctx;\n raise exn)\n\nlet render_children_array render_element arr =\n let total = Array.length arr in\n if total = 0 then ()\n else if total = 1 then render_element (Array.unsafe_get arr 0)\n else\n let saved_ctx = !React.current_tree_context in\n match\n for i = 0 to total - 1 do\n React.current_tree_context := React.Tree_context.push saved_ctx ~total_children:total ~index:i;\n render_element (Array.unsafe_get arr i)\n done\n with\n | () -> React.current_tree_context := saved_ctx\n | exception exn ->\n React.current_tree_context := saved_ctx;\n raise exn\n\nlet render_upper_case_component_lwt render_element component =\n let saved_ctx = !React.current_tree_context in\n React.reset_component_id_state saved_ctx;\n let result =\n try component ()\n with exn ->\n React.current_tree_context := saved_ctx;\n raise_notrace exn\n in\n let did_use_id = React.check_did_render_id_hook () in\n if did_use_id then React.current_tree_context := React.Tree_context.push saved_ctx ~total_children:1 ~index:0;\n try%lwt\n let%lwt () = render_element result in\n React.current_tree_context := saved_ctx;\n Lwt.return ()\n with exn ->\n React.current_tree_context := saved_ctx;\n raise exn\n\nlet render_children_list_lwt render_element list =\n match list with\n | [] -> Lwt.return ()\n | [ single ] -> render_element single\n | _ -> (\n let saved_ctx = !React.current_tree_context in\n try%lwt\n let total = List.length list in\n let%lwt () =\n Lwt_list.iteri_s\n (fun i el ->\n React.current_tree_context := React.Tree_context.push saved_ctx ~total_children:total ~index:i;\n render_element el)\n list\n in\n React.current_tree_context := saved_ctx;\n Lwt.return ()\n with exn ->\n React.current_tree_context := saved_ctx;\n raise exn)\n\nlet render_children_array_lwt render_element arr =\n let total = Array.length arr in\n if total = 0 then Lwt.return ()\n else if total = 1 then render_element (Array.unsafe_get arr 0)\n else\n let saved_ctx = !React.current_tree_context in\n let rec loop i =\n if i >= total then Lwt.return ()\n else (\n React.current_tree_context := React.Tree_context.push saved_ctx ~total_children:total ~index:i;\n let%lwt () = render_element (Array.unsafe_get arr i) in\n loop (i + 1))\n in\n try%lwt\n let%lwt () = loop 0 in\n React.current_tree_context := saved_ctx;\n Lwt.return ()\n with exn ->\n React.current_tree_context := saved_ctx;\n raise exn\n\ntype mode = String | Markup\n\nlet render_to_buffer ~mode buf element =\n let add_separator_between_text_nodes = mode = String in\n let previous_node_was_text = ref false in\n let should_add_doctype = ref true in\n\n let rec render_element ~buf element =\n match (element : React.element) with\n | Empty -> ()\n | Static { prerendered; _ } ->\n should_add_doctype := false;\n Buffer.add_string buf prerendered\n | Writer { emit; _ } ->\n should_add_doctype := false;\n emit buf\n | Client_component { import_module; _ } ->\n raise\n (Invalid_argument\n (\"Client components can't be rendered on the server via renderToString or renderToStaticMarkup. Please \\\n use the React server components API instead. module: \" ^ import_module))\n | Provider { children; push; _ } ->\n let pop = push () in\n render_element ~buf children;\n pop ()\n | Consumer children -> render_element ~buf children\n | Fragment children -> render_element ~buf children\n | List list -> render_children_list (render_element ~buf) list\n | Array arr -> render_children_array (render_element ~buf) arr\n | Upper_case_component (_, component) -> render_upper_case_component (render_element ~buf) component\n | Async_component (_name, _component) ->\n raise\n (Invalid_argument\n \"Async components can't be rendered to static markup, since rendering is synchronous. Please use \\\n `renderToStream` instead.\")\n | Lower_case_element { key; tag; attributes; children } -> render_lower_case ~buf ~key tag attributes children\n | Text text ->\n let is_previous_text_node = !previous_node_was_text in\n previous_node_was_text := true;\n if is_previous_text_node && add_separator_between_text_nodes then Buffer.add_string buf \"\";\n Html.escape buf text;\n should_add_doctype := false\n | Suspense { key = _; children; fallback } -> (\n let suspense_inner_buf = Buffer.create 128 in\n match render_element ~buf:suspense_inner_buf children with\n | () ->\n Buffer.add_string buf \"\";\n Buffer.add_buffer buf suspense_inner_buf;\n Buffer.add_string buf \"\"\n | exception _e ->\n Buffer.add_string buf \"\";\n render_element ~buf fallback;\n Buffer.add_string buf \"\")\n and render_lower_case ~buf ~key:_ tag attributes children =\n if Html.is_self_closing_tag tag then (\n should_add_doctype := false;\n if add_separator_between_text_nodes then previous_node_was_text := false;\n Buffer.add_char buf '<';\n Buffer.add_string buf tag;\n let _ = write_attributes_and_extract_inner_html buf attributes in\n Buffer.add_string buf \" />\")\n else\n let doctype = !should_add_doctype in\n should_add_doctype := false;\n if add_separator_between_text_nodes then previous_node_was_text := false;\n if tag = \"html\" && doctype then Buffer.add_string buf \"\";\n Buffer.add_char buf '<';\n Buffer.add_string buf tag;\n let inner_html = write_attributes_and_extract_inner_html buf attributes in\n Buffer.add_char buf '>';\n (match inner_html with\n | Some html -> Buffer.add_string buf html\n | None -> render_children_list (render_element ~buf) children);\n Buffer.add_string buf \"';\n if add_separator_between_text_nodes then previous_node_was_text := false\n in\n render_element ~buf element\n\nlet write_to_buffer buf element =\n let rec render ~buf element =\n match (element : React.element) with\n | Empty -> ()\n | Static { prerendered; _ } -> Buffer.add_string buf prerendered\n | Writer { emit; _ } -> emit buf\n | Client_component { import_module; _ } ->\n raise (Invalid_argument (\"Client components can't be rendered via write_to_buffer. module: \" ^ import_module))\n | Provider { children; push; _ } ->\n let pop = push () in\n render ~buf children;\n pop ()\n | Consumer children -> render ~buf children\n | Fragment children -> render ~buf children\n | List list -> render_children_list (render ~buf) list\n | Array arr -> render_children_array (render ~buf) arr\n | Upper_case_component (_, component) -> render_upper_case_component (render ~buf) component\n | Async_component (_name, _component) ->\n raise (Invalid_argument \"Async components can't be rendered synchronously via write_to_buffer.\")\n | Lower_case_element { key = _; tag; attributes; children } ->\n if Html.is_self_closing_tag tag then (\n Buffer.add_char buf '<';\n Buffer.add_string buf tag;\n let _ = write_attributes_and_extract_inner_html buf attributes in\n Buffer.add_string buf \" />\")\n else (\n Buffer.add_char buf '<';\n Buffer.add_string buf tag;\n let inner_html = write_attributes_and_extract_inner_html buf attributes in\n Buffer.add_char buf '>';\n (match inner_html with\n | Some html -> Buffer.add_string buf html\n | None -> render_children_list (render ~buf) children);\n Buffer.add_string buf \"')\n | Text text -> Html.escape buf text\n | Suspense { children; fallback; _ } -> (\n let suspense_inner_buf = Buffer.create 128 in\n match render ~buf:suspense_inner_buf children with\n | () -> Buffer.add_buffer buf suspense_inner_buf\n | exception _e -> render ~buf fallback)\n in\n render ~buf element\n\nlet escape_to_buffer = Html.escape\n\nlet renderToString ?identifier_prefix element =\n (* TODO: try catch to avoid React.use usages *)\n React.reset_id_rendering ?prefix:identifier_prefix ();\n let buf = Buffer.create 1024 in\n render_to_buffer ~mode:String buf element;\n Buffer.contents buf\n\nlet renderToStaticMarkup ?identifier_prefix element =\n (* TODO: try catch to avoid React.use usages *)\n React.reset_id_rendering ?prefix:identifier_prefix ();\n let buf = Buffer.create 1024 in\n render_to_buffer ~mode:Markup buf element;\n Buffer.contents buf\n\ntype stream_context = {\n push : string -> unit;\n close : unit -> unit;\n mutable closed : bool;\n mutable has_rc_script_been_injected : bool;\n mutable boundary_id : int;\n mutable suspense_id : int;\n mutable waiting : int;\n}\n\n(* https://github.com/facebook/react/blob/493f72b0a7111b601c16b8ad8bc2649d82c184a0/packages/react-dom-bindings/src/server/fizz-instruction-set/ReactDOMFizzInstructionSetShared.js#L46 *)\nlet complete_boundary_script =\n {|function $RC(a,b){a=document.getElementById(a);b=document.getElementById(b);b.parentNode.removeChild(b);if(a){a=a.previousSibling;var f=a.parentNode,c=a.nextSibling,e=0;do{if(c&&8===c.nodeType){var d=c.data;if(\"/$\"===d)if(0===e)break;else e--;else\"$\"!==d&&\"$?\"!==d&&\"$!\"!==d||e++}d=c.nextSibling;f.removeChild(c);c=d}while(c);for(;b.firstChild;)f.insertBefore(b.firstChild,c);a.data=\"$\";a._reactRetry&&a._reactRetry()}}|}\n\nlet write_inline_complete_boundary_script buf has_rc_script_been_injected boundary_id suspense_id =\n let rc_call = Printf.sprintf \"$RC('B:%i','S:%i')\" boundary_id suspense_id in\n if not has_rc_script_been_injected then (\n Buffer.add_string buf \"\")\n else (\n Buffer.add_string buf \"\")\n\nlet write_suspense_resolved_element buf ~id html =\n Buffer.add_string buf \"
\"\n\nlet hoisted_elements_order_issue () =\n (* This test demonstrates the ordering issue with hoisted elements.\n When multiple elements are hoisted (title, meta, link, scripts),\n their order in the final HTML may not match the order they were defined *)\n let app =\n html\n [\n body\n [\n (* These elements will be hoisted to head but their order might not be preserved *)\n React.createElement \"title\" [] [ React.string \"First Title\" ];\n React.createElement \"meta\"\n [\n React.JSX.String (\"name\", \"name\", \"description\");\n React.JSX.String (\"content\", \"content\", \"Page description\");\n ]\n [];\n link ~rel:\"stylesheet\" ~href:\"/first.css\" ();\n React.createElement \"title\" [] [ React.string \"Second Title\" ];\n (* Will override first *)\n React.createElement \"meta\"\n [ React.JSX.String (\"name\", \"name\", \"keywords\"); React.JSX.String (\"content\", \"content\", \"react, ssr\") ]\n [];\n link ~rel:\"stylesheet\" ~href:\"/second.css\" ();\n script ~async:true ~src:\"/first.js\" ();\n link ~rel:\"stylesheet\" ~precedence:\"high\" ~href:\"/third.css\" ();\n (* This is a resource *)\n script ~async:true ~src:\"/second.js\" ();\n React.createElement \"meta\"\n [ React.JSX.String (\"name\", \"name\", \"author\"); React.JSX.String (\"content\", \"content\", \"Developer\") ]\n [];\n div [] [ React.string \"Body content\" ];\n ];\n ]\n in\n assert_html app\n ~shell:\n \"First TitleSecond Title
\"\n\nlet html_attributes_are_preserved () =\n let app = html ~attributes:[ React.JSX.String (\"lang\", \"lang\", \"en\") ] [] in\n assert_html app\n ~shell:\n \"\"\n\nlet tests =\n [\n test \"doctype\" doctype;\n test \"just_an_html_node\" just_an_html_node;\n test \"no_head_no_body_nothing_just_an_html_node\" no_head_no_body_nothing_just_an_html_node;\n test \"html_with_no_srr_html_body\" html_with_no_srr_html_body;\n test \"html_with_a_node\" html_with_a_node;\n test \"html_inside_a_div\" html_inside_a_div;\n test \"html_inside_a_fragment\" html_inside_a_fragment;\n test \"head_with_content\" head_with_content;\n test \"html_with_only_a_body\" html_with_only_a_body;\n test \"html_with_head_like_elements_not_in_head\" html_with_head_like_elements_not_in_head;\n test \"html_without_body_and_bootstrap_scripts\" html_without_body_and_bootstrap_scripts;\n test \"html_with_body_and_bootstrap_scripts\" html_with_body_and_bootstrap_scripts;\n test \"input_and_bootstrap_scripts\" input_and_bootstrap_scripts;\n test \"title_and_meta_populates_to_the_head\" title_and_meta_populates_to_the_head;\n test \"async_scripts_to_head\" async_scripts_to_head;\n test \"no_async_scripts_to_remain\" no_async_scripts_to_remain;\n test \"async_scripts_gets_deduplicated\" async_scripts_gets_deduplicated;\n test \"async_scripts_gets_deduplicated_2\" async_scripts_gets_deduplicated_2;\n test \"link_with_rel_and_precedence\" link_with_rel_and_precedence;\n test \"links_gets_pushed_to_the_head\" links_gets_pushed_to_the_head;\n test \"self_closing_with_dangerously\" self_closing_with_dangerously;\n test \"self_closing_with_dangerously_in_head\" self_closing_with_dangerously_in_head;\n test \"upper_case_component_with_resources\" upper_case_component_with_resources;\n test \"hoisted_elements_order_issue\" hoisted_elements_order_issue;\n test \"head_reorders_children_by_priority\" head_reorders_children_by_priority;\n test \"html_attributes_are_preserved\" html_attributes_are_preserved;\n ]\n"
},
{
"path": "packages/reactDom/test/test_RSC_model.ml",
"content": "let yojson = Alcotest.testable Yojson.Safe.pretty_print ( = )\nlet check_json = Alcotest.check yojson \"should be equal\"\nlet assert_json left right = Alcotest.check yojson \"should be equal\" right left\n\nlet assert_list (type a) (ty : a Alcotest.testable) (left : a list) (right : a list) =\n Alcotest.check (Alcotest.list ty) \"should be equal\" right left\n\nlet assert_list_of_strings left right = Alcotest.check (Alcotest.list Alcotest.string) \"should be equal\" right left\n\nlet uuid_re =\n Str.regexp\n \"[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f]-[0-9a-f][0-9a-f][0-9a-f][0-9a-f]-[0-9a-f][0-9a-f][0-9a-f][0-9a-f]-[0-9a-f][0-9a-f][0-9a-f][0-9a-f]-[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f]\"\n\nlet replace_uuids s = Str.global_replace uuid_re \"\" s\n\nlet sleep ~ms =\n let%lwt () = Lwt_unix.sleep (Int.to_float ms /. 1000.0) in\n Lwt.return ()\n\nlet test title fn =\n let test_case _switch () =\n let start = Unix.gettimeofday () in\n let timeout =\n let%lwt () = sleep ~ms:20 in\n Alcotest.failf \"Test '%s' timed out\" title\n in\n let%lwt test_promise = Lwt.pick [ fn (); timeout ] in\n let epsilon = 0.001 in\n let duration = Unix.gettimeofday () -. start in\n if abs_float duration >= epsilon then\n Printf.printf \" \\027[1m\\027[33m[WARNING]\\027[0m Test '%s' took %.3f seconds\\n\" title duration\n else ();\n Lwt.return test_promise\n in\n (Printf.sprintf \"ReactServerDOM.render_model / %s\" title, [ Alcotest_lwt.test_case \"\" `Quick test_case ])\n\nlet mk_suspense ?key ?fallback ?children () = React.Suspense.make ?key (React.Suspense.makeProps ?fallback ?children ())\n\nlet mk_context context ~value ~children () =\n React.Context.provider context (React.Context.makeProps ~value ~children ())\n\nlet[@warning \"-27\"] skip title _fn =\n let test_case _switch () = Lwt.return () in\n (Printf.sprintf \"ReactServerDOM.render_model / %s\" title, [ Alcotest_lwt.test_case \"\" `Quick test_case ])\n\nlet assert_stream (stream : string Lwt_stream.t) expected =\n let%lwt content = Lwt_stream.to_list stream in\n if content = [] then Lwt.return @@ Alcotest.fail \"stream should not be empty\"\n else Lwt.return @@ assert_list_of_strings content expected\n\nlet capture_stream () =\n let output = ref [] in\n let subscribe chunk =\n output := !output @ [ chunk ];\n Lwt.return ()\n in\n (output, subscribe)\n\nlet drop_all_frames _ _ = false\nlet text ~children () = React.createElement \"span\" [] children\n\n(* ***** *)\n(* Tests *)\n(* ***** *)\n\nlet null_element () =\n let app = React.null in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:null\\n\" ];\n Lwt.return ()\n\nlet string_element () =\n let app = React.string \"hi\" in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:\\\"hi\\\"\\n\" ];\n Lwt.return ()\n\nlet lower_case_component () =\n let app = React.createElement \"div\" (ReactDOM.domProps ~className:\"foo\" ()) [] in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"className\\\":\\\"foo\\\"},null,null,1]\\n\" ];\n Lwt.return ()\n\nlet lower_case_with_children () =\n let app =\n React.createElement \"div\" []\n [ React.createElement \"span\" [] [ React.string \"Home\" ]; React.createElement \"span\" [] [ React.string \"Nohome\" ] ]\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"Home\\\"},null,null,1],[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"Nohome\\\"},null,null,1]]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet lower_case_component_nested () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.createElement \"div\" []\n [\n React.createElement \"section\" []\n [ React.createElement \"article\" [] [ React.string \"Deep Server Content\" ] ];\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[\\\"$\\\",\\\"section\\\",null,{\\\"children\\\":[\\\"$\\\",\\\"article\\\",null,{\\\"children\\\":\\\"Deep \\\n Server Content\\\"},null,null,1]},null,null,1]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet dangerouslySetInnerHtml () =\n let app =\n React.createElement \"script\"\n [\n React.JSX.String (\"type\", \"type\", \"application/javascript\"); React.JSX.DangerouslyInnerHtml \"console.log('Hi!')\";\n ]\n []\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"script\\\",null,{\\\"type\\\":\\\"application/javascript\\\",\\\"dangerouslySetInnerHTML\\\":{\\\"__html\\\":\\\"console.log('Hi!')\\\"}},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet upper_case_component () =\n let app codition =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n let text = if codition then \"foo\" else \"bar\" in\n React.createElement \"span\" [] [ React.string text ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app true) in\n assert_list_of_strings !output [ \"0:[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"foo\\\"},null,null,1]\\n\" ];\n Lwt.return ()\n\nlet nested_upper_case_components () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.Upper_case_component (\"Foo\", fun () -> React.Upper_case_component (\"Bar\", fun () -> React.string \"Bar\"))\n )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output [ \"0:\\\"Bar\\\"\\n\" ];\n Lwt.return ()\n\nlet upper_case_with_list () =\n let app () =\n React.Fragment\n (React.list\n [\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hi\" ]);\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hola\" ]);\n ])\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"0:[[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"hi\\\"},null,null,1],[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"hola\\\"},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet upper_case_with_children () =\n let layout ~children () = React.createElement \"div\" [] children in\n let app () =\n React.Upper_case_component\n ( \"Layout\",\n layout\n ~children:\n [\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hi\" ]);\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hola\" ]);\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"hi\\\"},null,null,1],[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"hola\\\"},null,null,1]]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_without_promise () =\n let app () =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:\n (React.createElement \"div\" []\n [\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hi\" ]);\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hola\" ]);\n ])\n ()\n in\n let main = React.Upper_case_component (\"App\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"hi\\\"},null,null,1],[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"hola\\\"},null,null,1]]},null,null,1]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_with_promise () =\n let app () =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:\n (React.Async_component\n ( \"suspense_with_promise\",\n fun () ->\n let%lwt () = Lwt.pause () in\n Lwt.return (React.string \"lol\") ))\n ()\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]\\n\";\n \"1:\\\"lol\\\"\\n\";\n ];\n Lwt.return ()\n\nlet suspense_with_error () =\n let app () =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:(React.Upper_case_component (__FUNCTION__, fun () -> raise (Failure \"lol\")))\n ()\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_with_error_in_async () =\n let app () =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:(React.Async_component (__FUNCTION__, fun () -> Lwt.fail (Failure \"lol\")))\n ()\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_with_error_under_lowercase () =\n let app () =\n React.createElement \"div\" []\n [\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:(React.Async_component (__FUNCTION__, fun () -> Lwt.fail (Failure \"lol\")))\n ();\n ]\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet error_without_suspense () =\n let app () = React.Upper_case_component (__FUNCTION__, fun () -> raise (Failure \"lol\")) in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [ \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\"; \"0:\\\"$L1\\\"\\n\" ];\n Lwt.return ()\n\nlet error_in_toplevel () =\n let app () = raise (Failure \"lol\") in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [ \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\"; \"0:\\\"$L1\\\"\\n\" ];\n Lwt.return ()\n\nlet error_in_toplevel_in_async () =\n let app () = Lwt.fail (Failure \"lol\") in\n let main = React.Async_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [ \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\"; \"0:\\\"$L1\\\"\\n\" ];\n Lwt.return ()\n\nlet await_tick ?(raise = false) ?(ms = 1) num =\n React.Async_component\n ( \"await_tick\",\n fun () ->\n let%lwt () = sleep ~ms in\n if raise then Lwt.fail (Failure \"lol\") else Lwt.return (React.string num) )\n\nlet suspense_in_a_list () =\n let fallback = React.string \"Loading...\" in\n let app () =\n React.Fragment\n (React.list\n [\n mk_suspense ~fallback ~children:(await_tick ~ms:1 \"A\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:2 \"B\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:3 \"C\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:4 \"D\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:5 \"E\") ();\n ])\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L2\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L3\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L4\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L5\\\"},null,null,1]]\\n\";\n \"1:\\\"A\\\"\\n\";\n \"2:\\\"B\\\"\\n\";\n \"3:\\\"C\\\"\\n\";\n \"4:\\\"D\\\"\\n\";\n \"5:\\\"E\\\"\\n\";\n ];\n Lwt.return ()\n\nlet suspense_in_a_list_with_error () =\n let fallback = React.string \"Loading...\" in\n let app () =\n React.Fragment\n (React.list\n [\n mk_suspense ~fallback ~children:(await_tick ~ms:1 \"A\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:2 ~raise:true \"B\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:3 \"C\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:4 \"D\") ();\n mk_suspense ~fallback ~children:(await_tick ~ms:5 \"E\") ();\n ])\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L2\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L3\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L4\\\"},null,null,1],[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L5\\\"},null,null,1]]\\n\";\n \"1:\\\"A\\\"\\n\";\n \"2:E{\\\"message\\\":\\\"Failure(\\\\\\\"lol\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"3:\\\"C\\\"\\n\";\n \"4:\\\"D\\\"\\n\";\n \"5:\\\"E\\\"\\n\";\n ];\n Lwt.return ()\n\nlet suspense_with_immediate_promise () =\n let resolved_component =\n React.Async_component\n ( __FUNCTION__,\n fun () ->\n let value = \"DONE :)\" in\n Lwt.return (React.string value) )\n in\n let app = mk_suspense ~fallback:(React.string \"Loading...\") ~children:resolved_component in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [ \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"DONE :)\\\"},null,null,1]\\n\" ];\n Lwt.return ()\n\nlet delayed_value value =\n let%lwt () = Lwt.pause () in\n Lwt.return value\n\nlet suspense () =\n let suspended_component =\n React.Async_component\n ( __FUNCTION__,\n fun () ->\n let%lwt value = delayed_value \"DONE :)\" in\n Lwt.return (React.string value) )\n in\n let app () = mk_suspense ~fallback:(React.string \"Loading...\") ~children:suspended_component () in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]\\n\";\n \"1:\\\"DONE :)\\\"\\n\";\n ];\n Lwt.return ()\n\nlet nested_suspense () =\n let deffered_component =\n React.Async_component\n ( __FUNCTION__,\n fun () ->\n let%lwt value = delayed_value \"DONE :)\" in\n Lwt.return (React.string value) )\n in\n let app () = mk_suspense ~fallback:(React.string \"Loading...\") ~children:deffered_component () in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]\\n\";\n \"1:\\\"DONE :)\\\"\\n\";\n ];\n Lwt.return ()\n\nlet async_component_without_suspense () =\n (* Because there's no Suspense. We await for the promise to resolve before rendering the component *)\n let app =\n React.Async_component\n ( __FUNCTION__,\n fun () ->\n let%lwt value = delayed_value \"DONE :)\" in\n Lwt.return (React.string value) )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:\\\"$L1\\\"\\n\"; \"1:\\\"DONE :)\\\"\\n\" ];\n Lwt.return ()\n\nlet async_component_without_suspense_immediate () =\n let app =\n React.Async_component\n ( __FUNCTION__,\n fun () ->\n let%lwt value = delayed_value \"DONE :)\" in\n Lwt.return (React.string value) )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:\\\"$L1\\\"\\n\"; \"1:\\\"DONE :)\\\"\\n\" ];\n Lwt.return ()\n\nlet client_without_props () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props = [];\n client = React.string \"Client without Props\";\n import_module = \"./client-without-props.js\";\n import_name = \"ClientWithoutProps\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-without-props.js\\\",[],\\\"ClientWithoutProps\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet client_with_json_props () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props =\n [\n (\"null\", React.Model.Json `Null);\n (\"string\", React.Model.Json (`String \"Title\"));\n (\"int\", React.Model.Json (`Int 1));\n (\"float\", React.Model.Json (`Float 1.1));\n (\"bool true\", React.Model.Json (`Bool true));\n (\"bool false\", React.Model.Json (`Bool false));\n (\"string list\", React.Model.Json (`List [ `String \"Item 1\"; `String \"Item 2\" ]));\n (\"object\", React.Model.Json (`Assoc [ (\"name\", `String \"John\"); (\"age\", `Int 30) ]));\n ];\n client = React.string \"Client with Props\";\n import_module = \"./client-with-props.js\";\n import_name = \"ClientWithProps\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-with-props.js\\\",[],\\\"ClientWithProps\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server \\\n Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{\\\"null\\\":null,\\\"string\\\":\\\"Title\\\",\\\"int\\\":1,\\\"float\\\":1.1,\\\"bool \\\n true\\\":true,\\\"bool false\\\":false,\\\"string list\\\":[\\\"Item 1\\\",\\\"Item \\\n 2\\\"],\\\"object\\\":{\\\"name\\\":\\\"John\\\",\\\"age\\\":30}},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet client_with_element_props () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props = [ (\"children\", React.Model.Element (React.string \"Client Content\")) ];\n client = React.string \"Client with Props\";\n import_module = \"./client-with-props.js\";\n import_name = \"ClientWithProps\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-with-props.js\\\",[],\\\"ClientWithProps\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{\\\"children\\\":\\\"Client \\\n Content\\\"},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet client_with_promise_props () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props =\n [\n ( \"promise\",\n React.Model.Promise (delayed_value \"||| Resolved |||\", fun res -> React.Model.Json (`String res))\n );\n ];\n client = React.string \"Client with Props\";\n import_module = \"./client-with-props.js\";\n import_name = \"ClientWithProps\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-with-props.js\\\",[],\\\"ClientWithProps\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server \\\n Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{\\\"promise\\\":\\\"$@2\\\"},null,null,1]]\\n\";\n \"2:\\\"||| Resolved |||\\\"\\n\";\n ];\n Lwt.return ()\n\nlet client_with_promise_failed_props () =\n let app () =\n let promise =\n React.Model.Promise\n ( (let%lwt _str = delayed_value \"||| Resolved |||\" in\n Lwt.fail (Failure \"Already failed\")),\n fun res -> React.Model.Json (`String res) )\n in\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props = [ (\"promise\", promise) ];\n client = React.string \"Client with Props\";\n import_module = \"./client-with-props.js\";\n import_name = \"ClientWithProps\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-with-props.js\\\",[],\\\"ClientWithProps\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server \\\n Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{\\\"promise\\\":\\\"$@2\\\"},null,null,1]]\\n\";\n \"2:E{\\\"message\\\":\\\"Failure(\\\\\\\"Already failed\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n ];\n Lwt.return ()\n\nlet client_with_promise_already_failed_props () =\n let app () =\n let promise =\n React.Model.Promise (Lwt.fail (Failure \"Already failed\"), fun res -> React.Model.Json (`String res))\n in\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props = [ (\"promise\", promise) ];\n client = React.string \"Client with Props\";\n import_module = \"./client-with-props.js\";\n import_name = \"ClientWithProps\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-with-props.js\\\",[],\\\"ClientWithProps\\\"]\\n\";\n \"2:E{\\\"message\\\":\\\"Failure(\\\\\\\"Already failed\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server \\\n Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{\\\"promise\\\":\\\"$@2\\\"},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet mixed_server_and_client () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"header\" [] [ React.string \"Server Header\" ];\n React.Client_component\n {\n key = None;\n props = [];\n client = React.string \"Client 1\";\n import_module = \"./client-1.js\";\n import_name = \"Client1\";\n };\n React.createElement \"footer\" [] [ React.string \"Server Footer\" ];\n React.Client_component\n {\n key = None;\n props = [];\n client = React.string \"Client 2\";\n import_module = \"./client-2.js\";\n import_name = \"Client2\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-1.js\\\",[],\\\"Client1\\\"]\\n\";\n \"2:I[\\\"./client-2.js\\\",[],\\\"Client2\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"header\\\",null,{\\\"children\\\":\\\"Server \\\n Header\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{},null,null,1],[\\\"$\\\",\\\"footer\\\",null,{\\\"children\\\":\\\"Server \\\n Footer\\\"},null,null,1],[\\\"$\\\",\\\"$2\\\",null,{},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet client_with_server_children () =\n let server_child () = React.createElement \"div\" [] [ React.string \"Server Component Inside Client\" ] in\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.list\n [\n React.createElement \"div\" [] [ React.string \"Server Content\" ];\n React.Client_component\n {\n key = None;\n props = [ (\"children\", React.Model.Element (React.Upper_case_component (\"Server\", server_child))) ];\n client = React.string \"Client with Server Children\";\n import_module = \"./client-with-server-children.js\";\n import_name = \"ClientWithServerChildren\";\n };\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client-with-server-children.js\\\",[],\\\"ClientWithServerChildren\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server \\\n Content\\\"},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{\\\"children\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Server Component \\\n Inside Client\\\"},null,null,1]},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet key_renders_outside_of_props () =\n let app =\n React.createElementWithKey ~key:\"important key\" \"section\"\n [ React.JSX.String (\"className\", \"className\", \"sidebar-header\") ]\n [ React.createElement \"strong\" [] [ React.string \"React Notes\" ] ]\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"section\\\",\\\"important key\\\",{\\\"children\\\":[\\\"$\\\",\\\"strong\\\",null,{\\\"children\\\":\\\"React \\\n Notes\\\"},null,null,1],\\\"className\\\":\\\"sidebar-header\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet style_as_json () =\n let app =\n React.createElement \"div\"\n [ React.JSX.style (ReactDOMStyle.make ~color:\"red\" ~background:\"blue\" ~zIndex:\"34\" ()) ]\n []\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [ \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"style\\\":{\\\"zIndex\\\":\\\"34\\\",\\\"color\\\":\\\"red\\\",\\\"background\\\":\\\"blue\\\"}},null,null,1]\\n\" ];\n Lwt.return ()\n\nlet act_with_simple_response () =\n let response = Lwt.return (React.Model.Json (`String \"Server Content\")) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.create_action_response ~subscribe response in\n assert_list_of_strings !output [ \"0:\\\"Server Content\\\"\\n\" ];\n Lwt.return ()\n\nlet act_with_error () =\n let output, subscribe = capture_stream () in\n let response = Lwt.fail (Failure \"Error\") in\n let%lwt () = ReactServerDOM.create_action_response ~subscribe response in\n assert_list_of_strings (List.map replace_uuids !output)\n [\n \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"Error\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"0:\\\"$Z1\\\"\\n\";\n ];\n Lwt.return ()\n\n(* Test that simulates the streamFunctionResponse pattern:\n a failing server function's error is serialized into the RSC stream\n (not swallowed or re-raised as an HTTP 500). *)\nlet act_with_error_from_handler () =\n let output, subscribe = capture_stream () in\n (* Simulate what streamFunctionResponse does:\n 1. Run the handler (which may fail)\n 2. Capture the outcome as a promise (success or failure)\n 3. Pass the promise to create_action_response *)\n let action_promise =\n Lwt.catch\n (fun () ->\n (* Simulate a failing server function handler *)\n let%lwt _result = Lwt.fail (Failure \"Error from server\") in\n Lwt.return (Lwt.return _result))\n (fun exn -> Lwt.return (Lwt.fail exn))\n in\n let%lwt action_promise = action_promise in\n let%lwt () = ReactServerDOM.create_action_response ~subscribe action_promise in\n assert_list_of_strings (List.map replace_uuids !output)\n [\n \"1:E{\\\"message\\\":\\\"Failure(\\\\\\\"Error from server\\\\\\\")\\\",\\\"stack\\\":[],\\\"env\\\":\\\"Server\\\",\\\"digest\\\":\\\"\\\"}\\n\";\n \"0:\\\"$Z1\\\"\\n\";\n ];\n Lwt.return ()\n\n(* Test that a successful action followed by create_action_response works *)\nlet act_with_success_from_handler () =\n let output, subscribe = capture_stream () in\n let action_promise =\n Lwt.catch\n (fun () ->\n let%lwt result = Lwt.return (React.Model.Json (`String \"Success\")) in\n Lwt.return (Lwt.return result))\n (fun exn -> Lwt.return (Lwt.fail exn))\n in\n let%lwt action_promise = action_promise in\n let%lwt () = ReactServerDOM.create_action_response ~subscribe action_promise in\n assert_list_of_strings !output [ \"0:\\\"Success\\\"\\n\" ];\n Lwt.return ()\n\n(* Test that decodeReply errors produce Error, not exceptions *)\nlet act_decode_error_does_not_raise () =\n (match ReactServerDOM.decodeReply \"not valid json at all\" with\n | Error msg -> if not (String.length msg > 0) then Alcotest.fail \"expected non-empty error message\"\n | Ok _ -> Alcotest.fail \"expected Error for invalid JSON\");\n (match ReactServerDOM.decodeReply \"[\\\"$@1\\\"]\" with\n | Error msg ->\n if not (String.starts_with ~prefix:\"decodeReply: Promise\" msg) then\n Alcotest.fail (Printf.sprintf \"unexpected error message: %s\" msg)\n | Ok _ -> Alcotest.fail \"expected Error for unsupported type\");\n Lwt.return ()\n\nlet env_development_adds_debug_info () =\n let app =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n let value = \"my friend\" in\n React.createElement \"input\"\n [\n React.JSX.String (\"id\", \"id\", \"sidebar-search-input\");\n React.JSX.String (\"placeholder\", \"placeholder\", \"Search\");\n React.JSX.String (\"value\", \"value\", value);\n ]\n [] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe ~debug:true ~filter_stack_frame:drop_all_frames app in\n assert_list_of_strings !output\n [\n \"1:{\\\"name\\\":\\\"app\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":null,\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"0:D\\\"$1\\\"\\n\";\n \"0:[\\\"$\\\",\\\"input\\\",null,{\\\"id\\\":\\\"sidebar-search-input\\\",\\\"placeholder\\\":\\\"Search\\\",\\\"value\\\":\\\"my \\\n friend\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\n(* let env_development_adds_debug_info_2 () =\n let app () =\n React.Fragment\n (React.list\n [\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hi\" ]);\n React.Upper_case_component (\"Text\", text ~children:[ React.string \"hola\" ]);\n ])\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:{\\\"name\\\":\\\"App\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":null,\\\"stack\\\":[[\\\"module \\\n code\\\",\\\"/Users/davesnx/Code/github/ml-in-barcelona/server-reason-react/arch/server/render-rsc-to-stream.js\\\",54,42]],\\\"props\\\":{}}\";\n \"0:D\\\"$1\\\"\";\n \"3:{\\\"name\\\":\\\"Comp\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":\\\"$1\\\",\\\"stack\\\":[[\\\"App\\\",\\\"/Users/davesnx/Code/github/ml-in-barcelona/server-reason-react/arch/server/render-rsc-to-stream.js\\\",50,15]],\\\"props\\\":{\\\"name\\\":\\\"hi\\\"}}\";\n \"2:D\\\"$3\\\"\";\n \"2:[\\\"$\\\",\\\"h1\\\",null,{\\\"children\\\":[\\\"Hello \\\",\\\"hi\\\"]},\\\"$1\\\",null,1]\";\n \"5:{\\\"name\\\":\\\"Comp\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":\\\"$1\\\",\\\"stack\\\":[[\\\"App\\\",\\\"/Users/davesnx/Code/github/ml-in-barcelona/server-reason-react/arch/server/render-rsc-to-stream.js\\\",51,15]],\\\"props\\\":{\\\"name\\\":\\\"Hola\\\"}}\";\n \"4:D\\\"$5\\\"\";\n \"4:[\\\"$\\\",\\\"h1\\\",null,{\\\"children\\\":[\\\"Hello \\\",\\\"Hola\\\"]},\\\"$1\\\",null,1]\";\n \"0:[\\\"$2\\\",\\\"$4\\\"]\";\n ];\n Lwt.return () *)\n\nlet client_component_with_resources_metadata () =\n (* Test that resources are tracked in the RSC payload *)\n let app () =\n React.Upper_case_component\n ( \"Page\",\n fun () ->\n React.list\n [\n React.createElement \"html\" []\n [\n React.createElement \"head\" []\n [\n React.createElement \"link\"\n [\n React.JSX.String (\"rel\", \"rel\", \"stylesheet\");\n React.JSX.String (\"href\", \"href\", \"/styles.css\");\n React.JSX.String (\"precedence\", \"precedence\", \"default\");\n ]\n [];\n React.createElement \"script\"\n [ React.JSX.String (\"src\", \"src\", \"/app.js\"); React.JSX.Bool (\"async\", \"async\", true) ]\n [];\n ];\n React.createElement \"body\" []\n [\n React.Client_component\n {\n key = None;\n props = [];\n client = React.string \"Client Component\";\n import_module = \"./client.js\";\n import_name = \"Client\";\n };\n ];\n ];\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n (* Check that client reference is created *)\n let has_client_ref = List.exists (fun s -> Str.string_match (Str.regexp \".*:I\\\\[\\\"./client.js\\\".*\") s 0) !output in\n Alcotest.(check bool) \"should have client reference\" true has_client_ref;\n (* Check that the resources are in the model payload *)\n let has_head_with_resources =\n List.exists\n (fun s ->\n Str.string_match (Str.regexp \".*\\\"head\\\".*\") s 0\n && Str.string_match (Str.regexp \".*\\\"link\\\".*\") s 0\n && Str.string_match (Str.regexp \".*\\\"script\\\".*\") s 0)\n !output\n in\n Alcotest.(check bool) \"should have head with resources\" true has_head_with_resources;\n Lwt.return ()\n\nlet client_component_with_async_component () =\n let async_component =\n React.Async_component\n ( __FUNCTION__,\n fun () ->\n let%lwt () = Lwt.pause () in\n Lwt.return (React.string \"Async Component\") )\n in\n let app ~children =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.Client_component\n {\n key = None;\n import_module = \"./client.js\";\n import_name = \"Client\";\n props = [ (\"children\", React.Model.Element children) ];\n client = children;\n } )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ~children:async_component) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client.js\\\",[],\\\"Client\\\"]\\n\";\n \"0:[\\\"$\\\",\\\"$1\\\",null,{\\\"children\\\":\\\"$L2\\\"},null,null,1]\\n\";\n \"2:\\\"Async Component\\\"\\n\";\n ];\n Lwt.return ()\n\nlet page_with_hoisted_resources () =\n (* Test that resources like scripts and styles are properly hoisted *)\n let app () =\n React.Upper_case_component\n ( \"Page\",\n fun () ->\n React.list\n [\n React.createElement \"div\" []\n [\n React.createElement \"link\"\n [\n React.JSX.String (\"rel\", \"rel\", \"stylesheet\");\n React.JSX.String (\"href\", \"href\", \"/main.css\");\n React.JSX.String (\"precedence\", \"precedence\", \"high\");\n ]\n [];\n React.createElement \"script\"\n [ React.JSX.String (\"src\", \"src\", \"/runtime.js\"); React.JSX.Bool (\"async\", \"async\", true) ]\n [];\n React.createElement \"h1\" [] [ React.string \"Page Title\" ];\n ];\n ] )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n (* Check that the output contains the expected structure *)\n Alcotest.(check bool) \"should have output\" (List.length !output > 0) true;\n (* Check that h1 with Page Title is in the output *)\n let has_page_title = List.exists (fun s -> Str.string_match (Str.regexp \".*\\\"h1\\\".*\\\"Page Title\\\".*\") s 0) !output in\n Alcotest.(check bool) \"should have page title\" true has_page_title;\n Lwt.return ()\n\nlet nested_context () =\n let context = React.createContext React.null in\n let provider ~value ~children = mk_context context ~value ~children () in\n let client_provider ~value ~children =\n React.Upper_case_component\n ( \"client_provider\",\n fun () ->\n React.Client_component\n {\n key = None;\n import_module = \"./provider.js\";\n import_name = \"Provider\";\n props = [ (\"value\", React.Model.Element value); (\"children\", React.Model.Element children) ];\n client = provider ~value ~children;\n } )\n in\n let client_consumer () =\n React.Client_component\n {\n key = None;\n import_module = \"./consumer.js\";\n import_name = \"Consumer\";\n props = [];\n client =\n React.Upper_case_component\n ( \"client_consumer\",\n fun () ->\n let context = React.useContext context in\n context );\n }\n in\n let content () =\n React.Upper_case_component\n (\"content\", fun () -> client_provider ~value:React.null ~children:(React.string \"Hey you\"))\n in\n let me () =\n React.Upper_case_component\n ( \"me\",\n fun () ->\n client_provider ~value:(content ()) ~children:(React.array [| React.string \"/me\"; client_consumer () |]) )\n in\n let about () =\n React.Upper_case_component\n ( \"about\",\n fun () -> client_provider ~value:(me ()) ~children:(React.array [| React.string \"/about\"; client_consumer () |])\n )\n in\n let app () =\n React.Upper_case_component\n ( \"root\",\n fun () ->\n client_provider ~value:(about ()) ~children:(React.array [| React.string \"/root\"; client_consumer () |]) )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./provider.js\\\",[],\\\"Provider\\\"]\\n\";\n \"2:I[\\\"./consumer.js\\\",[],\\\"Consumer\\\"]\\n\";\n \"0:[\\\"$\\\",\\\"$1\\\",null,{\\\"value\\\":[\\\"$\\\",\\\"$1\\\",null,{\\\"value\\\":[\\\"$\\\",\\\"$1\\\",null,{\\\"value\\\":[\\\"$\\\",\\\"$1\\\",null,{\\\"value\\\":null,\\\"children\\\":\\\"Hey \\\n you\\\"},null,null,1],\\\"children\\\":[\\\"/me\\\",[\\\"$\\\",\\\"$2\\\",null,{},null,null,1]]},null,null,1],\\\"children\\\":[\\\"/about\\\",[\\\"$\\\",\\\"$2\\\",null,{},null,null,1]]},null,null,1],\\\"children\\\":[\\\"/root\\\",[\\\"$\\\",\\\"$2\\\",null,{},null,null,1]]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_with_nested_upper_case () =\n (* Server components are always inlined, matching React.js behavior. Everything resolves in chunk 0. *)\n let inner () = React.Upper_case_component (\"Inner\", fun () -> React.string \"inner-value\") in\n let app () =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:(React.Upper_case_component (\"Wrapper\", fun () -> React.createElement \"div\" [] [ inner () ]))\n ()\n in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe main in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"inner-value\\\"},null,null,1]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_at_root () =\n (* React: 0:[\"$\",\"$Sreact.suspense\",null,{\"fallback\":\"Loading...\",\"children\":\"Resolved content\"}] *)\n let app = mk_suspense ~fallback:(React.string \"Loading...\") ~children:(React.string \"Resolved content\") () in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"Resolved content\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_at_root_with_upper_case_children () =\n (* Server components inside Suspense are inlined, matching React.js.\n React: 0:[\"$\",\"$Sreact.suspense\",null,{\"fallback\":\"Loading...\",\"children\":[\"$\",\"div\",null,{\"children\":\"Hello\"}]}] *)\n let app =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:(React.Upper_case_component (\"Inner\", fun () -> React.createElement \"div\" [] [ React.string \"Hello\" ]))\n ()\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Hello\\\"},null,null,1]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_at_root_with_nested_components () =\n (* Server components are always inlined, matching React.js behavior.\n 0:[\"$\",\"$Sreact.suspense\",null,{\"fallback\":\"Loading...\",\n \"children\":[\"$\",\"div\",null,{\"children\":[\"$\",\"div\",null,{\"children\":\"Hello\"}]}]}] *)\n let inner () =\n React.Upper_case_component (\"Inner\", fun () -> React.createElement \"div\" [] [ React.string \"Hello\" ])\n in\n let wrapper () = React.Upper_case_component (\"Wrapper\", fun () -> React.createElement \"div\" [] [ inner () ]) in\n let app = mk_suspense ~fallback:(React.string \"Loading...\") ~children:(wrapper ()) () in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Hello\\\"},null,null,1]},null,null,1]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet suspense_at_root_with_async () =\n (* Async children inside root Suspense create a lazy ref.\n React: 0:[\"$\",\"$Sreact.suspense\",null,{\"fallback\":\"Loading...\",\"children\":\"$L1\"}] then 1:resolved *)\n let app =\n mk_suspense ~fallback:(React.string \"Loading...\")\n ~children:\n (React.Async_component\n ( \"async\",\n fun () ->\n let%lwt () = Lwt.pause () in\n Lwt.return (React.createElement \"span\" [] [ React.string \"Async resolved\" ]) ))\n ()\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"$Sreact.suspense\\\",null,{\\\"fallback\\\":\\\"Loading...\\\",\\\"children\\\":\\\"$L1\\\"},null,null,1]\\n\";\n \"1:[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"Async resolved\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet root_async_component_immediate () =\n (* Immediately resolved async component at root inlines at chunk 0.\n React: 0:[\"$\",\"span\",null,{\"children\":\"Immediate async\"}] *)\n let app =\n React.Async_component\n (\"immediate\", fun () -> Lwt.return (React.createElement \"span\" [] [ React.string \"Immediate async\" ]))\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"Immediate async\\\"},null,null,1]\\n\" ];\n Lwt.return ()\n\nlet root_upper_case_chain () =\n (* Chained root server components all inline in chunk 0.\n React: 0:[\"$\",\"div\",null,{\"children\":\"Hello\"}] *)\n let inner () =\n React.Upper_case_component (\"Inner\", fun () -> React.createElement \"div\" [] [ React.string \"Hello\" ])\n in\n let layout () = React.Upper_case_component (\"Layout\", fun () -> inner ()) in\n let app = React.Upper_case_component (\"App\", fun () -> layout ()) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output [ \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Hello\\\"},null,null,1]\\n\" ];\n Lwt.return ()\n\nlet model_list_value () =\n let list =\n React.Model.List\n [\n React.Model.Json (`String \"Item 1\");\n React.Model.Element\n (React.Upper_case_component\n (\"Component\", fun () -> React.createElement \"div\" [] [ React.string \"Hello world\" ]));\n ]\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model_value ~subscribe list in\n assert_list_of_strings !output [ \"0:[\\\"Item 1\\\",[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Hello world\\\"},null,null,1]]\\n\" ];\n Lwt.return ()\n\nlet model_value_assoc () =\n let assoc =\n React.Model.Assoc\n [\n (\"key\", React.Model.Json (`String \"value\"));\n ( \"component\",\n React.Model.Element\n (React.Upper_case_component\n (\"Component\", fun () -> React.createElement \"div\" [] [ React.string \"Hello world\" ])) );\n ]\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model_value ~subscribe assoc in\n assert_list_of_strings !output\n [ \"0:{\\\"key\\\":\\\"value\\\",\\\"component\\\":[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"Hello world\\\"},null,null,1]}\\n\" ];\n Lwt.return ()\n\nlet special_characters_not_html_encoded () =\n let app =\n React.createElement \"div\" []\n [\n React.string \"Tom & Jerry\";\n React.string \"\";\n React.string \"it's a \\\"test\\\"\";\n React.string \"& < >\";\n ]\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe app in\n assert_list_of_strings !output\n [\n \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":[\\\"Tom & Jerry\\\",\\\"\\\",\\\"it's a \\\n \\\\\\\"test\\\\\\\"\\\",\\\"& < >\\\"]},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet debug_nested_owner_chain () =\n let app =\n React.Upper_case_component\n ( \"App\",\n fun () -> React.Upper_case_component (\"Child\", fun () -> React.createElement \"div\" [] [ React.string \"hello\" ])\n )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe ~debug:true ~filter_stack_frame:drop_all_frames app in\n assert_list_of_strings !output\n [\n \"1:{\\\"name\\\":\\\"App\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":null,\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"0:D\\\"$1\\\"\\n\";\n \"3:{\\\"name\\\":\\\"Child\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":\\\"$1\\\",\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"2:D\\\"$3\\\"\\n\";\n \"2:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"hello\\\"},\\\"$1\\\",null,1]\\n\";\n \"0:\\\"$2\\\"\\n\";\n ];\n Lwt.return ()\n\nlet debug_async_component () =\n let app =\n React.Upper_case_component\n ( \"App\",\n fun () ->\n React.Async_component\n (\"AsyncChild\", fun () -> Lwt.return (React.createElement \"span\" [] [ React.string \"async\" ])) )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe ~debug:true ~filter_stack_frame:drop_all_frames app in\n assert_list_of_strings !output\n [\n \"1:{\\\"name\\\":\\\"App\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":null,\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"0:D\\\"$1\\\"\\n\";\n \"3:{\\\"name\\\":\\\"AsyncChild\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":\\\"$1\\\",\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"2:D\\\"$3\\\"\\n\";\n \"2:[\\\"$\\\",\\\"span\\\",null,{\\\"children\\\":\\\"async\\\"},\\\"$1\\\",null,1]\\n\";\n \"0:\\\"$2\\\"\\n\";\n ];\n Lwt.return ()\n\nlet debug_outlines_components () =\n let app = React.Upper_case_component (\"App\", fun () -> React.createElement \"h1\" [] [ React.string \"title\" ]) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe ~debug:true ~filter_stack_frame:drop_all_frames app in\n assert_list_of_strings !output\n [\n \"1:{\\\"name\\\":\\\"App\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":null,\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"0:D\\\"$1\\\"\\n\";\n \"0:[\\\"$\\\",\\\"h1\\\",null,{\\\"children\\\":\\\"title\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet debug_not_emitted_without_flag () =\n let app = React.Upper_case_component (\"App\", fun () -> React.createElement \"div\" [] [ React.string \"no debug\" ]) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe ~debug:false app in\n assert_list_of_strings !output [ \"0:[\\\"$\\\",\\\"div\\\",null,{\\\"children\\\":\\\"no debug\\\"},null,null,1]\\n\" ];\n Lwt.return ()\n\n(* Validates the React 19 RSC wire format for debug info with a 3-level component chain:\n - Element tuple: [\"$\", type, key, props, debugOwner, debugStack, validated]\n - debugOwner must be a \"$\" chunk reference (not a bare integer)\n - debugStack must be null when absent (not an empty list)\n - Debug info chunks use the D prefix and reference their parent via \"$\" *)\nlet debug_wire_format () =\n let app =\n React.Upper_case_component\n ( \"GrandParent\",\n fun () ->\n React.Upper_case_component\n ( \"Parent\",\n fun () ->\n React.Upper_case_component (\"Child\", fun () -> React.createElement \"em\" [] [ React.string \"deep\" ]) ) )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe ~debug:true ~filter_stack_frame:drop_all_frames app in\n assert_list_of_strings !output\n [\n (* GrandParent debug info (chunk 1): root component, no owner *)\n \"1:{\\\"name\\\":\\\"GrandParent\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":null,\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"0:D\\\"$1\\\"\\n\";\n (* Parent debug info (chunk 3): owner is GrandParent via \"$1\" *)\n \"3:{\\\"name\\\":\\\"Parent\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":\\\"$1\\\",\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n (* Child debug info (chunk 5): owner is Parent via \"$3\" *)\n \"5:{\\\"name\\\":\\\"Child\\\",\\\"env\\\":\\\"Server\\\",\\\"key\\\":null,\\\"owner\\\":\\\"$3\\\",\\\"stack\\\":[],\\\"props\\\":{}}\\n\";\n \"4:D\\\"$5\\\"\\n\";\n (* Element tuple: debugOwner=\"$3\" (chunk ref, not bare int), debugStack=null, validated=1 *)\n \"4:[\\\"$\\\",\\\"em\\\",null,{\\\"children\\\":\\\"deep\\\"},\\\"$3\\\",null,1]\\n\";\n (* Outlined chunks resolve *)\n \"2:D\\\"$3\\\"\\n\";\n \"2:\\\"$4\\\"\\n\";\n \"0:\\\"$2\\\"\\n\";\n ];\n Lwt.return ()\n\nlet server_function_as_model_prop () =\n let app () =\n React.Upper_case_component\n ( \"app\",\n fun () ->\n React.Client_component\n {\n key = None;\n props =\n [\n ( \"onSubmit\",\n React.Model.Function\n { Runtime.id = \"action-id-123\"; call = (fun () -> Lwt.return (React.Model.Json `Null)) } );\n ];\n client = React.string \"Client\";\n import_module = \"./client.js\";\n import_name = \"Client\";\n } )\n in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client.js\\\",[],\\\"Client\\\"]\\n\";\n \"2:{\\\"id\\\":\\\"action-id-123\\\",\\\"bound\\\":null}\\n\";\n \"0:[\\\"$\\\",\\\"$1\\\",null,{\\\"onSubmit\\\":\\\"$F2\\\"},null,null,1]\\n\";\n ];\n Lwt.return ()\n\nlet error_in_prod_hides_message () =\n let app () = React.Upper_case_component (__FUNCTION__, fun () -> raise (Failure \"secret\")) in\n let main = React.Upper_case_component (\"app\", app) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~env:`Prod ~subscribe main in\n assert_list_of_strings !output [ \"1:E{\\\"digest\\\":\\\"\\\"}\\n\"; \"0:\\\"$L1\\\"\\n\" ];\n Lwt.return ()\n\nlet duplicate_client_component_deduplicates_ref () =\n let make_client () =\n React.Client_component\n { key = None; props = []; client = React.string \"Client\"; import_module = \"./client.js\"; import_name = \"Client\" }\n in\n let app () = React.Upper_case_component (\"app\", fun () -> React.list [ make_client (); make_client () ]) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client.js\\\",[],\\\"Client\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"$1\\\",null,{},null,null,1],[\\\"$\\\",\\\"$1\\\",null,{},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet keyed_duplicate_client_component_preserves_keys () =\n let make_client key =\n React.Client_component\n {\n key = Some key;\n props = [];\n client = React.string \"Client\";\n import_module = \"./client.js\";\n import_name = \"Client\";\n }\n in\n let app () = React.Upper_case_component (\"app\", fun () -> React.list [ make_client \"first\"; make_client \"second\" ]) in\n let output, subscribe = capture_stream () in\n let%lwt () = ReactServerDOM.render_model ~subscribe (app ()) in\n assert_list_of_strings !output\n [\n \"1:I[\\\"./client.js\\\",[],\\\"Client\\\"]\\n\";\n \"0:[[\\\"$\\\",\\\"$1\\\",\\\"first\\\",{},null,null,1],[\\\"$\\\",\\\"$1\\\",\\\"second\\\",{},null,null,1]]\\n\";\n ];\n Lwt.return ()\n\nlet tests =\n [\n test \"null_element\" null_element;\n test \"special_characters_not_html_encoded\" special_characters_not_html_encoded;\n test \"string_element\" string_element;\n test \"key_renders_outside_of_props\" key_renders_outside_of_props;\n test \"style_as_json\" style_as_json;\n test \"lower_case_component\" lower_case_component;\n test \"lower_case_component_nested\" lower_case_component_nested;\n test \"lower_case_with_children\" lower_case_with_children;\n test \"dangerouslySetInnerHtml\" dangerouslySetInnerHtml;\n test \"upper_case_component\" upper_case_component;\n test \"nested_upper_case_components\" nested_upper_case_components;\n test \"upper_case_with_list\" upper_case_with_list;\n test \"upper_case_with_children\" upper_case_with_children;\n test \"suspense_without_promise\" suspense_without_promise;\n test \"suspense_with_promise\" suspense_with_promise;\n test \"suspense_with_error\" suspense_with_error;\n test \"suspense_with_error_in_async\" suspense_with_error_in_async;\n test \"suspense_with_immediate_promise\" suspense_with_immediate_promise;\n test \"suspense\" suspense;\n test \"async_component_without_suspense\" async_component_without_suspense;\n test \"suspense_in_a_list\" suspense_in_a_list;\n test \"client_with_promise_props\" client_with_promise_props;\n test \"async_component_without_suspense_immediate\" async_component_without_suspense_immediate;\n test \"mixed_server_and_client\" mixed_server_and_client;\n test \"client_with_json_props\" client_with_json_props;\n test \"client_without_props\" client_without_props;\n test \"client_with_element_props\" client_with_element_props;\n test \"client_with_server_children\" client_with_server_children;\n test \"client_component_with_async_component\" client_component_with_async_component;\n test \"act_with_simple_response\" act_with_simple_response;\n test \"env_development_adds_debug_info\" env_development_adds_debug_info;\n test \"debug_nested_owner_chain\" debug_nested_owner_chain;\n test \"debug_async_component\" debug_async_component;\n test \"debug_outlines_components\" debug_outlines_components;\n test \"debug_not_emitted_without_flag\" debug_not_emitted_without_flag;\n test \"debug_wire_format\" debug_wire_format;\n test \"act_with_error\" act_with_error;\n test \"act_with_error_from_handler\" act_with_error_from_handler;\n test \"act_with_success_from_handler\" act_with_success_from_handler;\n test \"act_decode_error_does_not_raise\" act_decode_error_does_not_raise;\n test \"error_without_suspense\" error_without_suspense;\n test \"keyed_duplicate_client_component_preserves_keys\" keyed_duplicate_client_component_preserves_keys;\n test \"error_in_toplevel\" error_in_toplevel;\n test \"error_in_toplevel_in_async\" error_in_toplevel_in_async;\n test \"suspense_in_a_list_with_error\" suspense_in_a_list_with_error;\n test \"suspense_with_error_under_lowercase\" suspense_with_error_under_lowercase;\n test \"client_component_with_resources_metadata\" client_component_with_resources_metadata;\n test \"page_with_hoisted_resources\" page_with_hoisted_resources;\n test \"nested_context\" nested_context;\n test \"suspense_with_nested_upper_case\" suspense_with_nested_upper_case;\n test \"suspense_at_root\" suspense_at_root;\n test \"suspense_at_root_with_upper_case_children\" suspense_at_root_with_upper_case_children;\n test \"suspense_at_root_with_nested_components\" suspense_at_root_with_nested_components;\n test \"suspense_at_root_with_async\" suspense_at_root_with_async;\n test \"root_async_component_immediate\" root_async_component_immediate;\n test \"root_upper_case_chain\" root_upper_case_chain;\n test \"model_list_value\" model_list_value;\n test \"model_value_assoc\" model_value_assoc;\n test \"client_with_promise_failed_props\" client_with_promise_failed_props;\n test \"client_with_promise_already_failed_props\" client_with_promise_already_failed_props;\n test \"server_function_as_model_prop\" server_function_as_model_prop;\n test \"error_in_prod_hides_message\" error_in_prod_hides_message;\n test \"duplicate_client_component_deduplicates_ref\" duplicate_client_component_deduplicates_ref;\n ]\n"
},
{
"path": "packages/reactDom/test/test_reactDOMStyle.ml",
"content": "let assert_styles styles str = Alcotest.check Alcotest.string \"should be equal\" str (ReactDOM.Style.to_string styles)\n\nlet one_styles () =\n let styles = ReactDOM.Style.make ~background:\"#333\" () in\n assert_styles styles \"background:#333\"\n\nlet two_styles () =\n let styles = ReactDOM.Style.make ~background:\"#333\" ~fontSize:\"24px\" () in\n assert_styles styles \"font-size:24px;background:#333\"\n\nlet zero_styles () =\n let styles = ReactDOM.Style.make () in\n assert_styles styles \"\"\n\nlet emtpy_value () =\n let styles = ReactDOM.Style.make ~background:\"\" () in\n assert_styles styles \"\"\n\nlet emtpy_value_with_more () =\n let styles = ReactDOM.Style.make ~background:\"\" ~color:\"transparent\" () in\n assert_styles styles \"color:transparent\"\n\nlet unsafe_add_prop () =\n let styles = ReactDOM.Style.unsafeAddProp (ReactDOM.Style.make ~background:\"#333\" ()) \"colorScheme\" \"dark\" in\n assert_styles styles \"color-scheme:dark;background:#333\"\n\nlet unsafe_add_prop_css_custom_property () =\n let styles = ReactDOM.Style.unsafeAddProp (ReactDOM.Style.make ()) \"--var-136njlt_1\" \"8px\" in\n assert_styles styles \"--var-136njlt_1:8px\"\n\nlet unsafe_add_prop_css_custom_property_with_var_value () =\n let styles = ReactDOM.Style.unsafeAddProp (ReactDOM.Style.make ()) \"--var-qog-9iu\" \"var(--alt-background--box)\" in\n assert_styles styles \"--var-qog-9iu:var(--alt-background--box)\"\n\nlet unsafe_add_prop_css_custom_property_simple () =\n let styles = ReactDOM.Style.unsafeAddProp (ReactDOM.Style.make ()) \"--var-5uugbw\" \"16px\" in\n assert_styles styles \"--var-5uugbw:16px\"\n\nlet unsafe_add_prop_camel_with_digits () =\n (* Digits and underscores in non-custom-property keys must not insert dashes. *)\n let styles = ReactDOM.Style.unsafeAddProp (ReactDOM.Style.make ()) \"grid_area1\" \"main\" in\n assert_styles styles \"grid_area1:main\"\n\nlet style_order_matters () =\n let styles = ReactDOM.Style.make ~lineBreak:\"100px\" ~overflowWrap:\"break-word\" () in\n assert_styles styles \"overflow-wrap:break-word;line-break:100px\"\n\nlet style_order_matters_2 () =\n let styles = ReactDOM.Style.make ~opacity:\"1.0\" ~stress:\"0\" ~width:\"20\" ~backgroundColor:\"red\" ~columnGap:\"2px\" () in\n assert_styles styles \"column-gap:2px;opacity:1.0;width:20;stress:0;background-color:red\"\n\nlet test title fn = (Printf.sprintf \"ReactDOM.Style.make / %s\" title, [ Alcotest_lwt.test_case_sync \"\" `Quick fn ])\n\nlet tests =\n [\n test \"generate empty style\" zero_styles;\n test \"generate one style\" one_styles;\n test \"generate more than one style\" two_styles;\n test \"unsafeAddProp should be kebab-case\" unsafe_add_prop;\n test \"unsafeAddProp preserves CSS custom property keys verbatim\" unsafe_add_prop_css_custom_property;\n test \"unsafeAddProp preserves CSS custom property with var() value\"\n unsafe_add_prop_css_custom_property_with_var_value;\n test \"unsafeAddProp preserves simple CSS custom property\" unsafe_add_prop_css_custom_property_simple;\n test \"unsafeAddProp does not insert dashes around digits/underscores\" unsafe_add_prop_camel_with_digits;\n (* TODO: Add more test for unsafeAddProp *)\n test \"order matters\" style_order_matters;\n test \"order matters II\" style_order_matters_2;\n ]\n"
},
{
"path": "packages/reactDom/test/test_renderToStaticMarkup.ml",
"content": "let assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\n\nlet single_empty_tag () =\n let div = React.createElement \"div\" [] [] in\n assert_string (ReactDOM.renderToStaticMarkup div) \"\"\n\nlet html_doctype () =\n let app = React.createElement \"html\" [] [] in\n assert_string (ReactDOM.renderToStaticMarkup app) \"\"\n\nlet empty_string_attribute () =\n let div = React.createElement \"div\" [ React.JSX.String (\"class\", \"className\", \"\") ] [] in\n assert_string (ReactDOM.renderToStaticMarkup div) \"\"\n\nlet string_attributes () =\n let a =\n React.createElement \"a\"\n [ React.JSX.String (\"href\", \"href\", \"google.html\"); React.JSX.String (\"target\", \"target\", \"_blank\") ]\n []\n in\n assert_string (ReactDOM.renderToStaticMarkup a) \"\"\n\nlet bool_attributes () =\n let a =\n React.createElement \"input\"\n [\n React.JSX.String (\"type\", \"type\", \"checkbox\");\n React.JSX.String (\"name\", \"name\", \"cheese\");\n React.JSX.Bool (\"checked\", \"checked\", true);\n React.JSX.Bool (\"disabled\", \"disabled\", false);\n ]\n []\n in\n assert_string (ReactDOM.renderToStaticMarkup a) \"\"\n\nlet truthy_attributes () =\n let component = React.createElement \"input\" [ React.JSX.String (\"aria-hidden\", \"ariaHidden\", \"true\") ] [] in\n assert_string (ReactDOM.renderToStaticMarkup component) \"\"\n\nlet self_closing_tag () =\n let input = React.createElement \"input\" [] [] in\n assert_string (ReactDOM.renderToStaticMarkup input) \"\"\n\nlet dom_element_innerHtml () =\n let p = React.createElement \"p\" [] [ React.string \"text\" ] in\n assert_string (ReactDOM.renderToStaticMarkup p) \"
text
\"\n\nlet children () =\n let children = React.createElement \"div\" [] [] in\n let div = React.createElement \"div\" [] [ children ] in\n assert_string (ReactDOM.renderToStaticMarkup div) \"
\"\n\nlet ignored_attributes_on_jsx () =\n let div =\n React.createElement \"div\"\n [\n React.JSX.String (\"key\", \"key\", \"uniqueKeyId\");\n React.JSX.Bool (\"suppressContentEditableWarning\", \"suppressContentEditableWarning\", true);\n ]\n []\n in\n assert_string (ReactDOM.renderToStaticMarkup div) \"\"\n\nlet fragment () =\n let div = React.createElement \"div\" [] [] in\n let component = React.fragment (React.list [ div; div ]) in\n assert_string (ReactDOM.renderToStaticMarkup component) \"\"\n\nlet ignore_nulls () =\n let div = React.createElement \"div\" [] [] in\n let span = React.createElement \"span\" [] [] in\n let component = React.createElement \"div\" [] [ div; span; React.null ] in\n assert_string (ReactDOM.renderToStaticMarkup component) \"
\";\n \"\";\n ]\n\nlet tests =\n [\n test \"silly_stream\" silly_stream;\n test \"render_inner_html\" render_inner_html;\n test \"react_use_without_suspense\" react_use_without_suspense;\n test \"uppercase_component_always_throwing\" uppercase_component_always_throwing;\n test \"suspense_with_react_use\" suspense_with_react_use;\n test \"async component\" async_component;\n test \"async_component_without_suspense\" async_component_without_suspense;\n test \"suspense_without_promise\" suspense_without_promise;\n test \"text_after_element_with_text_child\" text_after_element_with_text_child;\n test \"suspense_with_resolved_text_after_element_with_text_child\"\n suspense_with_resolved_text_after_element_with_text_child;\n test \"suspense_with_async_component\" suspense_with_async_component;\n test \"suspense_with_always_throwing\" suspense_with_always_throwing;\n test \"suspense_with_nested_suspense\" suspense_with_nested_suspense;\n test \"suspense_with_nested_suspenses\" suspense_with_nested_suspenses;\n test \"suspense_with_nested_suspense_with_error\" suspense_with_nested_suspense_with_error;\n test \"suspense_with_multiple_children\" suspense_with_multiple_children;\n test \"suspense_with_multiple_children_reordered\" suspense_with_multiple_children_reordered;\n test \"suspense_with_concurrent_suspenses\" suspense_with_concurrent_suspenses;\n test \"suspense_with_comments\" suspense_with_comments;\n (* test \"abort_streaming\" abort_streaming; *)\n test \"context_basic\" context_basic;\n test \"context_default_value\" context_default_value;\n test \"context_nested_providers\" context_nested_providers;\n test \"context_multiple_independent\" context_multiple_independent;\n test \"context_with_suspense\" context_with_suspense;\n test \"async_component_with_use_id\" async_component_with_use_id;\n test \"async_component_with_use_id_and_sibling\" async_component_with_use_id_and_sibling;\n test \"async_component_with_use_id_in_suspense\" async_component_with_use_id_in_suspense;\n test \"async_component_with_multiple_use_ids\" async_component_with_multiple_use_ids;\n test \"multiple_async_components_without_suspense\" multiple_async_components_without_suspense;\n test \"context_provider_with_suspended_consumer\" context_provider_with_suspended_consumer;\n test \"async_component_returning_suspense_with_async_children\" async_component_returning_suspense_with_async_children;\n test \"static_element_in_stream\" static_element_in_stream;\n test \"client_component_error_in_stream\" client_component_error_in_stream;\n test \"suspense_with_failed_promise\" suspense_with_failed_promise;\n test \"fragment_in_stream\" fragment_in_stream;\n test \"list_in_stream\" list_in_stream;\n test \"array_in_stream\" array_in_stream;\n test \"empty_element_in_stream\" empty_element_in_stream;\n test \"dangerous_html_in_suspense\" dangerous_html_in_suspense;\n ]\n"
},
{
"path": "packages/reactDom/test/test_renderToString.ml",
"content": "let assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\n\nlet react_root_one_element () =\n let div = React.createElement \"div\" [] [] in\n assert_string (ReactDOM.renderToString div) \"\"\n\nlet react_root_two_elements () =\n let div = React.createElement \"div\" [] [ React.createElement \"span\" [] [] ] in\n assert_string (ReactDOM.renderToString div) \"
\"\n\nlet suspense_children_render_once () =\n let render_count = ref 0 in\n let child () =\n React.Upper_case_component\n ( \"Child\",\n fun () ->\n render_count := !render_count + 1;\n React.createElement \"div\" [] [ React.string \"hello\" ] )\n in\n let el =\n React.Suspense\n { key = None; children = child (); fallback = React.createElement \"div\" [] [ React.string \"loading\" ] }\n in\n let html = ReactDOM.renderToString el in\n assert_string html \"
hello
\";\n Alcotest.(check int) \"children should render exactly once\" 1 !render_count\n\nlet suspense_fallback_on_error () =\n let el =\n React.Suspense\n {\n key = None;\n children = React.Upper_case_component (\"Throws\", fun () -> raise (Failure \"boom\"));\n fallback = React.createElement \"div\" [] [ React.string \"fallback\" ];\n }\n in\n let html = ReactDOM.renderToString el in\n assert_string html \"
fallback
\"\n\nlet test title fn = (Printf.sprintf \"ReactDOM.renderToString / %s\" title, [ Alcotest_lwt.test_case_sync \"\" `Quick fn ])\n\nlet tests =\n [\n test \"react_root_one_element\" react_root_one_element;\n test \"react_root_two_elements\" react_root_two_elements;\n test \"text_single_node should not add \" text_single_node;\n test \"consecutives_text_nodes should add \" consecutives_text_nodes;\n test \"separated_text_nodes_by_other_parents\" separated_text_nodes_by_other_parents;\n test \"text_after_element_with_text_child\" text_after_element_with_text_child;\n test \"suspense children render exactly once\" suspense_children_render_once;\n test \"suspense renders fallback on error\" suspense_fallback_on_error;\n ]\n"
},
{
"path": "packages/reactDom/test/test_useId.ml",
"content": "let assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\n\n(* Helper components *)\nlet div_with_id () =\n React.Upper_case_component\n ( \"DivWithId\",\n fun () ->\n let id = React.useId () in\n React.createElement \"div\" [ React.JSX.String (\"id\", \"id\", id) ] [] )\n\nlet div_with_two_ids () =\n React.Upper_case_component\n ( \"DivWithTwoIds\",\n fun () ->\n let id1 = React.useId () in\n let id2 = React.useId () in\n React.createElement \"div\"\n [ React.JSX.String (\"data-id1\", \"data-id1\", id1); React.JSX.String (\"data-id2\", \"data-id2\", id2) ]\n [] )\n\nlet div_with_three_ids () =\n React.Upper_case_component\n ( \"DivWithThreeIds\",\n fun () ->\n let id1 = React.useId () in\n let id2 = React.useId () in\n let id3 = React.useId () in\n React.createElement \"div\"\n [\n React.JSX.String (\"data-id1\", \"data-id1\", id1);\n React.JSX.String (\"data-id2\", \"data-id2\", id2);\n React.JSX.String (\"data-id3\", \"data-id3\", id3);\n ]\n [] )\n\nlet wrapper children =\n React.Upper_case_component\n (\"Wrapper\", fun () -> React.createElement \"div\" [ React.JSX.String (\"class\", \"className\", \"wrapper\") ] [ children ])\n\nlet parent_with_id children =\n React.Upper_case_component\n ( \"ParentWithId\",\n fun () ->\n let id = React.useId () in\n React.createElement \"div\" [ React.JSX.String (\"id\", \"id\", id) ] [ children ] )\n\nlet mk_provider ctx ~value ~children () = React.Context.provider ctx (React.Context.makeProps ~value ~children ())\n\n(* All expected values verified against React 19.1.0 (bun arch/server/test-useid.js)\n React 19 ID format: \\xc2\\xab (U+00AB «) + prefix + R + treeId + \\xc2\\xbb (U+00BB ») *)\n\nlet single_component_with_use_id () =\n let html = ReactDOM.renderToString (div_with_id ()) in\n assert_string html \"\"\n\nlet two_sibling_components () =\n let el = React.createElement \"div\" [] [ div_with_id (); div_with_id () ] in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet nested_components () =\n let el = parent_with_id (div_with_id ()) in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet multiple_use_id_calls () =\n let html = ReactDOM.renderToString (div_with_two_ids ()) in\n assert_string html \"\"\n\nlet three_use_id_calls () =\n let html = ReactDOM.renderToString (div_with_three_ids ()) in\n assert_string html\n \"\"\n\nlet siblings_with_nested_children () =\n let el = React.createElement \"div\" [] [ parent_with_id (div_with_id ()); div_with_id () ] in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet deep_nesting () =\n let el = parent_with_id (parent_with_id (div_with_id ())) in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet wrapper_without_use_id () =\n let el = wrapper (div_with_id ()) in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet three_siblings () =\n let el = React.createElement \"div\" [] [ div_with_id (); div_with_id (); div_with_id () ] in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet complex_siblings_with_nested () =\n let el =\n React.createElement \"div\" []\n [\n parent_with_id (React.Fragment (React.List [ div_with_id (); div_with_id () ])); parent_with_id (div_with_id ());\n ]\n in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet separate_renders_same_ids () =\n let html1 = ReactDOM.renderToString (div_with_id ()) in\n let html2 = ReactDOM.renderToString (div_with_id ()) in\n assert_string html1 html2\n\nlet static_markup_use_id () =\n let html = ReactDOM.renderToStaticMarkup (div_with_id ()) in\n assert_string html \"\"\n\nlet identifier_prefix () =\n let html = ReactDOM.renderToString ~identifier_prefix:\"myapp\" (div_with_id ()) in\n assert_string html \"\"\n\n(* ── Edge case tests (verified against React 19.1.0 output) ────────────────── *)\n\nlet use_id_inside_suspense () =\n let el =\n React.Suspense\n { key = None; children = div_with_id (); fallback = React.createElement \"div\" [] [ React.string \"loading\" ] }\n in\n let html = ReactDOM.renderToString el in\n assert_string html \"\"\n\nlet use_id_suspense_and_sibling () =\n let el =\n React.createElement \"div\" []\n [\n React.Suspense\n { key = None; children = div_with_id (); fallback = React.createElement \"div\" [] [ React.string \"loading\" ] };\n div_with_id ();\n ]\n in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet fragment_single_child () =\n let el = React.createElement \"div\" [] [ React.Fragment (div_with_id ()) ] in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet fragment_multiple_children () =\n let el = React.createElement \"div\" [] [ React.Fragment (React.List [ div_with_id (); div_with_id () ]) ] in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet nested_fragments () =\n let el = React.createElement \"div\" [] [ React.Fragment (React.Fragment (div_with_id ())) ] in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet null_between_siblings () =\n let el = React.createElement \"div\" [] [ div_with_id (); React.Empty; div_with_id () ] in\n let html = ReactDOM.renderToString el in\n assert_string html \"
\"\n\nlet many_siblings () =\n let children = List.init 10 (fun _ -> div_with_id ()) in\n let el = React.createElement \"div\" [] children in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet provider_transparent () =\n let ctx = React.createContext \"default\" in\n let el = mk_provider ctx ~value:\"provided\" ~children:(div_with_id ()) () in\n let html = ReactDOM.renderToString el in\n assert_string html \"\"\n\nlet kitchen_sink () =\n let ctx = React.createContext \"default\" in\n let el =\n React.createElement \"div\" []\n [\n mk_provider ctx ~value:\"a\"\n ~children:\n (React.Fragment\n (React.List\n [\n div_with_id ();\n React.Suspense\n {\n key = None;\n children = div_with_id ();\n fallback = React.createElement \"span\" [] [ React.string \"...\" ];\n };\n ]))\n ();\n div_with_id ();\n ]\n in\n let html = ReactDOM.renderToString el in\n assert_string html\n \"
\"\n\nlet test title fn =\n (Printf.sprintf \"ReactDOM.renderToString / useId / %s\" title, [ Alcotest_lwt.test_case_sync \"\" `Quick fn ])\n\nlet tests =\n [\n test \"single component with useId\" single_component_with_use_id;\n test \"two sibling components\" two_sibling_components;\n test \"nested components\" nested_components;\n test \"multiple useId calls in one component\" multiple_use_id_calls;\n test \"three useId calls in one component\" three_use_id_calls;\n test \"siblings with nested children\" siblings_with_nested_children;\n test \"deep nesting (3 levels)\" deep_nesting;\n test \"wrapper without useId is transparent\" wrapper_without_use_id;\n test \"three siblings\" three_siblings;\n test \"complex siblings with nested\" complex_siblings_with_nested;\n test \"separate renders produce same IDs\" separate_renders_same_ids;\n test \"renderToStaticMarkup also works\" static_markup_use_id;\n test \"identifier_prefix\" identifier_prefix;\n test \"useId inside Suspense (sync)\" use_id_inside_suspense;\n test \"Suspense with useId + sibling\" use_id_suspense_and_sibling;\n test \"Fragment single child is transparent\" fragment_single_child;\n test \"Fragment multiple children forks\" fragment_multiple_children;\n test \"Nested fragments transparent\" nested_fragments;\n test \"Null/Empty between siblings preserves slots\" null_between_siblings;\n test \"Many siblings (10, base-32 at Ra)\" many_siblings;\n test \"Provider is transparent\" provider_transparent;\n test \"Kitchen sink (Provider + Fragment + Suspense)\" kitchen_sink;\n ]\n"
},
{
"path": "packages/reactDom/test/test_write_to_buffer.ml",
"content": "let assert_string left right = Alcotest.check Alcotest.string \"should be equal\" right left\n\nlet write element =\n let buf = Buffer.create 128 in\n ReactDOM.write_to_buffer buf element;\n Buffer.contents buf\n\nlet empty_element () = assert_string (write React.null) \"\"\n\nlet single_element () =\n let div = React.createElement \"div\" [] [] in\n assert_string (write div) \"\"\n\nlet nested_elements () =\n let div = React.createElement \"div\" [] [ React.createElement \"span\" [] [] ] in\n assert_string (write div) \"
\";\n ReactDOM.write_to_buffer b children;\n Buffer.add_string b \"
\";\n ());\n original =\n (fun () ->\n React.createElement \"div\"\n (Stdlib.List.filter_map\n Stdlib.Fun.id\n [\n Some\n (React.JSX.String\n ( \"id\",\n \"id\",\n (\"root\" : string) ));\n ])\n [ children ]);\n };\n React.Static\n {\n prerendered =\n \"\";\n original =\n React.createElement \"script\"\n (Stdlib.List.filter_map\n Stdlib.Fun.id\n [\n Some\n (React.JSX.String\n ( \"src\",\n \"src\",\n (\"/static/client.js\"\n : string) ));\n ])\n [];\n };\n ]);\n };\n ]);\n } ))\n [@warning \"-16\"]\n \n let make ?(key : string option)\n (Props : < children : 'children ; moreProps : 'moreProps > Js.t) =\n make ?key ~children:Props#children ~moreProps:Props#moreProps ()\n end\n end\n \n module Upper_with_aria = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.Writer\n {\n emit =\n (fun b ->\n Buffer.add_string b \"
\";\n ReactDOM.write_to_buffer b children;\n Buffer.add_string b \"
\";\n ());\n original =\n (fun () ->\n React.createElement \"div\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n Some\n (React.JSX.String\n ( \"aria-hidden\",\n \"aria-hidden\",\n Stdlib.Bool.to_string (\"true\" : bool) ));\n ])\n [ children ]);\n } )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n module Form_with_method = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.Writer\n {\n emit =\n (fun b ->\n Buffer.add_string b \"\";\n ());\n original =\n (fun () ->\n React.createElement \"form\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n Some\n (React.JSX.String\n (\"method\", \"method\", (\"GET\" : string)));\n ])\n [ children ]);\n } )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n module Form_with_method = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.createElement \"form\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n (match\n (`String \"\"\n : [ `String of string\n | `Function of 'a Runtime.server_function ])\n with\n | `String s ->\n Some\n (React.JSX.String (\"action\", \"action\", (s : string)))\n | `Function f ->\n Some\n (React.JSX.Action\n ( \"action\",\n \"action\",\n (f : 'a Runtime.server_function) )));\n ])\n [ children ] )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n module Form_with_action_function = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.createElement \"form\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n (match\n (`Function\n {\n id = \"123\";\n call = (fun () -> Js.Promise.resolve \"Hello\");\n }\n : [ `String of string\n | `Function of 'a Runtime.server_function ])\n with\n | `String s ->\n Some\n (React.JSX.String (\"action\", \"action\", (s : string)))\n | `Function f ->\n Some\n (React.JSX.Action\n ( \"action\",\n \"action\",\n (f : 'a Runtime.server_function) )));\n ])\n [ children ] )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n module Form_with_action_string = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.createElement \"form\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n (match\n (`String \"\"\n : [ `String of string\n | `Function of 'a Runtime.server_function ])\n with\n | `String s ->\n Some\n (React.JSX.String (\"action\", \"action\", (s : string)))\n | `Function f ->\n Some\n (React.JSX.Action\n ( \"action\",\n \"action\",\n (f : 'a Runtime.server_function) )));\n ])\n [ children ] )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n module Button_with_formAction_string = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.createElement \"button\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n (match\n (`String \"\"\n : [ `String of string\n | `Function of 'a Runtime.server_function ])\n with\n | `String s ->\n Some\n (React.JSX.String\n (\"formaction\", \"formAction\", (s : string)))\n | `Function f ->\n Some\n (React.JSX.Action\n ( \"formaction\",\n \"formAction\",\n (f : 'a Runtime.server_function) )));\n ])\n [ children ] )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n module Button_with_formAction_function = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.createElement \"button\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n (match\n (`Function\n {\n id = \"123\";\n call = (fun () -> Js.Promise.resolve \"Hello\");\n }\n : [ `String of string\n | `Function of 'a Runtime.server_function ])\n with\n | `String s ->\n Some\n (React.JSX.String\n (\"formaction\", \"formAction\", (s : string)))\n | `Function f ->\n Some\n (React.JSX.Action\n ( \"formaction\",\n \"formAction\",\n (f : 'a Runtime.server_function) )));\n ])\n [ children ] )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n let a =\n Uppercase.make\n (Uppercase.makeProps\n ~children:\n (React.Static\n {\n prerendered = \"\";\n original = React.createElement \"div\" [] [];\n })\n ())\n \n module Async_component = struct\n include struct\n let makeProps ~(children : 'children) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"children\" ~js_name:\"children\"\n ~present:true children\n in\n let __js_obj =\n object\n method children = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < children : 'children > Js.t)\n \n let make ?key:(_ : string option) ~children () =\n React.Async_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.Writer\n {\n emit =\n (fun b ->\n Buffer.add_string b \"
\";\n ReactDOM.write_to_buffer b children;\n Buffer.add_string b \"
\";\n ());\n original =\n (fun () ->\n React.createElement \"div\"\n (Stdlib.List.filter_map Stdlib.Fun.id\n [\n Some\n (React.JSX.String\n ( \"class\",\n \"className\",\n (\"async-component\" : string) ));\n ])\n [ children ]);\n } )\n \n let make ?(key : string option) (Props : < children : 'children > Js.t) =\n make ?key ~children:Props#children ()\n end\n end\n \n let a =\n Async_component.make\n (Async_component.makeProps\n ~children:\n (React.Static\n {\n prerendered = \"\";\n original = React.createElement \"div\" [] [];\n })\n ())\n \n module Sequence = struct\n include struct\n let makeProps ~(lola : 'lola) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"lola\" ~js_name:\"lola\"\n ~present:true lola\n in\n let __js_obj =\n object\n method lola = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < lola : 'lola > Js.t)\n \n let make ?key:(_ : string option) ~lola () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n let state, setState = React.useState lola in\n React.useEffect (fun () ->\n setState lola;\n None);\n React.Writer\n {\n emit =\n (fun b ->\n Buffer.add_string b \"
\";\n ReactDOM.escape_to_buffer b state;\n Buffer.add_string b \"
\";\n ());\n original =\n (fun () ->\n React.createElement \"div\" [] [ React.string state ]);\n } )\n \n let make ?(key : string option) (Props : < lola : 'lola > Js.t) =\n make ?key ~lola:Props#lola ()\n end\n end\n \n module Use_context = struct\n include struct\n let makeProps () =\n let __js_obj = object end in\n (Js.Obj.Internal.register_abstract __js_obj [] : < > Js.t)\n \n let make ?key:(_ : string option) () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n let captured = React.useContext Context.value in\n React.Writer\n {\n emit =\n (fun b ->\n Buffer.add_string b \"
\";\n ReactDOM.escape_to_buffer b captured;\n Buffer.add_string b \"
\";\n ());\n original =\n (fun () ->\n React.createElement \"div\" [] [ React.string captured ]);\n } )\n \n let make ?(key : string option) (_Props : < > Js.t) = make ?key ()\n end\n end\n"
},
{
"path": "packages/server-reason-react-ppx/cram/component-defintion-signatures.t/input.re",
"content": "module Greeting: {\n [@react.component]\n let make: (~mockup: string=?) => React.element;\n} = {\n [@react.component]\n let make = (~mockup: option(string)=?) => {\n ;\n };\n};\n\nmodule MyPropIsOptionOptionBoolLetWithValSig: {\n [@react.component]\n let make: (~myProp: option(bool)=?) => React.element;\n} = {\n [@react.component]\n let make = (~myProp: option(option(bool))=?) => React.null;\n};\n"
},
{
"path": "packages/server-reason-react-ppx/cram/component-defintion-signatures.t/run.t",
"content": " $ ../ppx.sh --output ml input.re\n module Greeting : sig\n include sig\n val makeProps : ?mockup:string -> unit -> < mockup : string option > Js.t\n \n val make :\n (< mockup : string option > Js.t, React.element) React.componentLike\n end\n end = struct\n include struct\n let makeProps ?(mockup : string option) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"mockup\" ~js_name:\"mockup\"\n ~present:(match mockup with None -> false | Some _ -> true)\n mockup\n in\n let __js_obj =\n object\n method mockup = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < mockup : string option > Js.t)\n \n let make ?key:(_ : string option) ?(mockup : string option) () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.Static\n {\n prerendered = \"\";\n original =\n React.createElement \"button\" [] [ React.string \"Hello!\" ];\n } )\n \n let make ?(key : string option) (Props : < mockup : string option > Js.t) =\n make ?key ?mockup:Props#mockup ()\n end\n end\n \n module MyPropIsOptionOptionBoolLetWithValSig : sig\n include sig\n val makeProps : ?myProp:bool option -> unit -> < myProp : bool option > Js.t\n \n val make :\n (< myProp : bool option > Js.t, React.element) React.componentLike\n end\n end = struct\n include struct\n let makeProps ?(myProp : bool option option) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"myProp\" ~js_name:\"myProp\"\n ~present:(match myProp with None -> false | Some _ -> true)\n myProp\n in\n let __js_obj =\n object\n method myProp = !__js_obj_cell_0\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj [ __js_obj_entry_0 ]\n : < myProp : bool option option > Js.t)\n \n let make ?key:(_ : string option) ?(myProp : bool option option) () =\n React.Upper_case_component (Stdlib.__FUNCTION__, fun () -> React.null)\n \n let make ?(key : string option)\n (Props : < myProp : bool option option > Js.t) =\n make ?key ?myProp:Props#myProp ()\n end\n end\n"
},
{
"path": "packages/server-reason-react-ppx/cram/dune",
"content": "(cram\n (package server-reason-react)\n (enabled_if\n (>= %{ocaml_version} 5.2.0))\n (deps\n (package server-reason-react)\n standalone.exe\n dune-describe-pp.sh\n %{bin:refmt}\n %{bin:ocamlformat}\n %{bin:server-reason-react.extract_client_components}\n ppx.sh))\n\n(executable\n (name standalone)\n (modules standalone)\n (libraries server-reason-react.ppx server-reason-react.runtime ppxlib))\n"
},
{
"path": "packages/server-reason-react-ppx/cram/dune-describe-pp.sh",
"content": "#!/bin/bash\n\nset -euo pipefail\n\ndune describe pp \"$@\" | perl -0pe 's/\\A\\s*\\[\\@(?:\\@\\@)?ocaml\\.ppx\\.context\\b.*?(?:\\n\\s*\\];|\\n\\s*\\}\\])\\n?//ms'\n"
},
{
"path": "packages/server-reason-react-ppx/cram/ensure-attributes-are-present.t/input.re",
"content": "[@platform js]\n[@react.component]\nlet make = () => {\n
{React.string(\"lol\")}
;\n};\n"
},
{
"path": "packages/server-reason-react-ppx/cram/ensure-attributes-are-present.t/run.t",
"content": " $ ../ppx.sh --output ml input.re\n include struct\n let makeProps () =\n let __js_obj = object end in\n (Js.Obj.Internal.register_abstract __js_obj [] : < > Js.t)\n \n let make ?key:(_ : string option) () =\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n React.Static\n {\n prerendered = \"
lol
\";\n original = React.createElement \"div\" [] [ React.string \"lol\" ];\n } )\n [@@platform js]\n \n let make ?(key : string option) (_Props : < > Js.t) = make ?key ()\n end [@@platform js]\n"
},
{
"path": "packages/server-reason-react-ppx/cram/external.t/input.re",
"content": "module MyPropIsOptionOptionBoolWithSig = {\n [@react.component] external make: unit => React.element = \"B\";\n};\n"
},
{
"path": "packages/server-reason-react-ppx/cram/external.t/run.t",
"content": " $ ../ppx.sh --output re input.re\n module MyPropIsOptionOptionBoolWithSig = {\n [%%ocaml.error\n \"externals aren't supported on server-reason-react. externals are used to bind to React components defined in JavaScript, in the server, that doesn't make sense. If you need to render this on the server, implement a placeholder or an empty element\"\n ];\n };\n"
},
{
"path": "packages/server-reason-react-ppx/cram/functor.t/input.re",
"content": "module type X_int = {let x: int;};\n\nmodule Func = (M: X_int) => {\n let x = M.x + 1;\n [@react.component]\n let make = (~a, ~b) => {\n print_endline(\"This function should be named `Test$Func`\", M.x);\n ;\n };\n};\n"
},
{
"path": "packages/server-reason-react-ppx/cram/functor.t/run.t",
"content": "Since we generate invalid syntax for the argument of the make fn `(Props : <>)`\nWe need to output ML syntax here, otherwise refmt could not parse it.\n $ ../ppx.sh --output ml input.re\n module type X_int = sig\n val x : int\n end\n \n module Func (M : X_int) = struct\n let x = M.x + 1\n \n include struct\n let makeProps ~(a : 'a) ~(b : 'b) () =\n let __js_obj_cell_0, __js_obj_entry_0 =\n Js.Obj.Internal.slot_ref ~method_name:\"a\" ~js_name:\"a\" ~present:true a\n in\n let __js_obj_cell_1, __js_obj_entry_1 =\n Js.Obj.Internal.slot_ref ~method_name:\"b\" ~js_name:\"b\" ~present:true b\n in\n let __js_obj =\n object\n method a = !__js_obj_cell_0\n method b = !__js_obj_cell_1\n end\n in\n (Js.Obj.Internal.register_abstract __js_obj\n [ __js_obj_entry_0; __js_obj_entry_1 ]\n : < a : 'a ; b : 'b > Js.t)\n \n let make ?key:(_ : string option) ~a =\n (fun ~b () ->\n React.Upper_case_component\n ( Stdlib.__FUNCTION__,\n fun () ->\n print_endline \"This function should be named `Test$Func`\" M.x;\n React.Static\n {\n prerendered = \"\";\n original = React.createElement \"div\" [] [];\n } ))\n [@warning \"-16\"]\n \n let make ?(key : string option) (Props : < a : 'a ; b : 'b > Js.t) =\n make ?key ~a:Props#a ~b:Props#b ()\n end\n end\n"
},
{
"path": "packages/server-reason-react-ppx/cram/jsx-fragment.t/input.re",
"content": "let fragment = foo => [@bla] <> foo ;\n\nlet poly_children_fragment = (foo, bar) => <> foo bar ;\nlet nested_fragment = (foo, bar, baz) => <> foo <> bar baz ;\n\nlet nested_fragment_with_lower = foo => <>
foo
;\n\nmodule Fragment = {\n [@react.component]\n let make = (~name=\"\") =>\n <>\n
{React.string(\"First \" ++ name)}
\n {React.string(\"2nd \" ++ name)} \n ;\n};\n"
},
{
"path": "packages/server-reason-react-ppx/cram/jsx-fragment.t/run.t",
"content": " $ ../ppx.sh --output re input.re\n let fragment = foo => [@bla] React.fragment(React.list([foo]));\n let poly_children_fragment = (foo, bar) =>\n React.fragment(React.list([foo, bar]));\n let nested_fragment = (foo, bar, baz) =>\n React.fragment(\n React.list([foo, React.fragment(React.list([bar, baz]))]),\n );\n let nested_fragment_with_lower = foo =>\n React.fragment(\n React.list([\n React.Writer({\n emit: b => {\n Buffer.add_string(b, \"
![Hydrate error](\"ssr-and-hydration-pipeline.png\")
%}\n\n* React to complain about a hydration error because of the content of className attribute from the server is [className=\"red\"] (IV) and what it expects on the client during hydration is [className=\"blue\"] (V).\n\nTo fix this, the server and client render must provide the same markup.\n\n{2 Possible solution: check if the client is mounted}\n\nThere are cases where your server doesn't have all the information needed to render the same markup on the client. For example, the client can access the DOM and run some calculations like [window.innerWidth] or [getBoundingClientRect].\n\nThe trick here is to make sure the server-render and the first client-render have the same markup, while the second client-render can have any value. This way, React will be happy with the first client-render and will not throw a hydration error.\n\nTo make it happen, we can check if the client is mounted and then change apply the final value. This is often done with a hook that will be executed only after the client is mounted.\n\n{@reasonml[\nmodule UseMounted = {\n let use = () => {\n let (isMounted, setIsMounted) = React.useState(() => false);\n\n React.useEffect0(() => {\n // The useEffect hook will be executed only on the client and after the hydration\n setIsMounted(_ => true);\n None;\n });\n\n isMounted;\n };\n};\n\n[@react.component]\nlet make = () => {\n let isClientMounted = UseMounted.use();\n let backgroundColor = isClientMounted ? \"blue\" : \"red\"\n\n ;\n};\n]}\n\nWith a code like this one, the flow will be:\n\n{%html:![Hydrate error](\"ssr-and-hydration-pipeline-fixed.png\")
%}\n\n** As we can see, isClientMounted is false on III, IV and V and eventually true on VI. So there is no difference between III and IV, and React will be happy with it.\n\nIn this case, we don't even need [switch%platform], as [useEffects] only runs on client and the value is provided on the client.\n\n{1 Some helpers that you can create}\n\nThose helpers are useful, but [server-reason-react] doesn't provide any, this code should live in your project.\n\n{2 UseMounted}\n\n[UseMounted] is a hook to check if the component has mounted.\n\n{@reasonml[\nlet use = () => {\n let (isMounted, setIsMounted) = React.useState(() => false);\n\n React.useEffect0(() => {\n setIsMounted(_ => true);\n None;\n });\n\n isMounted;\n};\n]}\n\n{3 When using it:}\n\nYou should use [UseMounted] whenever you have to deal with variables inside a component. For different JSX, take a look at {{!section-\"server-or-client-render\"} ![\\\"test](\\\"picture/img.png\\\")
\",\n original:\n React.createElement(\n \"img\",\n Stdlib.List.filter_map(\n Stdlib.Fun.id,\n [\n Some(\n [@implicit_arity]\n React.JSX.String(\n \"src\",\n \"src\",\n \"picture/img.png\": string,\n ),\n ),\n Some(\n [@implicit_arity]\n React.JSX.String(\n \"alt\",\n \"alt\",\n \"test picture/img.png\": string,\n ),\n ),\n Some(\n [@implicit_arity]\n React.JSX.String(\"id\", \"id\", \"idimg\": string),\n ),\n ],\n ),\n [],\n ),\n }),\n );\n ReactDOM.write_to_buffer(\n b,\n React.Static({\n prerendered: \"