simon/linol
1
0
Fork 0
mirror of https://github.com/c-cube/linol.git synced 2026-01-21 08:56:40 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge commit '7fbc187548241d93593b8abe4065359b1823d5b7' as 'thirdparty/lsp'

Browse source
This commit is contained in:
Simon Cruanes 2025-04-10 15:44:25 -04:00
commit 9be3237051
513 changed files with 166860 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
thirdparty/lsp/.editorconfig vendored Normal file
View file

@ -0,0 +1,11 @@
root = true
[*]
indent_style = space
indent_size = 2
charset = utf-8
trim_trailing_whitespace = true
insert_final_newline = true
[Makefile]
indent_style = tab

11
thirdparty/lsp/.git-blame-ignore-revs vendored Normal file
View file

@ -0,0 +1,11 @@
# To understand why we need this file, see https://www.moxio.com/blog/43/ignoring-bulk-change-commits-with-git-blame
# add ocamlformat config `wrap-fun-args=false`
75504946eaa6f817550b649df508d61dde12bbda
# Upgrade to OCamlformat 0.26.0
ab49baa5873e7f0b9181dbed3ad89681f1e4bcee
# Upgrade to OCamlformat 0.26.1
1a6419bac3ce012deb9c6891e6b25e2486c33388
# Upgrade to OCamlformat 0.27.0
2ccbee5dd691690228307d3636e2f82c8cdb3902

16
thirdparty/lsp/.github/dependabot.yml vendored Normal file
View file

@ -0,0 +1,16 @@
version: 2
updates:
- package-ecosystem: github-actions
directory: /
schedule:
interval: weekly
labels:
- dependencies
- no changelog
- package-ecosystem: npm
directory: /
schedule:
interval: daily
labels:
- dependencies
- no changelog

103
thirdparty/lsp/.github/workflows/build-and-test.yml vendored Normal file
View file

@ -0,0 +1,103 @@
name: Build and Test
on:
pull_request:
push:
branches:
- master
schedule:
# Prime the caches every Monday
- cron: 0 1 * * MON
jobs:
build-and-test:
name: Build and Test
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
- macos-latest
- windows-latest
runs-on: ${{ matrix.os }}
steps:
- name: Set git to use LF
run: |
git config --global core.autocrlf false
git config --global core.eol lf
- name: Checkout tree
uses: actions/checkout@v4
with:
submodules: true
- name: Set-up Node.js
uses: actions/setup-node@v4
with:
node-version: lts/*
- name: Install npm packages
run: yarn install --frozen-lockfile
- name: Set-up OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: "ocaml-base-compiler.5.3.0"
# Remove this pin once a compatible version of Merlin has been released
- name: Pin dev Merlin
run: opam --cli=2.1 pin --with-version=5.4-503 https://github.com/ocaml/merlin.git#main
- name: Build and install dependencies
run: opam install .
# the makefile explains why we don't use --with-test
# ppx expect is not yet compatible with 5.1 and test output vary from one
# compiler to another. We only test on 4.14.
- name: Install test dependencies
run: opam exec -- make install-test-deps
- name: Run build @all
run: opam exec -- make all
- name: Run the unit tests
run: opam exec -- make test-ocaml
- name: Run the template integration tests
run: opam exec -- make test-e2e
coverage:
name: Coverage
runs-on: ubuntu-latest
steps:
- name: Checkout tree
uses: actions/checkout@v4
with:
submodules: true
- name: Set-up OCaml
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: "ocaml-base-compiler.5.3.0"
- name: Set git user
run: |
git config --global user.name github-actions[bot]
git config --global user.email github-actions[bot]@users.noreply.github.com
# Remove this pin once a compatible version of Merlin has been released
- name: Pin dev Merlin
run: opam --cli=2.1 pin --with-version=5.4-503 https://github.com/ocaml/merlin.git#main
- name: Install dependencies
run: |
opam install . --deps-only
opam exec -- make coverage-deps install-test-deps
- run: opam exec -- make test-coverage
env:
COVERALLS_REPO_TOKEN: ${{ github.token }}
PULL_REQUEST_NUMBER: ${{ github.event.number }}

13
thirdparty/lsp/.github/workflows/changelog.yml vendored Normal file
View file

@ -0,0 +1,13 @@
name: Changelog check
on:
pull_request:
branches: [master]
types: [opened, synchronize, reopened, labeled, unlabeled]
jobs:
Changelog-Entry-Check:
name: Check Changelog Action
runs-on: ubuntu-latest
steps:
- uses: tarides/changelog-check-action@v3

31
thirdparty/lsp/.github/workflows/nix.yml vendored Normal file
View file

@ -0,0 +1,31 @@
name: "Nix"
on:
pull_request:
push:
branches:
- master
jobs:
# tests:
# runs-on: ubuntu-latest
# steps:
# - name: Checkout tree
# uses: actions/checkout@v4
# with:
# submodules: true
# - name: nix
# uses: cachix/install-nix-action@v30
# with:
# nix_path: nixpkgs=channel:nixos-unstable
# - run: nix develop .#check -c make nix-tests
fmt:
runs-on: ubuntu-latest
steps:
- name: Checkout tree
uses: actions/checkout@v4
with:
submodules: true
- name: nix
uses: cachix/install-nix-action@v30
with:
nix_path: nixpkgs=channel:nixos-unstable
- run: nix develop .#fmt -c make nix-fmt

21
thirdparty/lsp/.github/workflows/update-flake-lock.yml vendored Normal file
View file

@ -0,0 +1,21 @@
name: Update Nix Flake Lock
on:
workflow_dispatch:
schedule:
- cron: 0 0 * * 0
jobs:
lockfile:
runs-on: ubuntu-latest
steps:
- name: Checkout code
uses: actions/checkout@v4
- uses: cachix/install-nix-action@v30
with:
nix_path: nixpkgs=channel:nixos-unstable
- uses: DeterminateSystems/update-flake-lock@v24
with:
pr-labels: |
dependencies
no changelog

12
thirdparty/lsp/.gitignore vendored Normal file
View file

@ -0,0 +1,12 @@
_build/
_opam/
.idea/
.log/
.vscode/
node_modules/
tmp/
.DS_Store
.merlin
*.install
*.log
result

3
thirdparty/lsp/.ocamlformat vendored Normal file
View file

@ -0,0 +1,3 @@
version=0.27.0
profile=janestreet
ocaml-version=4.14.0

3
thirdparty/lsp/.ocamlformat-ignore vendored Normal file
View file

@ -0,0 +1,3 @@
vendor
_opam
_esy

769
thirdparty/lsp/CHANGES.md vendored Normal file
View file

@ -0,0 +1,769 @@
# 1.22.0
## Features
- Enable experimental project-wide renaming of identifiers (#1431)
# 1.21.0
## Features
- Add a new server option `standardHover`, that can be used by clients to
disable the default hover provider. When `standardHover = false`
`textDocument/hover` requests always returns with empty result. (#1416)
# 1.20.1
## Fixes
- Deactivate the `jump` code actions by default. Clients can enable them with
the `merlinJumpCodeActions` configuration option. Alternatively a custom
request is provided for ad hoc use of the feature. (#1411)
# 1.20.0
## Features
- Add custom
[`ocamllsp/typeSearch`](/ocaml-lsp-server/docs/ocamllsp/typeSearch-spec.md) request (#1369)
- Make MerlinJump code action configurable (#1376)
- Add support for OCaml 5.3 (#1386)
- Add custom [`ocamllsp/jump`](/ocaml-lsp-server/docs/ocamllsp/merlinJump-spec.md) request (#1374)
## Fixes
- Fix fd leak in running external processes for preprocessing (#1349)
- Fix prefix parsing for completion of object methods (#1363, fixes #1358)
- Remove some duplicates in the `selectionRange` answers (#1368)
# 1.19.0
## Features
- Add custom [`ocamllsp/getDocumentation`](/ocaml-lsp-server/docs/ocamllsp/getDocumentation-spec.md) request (#1336)
- Add support for OCaml 5.2 (#1233)
- Add a code-action for syntactic and semantic movement shortcuts based on Merlin's Jump command (#1364)
## Fixes
- Kill unnecessary ocamlformat processes with sigterm rather than sigint or
sigkill (#1343)
## Features
- Add custom [`ocamllsp/construct`](https://github.com/ocaml/ocaml-lsp/blob/ocaml-lsp-server/docs/ocamllsp/construct-spec.md) request (#1348)
# 1.18.0
## Features
- Introduce a configuration option to control dune diagnostics. The option is
called `duneDiganostics` and it may be set to `{ enable: false }` to disable
diagnostics. (#1221)
- Support folding of `ifthenelse` expressions (#1031)
- Improve hover behavior (#1245)
Hovers are no longer displaye on useless parsetree nodes such as keywords,
comments, etc.
Multiline hovers are now filtered away.
Display expanded ppx's in the hover window.
- Improve document symbols (#1247)
Use the parse tree instead of the typed tree. This means that document
symbols will work even if the source code doesn't type check.
Include symbols at arbitrary depth.
Differentiate functions / types / variants / etc.
This now includes PPXs like `let%expect_test` or `let%bench` in the outline.
- Introduce a `destruct-line` code action. This is an improved version of the
old `destruct` code action. (#1283)
- Improve signature inference to only include types for elements that were
absent from the signature. Previously, all signature items would always be
inserted. (#1289)
- Add an `update-signature` code action to update the types of elements that
were already present in the signature (#1289)
- Add custom
[`ocamllsp/merlinCallCompatible`](https://github.com/ocaml/ocaml-lsp/blob/e165f6a3962c356adc7364b9ca71788e93489dd0/ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-spec.md)
request (#1265)
- Add custom [`ocamllsp/typeEnclosing`](https://github.com/ocaml/ocaml-lsp/blob/109801e56f2060caf4487427bede28b824f4f1fe/ocaml-lsp-server/docs/ocamllsp/typeEnclosing-spec.md) request (#1304)
## Fixes
- Detect document kind by looking at merlin's `suffixes` config.
This enables more lsp features for non-.ml/.mli files. Though it still
depends on merlin's support. (#1237)
- Correctly accept the `--clientProcessId` flag. (#1242)
- Disable automatic completion and signature help inside comments (#1246)
- Includes a new optional/configurable option to toggle syntax documentation. If
toggled on, allows display of syntax documentation on hover tooltips. Can be
controlled via environment variables and by GUI for VS code. (#1218)
- For completions on labels that the LSP gets from merlin, take into account
whether the prefix being completed starts with `~` or `?`. Change the label
completions that start with `?` to start with `~` when the prefix being
completed starts with `~`. (#1277)
- Fix document syncing (#1278, #1280, fixes #1207)
- Stop generating inlay hints on generated code (#1290)
- Fix parenthesizing of function types in `SignatureHelp` (#1296)
- Fix syntax documentation rendering (#1318)
# 1.17.0
## Fixes
- Fix missing super & subscripts in markdown documentation. (#1170)
- Do not invoke dune at all if `--fallback-read-dot-merlin` flag is on. (#1173)
- Fix semantic highlighting of infix operators that contain '.'. (#1186)
- Disable highlighting unit as an enum member to fix comment highlighting bug. (#1185)
- Improve type-on-hover and type-annotate efficiency by only formatting the type
of the first enclosing. (#1191, #1196)
- Fix the encoding of URI's to match how vscode does it (#1197)
- Fix parsing of completion prefixes (#1181)
## Features
- Compatibility with Odoc 2.3.0, with support for the introduced syntax: tables,
and "codeblock output" (#1184)
- Display text of references in doc strings (#1166)
- Add mark/remove unused actions for open, types, for loop indexes, modules,
match cases, rec, and constructors (#1141)
- Add inlay hints for types on let bindings (#1159)
- Offer auto-completion for the keyword `in` (#1217)
# 1.16.2
## Fixes
- Fix file permissions used when specifying output files of pp and ppx. (#1153)
# 1.16.1
## Fixes
- Support building with OCaml 5.0 and 5.1 (#1150)
# 1.16.0
## Fixes
- Disable code lens by default. The support can be re-enabled by explicitly
setting it in the configuration. (#1134)
- Fix initilization of `ocamlformat-rpc` in some edge cases when ocamlformat is
initialized concurrently (#1132)
- Kill unnecessary `$ dune ocaml-merlin` with SIGTERM rather than SIGKILL
(#1124)
- Refactor comment parsing to use `odoc-parser` and `cmarkit` instead of
`octavius` and `omd` (#1088)
This allows users who migrated to omd 2.X to install ocaml-lsp-server in the
same opam switch.
We also slightly improved markdown generation support and fixed a couple in
the generation of inline heading and module types.
- Allow opening documents that were already open. This is a workaround for
neovim's lsp client (#1067)
- Disable type annotation for functions (#1054)
- Respect codeActionLiteralSupport capability (#1046)
- Fix a document syncing issue when utf-16 is the position encoding (#1004)
- Disable "Type-annotate" action for code that is already annotated.
([#1037](https://github.com/ocaml/ocaml-lsp/pull/1037)), fixes
[#1036](https://github.com/ocaml/ocaml-lsp/issues/1036)
- Fix semantic highlighting of long identifiers when using preprocessors
([#1049](https://github.com/ocaml/ocaml-lsp/pull/1049), fixes
[#1034](https://github.com/ocaml/ocaml-lsp/issues/1034))
- Fix the type of DocumentSelector in cram document registration (#1068)
- Accept the `--clientProcessId` command line argument. (#1074)
- Accept `--port` as a synonym for `--socket`. (#1075)
- Fix connecting to dune rpc on Windows. (#1080)
## Features
- Add "Remove type annotation" code action. (#1039)
- Support settings through `didChangeConfiguration` notification (#1103)
- Add "Extract local" and "Extract function" code actions. (#870)
- Depend directly on `merlin-lib` 4.9 (#1070)
# 1.15.1
## Fixes
- Fix race condition when a document was being edited and dune in watch mode was
running ([#1005](https://github.com/ocaml/ocaml-lsp/pull/1005), fixes
[#941](https://github.com/ocaml/ocaml-lsp/issues/941),
[#1003](https://github.com/ocaml/ocaml-lsp/issues/1003))
# 1.15.0
## Features
- Enable [semantic highlighting](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_semanticTokens)
support by default (#933)
- Support connecting over pipes and socket. Pipes on Windows aren't yet
supported (#946)
[More](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#implementationConsiderations)
about communication channels in LSP specification.
- Re-enable `ocamlformat-rpc` for formatting code snippets (but not files and
not on Windows) (#920, #939)
One needs to have installed either `ocamlformat` package version > 0.21.0 or,
otherwise, `ocamlformat-rpc` package. Note that previously `ocamlformat-rpc`
came in a standalone OPAM package, but since `ocamlformat` version > 0.21.0,
it comes within `ocamlformat` package.
- Add custom
[`ocamllsp/hoverExtended`](https://github.com/ocaml/ocaml-lsp/blob/e165f6a3962c356adc7364b9ca71788e93489dd0/ocaml-lsp-server/docs/ocamllsp/hoverExtended-spec.md#L1)
request (#561)
- Support utf-8 position encoding clients (#919)
[More](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#position) about position encoding in LSP specification.
- Show unwrapped module alias types on hovering over module names. This is due
to upgrading to merlin 4.7 and using merlin's `verbosity=smart` by default
(#942)
## Fixes
- Respect the client's completion item resolve and preSelect capabilities
(#925, #936)
- Disable polling for dune's watch mode on Windows and OCaml 4.14.0 (#935)
- Fix semantic highlighting of "long identifiers," e.g., `Foo.Bar.x` (#932)
- Fix syncing of document contents:
- For ranges that span an entire line (#927)
- Previously, whole line edits would incorrectly eat the newline characters (#971)
# 1.14.2
## Fixes
- Fix random requests failing after switching documents (#904, fixes #898)
- Do not offer related diagnostic information unless the user enables in client
capabilities (#905)
- Do not offer diagnostic tags unless the client supports them (#909)
- Do not attach extra data to diagnostics unless the client supports this
(#910)
- Use /bin/sh instead of /bin/bash. This fixes ocamllsp on NixOS
# 1.14.1
## Fixes
- Fix various server crashes when opening non OCaml/Reason files. Files such as
dune, cram, etc. would cause the server to crash. (#884, fixes #871)
- Ignore unknown tags in merlin configuration to improve forward compatibility
with Dune. (#883)
# 1.14.0
## Features
- Code action for inlining let bindings within a module or expression. (#847)
- Tag "unused code" and "deprecated" warnings, allowing clients to better
display them. (#848)
- Refresh merlin configuration after every dune build in watch mode (#853)
## Fixes
- Respect `showDocument` capabilities. Do not offer commands or code actions
that rely on this request without client support. (#836)
- Fix signatureHelp on .mll files: avoid "Document.dune" exceptions
# 1.13.1
## Fixes
- Fix cwd when executing ppx (#805)
# 1.13.0
## Features
- Code actions for jumping to related files (`.ml`, `.mli`, etc.) (#795)
# 1.12.4
- Allow cancellation of workspace symbols requests (#777)
- Fix unintentionally interleaved jsonrpc IO that would corrupt the session
(#786)
- Ignore `SIGPIPE` . (#788)
# 1.12.3
## Fixes
- Fix a bad interaction between inferred interfaces and promotion code actions
in watch mode (#753)
- Fix URI parsing (#739 fixes #471 and #459)
# 1.12.2
## Fixes
- Fix shutting down an already closed socket (#740)
# 1.12.1
## Fixes
- Fix preprocessing, ppx, and reason support (#735 fixes #696, #706)
- Support `include` in folding ranges (#730)
# 1.12.0
## Features
- Fix cancellation mechanism for all requests (#707)
- Allow cancellation of formatting requests (#707)
- Add `--fallback-read-dot-merlin` to the LSP Server (#705). If `ocamllsp` is
started with this new flag, it will fall back to looking for Merlin
configuration in `.merlin` files rather than calling `dune ocaml-merlin`.
(#705)
- Support folding more ranges (#692)
# 1.11.6
## Fixes
- Stop leaking file descriptors like a sieve (#701)
# 1.11.5
- Fix process termination. Once the lsp server is stepped, the process will
gracefully terminate (#697, fixes #694)
- Forward stderr from dune's merlin configuration to the lsp server's stderr
(#697)
# 1.11.4
## Fixes
- Fix bug with large buffers being resized incorrectly in Lev
- Add folding ranges for more AST types (#680)
# 1.11.3
## Fixes
- Enable dune rpc integration by default (#691, fixes #690)
# 1.11.2
## Fixes
- Fix running external processes on Windows
# 1.11.1
## Fixes
- Fix Uri handling on Windows
- Fix build on MSVC 2015
# 1.11.0
## Features
- Add support for dune in watch mode. The lsp server will now display build
errors in the diagnostics and offer promotion code actions.
- Re-introduce ocamlformat-rpc (#599, fixes #495)
## Fixes
- Fix workspace symbols that could have a wrong path in some cases
([#675](https://github.com/ocaml/ocaml-lsp/pull/671))
# 1.10.6
## Fixes
- Compatiblity with OCaml 4.14.0
# 1.10.5
## Fixes
- Patch merlin to remove the result module
# 1.10.4
## Fixes
- Use newer versions of ocamlformat-rpc-lib (fixes #697)
# 1.10.3
## Fixes
- Fix more debouncing bugs (#629)
# 1.10.2
## Fixes
- Catch merlin desturct exceptions (#626)
- Fix broken debouncing (#627)
# 1.10.1
## Fixes
- Fix executing ppx executables
# 1.10.0
## Features
- Add better support for code folding: more folds and more precise folds
## Fixes
- Fix infer interface code action crash when implementation source does not
exist (#597)
- Improve error message when the reason plugin for merlin is absent (#608)
- Fix `chdir` races when running ppx (#550)
- More accurate completion kinds.
New completion kinds for variants and fields. Removed inaccurate completion
kinds for constructors and types. (#510)
- Fix handling request cancellation (#616)
# 1.9.1
## Fixes
- Disable functionality reliant on ocamlformat-rpc for now (#555)
- 4.13 compatiblity
# 1.9.0 (11/21/2021)
## Fixes
- Ppx processes are now executed correctly (#513)
## Breaking Change
- ocamllsp drops support for `.merlin` files, and as a consequence no longer
depends on dot-merlin-reader. (#523)
## Features
- New code action to automatically remove values, types, opens (#502)
# 1.8.3 (09/26/2021)
- Fix debouncing of document updates. It was essentially completely broken in
all but the most trivial cases. (#509 fixes #504)
- Fix completion when passing named and functional arguments (#512)
# 1.8.2 (09/14/2021)
- Disable experimental dune support. It was accidentally left enabled.
# 1.8.1 (09/12/2021)
- Update to latest merlin.
# 1.8.0 (08/19/2021)
## Fixes
- Handle workspace change notifications. Previously, the server would only use
the set of workspaces given at startup to search for workspace symbols. After
this change, workspace folders that are added later will also be considered.
(#498)
## Features
- Add a new code action `Add missing rec keyword`, which is available when
adding a `rec` keyword can fix `Unbound value ...` error, e.g.,
```ocaml
let fact n = if n = 0 then 1 else n * fact (n - 1)
(* ^^^^ Unbound value fact *)
```
Adding `rec` to the definition of `fact` will fix the problem. The new code
action offers adding `rec`.
- Use ocamlformat to properly format type snippets. This feature requires the
`ocamlformat-rpc` opam package to be installed. (#386)
- Add completion support for polymorphic variants, when it is possible to pin
down the precise type. Examples (`<|>` stands for the cursor) when completion
will work (#473)
Function application:
```
let foo (a: [`Alpha | `Beta]) = ()
foo `A<|>
```
Type explicitly shown:
```
let a : [`Alpha | `Beta] = `B<|>
```
Note: this is actually a bug fix, since we were ignoring the backtick when
constructing the prefix for completion.
- Parse merlin errors (best effort) into a more structured form. This allows
reporting all locations as "related information" (#475)
- Add support for Merlin `Construct` command as completion suggestions, i.e.,
show complex expressions that could complete the typed hole. (#472)
- Add a code action `Construct an expression` that is shown when the cursor is
at the end of the typed hole, i.e., `_|`, where `|` is the cursor. The code
action simply triggers the client (currently only VS Code is supported) to
show completion suggestions. (#472)
- Change the formatting-on-save error notification to a warning notification
(#472)
- Code action to qualify ("put module name in identifiers") and unqualify
("remove module name from identifiers") module names in identifiers (#399)
Starting from:
```ocaml
open Unix
let times = Unix.times ()
let f x = x.Unix.tms_stime, x.Unix.tms_utime
```
Calling "remove module name from identifiers" with the cursor on the open
statement will produce:
```ocaml
open Unix
let times = times ()
let f x = x.tms_stime, x.tms_utime
```
Calling "put module name in identifiers" will restore:
```ocaml
open Unix
let times = Unix.times ()
let f x = x.Unix.tms_stime, x.Unix.tms_utime
```
## Fixes
- Do not show "random" documentation on hover
- fixed by [merlin#1364](https://github.com/ocaml/merlin/pull/1364)
- fixes duplicate:
- [ocaml-lsp#344](https://github.com/ocaml/ocaml-lsp/issues/344)
- [vscode-ocaml-platform#111](https://github.com/ocamllabs/vscode-ocaml-platform/issues/111)
- Correctly rename a variable used as a named/optional argument (#478)
- When reporting an error at the beginning of the file, use the first line not
the second (#489)
# 1.7.0 (07/28/2021)
## Features
- Add sub-errors as "related" information in diagnostics (#457)
- Add support for navigating to a symbol inside a workspace (#398)
- Show typed holes as errors
Merlin has a concept of "typed holes" that are syntactically represented as `_`. Files
that incorporate typed holes are not considered valid OCaml, but Merlin and OCaml-LSP
support them. One example when such typed holes can occur is when on "destructs" a value,
e.g., destructing `(Some 1)` will generate code `match Some 1 with Some _ -> _ | None -> _`. While the first underscore is a valid "match-all"/wildcard pattern, the rest of
underscores are typed holes.
# 1.6.1 (05/17/2020)
## Fixes
- Switch `verbosity` from 1 to 0. This is the same default that merlin uses.
The old value for verbosity (#433)
- Get fresh diagnostics (warning and error messages) on a file save (#438)
Note: If you want the fresh diagnostics to take into account changes in other
files, you likely need to rebuild your project. An easy way to get automatic
rebuilds is to run `dune` in a watching mode, e.g.,[dune build --watch].
# 1.6.0 (04/30/2020)
## Features
- Code action to annotate a value with its type (#397)
## Fixes
- Fix interface/implementation switching on Windows (#427)
- Correctly parse project paths with spaces and other special characters that
must be escaped.
- Print types with `-short-paths` even if the project wasn't built yet
# 1.5.0 (03/18/2020)
- Support 4.12 and drop support for all earlier versions
- Update to the latest version of merlin
# 1.4.1 (03/16/2020)
## Fixes
- Backport fixes from merlin (#382, #383)
- Encode request & notification `params` in a list. This is required by the
spec. (#351)
# 1.4.0 (12/17/2020)
## Features
- Support cancellation notifications when possible. (#323)
- Implement signature help request for functions (#324)
- Server LSP requests & notifications concurrently. Requests that require merlin
are still serialized. (#330)
# 1.3.0 (11/23/2020)
## Features
- Code action to insert inferred module interface (#308)
- Filter keywords by context (#307)
# 1.2.0 (11/16/2020)
## Features
- Add keyword completion
- Add go to declaration functionality to jump to a value's specification in a
.mli file (#294)
## Fixes
- #245: correctly use mutexes on OpenBSD (#264)
- #268: Do not use vendored libraries when building the lsp package (#260)
- #271: Clear diagnostics when files are closed
- Disable non-prefix completion. There's no reliably way to trigger it and it
can be slow.
# 1.1.0 (10/14/2020)
## Features
- Implement a command to switch between module interfaces and implementations
(#254)
## Fixes
- Do not crash on invalid positions (#248)
- add missing record fields to list of completions (#253)
- do not offer `destruct` as a code action in interface files (#255)
# 1.0.0 (08/28/2020)
- Initial Release

13
thirdparty/lsp/CODE_OF_CONDUCT.md vendored Normal file
View file

@ -0,0 +1,13 @@
# Code of Conduct
This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md).
# Enforcement
This project follows the OCaml Code of Conduct
[enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement).
To report any violations, please contact:
- Sonja Heinze <sonja [at] tarides [dot] com>
- Ulysse Gérard <ulysse [at] tarides [dot] com>
- Xavier Van de Woestyne <xavier [at] tarides [dot] com>

124
thirdparty/lsp/CONTRIBUTING.md vendored Normal file
View file

@ -0,0 +1,124 @@
# Contributing to ocaml-lsp
OCaml-lsp is a community oriented open-source project and we encourage and value
any kind of contribution. Thanks for taking the time to contribute 🐫 !
## Code of Conduct
OCaml-lsp adheres to the OCaml Code of Conduct as stated in the [Code of Conduct
document](CODE_OF_CONDUCT.md). By participating, you are expected to uphold this
code. Please report unacceptable behavior either to local contacts (listed in
[here](CODE_OF_CONDUCT.md)) or to someone listed in the upstream [OCaml Code of
Conduct](CODE_OF_CONDUCT.md).
## Documentation
Much of the information relating to the repository, such as installation
guidelines, how to set up a development environment and how to run unit tests,
can be found in the project [README](README.md). And custom requests are
documented in the
[ocaml-lsp-server/docs/ocamllsp](ocaml-lsp-server/docs/ocamllsp) directory.
Contributions to the documentation are welcome!
## Question, bug reports and feature requests
We rely on [Github's issue tracker](https://github.com/ocaml/ocaml-lsp/issues) for
support questions, feature requests and bug reports.
When reporting an issue, please include a precise reproduction in the bug report
when that's possible, as it is a very useful tool to investigate. You should
also check that you are using the latest version of OCaml-lsp and that a similar
issue has not already been submitted.
## Code contributions
### Styleguides
- **OCaml**: a large part of the code base is written in OCaml and the project
is configured to work with
[ocamlformat](https://ocaml.org/p/ocamlformat/latest) (version defined in the
[`.ocamlformat` file](.ocamlformat)).
- **TypeScript**: TypeScript is used to describe certain end-to-end tests
(abbreviated as `e2e`) and the project uses the
[prettier](https://prettier.io/) formatter. But the TypeScript testsuite is
deprecated (we do not allow extending them anymore. Gradually we'll rewrite
them all to OCaml).
Apart from that, the project tries to apply implicit conventions, at the
decision of the maintainers. At the same time, it tries to follow certain naming
conventions:
- use of `t` manifest types in modules, when it makes sense;
- conversion functions respecting the naming scheme: `to_xxx` or `of_xxx`;
- When you want to provide a conversion function for JSON, use the following
convention: `t_of_yojson` and `yojson_of_t` to fit properly with
`ppx_yojson_conv`.
Changes unrelated to the issue addressed by a PR should be made in a separate
PR. Additionally, formatting changes in parts of the code not concerned by a
specific PR should be proposed in another PR.
Ideally, any opened issue should be accompanied by a test with a reproduction.
When working on a fix for an issue, the first commit should contain the test
showing the issue. Following commits should fix the issue and update the test
result accordingly.
### Repository organization
The repository exposes a number of separate libraries (some of which are
internal) and vendor libraries (to reduce the dependencies required by the
project). Here is a list of the libraries exposed by the project.
#### ocaml-lsp-server
Contains the concrete implementation of a protocol server language for OCaml. A
frontend used in particular by [Visual Studio
Code](https://github.com/ocamllabs/vscode-ocaml-platform), but also by code
editors supporting LSP. The code lives mainly in the following directories:
[ocaml-lsp-server/](ocaml-lsp-server/).
In addition, the project exposes two sub-directories dedicated to [code
actions](ocaml-lsp-server/src/code_actions) and [custom
requests](https://github.com/ocaml/ocaml-lsp/tree/master/ocaml-lsp-server/src/custom_requests).
In most cases, it is likely that the contributions will focus solely on this
project.
##### Warning
For historical reasons, but also for development convenience, `ocaml-lsp-server`
should not build logic based on `Typedtree` (which changes from version to
version and migration logic is not provided by `lsp`, nor `ocaml-lsp-server` but
by [Merlin](https://github.com/ocaml/merlin)). If a command, or a constant,
relies on the `Typedtree`, it can be marked as _unstable_. Another approach,
more robust, is to build a command in Merlin that handles the logic to ensure
the migration is localized to a single project.
#### lsp
Implementation of the LSP protocol in OCaml. It is designed to be as portable as
possible and does not make any assumptions about IO. This is the implementation
of the plumbing required to describe the LSP protocol and is used by a concrete
server (for example the OCaml server) to describe the exposition of the
protocol. The code lives mainly in the following directories: [lsp/](lsp/) and
[lsp-fiber/](lsp-fiber/).
##### Warning
The set of types forming the LSP protocol API is generated automatically by a
[preprocessor](lsp/bin) based on the [protocol
specification](https://microsoft.github.io/language-server-protocol/overviews/lsp/overview/).
The pair of [types.ml](lsp/src/types.ml) and [types.mli](lsp/src/types.mli)
files must be consciously modified manually (never modifying the parts marked as
being generated by CINAPS, the preprocessor).
#### jsonrpc
Describes an implementation of the [JSON-RPC
2.0](https://www.jsonrpc.org/specification) protocol, which is mainly used as a
communication protocol for LSP. The code lives mainly in the following
directories: [jsonrpc](jsonrpc/) and [jsonrpc-fiber/](jsonrpc-fiber/).

16
thirdparty/lsp/LICENSE.md vendored Normal file
View file

@ -0,0 +1,16 @@
ISC License
Copyright (X) 2018-2019, the [ocaml-lsp
contributors](https://github.com/ocaml/ocaml-lsp/graphs/contributors)
Permission to use, copy, modify, and distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

104
thirdparty/lsp/Makefile vendored Normal file
View file

@ -0,0 +1,104 @@
.DEFAULT_GOAL := all
TEST_E2E_DIR = ocaml-lsp-server/test/e2e
.PHONY: yarn-install
yarn-install:
yarn install --frozen-lockfile
-include Makefile.dev
.PHONY: all
all:
dune build @all
# we don't use --with-test because it pulls test dependencies transitively in
# practice this ends up pulling a lot of extra packages which invariably
# results in a conflict
.PHONY: install-test-deps
install-test-deps:
opam install --yes cinaps 'ppx_expect>=v0.17.0' \
ocamlformat.$$(awk -F = '$$1 == "version" {print $$2}' .ocamlformat)
.PHONY: dev
dev: ## Setup a development environment
opam switch create --no-install . ocaml-base-compiler.4.14.0
opam install -y dune-release merlin ocamlformat utop ocaml-lsp-server
opam install --locked --deps-only --with-doc -y .
$(MAKE) install-test-deps
.PHONY: install
install: ## Install the packages on the system
dune build @install && dune install
.PHONY: lock
lock: ## Generate the lock files
opam lock -y .
.PHONY: bench
bench: ##
dune exec ocaml-lsp-server/bench/ocaml_lsp_bench.exe --profile bench
.PHONY: test-ocaml
test-ocaml: ## Run the unit tests
dune build @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
.PHONY: promote
promote:
dune promote
.PHONY: check
check:
dune build @check
.PHONY: test-e2e
test-e2e: yarn-install
dune build @install && dune exec -- ocaml-lsp-server/test/run_test_e2e.exe
.PHONY: promote-e2e
promote-e2e:
dune build @install && cd $(TEST_E2E_DIR) && dune exec -- yarn run promote
.PHONY: test
test: test-ocaml test-e2e
.PHONY: clean
clean: ## Clean build artifacts and other generated files
dune clean
.PHONY: fmt
fmt: ## Format the codebase with ocamlformat
dune build @fmt --auto-promote
.PHONY: watch
watch: ## Watch for the filesystem and rebuild on every change
dune build --watch
.PHONY: utop
utop: ## Run a REPL and link with the project's libraries
dune utop . -- -implicit-bindings
.PHONY: release
release: ## Release on Opam
dune-release distrib --skip-build --skip-lint --skip-tests --include-submodules
# See https://github.com/ocamllabs/dune-release/issues/206
DUNE_RELEASE_DELEGATE=github-dune-release-delegate dune-release publish distrib --verbose
dune-release opam pkg
dune-release opam submit
.PHONY: nix-tests
nix-tests: yarn-install
make test
.PHONY: nix-fmt
nix-fmt: yarn-install
dune build @fmt --auto-promote
.PHONY: coverage-deps
coverage-deps:
opam install -y bisect_ppx
.PHONY: test-coverage
test-coverage:
dune build --instrument-with bisect_ppx --force @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
bisect-ppx-report send-to Coveralls

423
thirdparty/lsp/README.md vendored Normal file
View file

@ -0,0 +1,423 @@
# OCaml-LSP <!-- omit from toc -->
<!-- TOC is updated automatically by "Markdown All in One" vscode extension -->
[![Build][build-badge]][build]
[![Coverage Status][coverall-badge]][coverall]
[build-badge]: https://github.com/ocaml/ocaml-lsp/actions/workflows/build-and-test.yml/badge.svg
[build]: https://github.com/ocaml/ocaml-lsp/actions
[coverall-badge]: https://coveralls.io/repos/github/ocaml/ocaml-lsp/badge.svg?branch=master
[coverall]: https://coveralls.io/github/ocaml/ocaml-lsp?branch=master
OCaml-LSP is a language server for OCaml that implements [Language Server
Protocol](https://microsoft.github.io/language-server-protocol/) (LSP).
> If you use Visual Studio Code, see OCaml Platform extension
> [page](https://github.com/ocamllabs/vscode-ocaml-platform) for detailed
> instructions on setting up your editor for OCaml development with OCaml-LSP:
> what packages need to be installed, how to configure your project and get
> most out of the OCaml editor support, and how to report and debug problems.
- [Installation](#installation)
- [Installing with package managers](#installing-with-package-managers)
- [Opam](#opam)
- [Esy](#esy)
- [Installing from sources](#installing-from-sources)
- [Additional package installations](#additional-package-installations)
- [Usage](#usage)
- [Integration with Dune RPC](#integration-with-dune-rpc)
- [Merlin configuration (advanced)](#merlin-configuration-advanced)
- [Features](#features)
- [Semantic highlighting](#semantic-highlighting)
- [LSP Extensions](#lsp-extensions)
- [Unusual features](#unusual-features)
- [Debugging](#debugging)
- [Contributing to project](#contributing-to-project)
- [Changelog](#changelog)
- [Tests](#tests)
- [Relationship to Other Tools](#relationship-to-other-tools)
- [History](#history)
- [Comparison to other LSP Servers for OCaml](#comparison-to-other-lsp-servers-for-ocaml)
## Installation
Below we show how to install OCaml-LSP using opam, esy, and from sources. OCaml-LSP comes in a package called `ocaml-lsp-server` but the installed program (i.e., binary) is called `ocamllsp`.
### Installing with package managers
#### Opam
To install the language server in the currently used opam [switch](https://opam.ocaml.org/doc/Manual.html#Switches):
```sh
$ opam install ocaml-lsp-server
```
_Note:_ you will need to install `ocaml-lsp-server` in every switch where you
would like to use it.
#### Esy
To add the language server to an esy project, run in terminal:
```sh
$ esy add @opam/ocaml-lsp-server
```
### Installing from sources
This project uses submodules to handle dependencies. This is done so that users
who install `ocaml-lsp-server` into their sandbox will not share dependency
constraints on the same packages that `ocaml-lsp-server` is using.
```sh
$ git clone --recurse-submodules http://github.com/ocaml/ocaml-lsp.git
$ cd ocaml-lsp
$ make install
```
### Additional package installations
- Install [ocamlformat](https://github.com/ocaml-ppx/ocamlformat#installation)
package if you want source file formatting support.
Note: To have source file formatting support in your project, there needs to
be an `.ocamlformat` file present in your project's root directory.
- OCaml-LSP also uses a program called `ocamlformat-rpc` to format code that is
either generated or displayed by OCaml-LSP, e.g., when you hover over a module
identifier, you can see its typed nicely formatted. This program comes with
`ocamlformat` (version > 0.21.0). Previously, it was a standalone package.
## Usage
Usually, your code editor, or some extension/plugin that you install on it, is
responsible for launching `ocamllsp`.
Important: OCaml Language Server has its information about the files from the
last time your built your project. We recommend using the Dune build system and
running it in "watch" mode to always have correctly functioning OCaml-LSP, e.g.,
`dune build --watch`.
### Integration with Dune RPC
> since OCaml-LSP 1.11.0
OCaml-LSP can communicate with Dune's RPC system to offer some interesting
features. User can launch Dune's RPC system by running Dune in watch mode.
OCaml-LSP will *not* launch Dune's RPC for you. But OCaml-LSP will see if there
is an RPC running and will communicate with it automatically.
There are various interesting features and caveats:
1. Dune's RPC enables new kinds of diagnostics (i.e., warnings and errors) to be
shown in the editor, e.g., mismatching interface and implementation files.
You need to save the file to refresh such diagnostics because Dune doesn't
see unsaved files; otherwise, you may see stale (no longer correct) warnings
or errors. OCaml-LSP updates diagnostics after each build is complete in
watch mode.
2. Dune file promotion support. If you, for example, use `ppx_expect` and have
failing tests, you will get a diagnostic when Dune reports that your file can
be promoted. You can promote your file using the code action `Promote`.
### Merlin configuration (advanced)
If you would like OCaml-LSP to respect your `.merlin` files, OCaml-LSP needs to
be invoked with `--fallback-read-dot-merlin` argument passed to it and you must
have the `dot-merlin-reader` package installed.
## Features
<!-- TODO:
this is quite a large list (which becomes even larger since it's missing some requests), which is not necessarily of big interest to users.
We should consider:
1. Moving it to the bottom
2. Converting it into a table
| Description | Method | OCaml | Reason | Dune | Menhir | .ocamlformat | ...
| Auto-completion | textDocument/completion | x | x | o | o | o | ...
3. (not sure how) Generate the table automatically because, otherwise, it's outdated frequently.
-->
The server supports the following LSP requests (inexhaustive list):
- [x] `textDocument/completion`
- [x] `completionItem/resolve`
- [x] `textdocument/hover`
- [ ] `textDocument/signatureHelp`
- [x] `textDocument/declaration`
- [x] `textDocument/definition`
- [x] `textDocument/typeDefinition`
- [ ] `textDocument/implementation`
- [x] `textDocument/codeLens`
- [x] `textDocument/documentHighlight`
- [x] `textDocument/documentSymbol`
- [x] `textDocument/references`
- [ ] `textDocument/documentColor`
- [ ] `textDocument/colorPresentation`
- [x] `textDocument/formatting`
- [ ] `textDocument/rangeFormatting`
- [ ] `textDocument/onTypeFormatting`
- [x] `textDocument/prepareRename`
- [x] `textDocument/foldingRange`
- [x] `textDocument/selectionRange`
- [x] `workspace/didChangeConfiguration`
- [x] `workspace/symbol`
Note that degrees of support for each LSP request are varying.
## Configuration
[Read more about configurations supported by ocamllsp](./ocaml-lsp-server/docs/ocamllsp/config.md)
### Semantic highlighting
> since OCaml-LSP 1.15.0 (since version `1.15.0-4.14` for OCaml 4, `1.15.0-5.0` for OCaml 5)
Semantic highlighting support is enabled by default.
> since OCaml-LSP 1.14.0
OCaml-LSP implements experimental semantic highlighting support (also known as
semantic tokens support). The support can be activated by passing an environment
variable to OCaml-LSP:
- To enable non-incremental (expectedly slower but more stable) version, pass
`OCAMLLSP_SEMANTIC_HIGHLIGHTING=full` environment variable to OCaml-LSP.
- To enable incremental (potentially faster but more error-prone, at least on VS
Code) version, pass `OCAMLLSP_SEMANTIC_HIGHLIGHTING=full/delta` to OCaml-LSP.
Tip (for VS Code OCaml Platform users): You can use `ocaml.server.extraEnv`
setting in VS Code to pass various environment variables to OCaml-LSP.
```json
{
"ocaml.server.extraEnv": {
"OCAMLLSP_SEMANTIC_HIGHLIGHTING": "full"
},
}
```
### LSP Extensions
The server also supports a number of OCaml specific extensions to the protocol:
- [Switch to implementation/interface](ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md)
- [Infer interface](ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md)
- [Locate typed holes](ocaml-lsp-server/docs/ocamllsp/typedHoles-spec.md)
- [Find wrapping AST node](ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md)
Note that editor support for these extensions varies. In general, the OCaml Platform extension for Visual Studio Code will have the best support.
### Unusual features
#### Destructing a value <!-- omit in toc -->
> since OCaml-LSP 1.0.0
OCaml-LSP has a code action that allows to generate an exhaustive pattern
matching for values. For example, placing a cursor near a value `(Some 10)|`
where `|` is your cursor, OCaml-LSP will offer a code action "Destruct", which
replaces `(Some 10)` with `(match Some with | None -> _ | Some _ -> _)`.
Importantly, one can only destruct a value if OCaml-LSP can infer the value's
precise type. The value can be type-annotated, e.g., if it's a function argument
with polymorphic (or yet unknown) type in this context. In the code snippet
below, we type-annotate the function parameter `v` because when we type `let f v
= v|`, the type of `v` is polymorphic, so we can't destruct it.
You can also usually destruct the value by placing the cursor on the wildcard
(`_`) pattern in a pattern-match. For example,
```ocaml
type t = A | B of string option
let f (v : t) = match v with | A -> _ | B _| -> _
```
invoking destruct near the cursor (`|`) in the snippet above, you get
```ocaml
type t = A | B of string option
let f (v : t) = match v with | A -> _ | B (None) | B (Some _) -> _
```
Importantly, note the underscores in place of expressions in each branch of the
pattern match above. The underscores that occur in place of expressions are
called "typed holes" - a concept explained below.
Tip (formatting): generated code may not be greatly formatted. If your project
uses a formatter such as OCamlFormat, you can run formatting and get a
well-formatted document (OCamlFormat supports typed holes formatting).
Tip (for VS Code OCaml Platform users): You can destruct a value using a keybinding
<kbd>Alt</kbd>+<kbd>D</kbd> or on MacOS <kbd>Option</kbd>+<kbd>D</kbd>
#### Typed holes <!-- omit in toc -->
> since OCaml-LSP 1.8.0
OCaml-LSP has a concept of a "typed hole" syntactically represented as `_`
(underscore). A typed hole represents a well-typed "substitute" for an
expression. OCaml-LSP considers these underscores that occur in place of
expressions as a valid well-typed OCaml program: `let foo : int = _` (the typed
hole has type `int` here) or `let bar = _ 10` (the hole has type `int -> 'a`).
One can use such holes during development as temporary substitutes for
expressions and "plug" the holes later with appropriate expressions.
Note, files that incorporate typed holes are *not* considered valid OCaml by the
OCaml compiler and, hence, cannot be compiled.
Also, an underscore occurring in place of a pattern (for example `let _ = 10`)
should not be confused with a typed hole that occurs in place of an expression,
e.g., `let a = _`.
#### Constructing values by type (experimental) <!-- omit in toc -->
> since OCaml-LSP 1.8.0
OCaml-LSP can "construct" expressions based on the type required and offer them
during auto-completion. For example, typing `_` (typed hole) in the snippet
below will trigger auto-completion (`|` is your cursor):
```ocaml
(* file foo.ml *)
type t = A | B of string option
(* file bar.ml *)
let v : Foo.t = _|
```
The auto-completion offers completions `Foo.A` and `Foo.B _`. You can further
construct values by placing the cursor as such: `Foo.B _|` and triggering code
action "Construct an expression" which offers completions `None` and `Some _`.
Trigger the same code action in `Some _|` will offer `""` - one of the possible
expressions to replace the typed hole with.
Constructing a value is thus triggered either by typing `_` in place of an
expression or trigger the code action "Construct an Expression". Also, the type
of the value needs to be non-polymorphic to construct a meaningful value.
Tip (for VS Code OCaml Platform users): You can construct a value using a keybinding
<kbd>Alt</kbd>+<kbd>C</kbd> or on MacOS <kbd>Option</kbd>+<kbd>C</kbd>
#### Syntax Documentation
> since OCaml-LSP 1.18.0
OCaml-LSP can display documentation about the node under the cursor when
the user hovers over some OCaml code. For example, hovering over the code
snippet below will display some information about what the syntax
is:
```ocaml
type point = {x: int; y: int}
```
Hovering over the above will
display:
```
ocaml type point = { x : int; y : int }
syntax Record type:
Allows you to define variants with a fixed set of fields, and all of the
constructors for a record variant type must have the same fields. See
Manual
```
The documentation is gotten from the Merlin engine which receives
the nodes under the cursor and infers what the syntax may be about, and
displays the required information along with links to the manual for further
reading.
Syntax Documentation is an optional feature and can be activated by
using the LSP config system with the key called `syntaxDocumentation` and can
be enabled via setting it to `{ enable: true }`.
## Debugging
If you use Visual Studio Code, please see OCaml Platform extension
[page](https://github.com/ocamllabs/vscode-ocaml-platform) for a detailed guide
on how to report and debug problems.
If you use another code editor and use OCaml-LSP, you should be able to set the
server trace to `verbose` using your editor's LSP client and watch the trace
for errors such as logged exceptions.
## Contributing to project
```bash
# clone repo with submodules
git clone --recursive git@github.com:ocaml/ocaml-lsp.git
cd ocaml-lsp
# if you already cloned, pull submodules
git submodule update --init --recursive
# create local switch (or use global one)
opam switch --yes create .
# don't forget to set your environment to use the local switch
eval $(opam env)
# install dependencies
make install-test-deps
# build
make all
# the ocamllsp executable can be found at _build/default/ocaml-lsp-server/bin/main.exe
```
### Changelog
User-visible changes should come with an entry in the changelog under the appropriate part of
the **unreleased** section. PR that doesn't provide an entry will fail CI check. This behavior
can be overridden by using the "no changelog" label, which is used for changes that are not user-visible.
## Tests
To run tests execute:
```sh
$ make test
```
Note that tests require [Node.js](https://nodejs.org/en/) and
[Yarn](https://yarnpkg.com/lang/en/) installed.
## Relationship to Other Tools
The lsp server uses merlin under the hood, but users are not required to have
merlin installed. We vendor merlin because we currently heavily depend on some
implementation details of merlin that make it infeasible to upgrade the lsp
server and merlin independently.
## History
The implementation of the lsp protocol itself was taken from
[facebook's hack](https://github.com/facebook/hhvm/blob/master/hphp/hack/src/utils/lsp/lsp.mli)
Previously, this lsp server was a part of merlin, until it was realized that
the lsp protocol covers a wider scope than merlin.
## Comparison to other LSP Servers for OCaml
Note that the comparisons below make no claims of being objective and may be
entirely out of
date. Also, both servers seem deprecated.
- [reason-language-server](https://github.com/jaredly/reason-language-server)
This server supports
[bucklescript](https://github.com/BuckleScript/bucklescript) &
[reason](https://github.com/facebook/reason). However, this project does not
use merlin which means that it supports fewer versions of OCaml and offers less
"smart" functionality - especially in the face of sources that do not yet
compile.
- [ocaml-language-server](https://github.com/ocaml-lsp/ocaml-language-server)
This project is extremely similar in the functionality it provides because it
also reuses merlin on the backend. The essential difference is that this
project is written in typescript, while our server is in OCaml. We feel that
it's best to use OCaml to maximize the contributor pool.

23
thirdparty/lsp/biome.json vendored Normal file
View file

@ -0,0 +1,23 @@
{
"$schema": "node_modules/@biomejs/biome/configuration_schema.json",
"formatter": {
"enabled": true,
"ignore": ["lsp/bin/metamodel/metaModel.json", "package.json"],
"useEditorconfig": true
},
"linter": {
"enabled": true,
"ignore": ["ocaml-lsp-server/test/e2e/**"],
"rules": {
"recommended": true
}
},
"organizeImports": {
"enabled": true
},
"vcs": {
"clientKind": "git",
"enabled": true,
"useIgnoreFile": true
}
}

13
thirdparty/lsp/dune vendored Normal file
View file

@ -0,0 +1,13 @@
(vendored_dirs vendor)
(data_only_dirs submodules)
(rule
(copy lsp.opam.template jsonrpc.opam.template))
(rule
(copy lsp.opam.template ocaml-lsp-server.opam.template))
(env
(_
(flags :standard -alert -unstable -w -58)))

82
thirdparty/lsp/dune-project vendored Normal file
View file

@ -0,0 +1,82 @@
(lang dune 3.0)
(using cinaps 1.0)
(name lsp)
(implicit_transitive_deps false)
(license ISC)
(maintainers "Rudi Grinberg <me@rgrinberg.com>")
(authors
"Andrey Popp <8mayday@gmail.com>"
"Rusty Key <iam@stfoo.ru>"
"Louis Roché <louis@louisroche.net>"
"Oleksiy Golovko <alexei.golovko@gmail.com>"
"Rudi Grinberg <me@rgrinberg.com>"
"Sacha Ayoun <sachaayoun@gmail.com>"
"cannorin <cannorin@gmail.com>"
"Ulugbek Abdullaev <ulugbekna@gmail.com>"
"Thibaut Mattio <thibaut.mattio@gmail.com>"
"Max Lantas <mnxndev@outlook.com>")
(source (github ocaml/ocaml-lsp))
(generate_opam_files true)
(package
(name lsp)
(synopsis "LSP protocol implementation in OCaml")
(description "
Implementation of the LSP protocol in OCaml. It is designed to be as portable as
possible and does not make any assumptions about IO.
")
(depends
(jsonrpc (= :version))
yojson
(ppx_yojson_conv_lib (>= "v0.14"))
(cinaps :with-test)
(ppx_expect (and (>= v0.17.0) :with-test))
(uutf (>= 1.0.2))
(odoc :with-doc)
(ocaml (>= 4.14))
(ppx_yojson_conv :with-dev-setup)))
(package
(name ocaml-lsp-server)
(synopsis "LSP Server for OCaml")
(description "An LSP server for OCaml.")
(depends
yojson
(base (>= v0.16.0))
(lsp (= :version))
(jsonrpc (= :version))
(re (>= 1.5.0))
(ppx_yojson_conv_lib (>= "v0.14"))
(dune-rpc (>= 3.4.0))
(chrome-trace (>= 3.3.0))
dyn
stdune
(fiber (and (>= 3.1.1) (< 4.0.0)))
(ocaml (and (>= 5.3) (< 5.4)))
xdg
ordering
dune-build-info
spawn
astring
camlp-streams
(ppx_expect (and (>= v0.17.0) :with-test))
(ocamlformat (and :with-test (= 0.27.0)))
(ocamlc-loc (>= 3.7.0))
(pp (>= 1.1.2))
(csexp (>= 1.5))
(ocamlformat-rpc-lib (>= 0.21.0))
(odoc :with-doc)
(merlin-lib (and (>= 5.4) (< 6.0)))
(ppx_yojson_conv :with-dev-setup)))
(package
(name jsonrpc)
(synopsis "Jsonrpc protocol implemenation")
(description "See https://www.jsonrpc.org/specification")
(depends
(ocaml (>= 4.08))
(odoc :with-doc)))

3
thirdparty/lsp/fiber-test/dune vendored Normal file
View file

@ -0,0 +1,3 @@
(library
(name fiber_test)
(libraries fiber stdune dyn pp))

52
thirdparty/lsp/fiber-test/fiber_test.ml vendored Normal file
View file

@ -0,0 +1,52 @@
open Stdune
let print pp = Format.printf "%a@." Pp.to_fmt pp
let print_dyn dyn = print (Dyn.pp dyn)
module Scheduler : sig
type t
exception Never
val create : unit -> t
val run : t -> 'a Fiber.t -> 'a
end = struct
type t = unit Fiber.Ivar.t Queue.t
let t_var = Fiber.Var.create ()
let create () = Queue.create ()
exception Never
let run t fiber =
let fiber = Fiber.Var.set t_var t (fun () -> fiber) in
Fiber.run fiber ~iter:(fun () ->
let next =
match Queue.pop t with
| None -> raise Never
| Some e -> Fiber.Fill (e, ())
in
Nonempty_list.[ next ])
;;
end
let test ?(expect_never = false) to_dyn f =
let never_raised = ref false in
let f =
let on_error exn =
Format.eprintf "%a@." Exn_with_backtrace.pp_uncaught exn;
Exn_with_backtrace.reraise exn
in
Fiber.with_error_handler f ~on_error
in
(try Scheduler.run (Scheduler.create ()) f |> to_dyn |> print_dyn with
| Scheduler.Never -> never_raised := true);
match !never_raised, expect_never with
| false, false ->
(* We don't raise in this case b/c we assume something else is being
tested *)
()
| true, true -> print_endline "[PASS] Never raised as expected"
| false, true -> print_endline "[FAIL] expected Never to be raised but it wasn't"
| true, false -> print_endline "[FAIL] unexpected Never raised"
;;

1
thirdparty/lsp/fiber-test/fiber_test.mli vendored Normal file
View file

@ -0,0 +1 @@
val test : ?expect_never:bool -> ('a -> Dyn.t) -> (unit -> 'a Fiber.t) -> unit

115
thirdparty/lsp/flake.lock generated vendored Normal file
View file

@ -0,0 +1,115 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1731533236,
"narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"merlin5_1": {
"flake": false,
"locked": {
"lastModified": 1727427299,
"narHash": "sha256-P9+3BPBWrulS/1r03CqMdicFcgEcLK1Gy7pCAcYt3n4=",
"owner": "ocaml",
"repo": "merlin",
"rev": "650a7865bc37a646250f7c52fa6644d9d4a5218b",
"type": "github"
},
"original": {
"owner": "ocaml",
"ref": "501",
"repo": "merlin",
"type": "github"
}
},
"merlin5_2": {
"flake": false,
"locked": {
"lastModified": 1736508467,
"narHash": "sha256-ZJFtPreWenLlXDokh3dOR+b3LRuZJgs9+6r+tEx9/Vo=",
"owner": "ocaml",
"repo": "merlin",
"rev": "9dcffb9e998703f5f5d6e7c575c30cd822cea210",
"type": "github"
},
"original": {
"owner": "ocaml",
"ref": "main",
"repo": "merlin",
"type": "github"
}
},
"nixpkgs": {
"inputs": {
"nixpkgs": "nixpkgs_2"
},
"locked": {
"lastModified": 1736449896,
"narHash": "sha256-Ct6RqUtqIfazkg1X4o2FXWuYpw0A+OJsd3cFGtmXaqk=",
"owner": "nix-ocaml",
"repo": "nix-overlays",
"rev": "be7cfa6043ed31b17e4b86769c05825c62e55829",
"type": "github"
},
"original": {
"owner": "nix-ocaml",
"repo": "nix-overlays",
"type": "github"
}
},
"nixpkgs_2": {
"locked": {
"lastModified": 1736384491,
"narHash": "sha256-h0hPzFp7iVhCqzBx+kJGdO/KmG8AkYRJ0jKxQ6+diug=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "8e97141d59b87e2bf254cd0920be29955d45a698",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "8e97141d59b87e2bf254cd0920be29955d45a698",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"merlin5_1": "merlin5_1",
"merlin5_2": "merlin5_2",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

184
thirdparty/lsp/flake.nix vendored Normal file
View file

@ -0,0 +1,184 @@
{
inputs = {
flake-utils.url = "github:numtide/flake-utils";
nixpkgs.url = "github:nix-ocaml/nix-overlays";
merlin5_2 = {
url = "github:ocaml/merlin/main";
flake = false;
};
merlin5_1 = {
url = "github:ocaml/merlin/501";
flake = false;
};
};
outputs = { self, flake-utils, nixpkgs, ... }@inputs:
let
package = "ocaml-lsp-server";
ocamlformat = pkgs: pkgs.ocamlformat_0_26_2;
basePackage = {
duneVersion = "3";
version = "n/a";
src = ./.;
doCheck = true;
};
overlay = merlin: final: prev: {
ocaml-lsp = prev.ocaml-lsp.overrideAttrs (_: {
# Do not add share/nix-support, so that dependencies from
# the scope don't leak into dependent derivations
doNixSupport = false;
});
dune-release =
prev.dune-release.overrideAttrs (_: { doCheck = false; });
ocamlPackages = prev.ocamlPackages.overrideScope' (oself: osuper:
let
fixPreBuild = o: {
propagatedBuildInputs = o.propagatedBuildInputs ++ [ oself.pp ];
preBuild = ''
rm -r vendor/csexp vendor/pp
'';
};
in {
# TODO remove these hacks eventually
dyn = osuper.dyn.overrideAttrs fixPreBuild;
dune-private-libs =
osuper.dune-private-libs.overrideAttrs fixPreBuild;
dune-glob = osuper.dune-glob.overrideAttrs fixPreBuild;
dune-action-plugin =
osuper.dune-action-plugin.overrideAttrs fixPreBuild;
dune-rpc = osuper.dune-rpc.overrideAttrs fixPreBuild;
stdune = osuper.stdune.overrideAttrs fixPreBuild;
merlin-lib = osuper.merlin-lib.overrideAttrs (o: { src = merlin; });
});
};
ocamlVersionOverlay =
(ocaml: self: super: { ocamlPackages = ocaml super.ocaml-ng; });
makeLocalPackages = pkgs:
let buildDunePackage = pkgs.ocamlPackages.buildDunePackage;
in rec {
jsonrpc = buildDunePackage (basePackage // {
pname = "jsonrpc";
doCheck = false;
propagatedBuildInputs = with pkgs.ocamlPackages; [ ];
});
lsp = buildDunePackage (basePackage // {
pname = "lsp";
doCheck = false;
propagatedBuildInputs = with pkgs.ocamlPackages; [
jsonrpc
yojson
ppx_yojson_conv_lib
uutf
];
checkInputs = let p = pkgs.ocamlPackages;
in [
p.stdune
p.cinaps
p.ppx_expect
p.ppx_yojson_conv
(ocamlformat pkgs)
];
});
ocaml-lsp = with pkgs.ocamlPackages;
buildDunePackage (basePackage // {
pname = package;
doCheck = false;
checkInputs = let p = pkgs.ocamlPackages;
in [
p.ppx_expect
p.ppx_yojson_conv
(ocamlformat pkgs)
pkgs.yarn
];
buildInputs = [
jsonrpc
lsp
ocamlc-loc
astring
camlp-streams
dune-build-info
re
dune-rpc
chrome-trace
dyn
fiber
xdg
ordering
spawn
csexp
ocamlformat-rpc-lib
stdune
yojson
ppx_yojson_conv_lib
merlin-lib
base
];
propagatedBuildInputs = [ ];
buildPhase = ''
runHook preBuild
dune build ${package}.install --release ''${enableParallelBuilding:+-j $NIX_BUILD_CORES}
runHook postBuild
'';
meta = { mainProgram = "ocamllsp"; };
});
};
in {
overlays.default = (final: prev: {
ocamlPackages = prev.ocamlPackages.overrideScope
(oself: osuper: with oself; makeLocalPackages final);
});
} // (flake-utils.lib.eachDefaultSystem (system:
let
pkgsWithoutOverlays = (import nixpkgs { inherit system; });
makeNixpkgs = ocaml: merlin:
import nixpkgs {
overlays = [ (ocamlVersionOverlay ocaml) (overlay merlin) ];
inherit system;
};
pkgs_5_1 =
makeNixpkgs (ocaml: ocaml.ocamlPackages_5_1) inputs.merlin5_1;
pkgs_5_2 =
makeNixpkgs (ocaml: ocaml.ocamlPackages_5_2) inputs.merlin5_2;
localPackages_5_1 = makeLocalPackages pkgs_5_1;
localPackages_5_2 = makeLocalPackages pkgs_5_2;
devShell = localPackages: nixpkgs:
nixpkgs.mkShell {
buildInputs = [ nixpkgs.ocamlPackages.utop ];
inputsFrom =
builtins.map (x: x.overrideAttrs (p: n: { doCheck = true; }))
(builtins.attrValues localPackages);
};
in {
packages = (localPackages_5_2 // {
default = localPackages_5_2.ocaml-lsp;
ocaml_5_1 = localPackages_5_1;
});
devShells = {
default = devShell localPackages_5_2 pkgs_5_2;
ocaml5_1 = devShell localPackages_5_1 pkgs_5_1;
release = pkgsWithoutOverlays.mkShell {
buildInputs = [ pkgsWithoutOverlays.dune-release ];
};
fmt = pkgsWithoutOverlays.mkShell {
buildInputs = [
# TODO: get rid of ocaml once dune get format without ocaml being
# present
pkgsWithoutOverlays.ocaml
(ocamlformat pkgsWithoutOverlays)
pkgsWithoutOverlays.yarn
pkgsWithoutOverlays.dune_3
];
};
check = pkgs_5_2.mkShell {
inputsFrom = builtins.attrValues localPackages_5_2;
};
};
}));
}

5
thirdparty/lsp/jsonrpc-fiber/src/dune vendored Normal file
View file

@ -0,0 +1,5 @@
(library
(name jsonrpc_fiber)
(libraries fiber dyn jsonrpc ppx_yojson_conv_lib stdune yojson)
(instrumentation
(backend bisect_ppx)))

85
thirdparty/lsp/jsonrpc-fiber/src/import.ml vendored Normal file
View file

@ -0,0 +1,85 @@
module List = ListLabels
include struct
(* TODO remove stdune dependence *)
open Stdune
module Code_error = Code_error
module Exn_with_backtrace = Exn_with_backtrace
end
include struct
open Jsonrpc
module Id = Id
module Response = Response
module Request = Request
module Notification = Notification
module Packet = Packet
end
module Json = struct
type t = Ppx_yojson_conv_lib.Yojson.Safe.t
let to_pretty_string (t : t) = Yojson.Safe.pretty_to_string ~std:false t
let error = Ppx_yojson_conv_lib.Yojson_conv.of_yojson_error
let pp ppf (t : t) = Yojson.Safe.pretty_print ppf t
let rec of_dyn (t : Dyn.t) : t =
match t with
| Opaque -> `String "<opaque>"
| Unit -> `String "()"
| Int i -> `Int i
| Int32 i -> `Int (Int32.to_int i)
| Nativeint i -> `Int (Nativeint.to_int i)
| Int64 i -> `Int (Int64.to_int i)
| Bool b -> `Bool b
| String s -> `String s
| Bytes s -> `String (Bytes.to_string s)
| Char c -> `String (String.make 1 c)
| Float f -> `Float f
| Option None -> `String "<none>"
| Option (Some s) -> of_dyn s
| List xs -> `List (List.map ~f:of_dyn xs)
| Array xs -> `List (List.map ~f:of_dyn (Array.to_list xs))
| Tuple xs -> `List (List.map ~f:of_dyn xs)
| Record r -> `Assoc (List.map r ~f:(fun (k, v) -> k, of_dyn v))
| Variant (name, args) -> `Assoc [ name, of_dyn (List args) ]
| Set xs -> `List (List.map ~f:of_dyn xs)
| Map map -> `List (List.map map ~f:(fun (k, v) -> `List [ of_dyn k; of_dyn v ]))
;;
end
module Log = struct
let level : (string option -> bool) ref = ref (fun _ -> false)
let out = ref Format.err_formatter
type message =
{ message : string
; payload : (string * Json.t) list
}
let msg message payload = { message; payload }
let log ?section k =
if !level section
then (
let message = k () in
(match section with
| None -> Format.fprintf !out "%s@." message.message
| Some section -> Format.fprintf !out "[%s] %s@." section message.message);
(match message.payload with
| [] -> ()
| fields -> Format.fprintf !out "%a@." Json.pp (`Assoc fields));
Format.pp_print_flush !out ())
;;
end
let sprintf = Printf.sprintf
let () =
Printexc.register_printer (function
| Jsonrpc.Response.Error.E t ->
let json = Jsonrpc.Response.Error.yojson_of_t t in
Some ("jsonrpc response error " ^ Json.to_pretty_string (json :> Json.t))
| _ -> None)
;;

369
thirdparty/lsp/jsonrpc-fiber/src/jsonrpc_fiber.ml vendored Normal file
View file

@ -0,0 +1,369 @@
open Import
open Fiber.O
module Id = struct
include Id
module Table = Stdlib.MoreLabels.Hashtbl.Make (Id)
end
module Notify = struct
type t =
| Stop
| Continue
end
module Sender = struct
type t =
{ mutable called : bool
; for_ : Id.t
; send : Response.t -> unit Fiber.t
}
let make id send = { for_ = id; called = false; send }
let send t (r : Response.t) : unit Fiber.t =
Fiber.of_thunk (fun () ->
if t.called
then Code_error.raise "cannot send response twice" []
else if not (Id.equal t.for_ r.id)
then Code_error.raise "invalid id" []
else t.called <- true;
t.send r)
;;
end
exception Stopped of Request.t
let () =
Printexc.register_printer (function
| Stopped req ->
let json = Request.yojson_of_t req in
Some ("Session closed. Request will not be answered. " ^ Json.to_pretty_string json)
| _ -> None)
;;
module Reply = struct
type t =
| Now of Response.t
| Later of ((Response.t -> unit Fiber.t) -> unit Fiber.t)
let now (r : Response.t) = Now r
let later f = Later f
let send (t : t) sender =
match t with
| Now r -> Sender.send sender r
| Later f -> f (fun (r : Response.t) -> Sender.send sender r)
;;
end
module Make (Chan : sig
type t
val send : t -> Packet.t list -> unit Fiber.t
val recv : t -> Packet.t option Fiber.t
val close : t -> [ `Read | `Write ] -> unit Fiber.t
end) =
struct
type 'state t =
{ chan : Chan.t
; on_request : ('state, Request.t) context -> (Reply.t * 'state) Fiber.t
; on_notification : ('state, Notification.t) context -> (Notify.t * 'state) Fiber.t
; pending : (Response.t, [ `Stopped | `Cancelled ]) result Fiber.Ivar.t Id.Table.t
; stopped : unit Fiber.Ivar.t
; name : string
; mutable running : bool
; mutable tick : int
; mutable state : 'state
; mutable pending_requests_stopped : bool
}
and ('a, 'message) context = 'a t * 'message
type cancel = unit Fiber.t
let fire cancel = cancel
module Context = struct
type nonrec ('a, 'id) t = ('a, 'id) context
let message = snd
let session = fst
let state t = (session t).state
end
let log t = Log.log ~section:t.name
let response_of_exn id (exn : Exn_with_backtrace.t) =
let error =
match exn.exn with
| Jsonrpc.Response.Error.E resp -> resp
| _ ->
let data = exn |> Exn_with_backtrace.to_dyn |> Json.of_dyn in
Response.Error.make ~code:InternalError ~data ~message:"uncaught exception" ()
in
Response.error id error
;;
let on_request_fail ctx : (Reply.t * _) Fiber.t =
let req : Request.t = Context.message ctx in
let state = Context.state ctx in
let error = Response.Error.make ~code:InternalError ~message:"not implemented" () in
Fiber.return (Reply.now (Response.error req.id error), state)
;;
let state t = t.state
let on_notification_fail ctx =
let state = Context.state ctx in
Fiber.return (Notify.Continue, state)
;;
let stop_pending_requests t =
Fiber.of_thunk (fun () ->
if t.pending_requests_stopped
then Fiber.return ()
else (
t.pending_requests_stopped <- true;
let to_cancel =
Id.Table.fold t.pending ~init:[] ~f:(fun ~key:_ ~data:x acc -> x :: acc)
in
Id.Table.clear t.pending;
Fiber.parallel_iter to_cancel ~f:(fun ivar ->
let* res = Fiber.Ivar.peek ivar in
match res with
| Some _ -> Fiber.return ()
| None -> Fiber.Ivar.fill ivar (Error `Stopped))))
;;
let create
?(on_request = on_request_fail)
?(on_notification = on_notification_fail)
~name
chan
state
=
let pending = Id.Table.create 10 in
{ chan
; on_request
; on_notification
; pending
; stopped = Fiber.Ivar.create ()
; name
; running = false
; tick = 0
; state
; pending_requests_stopped = false
}
;;
let stopped t = Fiber.Ivar.read t.stopped
let stop t =
Fiber.fork_and_join_unit
(fun () -> Chan.close t.chan `Read)
(fun () -> stop_pending_requests t)
;;
let close t =
Fiber.all_concurrently_unit
[ Chan.close t.chan `Read
; Chan.close t.chan `Write
; Fiber.Ivar.fill t.stopped ()
; stop_pending_requests t
]
;;
let run t =
let send_response resp =
log t (fun () ->
Log.msg "sending response" [ "response", Response.yojson_of_t resp ]);
Chan.send t.chan [ Response resp ]
in
let later = Fiber.Pool.create () in
let rec loop () =
t.tick <- t.tick + 1;
log t (fun () -> Log.msg "new tick" [ "tick", `Int t.tick ]);
let* res = Chan.recv t.chan in
log t (fun () -> Log.msg "waited for something" []);
match res with
| None -> Fiber.return ()
| Some packet ->
(match packet with
| Notification r -> on_notification r
| Request r -> on_request r
| Response r ->
let* () = Fiber.Pool.task later ~f:(fun () -> on_response r) in
loop ()
| Batch_call _ -> Code_error.raise "batch requests aren't supported" []
| Batch_response _ -> assert false)
and on_response r =
let log (what : string) =
log t (fun () -> Log.msg ("response " ^ what) [ "r", Response.yojson_of_t r ])
in
match Id.Table.find_opt t.pending r.id with
| None ->
log "dropped";
Fiber.return ()
| Some ivar ->
log "acknowledged";
Id.Table.remove t.pending r.id;
let* resp = Fiber.Ivar.peek ivar in
(match resp with
| Some _ -> Fiber.return ()
| None -> Fiber.Ivar.fill ivar (Ok r))
and on_request (r : Request.t) =
log t (fun () -> Log.msg "handling request" []);
let* result =
let sent = ref false in
Fiber.map_reduce_errors
(module Stdune.Monoid.Unit)
~on_error:(fun exn_bt ->
if !sent
then (* TODO log *)
Fiber.return ()
else (
let response = response_of_exn r.id exn_bt in
sent := true;
Fiber.Pool.task later ~f:(fun () -> send_response response)))
(fun () -> t.on_request (t, r))
in
log t (fun () -> Log.msg "received result" []);
match result with
| Error () -> loop ()
| Ok (reply, state) ->
t.state <- state;
let sender = Sender.make r.id send_response in
let* () =
Fiber.Pool.task later ~f:(fun () ->
let+ res =
Fiber.map_reduce_errors
(module Stdune.Monoid.Unit)
(fun () -> Reply.send reply sender)
~on_error:(fun exn_bt ->
if sender.called
then (* TODO we should log *)
Fiber.return ()
else (
let resp = response_of_exn r.id exn_bt in
Sender.send sender resp))
in
match res with
| Ok () -> ()
| Error () -> ())
in
loop ()
and on_notification (r : Notification.t) : unit Fiber.t =
let* res = Fiber.collect_errors (fun () -> t.on_notification (t, r)) in
match res with
| Ok (next, state) ->
t.state <- state;
(match next with
| Stop -> Fiber.return ()
| Continue -> loop ())
| Error errors ->
Format.eprintf
"Uncaught error when handling notification:@.%a@.Error:@.%s@."
Json.pp
(Notification.yojson_of_t r)
(Dyn.to_string (Dyn.list Exn_with_backtrace.to_dyn errors));
loop ()
in
Fiber.of_thunk (fun () ->
t.running <- true;
let* () =
Fiber.fork_and_join_unit
(fun () ->
let* () = loop () in
Fiber.Pool.stop later)
(fun () -> Fiber.Pool.run later)
in
close t)
;;
let check_running t =
if not t.running then Code_error.raise "jsonrpc must be running" []
;;
let notification t (n : Notification.t) =
Fiber.of_thunk (fun () ->
check_running t;
Chan.send t.chan [ Notification n ])
;;
let register_request_ivar t id ivar =
match Id.Table.find_opt t.pending id with
| Some _ -> Code_error.raise "duplicate request id" []
| None -> Id.Table.add t.pending ~key:id ~data:ivar
;;
let read_request_ivar req ivar =
let+ res = Fiber.Ivar.read ivar in
match res with
| Ok s -> s
| Error `Cancelled -> assert false
| Error `Stopped -> raise (Stopped req)
;;
let request t (req : Request.t) =
Fiber.of_thunk (fun () ->
check_running t;
let* () = Chan.send t.chan [ Request req ] in
let ivar = Fiber.Ivar.create () in
register_request_ivar t req.id ivar;
read_request_ivar req ivar)
;;
let request_with_cancel t (req : Request.t) =
let ivar = Fiber.Ivar.create () in
let cancel = Fiber.Ivar.fill ivar (Error `Cancelled) in
let resp =
Fiber.of_thunk (fun () ->
check_running t;
let* () =
let+ () = Chan.send t.chan [ Request req ] in
register_request_ivar t req.id ivar
in
let+ res = Fiber.Ivar.read ivar in
match res with
| Ok s -> `Ok s
| Error `Cancelled -> `Cancelled
| Error `Stopped -> raise (Stopped req))
in
cancel, resp
;;
module Batch = struct
type response =
Jsonrpc.Request.t
* (Jsonrpc.Response.t, [ `Stopped | `Cancelled ]) result Fiber.Ivar.t
type t = [ `Notification of Notification.t | `Request of response ] list ref
let await (req, resp) = read_request_ivar req resp
let create () = ref []
let notification t n = t := `Notification n :: !t
let request (t : t) r : response =
let ivar = Fiber.Ivar.create () in
let resp = r, ivar in
t := `Request resp :: !t;
resp
;;
end
let submit (t : _ t) (batch : Batch.t) =
Fiber.of_thunk (fun () ->
check_running t;
let pending = !batch in
batch := [];
let pending, ivars =
List.fold_left pending ~init:([], []) ~f:(fun (pending, ivars) -> function
| `Notification n -> Jsonrpc.Packet.Notification n :: pending, ivars
| `Request ((r : Request.t), ivar) ->
Jsonrpc.Packet.Request r :: pending, (r.id, ivar) :: ivars)
in
List.iter ivars ~f:(fun (id, ivar) -> register_request_ivar t id ivar);
Chan.send t.chan pending)
;;
end

75
thirdparty/lsp/jsonrpc-fiber/src/jsonrpc_fiber.mli vendored Normal file
View file

@ -0,0 +1,75 @@
module Notify : sig
type t =
| Stop
| Continue
end
module Reply : sig
type t
val now : Jsonrpc.Response.t -> t
val later : ((Jsonrpc.Response.t -> unit Fiber.t) -> unit Fiber.t) -> t
end
(** Raised when the server is shutdown and a pending request will not complete. *)
exception Stopped of Jsonrpc.Request.t
(** IO free implementation of the jsonrpc protocol. We stay completely agnostic
of transport by only dealing with abstract jsonrpc packets *)
module Make (Chan : sig
type t
val send : t -> Jsonrpc.Packet.t list -> unit Fiber.t
val recv : t -> Jsonrpc.Packet.t option Fiber.t
val close : t -> [ `Read | `Write ] -> unit Fiber.t
end) : sig
type 'state t
module Context : sig
type 'a session := 'a t
type ('state, 'message) t
val message : (_, 'message) t -> 'message
val state : ('a, _) t -> 'a
val session : ('a, _) t -> 'a session
end
val create
: ?on_request:(('state, Jsonrpc.Request.t) Context.t -> (Reply.t * 'state) Fiber.t)
-> ?on_notification:
(('state, Jsonrpc.Notification.t) Context.t -> (Notify.t * 'state) Fiber.t)
-> name:string
-> Chan.t
-> 'state
-> 'state t
val state : 'a t -> 'a
val stop : _ t -> unit Fiber.t
val stopped : _ t -> unit Fiber.t
val run : _ t -> unit Fiber.t
val notification : _ t -> Jsonrpc.Notification.t -> unit Fiber.t
val request : _ t -> Jsonrpc.Request.t -> Jsonrpc.Response.t Fiber.t
type cancel
val fire : cancel -> unit Fiber.t
val request_with_cancel
: _ t
-> Jsonrpc.Request.t
-> cancel * [ `Ok of Jsonrpc.Response.t | `Cancelled ] Fiber.t
module Batch : sig
type t
val create : unit -> t
val notification : t -> Jsonrpc.Notification.t -> unit
type response
val await : response -> Jsonrpc.Response.t Fiber.t
val request : t -> Jsonrpc.Request.t -> response
end
val submit : _ t -> Batch.t -> unit Fiber.t
end

22
thirdparty/lsp/jsonrpc-fiber/test/dune vendored Normal file
View file

@ -0,0 +1,22 @@
(library
(name jsonrpc_fiber_tests)
(enabled_if
(>= %{ocaml_version} 4.08))
(inline_tests)
(libraries
base
dyn
fiber
fiber_test
jsonrpc
jsonrpc_fiber
;; This is because of the (implicit_transitive_deps false)
;; in dune-project
ppx_expect
ppx_expect.config
ppx_expect.config_types
ppx_inline_test.config
stdune
yojson)
(preprocess
(pps ppx_expect)))

342
thirdparty/lsp/jsonrpc-fiber/test/jsonrpc_fiber_tests.ml vendored Normal file
View file

@ -0,0 +1,342 @@
open Stdune
open Jsonrpc
open Jsonrpc_fiber
open Fiber.O
open Fiber.Stream
module Stream_chan = struct
type t = Jsonrpc.Packet.t In.t * Jsonrpc.Packet.t Out.t
let close (_, o) what =
match what with
| `Read -> Fiber.return ()
| `Write -> Out.write o None
;;
let send (_, o) p = Fiber.sequential_iter p ~f:(fun x -> Out.write o (Some x))
let recv (i, _) = In.read i
end
module Jrpc = Jsonrpc_fiber.Make (Stream_chan)
module Context = Jrpc.Context
let print_json json = print_endline (Yojson.Safe.pretty_to_string ~std:false json)
let no_output () =
let received_none = ref false in
Out.create (function
| None ->
if !received_none
then failwith "received None more than once"
else received_none := true;
Fiber.return ()
| Some _ -> failwith "unexpected element")
;;
let%expect_test "start and stop server" =
let run () =
let in_ = In.of_list [] in
let jrpc = Jrpc.create ~name:"test" (in_, no_output ()) () in
let run = Jrpc.run jrpc in
Fiber.fork_and_join_unit (fun () -> run) (fun () -> Jrpc.stop jrpc)
in
let () = Fiber_test.test Dyn.opaque run in
[%expect
{|
<opaque> |}]
;;
let%expect_test "server accepts notifications" =
let notif =
{ Jsonrpc.Notification.method_ = "method"; params = Some (`List [ `String "bar" ]) }
in
let run () =
let in_ = In.of_list [ Jsonrpc.Packet.Notification notif ] in
let on_notification c =
let n = Context.message c in
let state = Context.state c in
assert (notif = n);
print_endline "received notification";
Fiber.return (Notify.Stop, state)
in
let jrpc = Jrpc.create ~name:"test" ~on_notification (in_, no_output ()) () in
Jrpc.run jrpc
in
Fiber_test.test Dyn.opaque run;
[%expect
{|
received notification
<opaque> |}]
;;
let of_ref ref =
Fiber.Stream.Out.create (function
| None -> Fiber.return ()
| Some x ->
ref := x :: !ref;
Fiber.return ())
;;
let%expect_test "serving requests" =
let id = `Int 1 in
let request =
{ Jsonrpc.Request.id; method_ = "bla"; params = Some (`List [ `Int 100 ]) }
in
let response_data = `String "response" in
let run () =
let responses = ref [] in
let in_ = In.of_list [ Jsonrpc.Packet.Request request ] in
let on_request c =
let r = Context.message c in
let state = Context.state c in
assert (r = request);
let response = Jsonrpc.Response.ok r.id response_data in
Fiber.return (Reply.now response, state)
in
let out = of_ref responses in
let jrpc = Jrpc.create ~name:"test" ~on_request (in_, out) () in
let+ () = Jrpc.run jrpc in
List.iter !responses ~f:(fun resp ->
let json = Jsonrpc.Packet.yojson_of_t resp in
print_endline (Yojson.Safe.pretty_to_string ~std:false json))
in
Fiber_test.test Dyn.opaque run;
[%expect
{|
{ "id": 1, "jsonrpc": "2.0", "result": "response" }
<opaque> |}]
;;
(* The current client/server implement has no concurrent handling of requests.
We can show this when we try to send a request when handling a response. *)
let%expect_test "concurrent requests" =
let print packet =
print_endline
(Yojson.Safe.pretty_to_string ~std:false (Jsonrpc.Packet.yojson_of_t packet))
in
let waiter chan =
let on_request c =
let self = Context.session c in
let request = Context.message c in
print_endline "waiter: received request";
print (Request request);
let response =
Reply.later (fun send ->
print_endline "waiter: sending response";
let* () = send (Jsonrpc.Response.ok request.id `Null) in
print_endline "waiter: making request";
let* response =
let request = Jsonrpc.Request.create ~id:(`Int 100) ~method_:"shutdown" () in
Jrpc.request self request
in
print_endline "waiter: received response:";
print (Response response);
let* () = send (Jsonrpc.Response.ok request.id `Null) in
print_endline "waiter: stopping";
let+ () = Jrpc.stop self in
print_endline "waiter: stopped")
in
Fiber.return (response, ())
in
Jrpc.create ~name:"waiter" ~on_request chan ()
in
let waitee chan =
let on_request c =
print_endline "waitee: received request";
let request = Context.message c in
print (Request request);
let response =
Reply.later (fun send ->
let* () = send (Jsonrpc.Response.ok request.id (`Int 42)) in
if request.method_ = "shutdown"
then (
let self = Context.session c in
print_endline "waitee: stopping";
let+ () = Jrpc.stop self in
print_endline "waitee: stopped")
else Fiber.return ())
in
let state = Context.state c in
Fiber.return (response, state)
in
Jrpc.create ~on_request ~name:"waitee" chan ()
in
let waitee_in, waiter_out = pipe () in
let waiter_in, waitee_out = pipe () in
let waitee = waitee (waitee_in, waitee_out) in
let waiter = waiter (waiter_in, waiter_out) in
let run () =
let initial_request () =
let request = Jsonrpc.Request.create ~id:(`String "initial") ~method_:"init" () in
print_endline "initial: waitee requests from waiter";
let+ resp = Jrpc.request waitee request in
print_endline "initial request response:";
print (Response resp)
in
Fiber.all_concurrently_unit [ Jrpc.run waitee; initial_request (); Jrpc.run waiter ]
in
Fiber_test.test Dyn.opaque run;
[%expect
{|
initial: waitee requests from waiter
waiter: received request
{ "id": "initial", "method": "init", "jsonrpc": "2.0" }
waiter: sending response
waiter: making request
waitee: received request
{ "id": 100, "method": "shutdown", "jsonrpc": "2.0" }
waitee: stopping
waitee: stopped
initial request response:
{ "id": "initial", "jsonrpc": "2.0", "result": null }
waiter: received response:
{ "id": 100, "jsonrpc": "2.0", "result": 42 }
[FAIL] unexpected Never raised |}]
;;
let%expect_test "test from jsonrpc_test.ml" =
Printexc.record_backtrace false;
let response =
let i = ref 0 in
fun () ->
incr i;
`Int !i
in
let on_request ctx =
let req : Jsonrpc.Request.t = Context.message ctx in
let state = Context.state ctx in
Fiber.return (Reply.now (Jsonrpc.Response.ok req.id (response ())), state)
in
let on_notification ctx =
let n : Jsonrpc.Notification.t = Context.message ctx in
if n.method_ = "raise" then failwith "special failure";
let json = Notification.yojson_of_t n in
print_endline ">> received notification";
print_json json;
Fiber.return (Jsonrpc_fiber.Notify.Continue, ())
in
let responses = ref [] in
let initial_requests =
let request ?params id method_ : Jsonrpc.Packet.t =
Request (Jsonrpc.Request.create ?params ~id ~method_ ())
in
let notification ?params method_ : Jsonrpc.Packet.t =
Notification (Jsonrpc.Notification.create ?params ~method_ ())
in
[ request (`Int 10) "foo"
; request (`String "testing") "bar"
; notification "notif1"
; notification "notif2"
; notification "raise"
]
in
let reqs_in, reqs_out = pipe () in
let chan =
let out = of_ref responses in
reqs_in, out
in
let session = Jrpc.create ~on_notification ~on_request ~name:"test" chan () in
let write_reqs () =
let* () =
Fiber.sequential_iter initial_requests ~f:(fun req -> Out.write reqs_out (Some req))
in
Out.write reqs_out None
in
Fiber_test.test Dyn.opaque (fun () ->
Fiber.fork_and_join_unit write_reqs (fun () -> Jrpc.run session));
List.rev !responses
|> List.iter ~f:(fun packet ->
let json = Jsonrpc.Packet.yojson_of_t packet in
print_json json);
[%expect
{|
>> received notification
{ "method": "notif1", "jsonrpc": "2.0" }
>> received notification
{ "method": "notif2", "jsonrpc": "2.0" }
Uncaught error when handling notification:
{ "method": "raise", "jsonrpc": "2.0" }
Error:
[ { exn = "Failure(\"special failure\")"; backtrace = "" } ]
<opaque>
{ "id": 10, "jsonrpc": "2.0", "result": 1 }
{ "id": "testing", "jsonrpc": "2.0", "result": 2 } |}]
;;
let%expect_test "cancellation" =
let () = Printexc.record_backtrace true in
let print packet =
print_endline
(Yojson.Safe.pretty_to_string ~std:false (Jsonrpc.Packet.yojson_of_t packet))
in
let server_req_ack = Fiber.Ivar.create () in
let client_req_ack = Fiber.Ivar.create () in
let server chan =
let on_request c =
let request = Context.message c in
let state = Context.state c in
print_endline "server: received request";
print (Request request);
let* () = Fiber.Ivar.fill server_req_ack () in
let response =
Reply.later (fun send ->
print_endline "server: waiting for client ack before sending response";
let* () = Fiber.Ivar.read client_req_ack in
print_endline "server: got client ack, sending response";
send (Jsonrpc.Response.ok request.id (`String "Ok")))
in
Fiber.return (response, state)
in
Jrpc.create ~name:"server" ~on_request chan ()
in
let client chan = Jrpc.create ~name:"client" chan () in
let run () =
let client_in, client_out = pipe () in
let server_in, server_out = pipe () in
let client = client (client_in, server_out) in
let server = server (server_in, client_out) in
let request = Jsonrpc.Request.create ~id:(`String "initial") ~method_:"init" () in
let cancel, req = Jrpc.request_with_cancel client request in
let fire_cancellation =
let* () = Fiber.return () in
print_endline "client: waiting for server ack before cancelling request";
let* () = Fiber.Ivar.read server_req_ack in
print_endline "client: got server ack, cancelling request";
let* () = Jrpc.fire cancel in
Fiber.Ivar.fill client_req_ack ()
in
let initial_request =
let* () = Fiber.return () in
print_endline "client: sending request";
let+ resp = req in
match resp with
| `Cancelled -> print_endline "request has been cancelled"
| `Ok resp ->
print_endline "request response:";
print (Response resp)
in
Fiber.all_concurrently
[ fire_cancellation
; Jrpc.run client
; initial_request
>>> Fiber.fork_and_join_unit
(fun () -> Out.write server_out None >>> Jrpc.stop client)
(fun () -> Jrpc.stop server)
; Jrpc.run server
; Jrpc.stopped client
; Jrpc.stopped server
]
in
Fiber_test.test Dyn.opaque run;
[%expect
{|
client: waiting for server ack before cancelling request
client: sending request
server: received request
{ "id": "initial", "method": "init", "jsonrpc": "2.0" }
server: waiting for client ack before sending response
client: got server ack, cancelling request
request has been cancelled
server: got client ack, sending response
<opaque> |}]
;;

0
thirdparty/lsp/jsonrpc-fiber/test/jsonrpc_fiber_tests.mli vendored Normal file
View file

41
thirdparty/lsp/jsonrpc.opam vendored Normal file
View file

@ -0,0 +1,41 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Jsonrpc protocol implemenation"
description: "See https://www.jsonrpc.org/specification"
maintainer: ["Rudi Grinberg <me@rgrinberg.com>"]
authors: [
"Andrey Popp <8mayday@gmail.com>"
"Rusty Key <iam@stfoo.ru>"
"Louis Roché <louis@louisroche.net>"
"Oleksiy Golovko <alexei.golovko@gmail.com>"
"Rudi Grinberg <me@rgrinberg.com>"
"Sacha Ayoun <sachaayoun@gmail.com>"
"cannorin <cannorin@gmail.com>"
"Ulugbek Abdullaev <ulugbekna@gmail.com>"
"Thibaut Mattio <thibaut.mattio@gmail.com>"
"Max Lantas <mnxndev@outlook.com>"
]
license: "ISC"
homepage: "https://github.com/ocaml/ocaml-lsp"
bug-reports: "https://github.com/ocaml/ocaml-lsp/issues"
depends: [
"dune" {>= "3.0"}
"ocaml" {>= "4.08"}
"odoc" {with-doc}
]
dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git"
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@doc" {with-doc}
]
]
x-maintenance-intent: [ "(latest)" "(latest)-414" ]

4
thirdparty/lsp/jsonrpc/src/dune vendored Normal file
View file

@ -0,0 +1,4 @@
(library
(public_name jsonrpc)
(instrumentation
(backend bisect_ppx)))

60
thirdparty/lsp/jsonrpc/src/import.ml vendored Normal file
View file

@ -0,0 +1,60 @@
module List = ListLabels
module Option = struct
let map t ~f =
match t with
| None -> None
| Some x -> Some (f x)
;;
end
module Json = struct
type t =
[ `Assoc of (string * t) list
| `Bool of bool
| `Float of float
| `Int of int
| `Intlit of string
| `List of t list
| `Null
| `String of string
| `Tuple of t list
| `Variant of string * t option
]
exception Of_json of (string * t)
let () =
Printexc.register_printer (function
| Of_json (msg, _) -> Some ("Jsonrpc: json conversion failed: " ^ msg)
| _ -> None)
;;
let error msg json = raise (Of_json (msg, json))
module Jsonable = struct
module type S = sig
type json
type t
val yojson_of_t : t -> json
val t_of_yojson : json -> t
end
with type json := t
end
let field fields name conv = List.assoc_opt name fields |> Option.map ~f:conv
let field_exn fields name conv =
match field fields name conv with
| Some f -> f
| None -> error ("missing field " ^ name) (`Assoc fields)
;;
module Conv = struct
let string_of_yojson = function
| `String s -> s
| json -> error "expected string" json
;;
end
end

319
thirdparty/lsp/jsonrpc/src/jsonrpc.ml vendored Normal file
View file

@ -0,0 +1,319 @@
open Import
open Json.Conv
module Json = Json
module Id = struct
type t =
[ `String of string
| `Int of int
]
let yojson_of_t = function
| `String s -> `String s
| `Int i -> `Int i
;;
let t_of_yojson = function
| `String s -> `String s
| `Int i -> `Int i
| json -> Json.error "Id.t" json
;;
let hash x = Hashtbl.hash x
let equal = ( = )
end
module Constant = struct
let jsonrpc = "jsonrpc"
let jsonrpcv = "2.0"
let id = "id"
let method_ = "method"
let params = "params"
let result = "result"
let error = "error"
end
let assert_jsonrpc_version fields =
let jsonrpc = Json.field_exn fields Constant.jsonrpc Json.Conv.string_of_yojson in
if not (String.equal jsonrpc Constant.jsonrpcv)
then
Json.error
("invalid packet: jsonrpc version doesn't match " ^ jsonrpc)
(`Assoc fields)
;;
module Structured = struct
type t =
[ `Assoc of (string * Json.t) list
| `List of Json.t list
]
let t_of_yojson = function
| `Assoc xs -> `Assoc xs
| `List xs -> `List xs
| json -> Json.error "invalid structured value" json
;;
let yojson_of_t t = (t :> Json.t)
end
module Notification = struct
type t =
{ method_ : string
; params : Structured.t option
}
let fields ~method_ ~params =
let json =
[ Constant.method_, `String method_; Constant.jsonrpc, `String Constant.jsonrpcv ]
in
match params with
| None -> json
| Some params -> (Constant.params, (params :> Json.t)) :: json
;;
let yojson_of_t { method_; params } = `Assoc (fields ~method_ ~params)
let create ?params ~method_ () = { params; method_ }
end
module Request = struct
type t =
{ id : Id.t
; method_ : string
; params : Structured.t option
}
let yojson_of_t { id; method_; params } =
let fields = Notification.fields ~method_ ~params in
`Assoc ((Constant.id, Id.yojson_of_t id) :: fields)
;;
let create ?params ~id ~method_ () = { params; id; method_ }
end
module Response = struct
module Error = struct
module Code = struct
type t =
| ParseError
| InvalidRequest
| MethodNotFound
| InvalidParams
| InternalError
(* the codes below are LSP specific *)
| ServerErrorStart
| ServerErrorEnd
| ServerNotInitialized
| UnknownErrorCode
| RequestFailed
| ServerCancelled
| ContentModified
| RequestCancelled
(* all other codes are custom *)
| Other of int
let of_int = function
| -32700 -> ParseError
| -32600 -> InvalidRequest
| -32601 -> MethodNotFound
| -32602 -> InvalidParams
| -32603 -> InternalError
| -32099 -> ServerErrorStart
| -32000 -> ServerErrorEnd
| -32002 -> ServerNotInitialized
| -32001 -> UnknownErrorCode
| -32800 -> RequestCancelled
| -32801 -> ContentModified
| -32802 -> ServerCancelled
| -32803 -> RequestFailed
| code -> Other code
;;
let to_int = function
| ParseError -> -32700
| InvalidRequest -> -32600
| MethodNotFound -> -32601
| InvalidParams -> -32602
| InternalError -> -32603
| ServerErrorStart -> -32099
| ServerErrorEnd -> -32000
| ServerNotInitialized -> -32002
| UnknownErrorCode -> -32001
| RequestCancelled -> -32800
| ContentModified -> -32801
| ServerCancelled -> -32802
| RequestFailed -> -32803
| Other code -> code
;;
let t_of_yojson json =
match json with
| `Int i -> of_int i
| _ -> Json.error "invalid code" json
;;
let yojson_of_t t = `Int (to_int t)
end
type t =
{ code : Code.t
; message : string
; data : Json.t option
}
let yojson_of_t { code; message; data } =
let assoc = [ "code", Code.yojson_of_t code; "message", `String message ] in
let assoc =
match data with
| None -> assoc
| Some data -> ("data", data) :: assoc
in
`Assoc assoc
;;
let t_of_yojson json =
match json with
| `Assoc fields ->
let code = Json.field_exn fields "code" Code.t_of_yojson in
let message = Json.field_exn fields "message" string_of_yojson in
let data = Json.field fields "data" (fun x -> x) in
{ code; message; data }
| _ -> Json.error "Jsonrpc.Response.t" json
;;
exception E of t
let raise t = raise (E t)
let make ?data ~code ~message () = { data; code; message }
let of_exn exn =
let message = Printexc.to_string exn in
make ~code:InternalError ~message ()
;;
end
type t =
{ id : Id.t
; result : (Json.t, Error.t) Result.t
}
let yojson_of_t { id; result } =
let result =
match result with
| Ok json -> Constant.result, json
| Error e -> Constant.error, Error.yojson_of_t e
in
`Assoc
[ Constant.id, Id.yojson_of_t id
; Constant.jsonrpc, `String Constant.jsonrpcv
; result
]
;;
let t_of_yojson json =
match json with
| `Assoc fields ->
let id = Json.field_exn fields Constant.id Id.t_of_yojson in
let jsonrpc = Json.field_exn fields Constant.jsonrpc Json.Conv.string_of_yojson in
if jsonrpc <> Constant.jsonrpcv
then Json.error "Invalid response" json
else (
match Json.field fields Constant.result (fun x -> x) with
| Some res -> { id; result = Ok res }
| None ->
let result = Error (Json.field_exn fields Constant.error Error.t_of_yojson) in
{ id; result })
| _ -> Json.error "Jsonrpc.Result.t" json
;;
let make ~id ~result = { id; result }
let ok id result = make ~id ~result:(Ok result)
let error id error = make ~id ~result:(Error error)
end
module Packet = struct
type t =
| Notification of Notification.t
| Request of Request.t
| Response of Response.t
| Batch_response of Response.t list
| Batch_call of [ `Request of Request.t | `Notification of Notification.t ] list
let yojson_of_t = function
| Notification r -> Notification.yojson_of_t r
| Request r -> Request.yojson_of_t r
| Response r -> Response.yojson_of_t r
| Batch_response r -> `List (List.map r ~f:Response.yojson_of_t)
| Batch_call r ->
`List
(List.map r ~f:(function
| `Request r -> Request.yojson_of_t r
| `Notification r -> Notification.yojson_of_t r))
;;
let t_of_fields (fields : (string * Json.t) list) =
assert_jsonrpc_version fields;
match Json.field fields Constant.id Id.t_of_yojson with
| None ->
let method_ = Json.field_exn fields Constant.method_ Json.Conv.string_of_yojson in
let params = Json.field fields Constant.params Structured.t_of_yojson in
Notification { Notification.params; method_ }
| Some id ->
(match Json.field fields Constant.method_ Json.Conv.string_of_yojson with
| Some method_ ->
let params = Json.field fields Constant.params Structured.t_of_yojson in
Request { Request.method_; params; id }
| None ->
Response
(match Json.field fields Constant.result (fun x -> x) with
| Some result -> { Response.id; result = Ok result }
| None ->
let error =
Json.field_exn fields Constant.error Response.Error.t_of_yojson
in
{ id; result = Error error }))
;;
let t_of_yojson_single json =
match json with
| `Assoc fields -> t_of_fields fields
| _ -> Json.error "invalid packet" json
;;
let t_of_yojson (json : Json.t) =
match json with
| `List [] -> Json.error "invalid packet" json
| `List (x :: xs) ->
(* we inspect the first element to see what we're dealing with *)
let x =
match x with
| `Assoc fields -> t_of_fields fields
| _ -> Json.error "invalid packet" json
in
(match
match x with
| Notification x -> `Call (`Notification x)
| Request x -> `Call (`Request x)
| Response r -> `Response r
| _ -> Json.error "invalid packet" json
with
| `Call x ->
Batch_call
(x
:: List.map xs ~f:(fun call ->
let x = t_of_yojson_single call in
match x with
| Notification n -> `Notification n
| Request n -> `Request n
| _ -> Json.error "invalid packet" json))
| `Response x ->
Batch_response
(x
:: List.map xs ~f:(fun resp ->
let resp = t_of_yojson_single resp in
match resp with
| Response n -> n
| _ -> Json.error "invalid packet" json)))
| _ -> t_of_yojson_single json
;;
end

128
thirdparty/lsp/jsonrpc/src/jsonrpc.mli vendored Normal file
View file

@ -0,0 +1,128 @@
(** Jsonrpc implementation *)
module Json : sig
type t =
[ `Assoc of (string * t) list
| `Bool of bool
| `Float of float
| `Int of int
| `Intlit of string
| `List of t list
| `Null
| `String of string
| `Tuple of t list
| `Variant of string * t option
]
(** Raised when conversions from json fail *)
exception Of_json of (string * t)
module Jsonable : sig
module type S = sig
type json
type t
val yojson_of_t : t -> json
val t_of_yojson : json -> t
end
with type json := t
end
end
module Id : sig
type t =
[ `String of string
| `Int of int
]
include Json.Jsonable.S with type t := t
val hash : t -> int
val equal : t -> t -> bool
end
module Structured : sig
type t =
[ `Assoc of (string * Json.t) list
| `List of Json.t list
]
include Json.Jsonable.S with type t := t
end
module Notification : sig
type t =
{ method_ : string
; params : Structured.t option
}
val create : ?params:Structured.t -> method_:string -> unit -> t
val yojson_of_t : t -> Json.t
end
module Request : sig
type t =
{ id : Id.t
; method_ : string
; params : Structured.t option
}
val create : ?params:Structured.t -> id:Id.t -> method_:string -> unit -> t
val yojson_of_t : t -> Json.t
end
module Response : sig
module Error : sig
module Code : sig
type t =
| ParseError
| InvalidRequest
| MethodNotFound
| InvalidParams
| InternalError
| ServerErrorStart
| ServerErrorEnd
| ServerNotInitialized
| UnknownErrorCode
| RequestFailed
| ServerCancelled
| ContentModified
| RequestCancelled
| Other of int
end
type t =
{ code : Code.t
; message : string
; data : Json.t option
}
exception E of t
val make : ?data:Json.t -> code:Code.t -> message:string -> unit -> t
val raise : t -> 'a
val of_exn : exn -> t
val yojson_of_t : t -> Json.t
end
type t =
{ id : Id.t
; result : (Json.t, Error.t) Result.t
}
val ok : Id.t -> Json.t -> t
val error : Id.t -> Error.t -> t
include Json.Jsonable.S with type t := t
end
module Packet : sig
type t =
| Notification of Notification.t
| Request of Request.t
| Response of Response.t
| Batch_response of Response.t list
| Batch_call of [ `Request of Request.t | `Notification of Notification.t ] list
include Json.Jsonable.S with type t := t
end

1
thirdparty/lsp/lsp-fiber/src/client.ml vendored Normal file
View file

@ -0,0 +1 @@
include Rpc.Client

1
thirdparty/lsp/lsp-fiber/src/client.mli vendored Normal file
View file

@ -0,0 +1 @@
include module type of Rpc.Client

14
thirdparty/lsp/lsp-fiber/src/dune vendored Normal file
View file

@ -0,0 +1,14 @@
(library
(name lsp_fiber)
(libraries
dyn
fiber
lev_fiber
jsonrpc
jsonrpc_fiber
lsp
ppx_yojson_conv_lib
stdune
yojson)
(instrumentation
(backend bisect_ppx)))

55
thirdparty/lsp/lsp-fiber/src/fiber_io.ml vendored Normal file
View file

@ -0,0 +1,55 @@
open Import
open Fiber.O
module Lio = Lev_fiber.Io
type t = Lio.input Lio.t * Lio.output Lio.t * Fiber.Mutex.t
module Io =
Io.Make
(struct
include Fiber
let raise exn = raise exn
end)
(struct
type input = Lio.Reader.t
type output = Lio.Writer.t
let read_line ic =
let+ res = Lio.Reader.read_line ic in
match res with
| Ok s -> Some s
| Error (`Partial_eof _) -> None
;;
let read_exactly ic len =
let+ res = Lio.Reader.read_exactly ic len in
match res with
| Ok s -> Some s
| Error (`Partial_eof _) -> None
;;
let write oc strings =
Fiber.of_thunk (fun () ->
List.iter strings ~f:(Lio.Writer.add_string oc);
Fiber.return ())
;;
end)
let send (_, oc, m) packets =
Fiber.Mutex.with_lock m ~f:(fun () ->
Lio.with_write oc ~f:(fun writer ->
let* () = Fiber.sequential_iter packets ~f:(Io.write writer) in
Lio.Writer.flush writer))
;;
let recv (ic, _, _) = Lio.with_read ic ~f:Io.read
let make ic oc = ic, oc, Fiber.Mutex.create ()
let close (ic, oc, _) what =
Fiber.of_thunk (fun () ->
(match what with
| `Write -> Lio.close oc
| `Read -> Lio.close ic);
Fiber.return ())
;;

11
thirdparty/lsp/lsp-fiber/src/fiber_io.mli vendored Normal file
View file

@ -0,0 +1,11 @@
(** Reprsents a bi-directional jsonrpc packet stream read in dedicated threads.
TODO Nothing here is specific to jsonrpc *)
open! Import
type t
val close : t -> [ `Read | `Write ] -> unit Fiber.t
val send : t -> Jsonrpc.Packet.t list -> unit Fiber.t
val recv : t -> Jsonrpc.Packet.t option Fiber.t
val make : Lev_fiber.Io.input Lev_fiber.Io.t -> Lev_fiber.Io.output Lev_fiber.Io.t -> t

115
thirdparty/lsp/lsp-fiber/src/import.ml vendored Normal file
View file

@ -0,0 +1,115 @@
module List = Stdlib.ListLabels
module Code_error = Stdune.Code_error
module Header = Lsp.Header
module Io = Lsp.Io
module Fdecl : sig
type 'a t
val get : 'a t -> 'a
val set : 'a t -> 'a -> unit
val create : unit -> 'a t
end = struct
type 'a t = 'a option ref
let create () = ref None
let set t x =
match !t with
| Some _ -> invalid_arg "Fdecl.create: already set"
| None -> t := Some x
;;
let get t =
match !t with
| None -> invalid_arg "Fdecl.get: not set"
| Some t -> t
;;
end
module Json = struct
include Lsp.Import.Json
let pp ppf (t : t) = Yojson.Safe.pretty_print ppf t
let rec of_dyn (t : Dyn.t) : t =
match t with
| Opaque -> `String "<opaque>"
| Unit -> `String "()"
| Int i -> `Int i
| Int32 i -> `Int (Int32.to_int i)
| Nativeint i -> `Int (Nativeint.to_int i)
| Int64 i -> `Int (Int64.to_int i)
| Bool b -> `Bool b
| String s -> `String s
| Bytes s -> `String (Bytes.to_string s)
| Char c -> `String (String.make 1 c)
| Float f -> `Float f
| Option None -> `String "<none>"
| Option (Some s) -> of_dyn s
| List xs -> `List (List.map ~f:of_dyn xs)
| Array xs -> `List (List.map ~f:of_dyn (Array.to_list xs))
| Tuple xs -> `List (List.map ~f:of_dyn xs)
| Record r -> `Assoc (List.map r ~f:(fun (k, v) -> k, of_dyn v))
| Variant (name, args) -> `Assoc [ name, of_dyn (List args) ]
| Set xs -> `List (List.map ~f:of_dyn xs)
| Map map -> `List (List.map map ~f:(fun (k, v) -> `List [ of_dyn k; of_dyn v ]))
;;
let rec to_dyn (t : t) : Dyn.t =
match t with
| `String s -> String s
| `Int i -> Int i
| `Float f -> Float f
| `Bool f -> Bool f
| `Assoc o -> Record (List.map o ~f:(fun (k, v) -> k, to_dyn v))
| `List l -> List (List.map l ~f:to_dyn)
| `Tuple args -> Tuple (List.map args ~f:to_dyn)
| `Null -> Dyn.Variant ("Null", [])
| `Variant (name, Some arg) -> Variant (name, [ to_dyn arg ])
| `Variant (name, None) -> Variant (name, [])
| `Intlit s -> String s
;;
end
module Log = struct
let level : (string option -> bool) ref = ref (fun _ -> false)
let out = ref Format.err_formatter
type message =
{ message : string
; payload : (string * Json.t) list
}
let msg message payload = { message; payload }
let log ?section k =
if !level section
then (
let message = k () in
(match section with
| None -> Format.fprintf !out "%s@." message.message
| Some section -> Format.fprintf !out "[%s] %s@." section message.message);
(match message.payload with
| [] -> ()
| fields -> Format.fprintf !out "%a@." Json.pp (`Assoc fields));
Format.pp_print_flush !out ())
;;
end
let sprintf = Printf.sprintf
module Types = Lsp.Types
module Client_request = Lsp.Client_request
module Server_request = Lsp.Server_request
module Server_notification = Lsp.Server_notification
module Client_notification = Lsp.Client_notification
module Jrpc_id = struct
include Jsonrpc.Id
let to_dyn = function
| `String s -> Dyn.String s
| `Int i -> Dyn.Int i
;;
end

18
thirdparty/lsp/lsp-fiber/src/lazy_fiber.ml vendored Normal file
View file

@ -0,0 +1,18 @@
type 'a t =
{ value : 'a Fiber.Ivar.t
; mutable f : (unit -> 'a Fiber.t) option
}
let create f = { f = Some f; value = Fiber.Ivar.create () }
let force t =
let open Fiber.O in
match t.f with
| None -> Fiber.Ivar.read t.value
| Some f ->
Fiber.of_thunk (fun () ->
t.f <- None;
let* v = f () in
let+ () = Fiber.Ivar.fill t.value v in
v)
;;

4
thirdparty/lsp/lsp-fiber/src/lazy_fiber.mli vendored Normal file
View file

@ -0,0 +1,4 @@
type 'a t
val create : (unit -> 'a Fiber.t) -> 'a t
val force : 'a t -> 'a Fiber.t

11
thirdparty/lsp/lsp-fiber/src/lsp_fiber.ml vendored Normal file
View file

@ -0,0 +1,11 @@
module Fiber_io = Fiber_io
module Lazy_fiber = Lazy_fiber
module Rpc = Rpc
module Client = Client
module Server = Server
module Json = Import.Json
module Private = struct
module Log = Import.Log
module Fdecl = Import.Fdecl
end

450
thirdparty/lsp/lsp-fiber/src/rpc.ml vendored Normal file
View file

@ -0,0 +1,450 @@
open Import
open Fiber.O
module Id = Jsonrpc.Id
module Response = Jsonrpc.Response
module Session = Jsonrpc_fiber.Make (Fiber_io)
module Reply = struct
type 'r t =
| Now of 'r
| Later of (('r -> unit Fiber.t) -> unit Fiber.t)
let now r = Now r
let later f = Later f
end
let cancel_token = Fiber.Var.create ()
module State = struct
type t =
| Waiting_for_init
| Running
| Closed
end
module type S = sig
type 'a out_request
type out_notification
type 'a in_request
type in_notification
type 'state t
module Handler : sig
type 'a session := 'a t
type 'state on_request =
{ on_request : 'a. 'state session -> 'a in_request -> ('a Reply.t * 'state) Fiber.t
}
type 'state t
val make
: ?on_request:'state on_request
-> ?on_notification:('state session -> in_notification -> 'state Fiber.t)
-> unit
-> 'state t
end
val state : 'a t -> 'a
val make : 'state Handler.t -> Fiber_io.t -> 'state -> 'state t
val stop : _ t -> unit Fiber.t
val request : _ t -> 'resp out_request -> 'resp Fiber.t
val notification : _ t -> out_notification -> unit Fiber.t
val cancel_token : unit -> Fiber.Cancel.t option Fiber.t
module Batch : sig
type 'a session := 'a t
type t
val create : _ session -> t
val notification : t -> out_notification -> unit
type 'a response
val await : 'a response -> 'a Fiber.t
val request : t -> 'resp out_request -> 'resp response
val submit : t -> unit Fiber.t
end
end
module type Request_intf = sig
type 'a t
type packed = E : 'r t -> packed
val of_jsonrpc : Jsonrpc.Request.t -> (packed, string) result
val yojson_of_result : 'a t -> 'a -> Json.t
val to_jsonrpc_request : 'a t -> id:Id.t -> Jsonrpc.Request.t
val response_of_json : 'a t -> Json.t -> 'a
end
module type Notification_intf = sig
type t
val of_jsonrpc : Jsonrpc.Notification.t -> (t, string) result
val to_jsonrpc : t -> Jsonrpc.Notification.t
end
module Table = Stdlib.Hashtbl.Make (Jsonrpc.Id)
module Make
(Initialize : sig
type t
end)
(Out_request : Request_intf)
(Out_notification : Notification_intf)
(In_request : Request_intf)
(In_notification : Notification_intf) =
struct
type 'a out_request = 'a Out_request.t
type 'a in_request = 'a In_request.t
type out_notification = Out_notification.t
type in_notification = In_notification.t
type 'state t =
{ io : Fiber_io.t
; (* mutable only to initialiaze this record *)
mutable session : 'state Session.t Fdecl.t
; (* Internal state of the session *)
mutable state : State.t
; (* Filled when the server is initialied *)
initialized : Initialize.t Fiber.Ivar.t
; mutable req_id : int
; pending : Fiber.Cancel.t Table.t
; detached : Fiber.Pool.t
}
and 'state on_request =
{ on_request : 'a. 'state t -> 'a in_request -> ('a Reply.t * 'state) Fiber.t }
and 'state handler =
{ h_on_request : 'state on_request
; h_on_notification : 'state t -> In_notification.t -> 'state Fiber.t
}
module Handler = struct
type nonrec 'state on_request = 'state on_request =
{ on_request : 'a. 'state t -> 'a in_request -> ('a Reply.t * 'state) Fiber.t }
type nonrec 'state t = 'state handler =
{ h_on_request : 'state on_request
; h_on_notification : 'state t -> In_notification.t -> 'state Fiber.t
}
let on_notification_default _ notification =
Format.eprintf "dropped notification@.%!";
let notification = In_notification.to_jsonrpc notification in
Code_error.raise
"unexpected notification"
[ "notification", Json.to_dyn (Jsonrpc.Notification.yojson_of_t notification) ]
;;
let on_request_default =
{ on_request =
(fun _ _ ->
Jsonrpc.Response.Error.make ~code:InternalError ~message:"Not supported" ()
|> Jsonrpc.Response.Error.raise)
}
;;
let make
?(on_request = on_request_default)
?(on_notification = on_notification_default)
()
=
{ h_on_request = on_request; h_on_notification = on_notification }
;;
end
let state t = Session.state (Fdecl.get t.session)
let to_jsonrpc (type state) (t : state t) h_on_request h_on_notification =
let on_request (ctx : (state, Jsonrpc.Request.t) Session.Context.t) =
let req = Session.Context.message ctx in
let state = Session.Context.state ctx in
match In_request.of_jsonrpc req with
| Error message ->
let code = Jsonrpc.Response.Error.Code.InvalidParams in
let error = Jsonrpc.Response.Error.make ~code ~message () in
Fiber.return (Jsonrpc_fiber.Reply.now (Jsonrpc.Response.error req.id error), state)
| Ok (In_request.E r) ->
let cancel = Fiber.Cancel.create () in
let remove = lazy (Table.remove t.pending req.id) in
let+ response, state =
Fiber.with_error_handler
~on_error:
(Stdune.Exn_with_backtrace.map_and_reraise ~f:(fun exn ->
Lazy.force remove;
exn))
(fun () ->
Fiber.Var.set cancel_token cancel (fun () ->
Table.replace t.pending req.id cancel;
h_on_request.on_request t r))
in
let to_response x =
Jsonrpc.Response.ok req.id (In_request.yojson_of_result r x)
in
let reply =
match response with
| Reply.Now r ->
Lazy.force remove;
Jsonrpc_fiber.Reply.now (to_response r)
| Reply.Later k ->
let f send =
Fiber.finalize
(fun () ->
Fiber.Var.set cancel_token cancel (fun () ->
k (fun r -> send (to_response r))))
~finally:(fun () ->
Lazy.force remove;
Fiber.return ())
in
Jsonrpc_fiber.Reply.later f
in
reply, state
in
let on_notification ctx =
let r = Session.Context.message ctx in
match In_notification.of_jsonrpc r with
| Ok r -> h_on_notification t r
| Error error ->
Log.log ~section:"lsp" (fun () ->
Log.msg "Invalid notification" [ "error", `String error ]);
let state = Session.Context.state ctx in
Fiber.return (Jsonrpc_fiber.Notify.Continue, state)
in
on_request, on_notification
;;
let make ~name h_on_request h_on_notification io state =
let t =
{ io
; state = Waiting_for_init
; session = Fdecl.create ()
; initialized = Fiber.Ivar.create ()
; req_id = 1
; pending = Table.create 32
; detached = Fiber.Pool.create ()
}
in
let session =
let on_request, on_notification = to_jsonrpc t h_on_request h_on_notification in
Session.create ~on_request ~on_notification ~name io state
in
Fdecl.set t.session session;
t
;;
let create_request t req =
let id = `Int t.req_id in
t.req_id <- t.req_id + 1;
Out_request.to_jsonrpc_request req ~id
;;
let receive_response req (resp : Jsonrpc.Response.t) =
match resp.result |> Result.map (Out_request.response_of_json req) with
| Ok s -> s
| Error e -> raise (Jsonrpc.Response.Error.E e)
;;
let request (type r) (t : _ t) (req : r Out_request.t) : r Fiber.t =
Fiber.of_thunk (fun () ->
let+ resp =
let req = create_request t req in
Session.request (Fdecl.get t.session) req
in
receive_response req resp)
;;
let request_with_cancel (type r) (t : _ t) cancel ~on_cancel (req : r Out_request.t)
: [ `Ok of r | `Cancelled ] Fiber.t
=
let* () = Fiber.return () in
let jsonrpc_req = create_request t req in
let+ resp, cancel_status =
Fiber.Cancel.with_handler
cancel
~on_cancel:(fun () -> on_cancel jsonrpc_req.id)
(fun () ->
let+ resp = Session.request (Fdecl.get t.session) jsonrpc_req in
match resp.result with
| Error { code = RequestCancelled; _ } -> `Cancelled
| Ok _ when Fiber.Cancel.fired cancel -> `Cancelled
| Ok s -> `Ok (Out_request.response_of_json req s)
| Error e -> raise (Jsonrpc.Response.Error.E e))
in
match cancel_status with
| Cancelled () -> `Cancelled
| Not_cancelled ->
(match resp with
| `Ok resp -> `Ok resp
| `Cancelled -> assert false)
;;
let notification (t : _ t) (n : Out_notification.t) : unit Fiber.t =
let jsonrpc_request = Out_notification.to_jsonrpc n in
Session.notification (Fdecl.get t.session) jsonrpc_request
;;
module Batch = struct
type session = E : 'a t -> session
type t =
{ batch : Session.Batch.t
; session : session
}
let create session = { batch = Session.Batch.create (); session = E session }
let notification t n =
let n = Out_notification.to_jsonrpc n in
Session.Batch.notification t.batch n
;;
type 'a response = 'a Lazy_fiber.t
let await req = Lazy_fiber.force req
let request (type r) (t : t) (req : r Out_request.t) : r response =
let (E session) = t.session in
let response =
let req = create_request session req in
Session.Batch.request t.batch req
in
Lazy_fiber.create (fun () ->
let+ response = Session.Batch.await response in
receive_response req response)
;;
let submit { session = E session; batch } =
let t = Fdecl.get session.session in
Session.submit t batch
;;
end
let initialized t = Fiber.Ivar.read t.initialized
let stop t =
let+ () = Session.stop (Fdecl.get t.session) in
t.state <- Closed
;;
let start_loop t =
Fiber.fork_and_join_unit
(fun () ->
let* () = Session.run (Fdecl.get t.session) in
Fiber.Pool.stop t.detached)
(fun () -> Fiber.Pool.run t.detached)
;;
let handle_cancel_req t id =
let+ () =
match Table.find_opt t.pending id with
| None -> Fiber.return ()
| Some token -> Fiber.Pool.task t.detached ~f:(fun () -> Fiber.Cancel.fire token)
in
Jsonrpc_fiber.Notify.Continue, state t
;;
let cancel_token () = Fiber.Var.get cancel_token
end
module Client = struct
open Types
include
Make (InitializeResult) (Client_request) (Client_notification) (Server_request)
(Server_notification)
let h_on_notification handler t n =
match n with
| Server_notification.CancelRequest id -> handle_cancel_req t id
| _ ->
let+ res = handler.h_on_notification t n in
Jsonrpc_fiber.Notify.Continue, res
;;
let make handler io =
let h_on_notification = h_on_notification handler in
make ~name:"client" handler.h_on_request h_on_notification io
;;
let request_with_cancel t cancel r =
request_with_cancel t cancel r ~on_cancel:(fun id ->
notification t (Client_notification.CancelRequest id))
;;
let start (t : _ t) (p : InitializeParams.t) =
Fiber.of_thunk (fun () ->
assert (t.state = Waiting_for_init);
let loop () = start_loop t in
let init () =
let* resp = request t (Client_request.Initialize p) in
Log.log ~section:"client" (fun () ->
let resp = InitializeResult.yojson_of_t resp in
Log.msg "initialized" [ "resp", resp ]);
t.state <- Running;
Fiber.Ivar.fill t.initialized resp
in
Fiber.fork_and_join_unit loop init)
;;
end
module Server = struct
open Types
include
Make (InitializeParams) (Server_request) (Server_notification) (Client_request)
(Client_notification)
let h_on_notification handler t n =
Fiber.of_thunk (fun () ->
match n with
| Client_notification.Exit ->
Log.log ~section:"server" (fun () -> Log.msg "received exit notification" []);
let* () = stop t in
Fiber.return (Jsonrpc_fiber.Notify.Stop, state t)
| Client_notification.CancelRequest id -> handle_cancel_req t id
| _ ->
if t.state = Waiting_for_init
then (
let state = state t in
Fiber.return (Jsonrpc_fiber.Notify.Continue, state))
else
let+ state = handler.h_on_notification t n in
Jsonrpc_fiber.Notify.Continue, state)
;;
let on_request handler t in_r =
Fiber.of_thunk (fun () ->
match Client_request.E in_r with
| Client_request.E (Client_request.Initialize i) ->
if t.state = Waiting_for_init
then (
let* result = handler.h_on_request.on_request t in_r in
t.state <- Running;
(* XXX Should we wait for the waiter of initialized to finish? *)
let* () = Fiber.Ivar.fill t.initialized i in
Fiber.return result)
else (
let code = Response.Error.Code.InvalidRequest in
let message = "already initialized" in
raise (Jsonrpc.Response.Error.E (Jsonrpc.Response.Error.make ~code ~message ())))
| Client_request.E _ ->
if t.state = Waiting_for_init
then (
let code = Response.Error.Code.ServerNotInitialized in
let message = "not initialized" in
raise (Jsonrpc.Response.Error.E (Jsonrpc.Response.Error.make ~code ~message ())))
else handler.h_on_request.on_request t in_r)
;;
let make (type s) (handler : s Handler.t) io (initial_state : s) =
let h_on_request : _ Handler.on_request =
{ Handler.on_request = (fun t x -> on_request handler t x) }
in
let h_on_notification = h_on_notification handler in
make ~name:"server" h_on_request h_on_notification io initial_state
;;
let start t = start_loop t
end

91
thirdparty/lsp/lsp-fiber/src/rpc.mli vendored Normal file
View file

@ -0,0 +1,91 @@
(** * This encodes LSP RPC state machine. *)
open! Import
module Reply : sig
type 'resp t
val now : 'r -> 'r t
val later : (('r -> unit Fiber.t) -> unit Fiber.t) -> 'r t
end
module type S = sig
type 'a out_request
type out_notification
type 'a in_request
type in_notification
type 'state t
module Handler : sig
type 'a session := 'a t
type 'state on_request =
{ on_request : 'a. 'state session -> 'a in_request -> ('a Reply.t * 'state) Fiber.t
}
type 'state t
val make
: ?on_request:'state on_request
-> ?on_notification:('state session -> in_notification -> 'state Fiber.t)
-> unit
-> 'state t
end
val state : 'a t -> 'a
val make : 'state Handler.t -> Fiber_io.t -> 'state -> 'state t
val stop : 'state t -> unit Fiber.t
val request : _ t -> 'resp out_request -> 'resp Fiber.t
val notification : _ t -> out_notification -> unit Fiber.t
(** only available inside requests *)
val cancel_token : unit -> Fiber.Cancel.t option Fiber.t
module Batch : sig
type 'a session := 'a t
type t
val create : _ session -> t
val notification : t -> out_notification -> unit
type 'a response
val await : 'a response -> 'a Fiber.t
val request : t -> 'resp out_request -> 'resp response
val submit : t -> unit Fiber.t
end
end
module Client : sig
open Types
include
S
with type 'a out_request = 'a Client_request.t
and type out_notification = Client_notification.t
and type 'a in_request = 'a Server_request.t
and type in_notification = Server_notification.t
val request_with_cancel
: _ t
-> Fiber.Cancel.t
-> 'resp out_request
-> [ `Ok of 'resp | `Cancelled ] Fiber.t
val initialized : _ t -> InitializeResult.t Fiber.t
val start : _ t -> InitializeParams.t -> unit Fiber.t
end
module Server : sig
open Types
include
S
with type 'a out_request = 'a Server_request.t
and type out_notification = Server_notification.t
and type 'a in_request = 'a Client_request.t
and type in_notification = Client_notification.t
val initialized : _ t -> InitializeParams.t Fiber.t
val start : _ t -> unit Fiber.t
end

1
thirdparty/lsp/lsp-fiber/src/server.ml vendored Normal file
View file

@ -0,0 +1 @@
include Rpc.Server

2
thirdparty/lsp/lsp-fiber/src/server.mli vendored Normal file
View file

@ -0,0 +1,2 @@
open! Import
include module type of Rpc.Server

29
thirdparty/lsp/lsp-fiber/test/dune vendored Normal file
View file

@ -0,0 +1,29 @@
; we cannot use the normal test alias because cinaps overtakes it
(library
(name lsp_fiber_tests)
(inline_tests)
(preprocess
(pps ppx_expect))
(enabled_if
(>= %{ocaml_version} 4.08))
(libraries
base
fiber
fiber_test
lev
lev_fiber
jsonrpc
jsonrpc_fiber
lsp
lsp_fiber
;; This is because of the (implicit_transitive_deps false)
;; in dune-project
ppx_expect
ppx_expect.config
ppx_expect.config_types
ppx_inline_test.config
ppx_yojson_conv_lib
stdune
threads.posix
yojson))

223
thirdparty/lsp/lsp-fiber/test/lsp_fiber_test.ml vendored Normal file
View file

@ -0,0 +1,223 @@
open Fiber.O
open Lsp
open Lsp.Types
open Lsp_fiber
module Test = struct
module Client = struct
let run
?(capabilities = ClientCapabilities.create ())
?on_request
?on_notification
state
(in_, out)
=
let initialize = InitializeParams.create ~capabilities () in
let client =
let stream_io = Lsp_fiber.Fiber_io.make in_ out in
let handler = Client.Handler.make ?on_request ?on_notification () in
Client.make handler stream_io state
in
client, Client.start client initialize
;;
end
module Server = struct
let run ?on_request ?on_notification state (in_, out) =
let server =
let stream_io = Fiber_io.make in_ out in
let handler = Server.Handler.make ?on_request ?on_notification () in
Server.make handler stream_io state
in
server, Server.start server
;;
end
end
let pipe () = Lev_fiber.Io.pipe ~cloexec:true ()
let test make_client make_server =
Printexc.record_backtrace false;
let run () =
let* client_in, server_out = pipe () in
let* server_in, client_out = pipe () in
let server () = make_server (server_in, server_out) in
let client () = make_client (client_in, client_out) in
let+ () = Fiber.fork_and_join_unit server client in
print_endline "Successful termination of test"
in
Lev_fiber.run run |> Lev_fiber.Error.ok_exn;
print_endline "[TEST] finished"
;;
let json_pp = Yojson.Safe.pretty_print ~std:false
module End_to_end_client = struct
let on_request (type a) _ (_ : a Server_request.t) =
Jsonrpc.Response.Error.raise
(Jsonrpc.Response.Error.make ~message:"not implemented" ~code:InternalError ())
;;
let on_notification (client : _ Client.t) n =
let state = Client.state client in
let received_notification = state in
let req = Server_notification.to_jsonrpc n in
Format.eprintf
"client: received notification@.%a@.%!"
json_pp
(Jsonrpc.Notification.yojson_of_t req);
let+ () = Fiber.Ivar.fill received_notification () in
Format.eprintf "client: filled received_notification@.%!";
state
;;
let run io =
let detached = Fiber.Pool.create () in
let received_notification = Fiber.Ivar.create () in
let client, running =
let on_request = { Client.Handler.on_request } in
Test.Client.run ~on_request ~on_notification received_notification io
in
let init () : unit Fiber.t =
Format.eprintf "client: waiting for initialization@.%!";
let* (_ : InitializeResult.t) = Client.initialized client in
Format.eprintf "client: server initialized. sending request@.%!";
let cancel = Fiber.Cancel.create () in
let* () =
Fiber.Pool.task detached ~f:(fun () ->
Format.eprintf
"client: waiting to receive notification before cancelling the request@.%!";
let* () = Fiber.Ivar.read received_notification in
Format.eprintf "client: received notification, cancelling the request@.%!";
Fiber.Cancel.fire cancel)
in
let* res_cancel =
let req_cancel =
Client_request.ExecuteCommand
(ExecuteCommandParams.create ~command:"cmd_cancel" ())
in
Format.eprintf "client: sending request cmd_cancel@.%!";
Client.request_with_cancel client cancel req_cancel
and* res_reply =
let req_reply =
Client_request.ExecuteCommand
(ExecuteCommandParams.create ~command:"cmd_reply" ())
in
Format.eprintf "client: sending request cmd_reply@.%!";
Client.request client req_reply
in
(match res_cancel with
| `Cancelled -> Format.eprintf "client: req_cancel got cancelled@.%!"
| `Ok _ -> assert false);
Format.eprintf
"client: Successfully executed req_reply with result:@.%a@."
json_pp
res_reply;
Format.eprintf "client: sending request to shutdown@.%!";
let* () = Fiber.Pool.stop detached in
Client.notification client Exit
in
Fiber.fork_and_join_unit init (fun () ->
Fiber.fork_and_join_unit (fun () -> running) (fun () -> Fiber.Pool.run detached))
;;
end
module End_to_end_server = struct
type status =
| Started
| Initialized
let on_request =
let on_request (type a) self (req : a Client_request.t) : (a Rpc.Reply.t * _) Fiber.t =
let state = Server.state self in
let _status, detached = state in
match req with
| Client_request.Initialize _ ->
let capabilities = ServerCapabilities.create () in
let result = InitializeResult.create ~capabilities () in
Format.eprintf "server: initializing server@.";
Format.eprintf "server: returning initialization result@.%!";
Fiber.return (Rpc.Reply.now result, (Initialized, detached))
| Client_request.ExecuteCommand { command; _ } ->
Format.eprintf "server: received command %s@.%!" command;
let* () =
match command with
| "cmd_cancel" ->
Fiber.Pool.task detached ~f:(fun () ->
Format.eprintf "server: sending message notification to client@.%!";
let msg =
ShowMessageParams.create
~type_:MessageType.Info
~message:"notifying client"
in
Server.notification self (Server_notification.ShowMessage msg))
| _ -> Fiber.return ()
in
let* () = Fiber.Pool.stop detached in
let result = `String "successful execution" in
let* cancel = Rpc.Server.cancel_token () in
(match command with
| "cmd_cancel" ->
let+ () = Lev_fiber.Timer.sleepf 0.2 in
( Rpc.Reply.later (fun k ->
let* cancel = Rpc.Server.cancel_token () in
(* Make sure that we can access the cancel token in a Reply
response *)
assert (Option.is_some cancel);
k result)
, state )
| _ ->
(* Make sure that we can access the cancel token in a Now response *)
assert (Option.is_some cancel);
Fiber.return (Rpc.Reply.now result, state))
| _ ->
Jsonrpc.Response.Error.raise
(Jsonrpc.Response.Error.make ~code:InternalError ~message:"not supported" ())
in
{ Server.Handler.on_request }
;;
let on_notification self _ =
let state = Server.state self in
Format.eprintf "server: Received notification@.%!";
Fiber.return state
;;
let run io =
let detached = Fiber.Pool.create () in
let _server, running =
Test.Server.run ~on_request ~on_notification (Started, detached) io
in
Fiber.fork_and_join_unit (fun () -> running) (fun () -> Fiber.Pool.run detached)
;;
end
let%expect_test "end to end run of lsp tests" =
test End_to_end_client.run End_to_end_server.run;
[%expect
{|
client: waiting for initialization
server: initializing server
server: returning initialization result
client: server initialized. sending request
client: sending request cmd_cancel
client: sending request cmd_reply
client: waiting to receive notification before cancelling the request
server: received command cmd_cancel
server: sending message notification to client
client: received notification
{
"params": { "message": "notifying client", "type": 3 },
"method": "window/showMessage",
"jsonrpc": "2.0"
}
client: filled received_notification
client: received notification, cancelling the request
server: received command cmd_reply
client: req_cancel got cancelled
client: Successfully executed req_reply with result:
"successful execution"
client: sending request to shutdown
Successful termination of test
[TEST] finished |}]
;;

0
thirdparty/lsp/lsp-fiber/test/lsp_fiber_test.mli vendored Normal file
View file

52
thirdparty/lsp/lsp.opam vendored Normal file
View file

@ -0,0 +1,52 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "LSP protocol implementation in OCaml"
description: """
Implementation of the LSP protocol in OCaml. It is designed to be as portable as
possible and does not make any assumptions about IO.
"""
maintainer: ["Rudi Grinberg <me@rgrinberg.com>"]
authors: [
"Andrey Popp <8mayday@gmail.com>"
"Rusty Key <iam@stfoo.ru>"
"Louis Roché <louis@louisroche.net>"
"Oleksiy Golovko <alexei.golovko@gmail.com>"
"Rudi Grinberg <me@rgrinberg.com>"
"Sacha Ayoun <sachaayoun@gmail.com>"
"cannorin <cannorin@gmail.com>"
"Ulugbek Abdullaev <ulugbekna@gmail.com>"
"Thibaut Mattio <thibaut.mattio@gmail.com>"
"Max Lantas <mnxndev@outlook.com>"
]
license: "ISC"
homepage: "https://github.com/ocaml/ocaml-lsp"
bug-reports: "https://github.com/ocaml/ocaml-lsp/issues"
depends: [
"dune" {>= "3.0"}
"jsonrpc" {= version}
"yojson"
"ppx_yojson_conv_lib" {>= "v0.14"}
"cinaps" {with-test}
"ppx_expect" {>= "v0.17.0" & with-test}
"uutf" {>= "1.0.2"}
"odoc" {with-doc}
"ocaml" {>= "4.14"}
"ppx_yojson_conv" {with-dev-setup}
]
dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git"
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@doc" {with-doc}
]
]
x-maintenance-intent: [ "(latest)" "(latest)-414" ]

15
thirdparty/lsp/lsp.opam.template vendored Normal file
View file

@ -0,0 +1,15 @@
build: [
["dune" "subst"] {dev}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@doc" {with-doc}
]
]
x-maintenance-intent: [ "(latest)" "(latest)-414" ]

178
thirdparty/lsp/lsp/bin/cinaps.ml vendored Normal file
View file

@ -0,0 +1,178 @@
open Import
let preprocess_metamodel =
object (self)
inherit Metamodel.map as super
method! or_ path (types : Metamodel.type_ list) =
match
List.filter_map types ~f:(function
| Literal (Record []) -> None
| _ as t -> Some (self#type_ path t))
with
| [] -> assert false
| [ t ] -> t
| [ Metamodel.Literal (Record f1); Literal (Record f2) ] as ts ->
(match path with
| Top (Alias s) when s.name = "TextDocumentContentChangeEvent" ->
let t =
let union_fields l1 l2 ~f =
let of_map =
String.Map.of_list_map_exn ~f:(fun (x : Metamodel.property) -> x.name, x)
in
String.Map.merge (of_map l1) (of_map l2) ~f |> String.Map.values
in
union_fields f1 f2 ~f:(fun k t1 t2 ->
if k = "text"
then t1
else if k = "range"
then (
match t1, t2 with
| None, Some s | Some s, None ->
assert (not s.optional);
Some { s with optional = true }
| None, None | Some _, Some _ -> assert false)
else (
match t1, t2 with
| None, None -> assert false
| Some s, None | None, Some s -> Some s
| Some _, Some _ -> assert false))
in
self#type_ path (Metamodel.Literal (Record t))
| _ -> super#or_ path ts)
| ts -> super#or_ path ts
method! property path (p : Metamodel.property) =
let update_type type_ =
let type_ = self#type_ path type_ in
super#property path { p with type_ }
in
let open Metamodel.Path in
match path with
| Top (Structure s)
when p.name = "trace"
&& (s.name = "_InitializeParams" || s.name = "InitializeParams") ->
update_type (Reference "TraceValues")
| Top (Structure s) when p.name = "location" && s.name = "WorkspaceSymbol" ->
(match p.type_ with
| Or [ type_; _ ] -> update_type type_
| _ -> assert false)
| _ -> super#property path p
method! enumeration m =
match m.name = "TraceValues" with
| false -> super#enumeration m
| true ->
super#enumeration
(let values =
let compact : Metamodel.enumerationEntry =
{ name = "Compact"
; value = `String "compact"
; doc = { since = None; documentation = None }
}
in
compact :: m.values
in
{ m with values })
end
;;
let expand_superclasses db (m : Metamodel.t) =
let structures =
let uniquify_fields fields =
List.fold_left fields ~init:String.Map.empty ~f:(fun acc (f : Metamodel.property) ->
String.Map.set acc f.name f)
|> String.Map.values
in
let rec fields_of_type (t : Metamodel.type_) =
match t with
| Reference s ->
(match Metamodel.Entity.DB.find db s with
| Structure s -> fields_of_structure s
| Enumeration _ -> assert false
| Alias a -> fields_of_type a.type_)
| _ -> assert false
and fields_of_structure (s : Metamodel.structure) =
let fields = List.map (s.extends @ s.mixins) ~f:fields_of_type @ [ s.properties ] in
List.concat fields
in
List.map m.structures ~f:(fun s ->
let properties = fields_of_structure s |> uniquify_fields in
{ s with properties })
in
{ m with structures }
;;
let ocaml =
lazy
(Metamodel_lsp.t ()
|> preprocess_metamodel#t
|> (fun metamodel ->
let db = Metamodel.Entity.DB.create metamodel in
expand_superclasses db metamodel)
|> Typescript.of_metamodel
|> Ocaml.of_typescript)
;;
module Output = struct
open Ocaml
type t =
{ mutable modules : Module.t list
; kind : Ml.Kind.t
; out : out_channel
}
let create modules kind out_channel = { modules; out = out_channel; kind }
let module_name (t : t) (m : Module.t) =
match t.kind with
| Intf -> (m.intf.name :> string)
| Impl -> (m.impl.name :> string)
;;
let _skip (t : t) name =
match t.modules with
| [] -> failwith "non left to skip"
| m :: modules ->
let name' = module_name t m in
assert (String.equal name name');
t.modules <- modules
;;
let pp_file pp ch =
let fmt = Format.formatter_of_out_channel ch in
Pp.to_fmt fmt pp;
Format.pp_print_flush fmt ()
;;
let write t cmd =
let to_write, modules =
match cmd with
| `Finish -> t.modules, []
| `Until m ->
let rec loop xs acc =
match xs with
| [] -> List.rev acc, []
| x :: xs ->
if module_name t x = m then List.rev acc, x :: xs else loop xs (x :: acc)
in
loop t.modules []
in
t.modules <- modules;
List.iter to_write ~f:(fun m ->
let pp = Module.pp m in
let pp = Ml.Kind.Map.get pp t.kind in
pp_file pp t.out)
;;
end
let print_ml () =
let output = Output.create (Lazy.force ocaml) Ml.Kind.Impl stdout in
Output.write output `Finish
;;
let print_mli () =
let output = Output.create (Lazy.force ocaml) Ml.Kind.Intf stdout in
Output.write output `Finish
;;

2
thirdparty/lsp/lsp/bin/cinaps.mli vendored Normal file
View file

@ -0,0 +1,2 @@
val print_ml : unit -> unit
val print_mli : unit -> unit

16
thirdparty/lsp/lsp/bin/dune vendored Normal file
View file

@ -0,0 +1,16 @@
(include_subdirs unqualified)
(test
(name test_metamodel)
(modules test_metamodel)
(libraries stdune yojson lsp_gen)
(deps metamodel/metaModel.json)
(action
(run ./test_metamodel.exe %{deps})))
(library
(name lsp_gen)
(instrumentation
(backend bisect_ppx))
(modules :standard \ test_metamodel)
(libraries stdune dyn pp yojson))

13
thirdparty/lsp/lsp/bin/import.ml vendored Normal file
View file

@ -0,0 +1,13 @@
include struct
open Stdune
module List = List
module Id = Id
module String = String
module Code_error = Code_error
module Comparable = Comparable
module Top_closure = Top_closure
module Poly = Poly
module Option = Option
let sprintf = sprintf
end

7
thirdparty/lsp/lsp/bin/lsp_gen.ml vendored Normal file
View file

@ -0,0 +1,7 @@
module Typescript = Typescript
module Ocaml = Ocaml
module Cinaps = Cinaps
module Metamodel = Metamodel
let print_ml = Cinaps.print_ml
let print_mli = Cinaps.print_mli

9
thirdparty/lsp/lsp/bin/metamodel/dune vendored Normal file
View file

@ -0,0 +1,9 @@
; get rid of this gross hack once dune has proper crunch support
(rule
(with-stdout-to
metamodel_lsp.ml
(progn
(echo "let t () = Metamodel.t @@ Yojson.Safe.from_string {json|")
(echo "%{read:metaModel.json}")
(echo "|json}"))))

14920
thirdparty/lsp/lsp/bin/metamodel/metaModel.json vendored Normal file
View file

File diff suppressed because it is too large Load diff

458
thirdparty/lsp/lsp/bin/metamodel/metamodel.ml vendored Normal file
View file

@ -0,0 +1,458 @@
open Stdune
type doc =
{ since : string option
; documentation : string option
}
type baseType =
| Uri
| DocumentUri
| Integer
| Uinteger
| Decimal
| RegExp
| String
| Boolean
| Null
type mapKeyType =
| Uri
| DocumentUri
| String
| Integer
| Reference of string
type literalType =
| String of string
| Boolean of bool
| Integer of int
| Record of property list
and property =
{ doc : doc
; name : string
; optional : bool
; type_ : type_
}
and mapType =
{ key : mapKeyType
; value : type_
}
and type_ =
| Base of baseType
| Reference of string
| Array of type_
| Or of type_ list
| And of type_ list
| Tuple of type_ list
| Literal of literalType
| Map of mapType
type typeAlias =
{ name : string
; type_ : type_
; doc : doc
}
type enumerationEntry =
{ name : string
; value : [ `String of string | `Int of int ]
; doc : doc
}
type enumerationType = { name : [ `String | `Integer | `Uinteger ] }
type enumeration =
{ doc : doc
; name : string
; supportsCustomValues : bool
; type_ : enumerationType
; values : enumerationEntry list
}
type structure =
{ doc : doc
; extends : type_ list
; mixins : type_ list
; name : string
; properties : property list
}
type call =
{ method_ : string
; params : [ `Param of type_ | `Params of type_ list ] option
; registrationOptions : type_ option
; doc : doc
}
type request =
{ call : call
; errorData : type_ option
; partialResult : type_ option
; result : type_
}
type notification = { call : call }
type t =
{ requests : request list
; notifications : notification list
; structures : structure list
; enumerations : enumeration list
; typeAliases : typeAlias list
}
let error msg json = failwith (msg ^ "\n" ^ Yojson.Safe.pretty_to_string ~std:false json)
let fields = function
| `Assoc xs -> xs
| xs -> error "expected fields" xs
;;
let field ?default (name : string) p fields =
match List.assoc fields name with
| Some f -> p f
| None ->
(match default with
| None -> error ("field not found " ^ name) (`Assoc fields)
| Some x -> x)
;;
let field_o name p fields =
match List.assoc fields name with
| None -> None
| Some f -> Some (p f)
;;
let bool = function
| `Bool b -> b
| json -> error "boolean expected" json
;;
let literal lit json = if not (Poly.equal json lit) then error "unexpected literal" json
let enum variants json =
match json with
| `String s ->
(match List.assoc variants s with
| None -> error "not a valid enum value" json
| Some v -> v)
| _ -> error "not a valid enum value" json
;;
let string = function
| `String s -> s
| json -> error "expected string" json
;;
let string_or_number = function
| `String s -> `String s
| `Int i -> `Int i
| json -> error "expected string or number" json
;;
let name fields = field "name" string fields
let list conv = function
| `List xs -> List.map xs ~f:conv
| json -> error "expected list" json
;;
let baseType json : baseType =
match json with
| `String s ->
(match s with
| "URI" | "Uri" -> Uri
| "DocumentUri" -> DocumentUri
| "integer" -> Integer
| "uinteger" -> Uinteger
| "decimal" -> Decimal
| "RegExp" -> RegExp
| "string" -> String
| "boolean" -> Boolean
| "null" -> Null
| _ -> error "unknown base type" json)
| _ -> error "unknown base type" json
;;
let mapKeyType json : mapKeyType =
let fields = fields json in
let kind = field "kind" string fields in
match kind with
| "reference" -> Reference (name fields)
| "base" ->
field
"name"
(enum
[ "Uri", Uri
; "URI", Uri
; "DocumentUri", DocumentUri
; "string", String
; "integer", Integer
])
fields
| kind -> error ("invalid kind for map key type: " ^ kind) json
;;
let doc fields =
let since = field_o "since" string fields in
let documentation = field_o "documentation" string fields in
{ since; documentation }
;;
let rec type_ json =
let fields_conv = fields in
let fields = fields json in
let kind = field "kind" string fields in
match kind with
| "reference" -> Reference (name fields)
| "array" ->
let element = field "element" type_ fields in
Array element
| "base" ->
let b = field "name" baseType fields in
Base b
| "or" ->
let items = field "items" (list type_) fields in
Or items
| "and" ->
let items = field "items" (list type_) fields in
And items
| "tuple" ->
let items = field "items" (list type_) fields in
Tuple items
| "stringLiteral" ->
let value = field "value" string fields in
Literal (String value)
| "map" ->
let key = field "key" mapKeyType fields in
let value = field "value" type_ fields in
Map { key; value }
| "literal" ->
let fields =
field
"value"
(fun json ->
let fields = fields_conv json in
properties fields)
fields
in
Literal (Record fields)
| kind -> error "unrecognized kind" (`String kind)
and properties fields : property list = field "properties" (list property) fields
and property json : property =
let fields = fields json in
let name = name fields in
let doc = doc fields in
let type_ = type_field fields in
let optional = field ~default:false "optional" bool fields in
{ name; type_; optional; doc }
and type_field fields = field "type" type_ fields
let params = function
| `List l -> `Params (List.map l ~f:type_)
| `Assoc _ as json -> `Param (type_ json)
| json -> error "list or object expected" json
;;
let call fields =
let method_ = field "method" string fields in
let params = field_o "params" params fields in
let doc = doc fields in
let registrationOptions = field_o "registrationOptions" type_ fields in
{ registrationOptions; doc; method_; params }
;;
let notification json =
let fields = fields json in
let call = call fields in
{ call }
;;
let request json =
let fields = fields json in
let call = call fields in
let errorData = field_o "errorData" type_ fields in
let partialResult = field_o "partialResult" type_ fields in
let result = field "result" type_ fields in
{ call; errorData; partialResult; result }
;;
let enumerationEntry json : enumerationEntry =
let fields = fields json in
let name = name fields in
let doc = doc fields in
let value = field "value" string_or_number fields in
{ name; value; doc }
;;
let enumerationType json =
let fields = fields json in
let () = field "kind" (literal (`String "base")) fields in
let name =
field
"name"
(enum [ "integer", `Integer; "string", `String; "uinteger", `Uinteger ])
fields
in
{ name }
;;
let enumeration json =
let fields = fields json in
let name = name fields in
let doc = doc fields in
let values = field "values" (list enumerationEntry) fields in
let type_ = field "type" enumerationType fields in
let supportsCustomValues = field ~default:false "supportsCustomValues" bool fields in
{ supportsCustomValues; type_; values; name; doc }
;;
let structure json =
let fields = fields json in
let doc = doc fields in
let name = name fields in
let extends = field ~default:[] "extends" (list type_) fields in
let mixins = field ~default:[] "mixins" (list type_) fields in
let properties = properties fields in
{ doc; name; extends; mixins; properties }
;;
let typeAlias json : typeAlias =
let fields = fields json in
let name = name fields in
let type_ = type_field fields in
let doc = doc fields in
{ doc; name; type_ }
;;
let t json =
let fields = fields json in
let requests = field "requests" (list request) fields in
let notifications = field "notifications" (list notification) fields in
let structures = field "structures" (list structure) fields in
let enumerations = field "enumerations" (list enumeration) fields in
let typeAliases = field "typeAliases" (list typeAlias) fields in
{ requests; notifications; structures; enumerations; typeAliases }
;;
type metamodel = t
module Entity = struct
type t =
| Structure of structure
| Enumeration of enumeration
| Alias of typeAlias
module DB = struct
type nonrec t = t String.Map.t
let create
({ structures; requests = _; notifications = _; enumerations; typeAliases } :
metamodel)
: t
=
let structures =
String.Map.of_list_map_exn structures ~f:(fun s -> s.name, Structure s)
in
let enumerations =
String.Map.of_list_map_exn enumerations ~f:(fun s -> s.name, Enumeration s)
in
let typeAliases =
String.Map.of_list_map_exn typeAliases ~f:(fun a -> a.name, Alias a)
in
String.Map.union_exn structures enumerations |> String.Map.union_exn typeAliases
;;
let find t x = String.Map.find_exn t x
end
end
module Path = struct
type top =
| Request of request
| Notification of notification
| Structure of structure
| Enumeration of enumeration
| Alias of typeAlias
type t =
| Top of top
| Property of property * t
end
class map =
let open Path in
object (self)
method property path (p : property) =
let path = Property (p, path) in
{ p with type_ = self#type_ path p.type_ }
method literal path t =
match (t : literalType) with
| Record ps -> Record (List.map ps ~f:(self#property path))
| _ -> t
method or_ path types = Or (List.map types ~f:(self#type_ path))
method type_ path t : type_ =
match t with
| Base _ as t -> t
| Reference _ -> t
| Array t -> Array (self#type_ path t)
| Or types -> self#or_ path types
| And ts -> And (List.map ts ~f:(self#type_ path))
| Tuple ts -> Tuple (List.map ts ~f:(self#type_ path))
| Literal lt -> Literal (self#literal path lt)
| Map mt -> Map { mt with value = self#type_ path mt.value }
method private call path (c : call) =
let params =
let params = function
| `Param t -> `Param (self#type_ path t)
| `Params ts -> `Params (List.map ts ~f:(self#type_ path))
in
Option.map ~f:params c.params
in
let registrationOptions = Option.map ~f:(self#type_ path) c.registrationOptions in
{ c with params; registrationOptions }
method request (r : request) =
let path = Top (Request r) in
let call = self#call path r.call in
let errorData = Option.map ~f:(self#type_ path) r.errorData in
let partialResult = Option.map ~f:(self#type_ path) r.partialResult in
let result = self#type_ path r.result in
{ call; errorData; partialResult; result }
method notification { call } =
let path = Top (Notification { call }) in
{ call = self#call path call }
method structure s =
let path = Top (Structure s) in
let extends = List.map s.extends ~f:(self#type_ path) in
let mixins = List.map s.mixins ~f:(self#type_ path) in
let properties = List.map s.properties ~f:(self#property path) in
{ s with extends; mixins; properties }
method typeAlias (a : typeAlias) =
let path = Top (Alias a) in
{ a with type_ = self#type_ path a.type_ }
method enumeration (e : enumeration) : enumeration = e
method t { requests; notifications; structures; enumerations; typeAliases } =
let requests = List.map requests ~f:self#request in
let notifications = List.map notifications ~f:self#notification in
let structures = List.map structures ~f:self#structure in
let typeAliases = List.map typeAliases ~f:self#typeAlias in
let enumerations = List.map enumerations ~f:self#enumeration in
{ enumerations; requests; notifications; structures; typeAliases }
end

149
thirdparty/lsp/lsp/bin/metamodel/metamodel.mli vendored Normal file
View file

@ -0,0 +1,149 @@
type doc =
{ since : string option
; documentation : string option
}
type baseType =
| Uri
| DocumentUri
| Integer
| Uinteger
| Decimal
| RegExp
| String
| Boolean
| Null
type mapKeyType =
| Uri
| DocumentUri
| String
| Integer
| Reference of string
type literalType =
| String of string
| Boolean of bool
| Integer of int
| Record of property list
and property =
{ doc : doc
; name : string
; optional : bool
; type_ : type_
}
and mapType =
{ key : mapKeyType
; value : type_
}
and type_ =
| Base of baseType
| Reference of string
| Array of type_
| Or of type_ list
| And of type_ list
| Tuple of type_ list
| Literal of literalType
| Map of mapType
type typeAlias =
{ name : string
; type_ : type_
; doc : doc
}
type enumerationEntry =
{ name : string
; value : [ `Int of int | `String of string ]
; doc : doc
}
type enumerationType = { name : [ `Integer | `String | `Uinteger ] }
type enumeration =
{ doc : doc
; name : string
; supportsCustomValues : bool
; type_ : enumerationType
; values : enumerationEntry list
}
type structure =
{ doc : doc
; extends : type_ list
; mixins : type_ list
; name : string
; properties : property list
}
type call =
{ method_ : string
; params : [ `Param of type_ | `Params of type_ list ] option
; registrationOptions : type_ option
; doc : doc
}
type request =
{ call : call
; errorData : type_ option
; partialResult : type_ option
; result : type_
}
type notification = { call : call }
type t =
{ requests : request list
; notifications : notification list
; structures : structure list
; enumerations : enumeration list
; typeAliases : typeAlias list
}
val t : Yojson.Safe.t -> t
module Entity : sig
type metamodel := t
type t =
| Structure of structure
| Enumeration of enumeration
| Alias of typeAlias
module DB : sig
type entity := t
type t
val create : metamodel -> t
val find : t -> string -> entity
end
end
module Path : sig
type top =
| Request of request
| Notification of notification
| Structure of structure
| Enumeration of enumeration
| Alias of typeAlias
type t =
| Top of top
| Property of property * t
end
class map : object
method literal : Path.t -> literalType -> literalType
method property : Path.t -> property -> property
method or_ : Path.t -> type_ list -> type_
method type_ : Path.t -> type_ -> type_
method t : t -> t
method request : request -> request
method structure : structure -> structure
method notification : notification -> notification
method typeAlias : typeAlias -> typeAlias
method enumeration : enumeration -> enumeration
end

15
thirdparty/lsp/lsp/bin/named.ml vendored Normal file
View file

@ -0,0 +1,15 @@
type 'a t =
{ name : string
; data : 'a
}
let make ~name data = { name; data }
let data t = t.data
let name t = t.name
let map t ~f = { t with data = f t.data }
let set_data t data = { t with data }
let to_dyn f { name; data } =
let open Dyn in
record [ "name", String name; "data", f data ]
;;

273
thirdparty/lsp/lsp/bin/ocaml/json_gen.ml vendored Normal file
View file

@ -0,0 +1,273 @@
open! Import
open Ml
let json_t = Type.Path (Dot (Ident "Json", "t"))
let pat_of_literal (t : Ts_types.Literal.t) : Expr.pat =
let open Expr in
let tag, args =
match t with
| Ts_types.Literal.String s -> "String", Pat (Expr.String s)
| Int i -> "Int", Pat (Expr.Int i)
| Float _ -> assert false
in
Pat (Constr { poly = true; tag; args = [ args ] })
;;
let constr_of_literal (t : Ts_types.Literal.t) : Expr.t =
let open Expr in
let tag, args =
match t with
| Ts_types.Literal.String s -> "String", Create (Expr.String s)
| Int i -> "Int", Create (Expr.Int i)
| Float _ -> assert false
in
Create (Constr { poly = true; tag; args = [ args ] })
;;
let json_error_pat msg =
let open Expr in
( Wildcard
, App
( Create (Ident "Json.error")
, [ Unnamed (Create (String msg)); Unnamed (Create (Ident "json")) ] ) )
;;
let is_json_constr (constr : Type.constr) =
List.mem [ "String"; "Int"; "Bool" ] constr.name ~equal:String.equal
;;
module Name = struct
let of_ = sprintf "%s_of_yojson"
let to_ = sprintf "yojson_of_%s"
let conv = function
| `To -> to_
| `Of -> of_
;;
end
open Arg
let of_json ~name expr =
let pat = [ Unnamed "json", Type.json ] in
let data = { Expr.pat; type_ = Type.name name; body = expr } in
let name = Name.of_ name in
{ Named.name; data }
;;
let to_json ~name expr =
let pat = [ Unnamed name, Type.name name ] in
let data = { Expr.pat; type_ = Type.json; body = expr } in
let name = Name.to_ name in
{ Named.name; data }
;;
let add_json_conv_for_t (sig_ : Module.sig_ Module.t) =
let conv_t =
{ Named.name = "t"
; data =
(let t = Type.Path (Path.Ident "t") in
Module.Include (Module.Name.of_string "Json.Jsonable.S", [ t, t ]))
}
in
{ sig_ with bindings = sig_.bindings @ [ conv_t ] }
;;
module Enum = struct
let of_json ~allow_other ~poly { Named.name; data = constrs } =
let open Ml.Expr in
let body =
let clauses =
List.map constrs ~f:(fun (constr, literal) ->
let pat = pat_of_literal literal in
let tag = constr in
pat, Create (Constr { tag; poly; args = [] }))
in
let clauses =
if allow_other
then (
let s = Ident "s" in
let pat = Pat (Constr { tag = "String"; poly = true; args = [ Pat s ] }) in
let make = Create (Constr { tag = "Other"; poly; args = [ Create s ] }) in
clauses @ [ pat, make ])
else clauses
in
let msg =
sprintf
"Invalid value. Expected one of: %s"
(List.map constrs ~f:(fun (_, literal) ->
Ts_types.Literal.to_maybe_quoted_string literal)
|> String.concat ~sep:", ")
in
Match (Create (Ident "json"), clauses @ [ json_error_pat msg ])
in
of_json ~name body
;;
let to_json ~allow_other ~poly { Named.name; data = constrs } =
let open Ml.Expr in
let body =
let clauses =
List.map constrs ~f:(fun (constr, literal) ->
let pat = Pat (Constr { tag = constr; poly; args = [] }) in
pat, constr_of_literal literal)
in
let clauses =
if allow_other
then (
let s = Ident "s" in
let pat = Pat (Constr { tag = "Other"; poly; args = [ Pat s ] }) in
let make =
Create (Constr { tag = "String"; poly = true; args = [ Create s ] })
in
clauses @ [ pat, make ])
else clauses
in
Match (Create (Ident name), clauses)
in
to_json ~name body
;;
let conv ~allow_other ~poly t =
let to_json = to_json ~allow_other ~poly t in
let of_json = of_json ~allow_other ~poly t in
[ to_json; of_json ]
;;
end
module Poly_variant = struct
type constrs =
{ json_constrs : Ml.Type.constr list
; untagged_constrs : Ml.Type.constr list
}
let split_clauses constrs =
let json_constrs, untagged_constrs =
List.partition_map constrs ~f:(fun x ->
if is_json_constr x then Left x else Right x)
in
{ json_constrs; untagged_constrs }
;;
let conv_of_constr target (utc : Ml.Type.constr) =
let rec conv (p : Ml.Path.t) : Ml.Path.t =
match p with
| Ident name -> Ident (Name.conv target name)
| Dot (s, name) -> Dot (s, Name.conv target name)
| Apply (s, y) -> Apply (s, conv y)
in
let conv p = Ml.Path.to_string (conv p) in
let open Ml.Expr in
let json_mod n =
match target with
| `To -> Ident ("Json.To." ^ n)
| `Of -> Ident ("Json.Of." ^ n)
in
let conv t = Create (Ident (conv t)) in
match (utc.args : Ml.Type.t list) with
| [ Path p ] -> conv p
| [ List (Prim p) ] ->
let ident =
match p with
| String -> "string"
| _ -> assert false
in
App (Create (json_mod "list"), [ Unnamed (conv (Ident ident)) ])
| [ List (Path p) ] -> App (Create (json_mod "list"), [ Unnamed (conv p) ])
| [ Tuple [ Prim Int; Prim Int ] ] -> Create (json_mod "int_pair")
| [] -> assert false
| _ -> Code_error.raise "untagged" [ "utc", Ml.Type.dyn_of_constr utc ]
;;
let json_clauses json_constrs =
List.map json_constrs ~f:(fun (c : Ml.Type.constr) ->
let open Ml.Expr in
let constr arg = Constr { tag = c.name; poly = true; args = [ arg ] } in
let pat = Pat (constr (Pat (Ident "j"))) in
let expr : t = Create (constr (Create (Ident "j"))) in
pat, expr)
;;
let to_json { Named.name; data = constrs } =
let { json_constrs; untagged_constrs } = split_clauses constrs in
let open Ml.Expr in
let json_clauses = json_clauses json_constrs in
let untagged_clauses =
List.map untagged_constrs ~f:(fun (utc : Ml.Type.constr) ->
let constr arg = Constr { tag = utc.name; poly = true; args = [ arg ] } in
let pat = Pat (constr (Pat (Ident "s"))) in
let expr = App (conv_of_constr `To utc, [ Unnamed (Create (Ident "s")) ]) in
pat, expr)
in
let expr = Match (Create (Ident name), json_clauses @ untagged_clauses) in
to_json ~name expr
;;
let of_json { Named.name; data = constrs } =
let { json_constrs; untagged_constrs } = split_clauses constrs in
let open Ml.Expr in
let clauses = json_clauses json_constrs in
let untagged =
let args =
let constrs =
List.map untagged_constrs ~f:(fun (utc : Ml.Type.constr) ->
let create =
let of_json =
App (conv_of_constr `Of utc, [ Unnamed (Create (Ident "json")) ])
in
Create (Constr { tag = utc.name; poly = true; args = [ of_json ] })
in
Fun ([ Unnamed (Pat (Ident "json")) ], create))
in
Create (List constrs)
in
App
( Create (Ident "Json.Of.untagged_union")
, [ Unnamed (Create (String name))
; Unnamed args
; Unnamed (Create (Ident "json"))
] )
in
let expr =
match json_constrs, untagged_constrs with
| [], [] -> assert false
| [], _ -> untagged
| _, [] -> Match (Create (Ident "json"), clauses @ [ json_error_pat name ])
| _ :: _, _ :: _ -> Match (Create (Ident "json"), clauses @ [ Wildcard, untagged ])
in
of_json ~name expr
;;
end
(* [name] is used as the pattern in the "to" converter. In the "of" converter,
it's used to generate better error messages. *)
let make_literal_wrapper_conv ~field_name ~literal_value ~type_name =
(* Some json representations require an extra "kind" field set to some string
constant *)
let open Ml.Expr in
let args = List.map ~f:(fun x -> Ml.Arg.Unnamed (Create x)) in
let to_ =
let a =
[ String field_name
; String literal_value
; Ident (Name.conv `To type_name)
; Ident type_name
]
in
App (Create (Ident "Json.To.literal_field"), args a)
in
let of_ =
let a =
[ String type_name
; String field_name
; String literal_value
; Ident (Name.conv `Of type_name)
; Ident "json"
]
in
App (Create (Ident "Json.Of.literal_field"), args a)
in
[ to_json ~name:type_name to_; of_json ~name:type_name of_ ]
|> List.map ~f:(Named.map ~f:(fun v -> Ml.Module.Value v))
;;

21
thirdparty/lsp/lsp/bin/ocaml/json_gen.mli vendored Normal file
View file

@ -0,0 +1,21 @@
val json_t : Ml.Type.t
val add_json_conv_for_t : Ml.Module.sig_ Ml.Module.t -> Ml.Module.sig_ Ml.Module.t
module Enum : sig
val conv
: allow_other:bool
-> poly:bool
-> (string * Ts_types.Literal.t) list Named.t
-> Ml.Expr.toplevel Named.t list
end
module Poly_variant : sig
val of_json : Ml.Type.constr list Named.t -> Ml.Expr.toplevel Named.t
val to_json : Ml.Type.constr list Named.t -> Ml.Expr.toplevel Named.t
end
val make_literal_wrapper_conv
: field_name:string
-> literal_value:string
-> type_name:string
-> Ml.Module.impl Named.t list

598
thirdparty/lsp/lsp/bin/ocaml/ml.ml vendored Normal file
View file

@ -0,0 +1,598 @@
open Import
module Kind = struct
type t =
| Intf
| Impl
type ('intf, 'impl) pair =
{ intf : 'intf
; impl : 'impl
}
module Map = struct
type 'a t = ('a, 'a) pair
let get { intf; impl } = function
| Impl -> impl
| Intf -> intf
;;
let make_both a = { intf = a; impl = a }
let iter { intf; impl } ~f =
f intf;
f impl
;;
let map { intf; impl } ~f = { intf = f intf; impl = f impl }
let both (type a b) (x : a t) (y : b t) : (a * b) t =
{ intf = x.intf, y.intf; impl = x.impl, y.impl }
;;
end
end
let is_kw = function
| "type" | "method" | "end" | "to" | "external" -> true
| _ -> false
;;
module Arg = struct
type 'e t =
| Unnamed of 'e
| Labeled of string * 'e
| Optional of string * 'e
let to_dyn f =
let open Dyn in
function
| Unnamed a -> Dyn.variant "Unnamed" [ f a ]
| Labeled (s, a) -> Dyn.variant "Labeled" [ string s; f a ]
| Optional (s, a) -> Dyn.variant "Optional" [ string s; f a ]
;;
end
module Path = struct
type t =
| Ident of string
| Dot of t * string
| Apply of t * t
let rec to_string = function
| Ident s -> s
| Dot (t, s) -> to_string t ^ "." ^ s
| Apply (f, x) -> to_string f ^ "(" ^ to_string x ^ ")"
;;
let rec pp = function
| Ident s -> Pp.verbatim s
| Dot (s, p) -> Pp.concat [ pp s; Pp.verbatim "."; Pp.verbatim p ]
| Apply (s, p) -> Pp.concat [ pp s; W.surround `Paren (pp p) ]
;;
end
module Type = struct
[@@@warning "-30"]
type prim =
| Unit
| String
| Int
| Bool
let dyn_of_prim : prim -> Dyn.t =
let open Dyn in
function
| Unit -> variant "Unit" []
| String -> variant "String" []
| Int -> variant "Int" []
| Bool -> variant "Bool" []
;;
type t =
| Path of Path.t
| Var of string
| Prim of prim
| Tuple of t list
| Optional of t
| List of t
| Poly_variant of constr list
| Assoc of t * t
| App of t * t list
| Fun of t Arg.t * t
and constr =
{ name : string
; args : t list
}
and field =
{ name : string
; typ : t
; attrs : (string * string list) list
}
let rec to_dyn =
let open Dyn in
function
| Var v -> variant "Var" [ string v ]
| List v -> variant "List" [ to_dyn v ]
| Assoc (x, y) -> variant "Assoc" [ to_dyn x; to_dyn y ]
| Tuple xs -> variant "Tuple" (List.map ~f:to_dyn xs)
| Optional t -> variant "Optional" [ to_dyn t ]
| Path p -> variant "Path" [ string @@ Path.to_string p ]
| Poly_variant xs -> variant "Poly_variant" (List.map ~f:dyn_of_constr xs)
| App (x, y) -> variant "App" (to_dyn x :: List.map y ~f:to_dyn)
| Prim p -> variant "Prim" [ dyn_of_prim p ]
| Fun (arg, t) -> variant "Fun" [ Arg.to_dyn to_dyn arg; to_dyn t ]
and dyn_of_constr { name; args } =
Dyn.(record [ "name", string name; "args", (list to_dyn) args ])
and dyn_of_field { name; typ; attrs } =
let open Dyn in
record
[ "name", string name
; "typ", to_dyn typ
; "attrs", list (pair string (list string)) attrs
]
;;
type decl =
| Alias of t
| Record of field list
| Variant of constr list
let dyn_of_decl =
let open Dyn in
function
| Alias a -> variant "Alias" [ to_dyn a ]
| Record fs -> variant "Record" (List.map ~f:dyn_of_field fs)
| Variant cs -> variant "Variant" (List.map ~f:dyn_of_constr cs)
;;
class virtual ['env, 'm] mapreduce =
object (self : 'self)
method virtual empty : 'm
method virtual plus : 'm -> 'm -> 'm
method poly_variant env constrs =
let r, s = self#fold_left_map constrs ~f:(fun c -> self#constr env c) in
Poly_variant r, s
method tuple (env : 'env) t =
let (r : t list), s = self#fold_left_map t ~f:(fun (t : t) -> self#t env t) in
Tuple r, s
method path _ p = Path p, self#empty
method var _ n = Var n, self#empty
method prim _ p = Prim p, self#empty
method optional env p =
let t, s = self#t env p in
Optional t, s
method list env t =
let t, s = self#t env t in
List t, s
method assoc env k v =
let k, s1 = self#t env k in
let v, s2 = self#t env v in
Assoc (k, v), self#plus s1 s2
method app env f xs =
let f, s1 = self#t env f in
let xs, s2 = self#fold_left_map xs ~f:(fun x -> self#t env x) in
App (f, xs), self#plus s1 s2
method t env this =
match (this : t) with
| Path p -> self#path env p
| Var v -> self#var env v
| Prim p -> self#prim env p
| Tuple t -> self#tuple env t
| Optional t -> self#optional env t
| List t -> self#list env t
| Poly_variant t -> self#poly_variant env t
| Assoc (k, v) -> self#assoc env k v
| App (f, xs) -> self#app env f xs
| Fun (_, _) -> assert false
method alias env t =
let r0, s0 = self#t env t in
Alias r0, s0
method constr env (constr : constr) =
let args, s = self#fold_left_map constr.args ~f:(fun t -> self#t env t) in
{ constr with args }, s
method private fold_left_map : 'a. f:('a -> 'a * 'm) -> 'a list -> 'a list * 'm =
fun ~f xs ->
let accf, accm =
List.fold_left xs ~init:([], self#empty) ~f:(fun (accf, accm) x ->
let r, s = f x in
r :: accf, self#plus accm s)
in
List.rev accf, accm
method field env f =
let typ, s = self#t env f.typ in
{ f with typ }, s
method record env fields =
let r, s = self#fold_left_map fields ~f:(fun f -> self#field env f) in
Record r, s
method variant env constrs =
let v, s = self#fold_left_map constrs ~f:(fun f -> self#constr env f) in
Variant v, s
method decl env decl =
match decl with
| Alias a -> self#alias env a
| Record fs -> self#record env fs
| Variant v -> self#variant env v
end
let field typ ~name = { name; typ; attrs = [] }
let fun_ args t = List.fold_right args ~init:t ~f:(fun arg acc -> Fun (arg, acc))
let constr args ~name = { name; args }
let list t = List t
let assoc_list ~key ~data = Assoc (key, data)
let t = Path (Ident "t")
let module_t m = Path (Dot (Ident (String.capitalize_ascii m), "t"))
let string = Prim String
let name s = Path (Ident s)
let int = Prim Int
let bool = Prim Bool
let alpha = Var "a"
let enum constrs =
Variant (List.map constrs ~f:(fun constr -> { name = constr; args = [] }))
;;
let poly_enum constrs =
Poly_variant (List.map constrs ~f:(fun constr -> { name = constr; args = [] }))
;;
let json = Path (Dot (Ident "Json", "t"))
let unit = Prim Unit
let array t = App (Path (Ident "array"), [ t ])
let void =
let void = Path.Dot (Ident "Json", "Void") in
Path (Dot (void, "t"))
;;
let json_object =
let obj = Path.Dot (Ident "Json", "Object") in
Path (Dot (obj, "t"))
;;
module Type = W.Type
let pp_prim (p : prim) : W.t =
match p with
| String -> Pp.verbatim "string"
| Int -> Pp.verbatim "int"
| Bool -> Pp.verbatim "bool"
| Unit -> Pp.verbatim "unit"
;;
let rec pp (a : t) ~(kind : Kind.t) : W.t =
match a with
| Prim p -> pp_prim p
| Var v -> Type.var v
| Path p -> Path.pp p
| App (f, xs) -> Type.app (pp ~kind f) (List.map ~f:(pp ~kind) xs)
| Tuple t -> Type.tuple (List.map ~f:(pp ~kind) t)
| Optional t -> pp ~kind (App (Path (Ident "option"), [ t ]))
| List t -> pp ~kind (App (Path (Ident "list"), [ t ]))
| Poly_variant constrs ->
List.map constrs ~f:(fun { name; args } -> name, List.map args ~f:(pp ~kind))
|> Type.poly
| Assoc (k, v) ->
let t = List (Tuple [ k; v ]) in
pp t ~kind
| Fun (a, r) ->
(match a with
| Arg.Unnamed t ->
Pp.concat [ pp t ~kind; Pp.space; Pp.verbatim "->"; Pp.space; pp ~kind r ]
| Arg.Labeled (l, t) ->
Pp.concat
[ Pp.textf "%s:" l
; pp t ~kind
; Pp.space
; Pp.verbatim "->"
; Pp.space
; pp ~kind r
]
| Arg.Optional (l, t) ->
Pp.concat
[ Pp.textf "?%s:" l
; pp t ~kind
; Pp.space
; Pp.verbatim "->"
; Pp.space
; pp ~kind r
])
;;
let pp_decl' ~(kind : Kind.t) (a : decl) =
match a with
| Alias a ->
let pp = pp ~kind a in
(match a, kind with
| (List _ | Path _ | Prim _), Impl -> W.Type.deriving ~record:false pp
| _, _ -> pp)
| Variant v ->
List.map v ~f:(fun { name; args } -> name, List.map ~f:(pp ~kind) args)
|> Type.variant
| Record r ->
let r =
List.map r ~f:(fun { name; typ; attrs } ->
let def =
let field = pp ~kind typ in
let attrs =
let attrs =
match kind with
| Intf -> []
| Impl -> attrs
in
List.concat_map attrs ~f:(fun (a, r) ->
[ W.Attr.make a (List.map ~f:Pp.verbatim r) ])
in
Type.field_attrs ~field ~attrs
in
name, def)
|> Type.record
in
(match kind with
| Intf -> r
| Impl -> W.Type.deriving r ~record:true)
;;
let pp_decl ~name ~kind (a : decl) : W.t =
let body = pp_decl' ~kind a in
Type.decl name body
;;
end
module Expr = struct
[@@@ocaml.warning "-30-32-37"]
type expr =
| Let of pat * expr * expr (** let pat = e1 in e2 *)
| Match of expr * (pat * expr) list (** match e1 with [p -> e]* *)
| Fun of pat Arg.t list * expr (** fun p2 p2 .. -> e *)
| App of expr * expr Arg.t list (** f e1 e2 .. *)
| Create of expr prim (** Literal/Primitive *)
| Assert_false (** assert false *)
and 'e prim =
| Unit
| Bool of bool
| Int of int
| String of string
| Ident of string
| Cons of 'e * 'e prim
| List of 'e list
| Tuple of 'e list
| Record of 'e record_
| Constr of 'e constr
and pat =
| Wildcard
| Pat of pat prim
and 'e record_ = (string * 'e) list
and 'e constr =
{ tag : string
; poly : bool
; args : 'e list
}
type t = expr
let assert_false_clause = Wildcard, Assert_false
type toplevel =
{ pat : (string Arg.t * Type.t) list
; type_ : Type.t
; body : t
}
let constr ?(poly = false) ?(args = []) tag = { poly; args; tag }
let pp_constr f { tag; poly; args } =
let tag =
let tag = String.capitalize tag in
Pp.verbatim (if poly then "`" ^ tag else tag)
in
match args with
| [] -> tag
| args ->
let sep = Pp.verbatim "," in
let args = W.surround `Paren (Pp.concat_map ~sep ~f args) in
Pp.concat [ tag; Pp.space; args ]
;;
let rec pp_pat = function
| Wildcard -> Pp.verbatim "_"
| Pat pat ->
(match pat with
| Unit -> Pp.verbatim "()"
| Bool b -> Pp.textf "%b" b
| Int i -> Pp.textf "%i" i
| String s -> Pp.textf "%S" s
| Ident s -> Pp.verbatim s
| Cons _ -> assert false
| List _ -> assert false
| Tuple _ -> assert false
| Record _ -> assert false
| Constr c -> pp_constr pp_pat c)
;;
let rec pp_create : expr prim -> _ Pp.t = function
| Unit -> Pp.verbatim "()"
| Bool b -> Pp.textf "%b" b
| Int i ->
let pp = Pp.textf "%i" i in
if i < 0 then W.surround `Paren pp else pp
| String s -> Pp.textf "%S" s
| Ident s -> Pp.verbatim s
| Cons _ -> assert false
| List xs ->
let xs = Pp.concat_map xs ~sep:(Pp.verbatim ";") ~f:pp in
W.surround `Square xs
| Tuple _ -> assert false
| Record fields ->
let record =
let open Pp.O in
Pp.concat_map
fields
~sep:(Pp.verbatim ";" ++ Pp.space)
~f:(fun (name, expr) ->
if expr = Create (Ident name)
then pp expr
else Pp.verbatim name ++ Pp.space ++ Pp.verbatim "=" ++ pp expr)
in
W.surround `Curly record
| Constr c -> pp_constr pp c
and pp = function
| Assert_false -> Pp.verbatim "assert false"
| Match (expr, patterns) ->
let with_ =
Pp.concat [ Pp.verbatim "match"; Pp.space; pp expr; Pp.space; Pp.verbatim "with" ]
in
let clauses =
Pp.concat_map patterns ~f:(fun (pat, expr) ->
Pp.concat
[ Pp.verbatim "| "
; pp_pat pat
; Pp.space
; Pp.verbatim "->"
; Pp.space
; Pp.verbatim "("
; pp expr
; Pp.verbatim ")"
])
in
Pp.concat [ with_; Pp.newline; clauses ]
| Create c -> pp_create c
| App (x, args) ->
let args =
Pp.concat_map args ~sep:Pp.space ~f:(fun arg ->
match arg with
| Unnamed e -> pp e
| _ -> assert false)
in
Pp.concat [ pp x; Pp.space; args ]
| Fun (pats, expr) ->
W.surround
`Paren
(Pp.concat
[ Pp.verbatim "fun"
; Pp.space
; Pp.concat_map pats ~sep:Pp.space ~f:(fun arg ->
match arg with
| Unnamed e -> pp_pat e
| _ -> assert false)
; Pp.space
; Pp.verbatim "->"
; pp expr
])
| _ -> assert false
;;
let pp_toplevel ~kind name { pat; type_; body } =
let pat =
Pp.concat_map pat ~f:(fun (pat, typ) ->
let typ = Type.pp ~kind typ in
match pat with
| Unnamed s ->
Pp.concat
[ Pp.verbatim "("; Pp.verbatim s; Pp.verbatim " : "; typ; Pp.verbatim ")" ]
| Labeled (l, r) ->
if l = r
then Pp.concat [ Pp.textf "~(%s :" l; typ; Pp.verbatim ")" ]
else assert false
| Optional (l, r) ->
if l = r
then Pp.concat [ Pp.textf "?(%s :" l; typ; Pp.space; Pp.verbatim "option)" ]
else assert false)
in
let body = pp body in
let type_ = Type.pp type_ ~kind in
Pp.concat
[ Pp.textf "let %s" name
; pat
; Pp.textf " : "
; type_
; Pp.textf "="
; Pp.newline
; body
]
;;
end
module Module = struct
module Name : sig
type t = private string
val of_string : string -> t
end = struct
type t = string
let of_string s =
match s.[0] with
| 'a' .. 'z' -> Code_error.raise "invalid module name" [ "s", Dyn.string s ]
| _ -> s
;;
end
type 'a t =
{ name : Name.t
; bindings : 'a Named.t list
}
let empty name = { name; bindings = [] }
type sig_ =
| Value of Type.t
| Type_decl of Type.decl
| Include of Name.t * (Type.t * Type.t) list
type impl =
| Type_decl of Type.decl
| Value of Expr.toplevel
let pp_sig { name; bindings } =
let bindings =
Pp.concat_map bindings ~sep:Pp.newline ~f:(fun { name; data } ->
match (data : sig_) with
| Value t -> W.Sig.val_ name [ Type.pp ~kind:Intf t ]
| Type_decl t -> W.Type.decl name (Type.pp_decl' ~kind:Intf t)
| Include (mod_, destructive_subs) ->
List.map destructive_subs ~f:(fun (l, r) ->
let f = Type.pp ~kind:Intf in
f l, f r)
|> W.Sig.include_ (mod_ :> string))
in
W.Sig.module_ (name :> string) bindings
;;
let pp_impl { name; bindings } =
let bindings =
Pp.concat_map bindings ~sep:Pp.newline ~f:(fun { name; data = v } ->
match v with
| Value decl -> Expr.pp_toplevel ~kind:Impl name decl
| Type_decl t -> W.Type.decl name (Type.pp_decl' ~kind:Impl t))
in
W.module_ (name :> string) bindings
;;
end

227
thirdparty/lsp/lsp/bin/ocaml/ml.mli vendored Normal file
View file

@ -0,0 +1,227 @@
(** Representation of OCaml code used for generation *)
val is_kw : string -> bool
module Kind : sig
type t =
| Intf
| Impl
type ('intf, 'impl) pair =
{ intf : 'intf
; impl : 'impl
}
module Map : sig
type 'a t = ('a, 'a) pair
type kind
val get : 'a t -> kind -> 'a
val iter : 'a t -> f:('a -> unit) -> unit
val map : 'a t -> f:('a -> 'b) -> 'b t
val both : 'a t -> 'b t -> ('a * 'b) t
val make_both : 'a -> 'a t
end
with type kind := t
end
module Arg : sig
(** Represent arrow types and argument patterns *)
type 'e t =
| Unnamed of 'e
| Labeled of string * 'e
| Optional of string * 'e
end
module Path : sig
type t =
| Ident of string
| Dot of t * string
| Apply of t * t
val to_string : t -> string
end
module Type : sig
[@@@warning "-30"]
type prim =
| Unit
| String
| Int
| Bool
type t =
| Path of Path.t
| Var of string
| Prim of prim
| Tuple of t list
| Optional of t
| List of t
| Poly_variant of constr list
| Assoc of t * t
| App of t * t list
| Fun of t Arg.t * t
and field =
{ name : string
; typ : t
; attrs : (string * string list) list
}
and constr =
{ name : string
; args : t list
}
val to_dyn : t -> Dyn.t
val dyn_of_constr : constr -> Dyn.t
type decl =
| Alias of t
| Record of field list
| Variant of constr list
val dyn_of_decl : decl -> Dyn.t
val fun_ : t Arg.t list -> t -> t
(* This is for lists where the keys are equal to strings *)
val assoc_list : key:t -> data:t -> t
val pp_decl : name:string -> kind:Kind.t -> decl -> unit Pp.t
val pp : t -> kind:Kind.t -> unit Pp.t
val field : t -> name:string -> field
val constr : t list -> name:string -> constr
(** Simplified sum types*)
val enum : string list -> decl
(** Polymorphic variant form *)
val poly_enum : string list -> t
val list : t -> t
val module_t : string -> t
val t : t
val string : t
val name : string -> t
val int : t
val bool : t
val alpha : t
val json : t
val json_object : t
val unit : t
val void : t
val array : t -> t
(** Fold and map over a type expression.
['m] is the type of monoid summarized.
['env] is a custom value threaded through the path. Parent nodes can use
this to give child nodes context *)
class virtual ['env, 'm] mapreduce : object ('self)
method virtual empty : 'm
method virtual plus : 'm -> 'm -> 'm
(** doesn't really to be here, but putting it here avoids passing [empty]
and [plus] to a general purpose [fold_left_map]*)
method private fold_left_map : 'a. f:('a -> 'a * 'm) -> 'a list -> 'a list * 'm
method alias : 'env -> t -> decl * 'm
method app : 'env -> t -> t list -> t * 'm
method assoc : 'env -> t -> t -> t * 'm
method constr : 'env -> constr -> constr * 'm
method field : 'env -> field -> field * 'm
method list : 'env -> t -> t * 'm
method path : 'env -> Path.t -> t * 'm
method optional : 'env -> t -> t * 'm
method poly_variant : 'env -> constr list -> t * 'm
method prim : 'env -> prim -> t * 'm
method record : 'env -> field list -> decl * 'm
method t : 'env -> t -> t * 'm
method decl : 'env -> decl -> decl * 'm
method tuple : 'env -> t list -> t * 'm
method var : 'env -> string -> t * 'm
method variant : 'env -> constr list -> decl * 'm
end
end
module Expr : sig
(** An (untyped) ocaml expression. It is the responsibility of the generator
to create well typed expressions *)
type expr =
| Let of pat * expr * expr
| Match of expr * (pat * expr) list
| Fun of pat Arg.t list * expr
| App of expr * expr Arg.t list
| Create of expr prim
| Assert_false
(* patterns or constructors, depending on ['e] *)
and 'e prim =
| Unit
| Bool of bool
| Int of int
| String of string
(* This should be Path.t as well *)
| Ident of string
| Cons of 'e * 'e prim
| List of 'e list
| Tuple of 'e list
| Record of 'e record_
| Constr of 'e constr
and pat =
| Wildcard (** [_ -> ] *)
| Pat of pat prim
and 'e record_ = (string * 'e) list
and 'e constr =
{ tag : string (** the tag in a tagged union *)
; poly : bool (** polymorphic variant? *)
; args : 'e list
}
type t = expr
(** [ _ -> assert false ] *)
val assert_false_clause : pat * expr
(** toplevel declartion (without the name) *)
type toplevel =
{ pat : (string Arg.t * Type.t) list
(** paterns and their types. types should be optional but they really
help the error messages if the generated code is incorrect *)
; type_ : Type.t (** useful to annotate the return types *)
; body : t
}
end
module Module : sig
(** Generate OCaml modules with JS converters *)
module Name : sig
type t = private string
val of_string : string -> t
end
type 'a t =
{ name : Name.t
; bindings : 'a Named.t list
}
val empty : Name.t -> 'a t
type sig_ =
| Value of Type.t
| Type_decl of Type.decl
| Include of Name.t * (Type.t * Type.t) list
type impl =
| Type_decl of Type.decl
| Value of Expr.toplevel
val pp_sig : sig_ t -> unit Pp.t
val pp_impl : impl t -> unit Pp.t
end

78
thirdparty/lsp/lsp/bin/ocaml/ml_create.ml vendored Normal file
View file

@ -0,0 +1,78 @@
open Import
let f_name name = if name = "t" then "create" else sprintf "create_%s" name
let need_unit =
List.exists ~f:(fun (f : Ml.Type.field) ->
match f.typ with
| Optional _ -> true
| _ -> false)
;;
let intf { Named.name; data = fields } =
let type_ =
let need_unit = need_unit fields in
let fields : Ml.Type.t Ml.Arg.t list =
List.map fields ~f:(fun (field : Ml.Type.field) ->
match field.typ with
| Optional t -> Ml.Arg.Optional (field.name, t)
| t -> Labeled (field.name, t))
in
let args : Ml.Type.t Ml.Arg.t list =
if need_unit
then
(* Gross hack because I was too lazy to allow patterns in toplevel
exprs *)
fields @ [ Ml.Arg.Unnamed Ml.Type.unit ]
else fields
in
Ml.Type.fun_ args (Ml.Type.name name)
in
let f_name = f_name name in
{ Named.name = f_name; data = type_ }
;;
let impl { Named.name; data = fields } =
let make =
let fields =
List.map fields ~f:(fun (field : Ml.Type.field) ->
let open Ml.Expr in
field.name, Create (Ident field.name))
in
Ml.Expr.Create (Record fields)
in
let pat =
let need_unit = need_unit fields in
let fields =
List.map fields ~f:(fun (field : Ml.Type.field) ->
match field.typ with
| Optional t -> Ml.Arg.Optional (field.name, field.name), t
| t -> Ml.Arg.Labeled (field.name, field.name), t)
in
if need_unit
then
(* Gross hack because I was too lazy to allow patterns in toplevel
exprs *)
fields @ [ Unnamed "()", Ml.Type.unit ]
else fields
in
let body = { Ml.Expr.pat; type_ = Ml.Type.name name; body = make } in
let f_name = f_name name in
{ Named.name = f_name; data = body }
;;
let impl_of_type (t : Ml.Type.decl Named.t) =
match (t.data : Ml.Type.decl) with
| Record fields ->
let create = impl { t with data = fields } in
[ { create with data = Ml.Module.Value create.data } ]
| _ -> []
;;
let intf_of_type (t : Ml.Type.decl Named.t) : Ml.Module.sig_ Named.t list =
match (t.data : Ml.Type.decl) with
| Record fields ->
let create = intf { t with data = fields } in
[ { create with data = Ml.Module.Value create.data } ]
| _ -> []
;;

3
thirdparty/lsp/lsp/bin/ocaml/ml_create.mli vendored Normal file
View file

@ -0,0 +1,3 @@
(* Generate create functions with optional/labeled arguments *)
val intf_of_type : Ml.Type.decl Named.t -> Ml.Module.sig_ Named.t list
val impl_of_type : Ml.Type.decl Named.t -> Ml.Module.impl Named.t list

28
thirdparty/lsp/lsp/bin/ocaml/ml_kind.ml vendored Normal file
View file

@ -0,0 +1,28 @@
open! Import
type 'a t =
{ intf : 'a
; impl : 'a
}
type kind =
| Impl
| Intf
let get { intf; impl } = function
| Impl -> impl
| Intf -> intf
;;
let make_both a = { intf = a; impl = a }
let iter { intf; impl } ~f =
f intf;
f impl
;;
let map { intf; impl } ~f = { intf = f intf; impl = f impl }
let both (type a b) (x : a t) (y : b t) : (a * b) t =
{ intf = x.intf, y.intf; impl = x.impl, y.impl }
;;

681
thirdparty/lsp/lsp/bin/ocaml/ocaml.ml vendored Normal file
View file

@ -0,0 +1,681 @@
open! Import
open! Ts_types
(* TypeScript to OCaml conversion pipeline. The goal of this pipeline is to do
the conversion in logical stages. Unfortunately, this doesn't quite work *)
(* These declarations are all excluded because we don't support them or their
definitions are hand written *)
let skipped_ts_decls =
[ "InitializedParams"
; "NotificationMessage"
; "RequestMessage"
; "ResponseError"
; "DocumentUri"
; "ResponseMessage"
; "Message"
; "ErrorCodes"
; "MarkedString"
; "ProgressToken"
; "ProgressParams"
; "TextDocumentFilter"
; "PrepareRenameResult"
; "LSPAny"
; "LSPObject"
; "LSPArray"
; "LSPErrorCodes"
; "NotebookDocumentSyncOptions"
; "NotebookDocumentFilter"
; "NotebookDocumentSyncRegistrationOptions"
; "URI"
]
;;
(* XXX this is temporary until we support the [supportsCustomValues] field *)
let with_custom_values =
[ "FoldingRangeKind"; "CodeActionKind"; "PositionEncodingKind"; "WatchKind" ]
;;
module Expanded = struct
(** The expanded form is still working with typescript types. However, all
"anonymous" records and sums have been hoisted to the toplevel. So there
is a 1-1 correspondence to the OCaml typse we are going to generate *)
[@@@ocaml.warning "-37"]
type binding =
| Record of Resolved.field list
| Interface of Resolved.interface
| Poly_enum of Resolved.typ list
| Alias of Resolved.typ
type t = binding Ml.Module.t
(** Every anonymous record *)
let new_binding_of_typ (x : Resolved.typ) : binding option =
let record = function
| [ { Named.name = _; data = Resolved.Pattern _ } ] -> None
| f -> Some (Record f)
in
match x with
| List (Record d) | Record d -> record d
| Sum [ _; Record d ] -> record d
| _ -> None
;;
class discovered_types =
object
inherit [binding Named.t list] Resolved.fold as super
(** Every record valued field introduces a new type
TODO handle the case where two fields share a type *)
method! field f ~init =
let init =
match f.data with
| Pattern _ -> init
| Single { optional = _; typ } ->
(match new_binding_of_typ typ with
| None -> init
| Some data ->
let new_record = { f with data } in
if List.mem ~equal:Poly.equal init new_record
then init
else new_record :: init)
in
super#field f ~init
end
let bindings (r : Resolved.t) =
let t : binding Named.t =
let data =
match r.data with
| Enum_anon _ -> assert false
| Interface i -> Interface i
| Type typ ->
(match new_binding_of_typ typ with
| Some data -> data
| None -> Alias typ)
in
{ data; name = "t" }
in
let init = [ t ] in
match r.data with
| Enum_anon _ -> assert false
| Type typ -> (new discovered_types)#typ typ ~init
| Interface intf -> (new discovered_types)#typ (Record intf.fields) ~init
;;
let of_ts (r : Resolved.t) : t =
let name = Ml.Module.Name.of_string (String.capitalize_ascii r.name) in
{ Ml.Module.name; bindings = bindings r }
;;
end
module Json = Json_gen
module Module : sig
open Ml
type t = (Module.sig_ Module.t, Module.impl Module.t) Kind.pair
val add_private_values : t -> Expr.toplevel Named.t list -> t
val type_decls : Module.Name.t -> Type.decl Named.t list Kind.Map.t -> t
(** Use Json.Nullable_option or Json.Assoc.t where appropriate *)
val use_json_conv_types : t -> t
(** Rename fields that are also OCaml keywords *)
val rename_invalid_fields : Ml.Kind.t -> Type.decl -> Type.decl
val pp : t -> unit Pp.t Kind.Map.t
end = struct
module Module = Ml.Module
type t = (Module.sig_ Module.t, Module.impl Module.t) Ml.Kind.pair
let type_decls name (type_decls : Ml.Type.decl Named.t list Ml.Kind.Map.t) : t =
let module_ bindings = { Ml.Module.name; bindings } in
let intf : Module.sig_ Module.t =
List.map type_decls.intf ~f:(fun (td : Ml.Type.decl Named.t) ->
{ td with Named.data = (Ml.Module.Type_decl td.data : Ml.Module.sig_) })
|> module_
in
let impl =
List.map type_decls.impl ~f:(fun (td : Ml.Type.decl Named.t) ->
{ td with Named.data = Ml.Module.Type_decl td.data })
|> module_
in
{ Ml.Kind.intf; impl }
;;
let add_private_values (t : t) bindings : t =
let bindings =
List.map bindings ~f:(fun (v : _ Named.t) ->
{ v with Named.data = Ml.Module.Value v.data })
in
let impl = { t.impl with bindings = t.impl.bindings @ bindings } in
{ t with impl }
;;
let json_assoc_t = Ml.Path.Dot (Dot (Ident "Json", "Assoc"), "t")
let rename_invalid_fields =
let map (kind : Ml.Kind.t) =
let open Ml.Type in
object (self)
inherit [unit, unit] Ml.Type.mapreduce as super
method empty = ()
method plus () () = ()
method! field x f =
let f =
if Ml.is_kw f.name
then (
let attrs =
match kind with
| Impl -> ("key", [ sprintf "%S" f.name ]) :: f.attrs
| Intf -> f.attrs
in
{ f with name = f.name ^ "_"; attrs })
else f
in
super#field x f
method! assoc x k v = self#t x (App (Path json_assoc_t, [ k; v ]))
end
in
fun kind t -> (map kind)#decl () t |> fst
;;
let use_json_conv_types =
let map =
let open Ml.Type in
object (self)
inherit [unit, unit] Ml.Type.mapreduce as super
method empty = ()
method plus () () = ()
method! optional x t =
if t = Json_gen.json_t
then super#optional x t
else (
let opt = Ml.Path.Dot (Dot (Ident "Json", "Nullable_option"), "t") in
self#t x (App (Path opt, [ t ])))
method! field x f =
let f =
match f.typ with
| Optional t ->
if t = Json_gen.json_t
then { f with attrs = ("yojson.option", []) :: f.attrs }
else
{ f with
attrs =
("default", [ "None" ])
:: ("yojson_drop_default", [ "( = )" ])
:: f.attrs
}
| _ -> f
in
super#field x f
method! assoc x k v = self#t x (App (Path json_assoc_t, [ k; v ]))
end
in
fun (t : t) ->
let impl =
let bindings =
List.map t.impl.bindings ~f:(fun (x : _ Named.t) ->
let data =
match (x.data : Module.impl) with
| Type_decl decl -> Ml.Module.Type_decl (map#decl () decl |> fst)
| x -> x
in
{ x with data })
in
{ t.impl with bindings }
in
{ t with impl }
;;
let pp (t : t) ~kind =
match (kind : Ml.Kind.t) with
| Intf -> Ml.Module.pp_sig t.intf
| Impl -> Ml.Module.pp_impl t.impl
;;
let pp t = { Ml.Kind.intf = pp t ~kind:Intf; impl = pp t ~kind:Impl }
end
let enum_module ~allow_other ({ Named.name; data = constrs } as t) =
let json_bindings = Json_gen.Enum.conv ~allow_other ~poly:false { t with name = "t" } in
let t =
let data =
let constrs = List.map constrs ~f:(fun (name, _) -> Ml.Type.constr ~name []) in
let constrs =
if allow_other
then
(* [String] is a hack. It could be a differnt type, but it isn't in
practice *)
constrs @ [ Ml.Type.constr ~name:"Other" [ Ml.Type.Prim String ] ]
else constrs
in
Ml.Type.Variant constrs
in
{ Named.name = "t"; data }
in
let type_decls = Ml.Kind.Map.make_both [ t ] in
let module_ = Module.type_decls (Ml.Module.Name.of_string name) type_decls in
Module.add_private_values module_ json_bindings
;;
module Entities = struct
type t = (Ident.t * Resolved.t) list
let find db e : _ Named.t =
match List.assoc db e with
| Some s -> s
| None -> Code_error.raise "Entities.find: unable to find" [ "e", Ident.to_dyn e ]
;;
let of_map map ts =
List.map ts ~f:(fun (r : Resolved.t) -> String.Map.find_exn map r.name, r)
;;
let rev_find (db : t) (resolved : Resolved.t) : Ident.t =
match
List.filter_map db ~f:(fun (id, r) ->
if r.name = resolved.name then Some id else None)
with
| [] -> Code_error.raise "rev_find: resolved not found" []
| [ x ] -> x
| _ :: _ -> Code_error.raise "re_vind: duplicate entries" []
;;
end
module Mapper : sig
(* Convert typescript types to OCaml types *)
val make_typ : Entities.t -> Resolved.typ Named.t -> Ml.Type.t
type literal_field =
{ field_name : string
; literal_value : string
}
(** Map a TS record into an OCaml record. Literal valued fields such as kind:
'foo' are extracted into a separate list *)
val record_
: Entities.t
-> Resolved.field list Named.t
-> Ml.Type.decl Named.t * literal_field list
(** Extract all untagged unions in field position. These will be turned into
polymorphic variants using a naming scheme for the tags. *)
val extract_poly_vars : Ml.Type.decl -> Ml.Type.decl * Ml.Type.constr list Named.t list
end = struct
type literal_field =
{ field_name : string
; literal_value : string
}
module Type = Ml.Type
let is_same_as_json =
let constrs =
[ Prim.Null; String; Bool; Number; Object; List ]
|> List.map ~f:(fun s -> Resolved.Ident s)
in
fun set -> List.for_all constrs ~f:(fun e -> List.mem set e ~equal:Poly.equal)
;;
let id = Type.name "Jsonrpc.Id.t"
let is_same_as_id =
let sort = List.sort ~compare:Poly.compare in
let constrs =
[ Prim.String; Number ] |> List.map ~f:(fun s -> Resolved.Ident s) |> sort
in
fun cs -> List.equal ( = ) constrs (sort cs)
;;
(* Any type that includes null needs to be extracted to be converted to an
option *)
let remove_null cs =
let is_null x =
match x with
| Resolved.Ident Prim.Null -> Either.Left x
| _ -> Right x
in
let nulls, non_nulls = List.partition_map ~f:is_null cs in
match nulls with
| [] -> `No_null_present
| _ :: _ :: _ -> assert false
| [ _ ] -> `Null_removed non_nulls
;;
let make_typ db { Named.name; data = t } =
let rec type_ topmost_field_name (t : Resolved.typ) =
match t with
| Ident Uinteger -> Type.int (* XXX shall we use a dedicated uinteger eventually? *)
| Ident Number -> Type.int
| Ident String -> Type.string
| Ident Bool -> Type.bool
| Ident Object -> Type.json_object
| Ident Self -> Type.t (* XXX wrong *)
| Ident Any -> Type.json
| Ident Null -> assert false
| Ident List -> Type.list Type.json
| Ident Uri | Ident (Resolved { id = _; name = "URI" }) ->
Type.module_t "DocumentUri"
| Ident (Resolved { id = _; name = "LSPAny" }) -> Type.json
| Ident (Resolved { id = _; name = "LSPObject" }) -> Type.json_object
| Ident (Resolved r) ->
let entity = Entities.find db r in
Type.module_t entity.name
| List (Ident (Uinteger | Number)) when topmost_field_name = Some "data" ->
Type.array Type.int
| List t -> Type.list (type_ topmost_field_name t)
| Tuple ts -> Type.Tuple (List.map ~f:(type_ topmost_field_name) ts)
| Sum s -> sum topmost_field_name s
| App _ | Literal _ -> Type.void
| Record r -> record r
and sum topmost_field_name s =
if is_same_as_json s
then Type.json
else (
match remove_null s with
| `No_null_present -> if is_same_as_id s then id else poly topmost_field_name s
| `Null_removed [ s ] -> Type.Optional (type_ topmost_field_name s)
| `Null_removed [] -> assert false
| `Null_removed cs -> Type.Optional (sum topmost_field_name cs))
and simplify_record (fields : Resolved.field list) =
(* A record with only a pattern field is simplified to an association
list *)
match fields with
| [ { Named.name; data = Pattern { pat; typ } } ] ->
let topmost_field_name = Some name in
let key = type_ topmost_field_name pat in
let data = type_ topmost_field_name typ in
Some (Type.assoc_list ~key ~data)
| [] -> Some Type.json_object
| _ -> None
and record fields =
match simplify_record fields with
| None -> Type.name name
| Some a -> a
and poly topmost_field_name s : Ml.Type.t =
let type_ = type_ topmost_field_name in
try
Poly_variant
(List.map s ~f:(fun t ->
let name, constrs =
match (t : Resolved.typ) with
| Ident Self | Ident Null -> assert false
| Ident String -> "String", [ type_ t ]
| Ident Number -> "Int", [ type_ t ]
| Ident Object -> "Assoc", [ type_ t ]
| Ident Bool -> "Bool", [ type_ t ]
| List _ | Ident List -> "List", [ type_ t ]
| Ident (Resolved r) -> (Entities.find db r).name, [ type_ t ]
| Tuple [ Ident Uinteger; Ident Uinteger ] -> "Offset", [ type_ t ]
| Literal (String x) -> x, []
| Record _ ->
let topmost_field_name = Option.value_exn topmost_field_name in
topmost_field_name, [ type_ t ]
| _ -> raise Exit
in
Type.constr ~name constrs))
with
| Exit -> Type.unit
in
type_ (Some name) t
;;
let make_field db (field : Resolved.field) =
match field.data with
| Pattern { pat; typ } ->
let key = make_typ db { Named.name = field.name; data = pat } in
let data = make_typ db { Named.name = field.name; data = typ } in
let typ = Type.assoc_list ~key ~data in
Either.Left (Ml.Type.field typ ~name:field.name)
| Single { typ = Literal s; optional = false } ->
let literal_value =
match s with
| String s -> s
| _ -> assert false
in
Right { literal_value; field_name = field.name }
| Single { typ; optional } ->
let typ = make_typ db { Named.name = field.name; data = typ } in
let typ = if optional then Type.Optional typ else typ in
Left (Ml.Type.field typ ~name:field.name)
;;
let record_ db { Named.name; data = (fields : Resolved.field list) } =
let data, literals =
match fields with
| [ { Named.name; data = Pattern { pat; typ } } ] ->
let key = make_typ db { Named.name; data = pat } in
let data = make_typ db { Named.name; data = typ } in
Type.Alias (Type.assoc_list ~key ~data), []
| [] -> Type.Alias Type.json_object, []
| _ ->
let fields, literals = List.partition_map fields ~f:(make_field db) in
Type.Record fields, literals
in
{ Named.name; data }, literals
;;
let extract_poly_vars s =
let extract =
object (self)
inherit
[string option, Ml.Type.constr list Named.t list] Ml.Type.mapreduce as super
method empty = []
(* TODO grossly slow *)
method plus x y = x @ y
method! field _ (f : Ml.Type.field) =
let env = Some f.name in
super#field env f
method! poly_variant env constrs =
match env with
| None -> super#poly_variant env constrs
| Some name ->
(* This hack is needed to avoid collision with user visible types
that we might introduce *)
let name = name ^ "_pvar" in
let replacement = Ml.Type.name name in
let constrs, m = self#fold_left_map ~f:(self#constr env) constrs in
replacement, self#plus m [ { Named.name; data = constrs } ]
end
in
extract#decl None s
;;
end
module Gen : sig
val module_ : Entities.t -> Expanded.binding Ml.Module.t -> Module.t
end = struct
module Type = Ml.Type
let type_ db ({ Named.name; data = _ } as t) =
let main_type =
let typ = Mapper.make_typ db t in
{ Named.name; data = Type.Alias typ }
in
[ main_type ]
;;
let record db ({ Named.name = _; data = _ } as t) =
let main_type, literals = Mapper.record_ db t in
Some (main_type, literals)
;;
let poly_enum { Named.name; data = _ } : Type.decl Named.t list =
[ { Named.name; data = Type.Alias Type.unit } ]
;;
let poly_enum_conv (t : _ Named.t) =
if List.for_all t.data ~f:(fun (c : Ml.Type.constr) -> List.is_empty c.args)
then
(* This is equivalent to an enum *)
List.map t.data ~f:(fun (c : Ml.Type.constr) -> c.name, Literal.String c.name)
|> Named.set_data t
|> Json_gen.Enum.conv ~allow_other:false ~poly:true
else [ Json_gen.Poly_variant.of_json t; Json_gen.Poly_variant.to_json t ]
;;
(* This is the more complex case *)
let module_ db { Ml.Module.name; bindings } : Module.t =
let type_decls =
let add_record = function
| None -> []
| Some (decl, literals) -> [ `Record (decl, literals) ]
in
let add_else = List.map ~f:(fun x -> `Type x) in
List.concat_map bindings ~f:(fun (r : Expanded.binding Named.t) ->
match r.data with
| Record data -> record db { r with data } |> add_record
| Interface data -> record db { r with data = data.fields } |> add_record
| Poly_enum data -> poly_enum { r with data } |> add_else
| Alias data -> type_ db { r with data } |> add_else)
in
let intf : Ml.Module.sig_ Named.t list =
List.map type_decls ~f:(function
| `Record (t, _) -> t
| `Type t -> t)
|> List.concat_map ~f:(fun (td : Ml.Type.decl Named.t) ->
let td = { td with data = Module.rename_invalid_fields Intf td.data } in
[ { td with Named.data = (Ml.Module.Type_decl td.data : Ml.Module.sig_) } ]
@ Ml_create.intf_of_type td)
in
let impl : Ml.Module.impl Named.t list =
(* TODO we should make sure to handle duplicate variants extracted *)
List.concat_map type_decls ~f:(fun d ->
let d, literal_wrapper =
match d with
| `Record (l, [ lw ]) -> l, Some lw
| `Record (l, []) -> l, None
| `Record (_, _ :: _) ->
assert false
(* we don't support multiple literals in a single record for
now *)
| `Type l -> l, None
in
let typ_, poly_vars = Mapper.extract_poly_vars (Named.data d) in
let poly_vars_and_convs =
List.concat_map poly_vars ~f:(fun pv ->
let decl =
Named.map pv ~f:(fun decl ->
Ml.Module.Type_decl (Alias (Poly_variant decl)))
in
let json_conv =
poly_enum_conv pv |> List.map ~f:(Named.map ~f:(fun v -> Ml.Module.Value v))
in
decl :: json_conv)
in
let typ_ = { d with data = typ_ } in
let literal_wrapper =
match literal_wrapper with
| None -> []
| Some { field_name; literal_value } ->
Json_gen.make_literal_wrapper_conv
~field_name
~literal_value
~type_name:typ_.name
in
let typ_ = { typ_ with data = Module.rename_invalid_fields Impl typ_.data } in
let json_convs_for_t =
match d.data with
| Alias (Poly_variant data) ->
poly_enum_conv { d with Named.data }
|> List.map ~f:(Named.map ~f:(fun v -> Ml.Module.Value v))
| _ -> []
in
poly_vars_and_convs
@ [ { typ_ with data = Ml.Module.Type_decl typ_.data } ]
@ json_convs_for_t
@ Ml_create.impl_of_type typ_
@ literal_wrapper)
in
let module_ bindings = { Ml.Module.name; bindings } in
{ Ml.Kind.intf = module_ intf; impl = module_ impl }
;;
end
(* extract all resovled identifiers *)
class name_idents =
object
inherit [Ident.t list] Resolved.fold
method! ident i ~init =
match i with
| Resolved r -> r :: init
| _ -> init
end
let resolve_typescript (ts : Unresolved.t list) =
let ts, db = Typescript.resolve_all ts in
let db = Entities.of_map db ts in
match
let idents = new name_idents in
Ident.Top_closure.top_closure
ts
~key:(fun x -> Entities.rev_find db x)
~deps:(fun x -> idents#t x ~init:[] |> List.map ~f:(Entities.find db))
with
| Error cycle ->
let cycle = List.map cycle ~f:(fun (x : Resolved.t) -> x.name) in
Code_error.raise "Unexpected cycle" [ "cycle", Dyn.(list string) cycle ]
| Ok ts -> db, ts
;;
let of_resolved_typescript db (ts : Resolved.t list) =
let simple_enums, everything_else =
List.filter_partition_map ts ~f:(fun (t : Resolved.t) ->
if List.mem skipped_ts_decls t.name ~equal:String.equal
then Skip
else (
match t.data with
| Enum_anon data -> Left { t with data }
| Interface _ | Type _ -> Right t))
in
let simple_enums =
List.map simple_enums ~f:(fun (t : _ Named.t) ->
(* "open" enums need an `Other constructor *)
let allow_other = List.mem ~equal:String.equal with_custom_values t.name in
let data =
List.filter_map t.data ~f:(fun (constr, v) ->
match (v : Ts_types.Enum.case) with
| Literal l -> Some (constr, l)
| Alias _ ->
(* TODO we don't handle these for now *)
None)
in
enum_module ~allow_other { t with data })
in
let everything_else =
List.map everything_else ~f:(fun (t : _ Named.t) ->
let mod_ = Expanded.of_ts t in
Gen.module_ db mod_)
in
simple_enums @ everything_else
|> List.map ~f:(fun (decl : _ Ml.Kind.pair) ->
let decl =
let intf = Json_gen.add_json_conv_for_t decl.intf in
{ decl with intf }
in
Module.use_json_conv_types decl)
;;
let of_typescript ts =
let db, ts = resolve_typescript ts in
of_resolved_typescript db ts
;;

7
thirdparty/lsp/lsp/bin/ocaml/ocaml.mli vendored Normal file
View file

@ -0,0 +1,7 @@
module Module : sig
type t = (Ml.Module.sig_ Ml.Module.t, Ml.Module.impl Ml.Module.t) Ml.Kind.pair
val pp : t -> unit Pp.t Ml.Kind.Map.t
end
val of_typescript : Ts_types.Unresolved.t list -> Module.t list

199
thirdparty/lsp/lsp/bin/ocaml/w.ml vendored Normal file
View file

@ -0,0 +1,199 @@
open Import
open Pp.O
open Pp
type t = unit Pp.t
type w = t
(* This module contains all the writing primitives *)
let ident = verbatim
let i = verbatim
let quoted s = i (sprintf "%S" s)
let surround delim a =
let start, finish =
match delim with
| `Paren -> i "(", i ")"
| `Curly -> i "{", i "}"
| `Square -> i "[", i "]"
in
Pp.concat [ start; a; finish ]
;;
module Json = struct
let invalid_pat name = ident "json", Pp.textf "Json.error \"invalid %s\" json" name
let typ = "Json.t"
module Literal = struct
let str n = sprintf "`String %S" n
let int i = sprintf "`Int (%d)" i
let null = "`Null"
let bool b = sprintf "`Bool %b" b
end
let str = sprintf "`String %s"
let int = sprintf "`Int %s"
let bool = sprintf "`Bool %s"
end
module Gen = struct
let record ~delim fields =
let sep = Pp.concat [ Pp.verbatim ";"; Pp.newline ] in
Pp.text "{"
++ Pp.concat_map ~sep fields ~f:(fun (name, f) ->
Pp.concat [ Pp.textf "%s %s " name delim; f ])
++ Pp.verbatim "}"
;;
let clause ~delim l r = Pp.concat [ l; Pp.verbatim (sprintf " %s " delim); r ]
end
module Attr = struct
type t =
{ name : string
; payload : w list
}
let make name payload = { name; payload }
let pp kind { name; payload } =
let kind =
match kind with
| `Field -> "@"
| `Type -> "@@"
in
Pp.concat [ i kind; i name; Pp.space; Pp.concat ~sep:Pp.space payload ]
|> surround `Square
;;
end
module Type = struct
let string = i "string"
let int = i "int"
let name = i
let bool = i "bool"
let gen_decl kw name body = Pp.concat [ Pp.textf "%s %s =" kw name; Pp.newline; body ]
let and_ name body = gen_decl "and" name body
let decl name body = gen_decl "type" name body
let record fields = Gen.record ~delim:":" fields
let field_attrs ~field ~attrs =
match attrs with
| [] -> field
| attrs ->
let attrs = Pp.concat_map attrs ~sep:Pp.space ~f:(Attr.pp `Field) in
Pp.concat [ field; Pp.space; attrs ]
;;
let var typ = Pp.textf "'%s" typ
let app typ = function
| [] -> assert false
| [ x ] -> Pp.concat [ x; Pp.space; typ ]
| xs ->
let args =
let sep = Pp.verbatim "," in
Pp.concat [ Pp.verbatim "("; Pp.concat ~sep xs; Pp.verbatim ")" ]
in
Pp.concat [ args; Pp.space; typ ]
;;
let tuple fields =
let sep = i "*" in
i "(" ++ Pp.concat ~sep fields ++ i ")"
;;
let rec_decls xs =
match xs with
| [] -> Pp.concat []
| (name, body) :: xs ->
decl name body
++ newline
++ Pp.concat_map xs ~sep:Pp.newline ~f:(fun (name, body) -> and_ name body)
;;
let deriving td ~record =
let fields = if record then space ++ i "[@@yojson.allow_extra_fields]" else space in
Pp.concat
[ td
; Pp.newline
; Pp.text "[@@deriving_inline yojson]"
; fields
; space
; Pp.text "[@@@end]"
]
;;
let opt_attr = ident "option [@yojson.option]"
let opt_field f = Pp.seq f opt_attr
let default f def = Pp.concat [ f; ident "[@default "; ident def; ident "]" ]
let key name = concat [ ident "[@key "; quoted name; ident "]" ]
let gen_variant ~poly constrs =
let sep = Pp.concat [ Pp.newline; i "| " ] in
Pp.concat_map constrs ~sep ~f:(fun (name, arg) ->
let name =
let name = String.capitalize_ascii name in
if poly then "`" ^ name else name
in
match arg with
| [] -> i name
| xs ->
let xs =
match xs with
| [ x ] -> x
| xs -> tuple xs
in
Gen.clause ~delim:"of" (ident name) xs)
;;
let poly constrs = concat [ i "["; gen_variant ~poly:true constrs; i "]" ]
let variant constrs = gen_variant ~poly:false constrs
end
let gen_module kw name body =
Pp.concat
[ Pp.textf "module %s %s" name kw
; Pp.newline
; body
; newline
; verbatim "end"
; newline
]
;;
module Sig = struct
let module_ name body = gen_module ": sig" name body
let include_ name destructive_subs =
let inc_ = Pp.textf "include %s" name in
match destructive_subs with
| [] -> inc_
| substs ->
let substs =
let sep = Pp.text " and " in
Pp.concat_map ~sep substs ~f:(fun (l, r) ->
Pp.concat
[ Pp.text "type"; Pp.space; l; Pp.space; Pp.verbatim ":="; Pp.space; r ])
in
Pp.concat [ inc_; Pp.space; Pp.text "with"; Pp.space; substs ]
;;
let val_ name b =
let sep = Pp.concat [ space; i "->"; space ] in
let b = Pp.concat ~sep b in
Pp.concat [ textf "val %s : " name; b; Pp.newline ]
;;
let assoc k v = Pp.concat [ Type.tuple [ k; v ]; Pp.space; i "list" ]
end
let warnings codes = seq (textf "[@@@warning %S]" codes) newline
let opens names =
Pp.concat_map names ~f:(fun name -> Pp.concat [ textf "open! %s" name; newline ])
;;
let module_ name body = gen_module "= struct" name body
let record fields = Gen.record ~delim:"=" fields

62
thirdparty/lsp/lsp/bin/ocaml/w.mli vendored Normal file
View file

@ -0,0 +1,62 @@
(** Helpers to generate OCaml code. Consider merging with ML *)
type t = unit Pp.t
type w = t
val surround : [ `Curly | `Paren | `Square ] -> 'a Pp.t -> 'a Pp.t
module Json : sig
val invalid_pat : string -> w * w
val typ : string
module Literal : sig
val str : string -> string
val int : int -> string
val null : string
val bool : bool -> string
end
val str : string -> string
val int : string -> string
val bool : string -> string
end
module Attr : sig
type t
val make : string -> unit Pp.t list -> t
end
module Type : sig
val string : w
val int : w
val bool : w
val name : string -> w
val and_ : string -> w -> w
val decl : string -> w -> w
val record : (string * w) list -> w
val field_attrs : field:w -> attrs:Attr.t list -> w
val rec_decls : (string * w) list -> w
val var : string -> w
val poly : (string * w list) list -> w
val app : w -> w list -> w
val tuple : w list -> w
val deriving : w -> record:bool -> w
val opt_attr : w
val opt_field : w -> w
val default : w -> string -> w
val key : string -> w
val variant : (string * w list) list -> w
end
module Sig : sig
val module_ : string -> w -> w
val include_ : string -> (w * w) list -> w
val val_ : string -> w list -> w
val assoc : w -> w -> w
end
val warnings : string -> w
val module_ : string -> w -> w
val opens : string list -> w
val record : (string * w) list -> w

11
thirdparty/lsp/lsp/bin/test_metamodel.ml vendored Normal file
View file

@ -0,0 +1,11 @@
module Metamodel = Lsp_gen.Metamodel
let file = Sys.argv.(1)
let () =
let read = open_in file in
let s = really_input_string read (in_channel_length read) in
let json = Yojson.Safe.from_string s in
let (_ : Metamodel.t) = Metamodel.t json in
close_in read
;;

423
thirdparty/lsp/lsp/bin/typescript/ts_types.ml vendored Normal file
View file

@ -0,0 +1,423 @@
(* Representation of the typescript defined spec we're working with *)
open Import
module Literal = struct
type t =
| String of string
| Int of int
| Float of float
let to_maybe_quoted_string = function
| String s -> sprintf "%S" s
| Int i -> string_of_int i
| Float f -> string_of_float f
;;
let to_dyn : t -> Dyn.t =
let open Dyn in
function
| String s -> string s
| Int i -> int i
| Float f -> float f
;;
end
module Enum = struct
type case =
| Literal of Literal.t
| Alias of string
let dyn_of_case =
let open Dyn in
function
| Literal l -> variant "Literal" [ Literal.to_dyn l ]
| Alias l -> variant "Alias" [ string l ]
;;
type t = (string * case) list
let to_dyn t =
let open Dyn in
list (fun (name, case) -> pair string dyn_of_case (name, case)) t
;;
end
module type S = sig
(** Kept abstract for resolved vs. unresolved trees *)
type ident
type field_def =
| Single of
{ optional : bool
; typ : typ
}
| Pattern of
{ pat : typ
; typ : typ
}
and field = field_def Named.t
and typ =
| Literal of Literal.t
| Ident of ident
| Sum of typ list
| List of typ
| Record of field list
| Tuple of typ list
| App of typ * typ
and interface = { fields : field list }
and decl =
| Interface of interface
| Type of typ
| Enum_anon of Enum.t
and t = decl Named.t
val to_dyn : t -> Dyn.t
val dyn_of_typ : typ -> Dyn.t
val dyn_of_field : field -> Dyn.t
class map : object
method typ : typ -> typ
method sum : typ list -> typ
method interface : interface -> interface
method enum_anon : Enum.t -> Enum.t
method field : field -> field
method t : t -> t
end
class ['a] fold : object
method field : field -> init:'a -> 'a
method ident : ident -> init:'a -> 'a
method t : t -> init:'a -> 'a
method typ : typ -> init:'a -> 'a
end
end
module Make (Ident : sig
type t
val to_dyn : t -> Dyn.t
end) =
struct
type field_def =
| Single of
{ optional : bool
; typ : typ
}
| Pattern of
{ pat : typ
; typ : typ
}
and field = field_def Named.t
and typ =
| Literal of Literal.t
| Ident of Ident.t
| Sum of typ list
| List of typ
| Record of field list
| Tuple of typ list
| App of typ * typ
and interface = { fields : field list }
and decl =
| Interface of interface
| Type of typ
| Enum_anon of Enum.t
and t = decl Named.t
let rec dyn_of_typ =
let open Dyn in
function
| Literal l -> variant "Literal" [ Literal.to_dyn l ]
| Ident l -> variant "Ident" [ Ident.to_dyn l ]
| Sum l -> variant "Sum" (List.map ~f:dyn_of_typ l)
| List l -> variant "List" [ dyn_of_typ l ]
| Tuple l -> variant "Tuple" (List.map ~f:dyn_of_typ l)
| App (f, x) -> variant "App" [ dyn_of_typ f; dyn_of_typ x ]
| Record fs -> variant "Record" (List.map fs ~f:dyn_of_field)
and field_def_of_dyn =
let open Dyn in
function
| Single { optional; typ } ->
record [ "optional", bool optional; "typ", dyn_of_typ typ ]
| Pattern { pat : typ; typ : typ } ->
record [ "pat", dyn_of_typ pat; "typ", dyn_of_typ typ ]
and dyn_of_field f = Named.to_dyn field_def_of_dyn f
let dyn_of_interface { fields } =
let open Dyn in
record [ "fields", (list dyn_of_field) fields ]
;;
let dyn_of_decl =
let open Dyn in
function
| Interface i -> variant "Interface" [ dyn_of_interface i ]
| Type t -> variant "Type" [ dyn_of_typ t ]
| Enum_anon t -> variant "Enum_anon" [ Enum.to_dyn t ]
;;
let to_dyn t = Named.to_dyn dyn_of_decl t
class ['a] fold =
object (self)
method t (t : t) ~init =
match t.data with
| Interface (i : interface) ->
List.fold_left ~init i.fields ~f:(fun init f -> self#field f ~init)
| Type (t : typ) -> self#typ t ~init
| Enum_anon _ -> init
method ident _ ~init = init
method field (f : field) ~init : 'a =
match f.data with
| Single { optional = _; typ } -> self#typ ~init typ
| Pattern { pat; typ } ->
let init = self#typ ~init pat in
self#typ ~init typ
method typ (t : typ) ~init =
match t with
| Literal _ -> init
| Ident i -> self#ident i ~init
| App (t1, t2) ->
let init = self#typ t1 ~init in
self#typ t2 ~init
| List t -> self#typ t ~init
| Tuple typs | Sum typs ->
List.fold_left typs ~init ~f:(fun init f -> self#typ f ~init)
| Record fs -> List.fold_left fs ~init ~f:(fun init f -> self#field f ~init)
end
class map =
object (self)
method field (f : field) =
let data =
match f.data with
| Single s ->
let typ = self#typ s.typ in
Single { s with typ }
| Pattern { pat; typ } ->
let pat = self#typ pat in
let typ = self#typ typ in
Pattern { pat; typ }
in
{ f with data }
method interface (i : interface) =
let fields = List.map ~f:self#field i.fields in
{ fields }
method sum (constrs : typ list) = Sum (List.map constrs ~f:self#typ)
method typ (t : typ) =
match t with
| Literal i -> Literal i
| Ident i -> Ident i
| App (x, y) ->
let x = self#typ x
and y = self#typ y in
App (x, y)
| List t -> List (self#typ t)
| Tuple ts -> Tuple (List.map ts ~f:self#typ)
| Sum ts -> self#sum ts
| Record ts -> Record (List.map ts ~f:self#field)
method enum_anon (t : Enum.t) = t
method t (t : t) =
let data =
match t.data with
| Interface i -> Interface (self#interface i)
| Type t -> Type (self#typ t)
| Enum_anon t -> Enum_anon (self#enum_anon t)
in
{ t with data }
end
end
module Unresolved = struct
(** In the unresolved AST, all identifiers are just strings *)
include Make (String)
let enum ~name ~constrs : Enum.t Named.t = { Named.name; data = constrs }
let interface ~name ~fields : interface Named.t = { Named.name; data = { fields } }
let pattern_field ~name ~pat ~typ = { Named.name; data = Pattern { pat; typ } }
let named_field ?(optional = false) typ name =
{ Named.name; data = Single { optional; typ } }
;;
end
module Ident = struct
module Id = Stdune.Id.Make ()
module T = struct
type t =
{ id : Id.t
; name : string
}
let to_dyn { id; name } =
let open Dyn in
record [ "id", Id.to_dyn id; "name", String name ]
;;
let compare t { id; name = _ } = Id.compare t.id id
end
include T
let make name = { name; id = Id.gen () }
module C = Comparable.Make (T)
module Set = C.Set
module Top_closure = Top_closure.Make (Set) (Stdune.Monad.Id)
end
module Prim = struct
type t =
| Null
| String
| Bool
| Number
| Uinteger
| Uri
| Any
| Object
| List
| Self
| Resolved of Ident.t
let to_dyn =
let open Dyn in
function
| Null -> variant "Null" []
| String -> variant "String" []
| Bool -> variant "Bool" []
| Number -> variant "Number" []
| Uinteger -> variant "Uinteger" []
| Any -> variant "Any" []
| Object -> variant "Object" []
| List -> variant "List" []
| Self -> variant "Self" []
| Uri -> variant "Uri" []
| Resolved r -> variant "Resolved" [ Ident.to_dyn r ]
;;
let of_string s ~resolve =
match String.lowercase_ascii s with
| "null" -> Null
| "string" -> String
| "boolean" -> Bool
| "number" -> Number
| "uinteger" -> Uinteger
| "json" -> Any
| "lspany" -> Any
| "array" -> List
| "object" -> Object
| "lspobject" -> Object
| "uri" -> Uri
| _ -> resolve s
;;
end
module Resolved = Make (Prim)
let subst unresolved =
object
val params = String.Map.empty
val inside = None
(* Resolve self references. *)
method inside s = {<inside = Some s>}
method resolve n =
match String.Map.find params n with
| Some [] -> assert false
| Some (x :: _) -> `Resolved x
| None ->
if inside = Some n then `Self else `Unresolved (String.Map.find_exn unresolved n)
method push x y =
let params =
String.Map.update params x ~f:(function
| None -> Some [ y ]
| Some [] -> assert false
| Some (y' :: xs) -> if y = y' then Some xs else Some (y :: y' :: xs))
in
{<params>}
method pop x =
let params =
String.Map.update params x ~f:(function
| None ->
ignore (String.Map.find_exn params x);
None
| Some [] -> assert false
| Some (_ :: xs) -> Some xs)
in
{<params>}
end
;;
let rec resolve_all ts ~(names : Ident.t String.Map.t) : Resolved.t list =
let names = subst names in
List.map ts ~f:(resolve ~names)
and resolve (t : Unresolved.t) ~names : Resolved.t =
let data : Resolved.decl =
match t.data with
| Interface i -> Interface (resolve_interface { t with data = i } ~names)
| Type t -> Type (resolve_type t ~names)
| Enum_anon a -> Enum_anon a
in
{ t with Named.data }
and resolve_ident i ~names : Prim.t =
Prim.of_string i ~resolve:(fun s ->
match names#resolve s with
| `Resolved s -> s
| `Self -> Self
| `Unresolved s -> Resolved s)
and resolve_type (t : Unresolved.typ) ~names : Resolved.typ =
match t with
| Literal l -> Literal l
| Ident i -> Ident (resolve_ident ~names i)
| Sum l -> Sum (List.map ~f:(resolve_type ~names) l)
| Tuple l -> Tuple (List.map ~f:(resolve_type ~names) l)
| App (f, x) -> App (resolve_type ~names f, resolve_type ~names x)
| List t -> List (resolve_type t ~names)
| Record fields -> Record (List.map ~f:(resolve_field ~names) fields)
and resolve_interface i ~names : Resolved.interface =
let names = names#inside i.name in
let i = i.data in
{ fields = List.map ~f:(resolve_field ~names) i.fields }
and resolve_field f ~names : Resolved.field =
let data : Resolved.field_def =
match f.data with
| Single { optional; typ } ->
let typ = resolve_type ~names typ in
Single { optional; typ }
| Pattern { pat; typ } ->
let typ = resolve_type ~names typ in
let pat = resolve_type ~names pat in
Pattern { pat; typ }
in
{ f with Named.data }
;;

128
thirdparty/lsp/lsp/bin/typescript/ts_types.mli vendored Normal file
View file

@ -0,0 +1,128 @@
open Import
module Literal : sig
type t =
| String of string
| Int of int
| Float of float
val to_maybe_quoted_string : t -> string
val to_dyn : t -> Dyn.t
end
module Enum : sig
type case =
| Literal of Literal.t
| Alias of string
val dyn_of_case : case -> Dyn.t
type t = (string * case) list
val to_dyn : (string * case) list -> Dyn.t
end
module type S = sig
type ident
type field_def =
| Single of
{ optional : bool
; typ : typ
}
| Pattern of
{ pat : typ
; typ : typ
}
and field = field_def Named.t
and typ =
| Literal of Literal.t
| Ident of ident
| Sum of typ list
| List of typ
| Record of field list
| Tuple of typ list
| App of typ * typ
and interface = { fields : field list }
and decl =
| Interface of interface
| Type of typ
| Enum_anon of Enum.t
and t = decl Named.t
val to_dyn : t -> Dyn.t
val dyn_of_typ : typ -> Dyn.t
val dyn_of_field : field -> Dyn.t
class map : object
method enum_anon : Enum.t -> Enum.t
method field : field -> field
method interface : interface -> interface
method sum : typ list -> typ
method t : t -> t
method typ : typ -> typ
end
class ['a] fold : object
method field : field -> init:'a -> 'a
method ident : ident -> init:'a -> 'a
method t : t -> init:'a -> 'a
method typ : typ -> init:'a -> 'a
end
end
module Unresolved : sig
include S with type ident := String.t
val enum : name:string -> constrs:Enum.t -> Enum.t Named.t
val interface : name:string -> fields:field list -> interface Named.t
val pattern_field : name:string -> pat:typ -> typ:typ -> field_def Named.t
val named_field : ?optional:bool -> typ -> string -> field_def Named.t
end
module Ident : sig
module Id : Id.S
type t =
{ id : Id.t
; name : string
}
val to_dyn : t -> Dyn.t
val make : string -> t
module Top_closure : sig
val top_closure
: key:('a -> t)
-> deps:('a -> 'a list)
-> 'a list
-> ('a list, 'a list) result
end
end
module Prim : sig
type t =
| Null
| String
| Bool
| Number
| Uinteger
| Uri
| Any
| Object
| List
| Self
| Resolved of Ident.t
val to_dyn : t -> Dyn.t
val of_string : string -> resolve:(string -> t) -> t
end
module Resolved : S with type ident := Prim.t
val resolve_all : Unresolved.t list -> names:Ident.t String.Map.t -> Resolved.t list

128
thirdparty/lsp/lsp/bin/typescript/typescript.ml vendored Normal file
View file

@ -0,0 +1,128 @@
open Import
open Ts_types
let name_table (defns : Unresolved.t list) =
List.map defns ~f:(fun (def : _ Named.t) ->
def.name, (def, Ts_types.Ident.make def.name))
|> String.Map.of_list_reducei ~f:(fun name (v1, id1) (v2, id2) ->
let open Unresolved in
match v1.Named.data, v2.data with
| Enum_anon _, _ -> v1, id1
| _, Enum_anon _ -> v2, id2
| _, _ ->
if v1 = v2
then v1, id1
else
let open Dyn in
Code_error.raise "definition conflict" [ "name", string name ])
;;
let resolve_all (defns : Unresolved.t list) =
let names = name_table defns in
let defns = String.Map.values names |> List.map ~f:fst in
let names = String.Map.map ~f:snd names in
Ts_types.resolve_all defns ~names, names
;;
module Unresolved = Ts_types.Unresolved
open Unresolved
open Metamodel
let rename = function
| "_InitializeParams" -> "InitializedParams_"
| s -> s
;;
let reference s =
match rename s with
| "LSPAny" -> "Json"
| s -> s
;;
let named ~name s =
let name = rename name in
Named.make ~name s
;;
let baseType (baseType : Metamodel.baseType) : Ts_types.Unresolved.typ =
match baseType with
| Uri -> Ident "URI"
| DocumentUri -> Ident "URI"
| Integer -> Ident "number"
| Uinteger -> Ident "uinteger"
| Decimal -> Ident "number"
| RegExp -> assert false
| String -> Ident "string"
| Boolean -> Ident "boolean"
| Null -> Ident "null"
;;
let rec typ (type_ : Metamodel.type_) : Ts_types.Unresolved.typ =
match type_ with
| Reference s -> Ident (reference s)
| Base b -> baseType b
| Array t -> List (typ t)
| Or ts -> Sum (List.map ts ~f:typ)
| And _ -> failwith "and"
| Tuple ts -> Tuple (List.map ts ~f:typ)
| Literal l -> literal l
| Map m -> mapType m
and mapType { Metamodel.key; value } : Ts_types.Unresolved.typ =
let pat =
match key with
| Uri -> Ident "URI"
| DocumentUri -> Ident "URI"
| String -> Ident "string"
| Integer -> Ident "number"
| Reference s -> Ident (reference s)
in
let typ = typ value in
let field = named ~name:"" (Pattern { pat; typ }) in
Record [ field ]
and literal (l : Metamodel.literalType) : Ts_types.Unresolved.typ =
match l with
| String s -> Literal (String s)
| Boolean _ -> assert false
| Integer i -> Literal (Int i)
| Record fields -> Record (List.map ~f:field fields)
and field { Metamodel.name; optional; doc = _; type_ } : Ts_types.Unresolved.field =
let field : Ts_types.Unresolved.field_def = Single { optional; typ = typ type_ } in
named ~name field
;;
let structure
({ doc = _; extends = _; mixins = _; name; properties } : Metamodel.structure)
: Ts_types.Unresolved.t
=
let interface : Ts_types.Unresolved.interface =
let fields = List.map properties ~f:field in
{ fields }
in
named ~name (Interface interface)
;;
let typeAlias ({ name; type_; doc = _ } : Metamodel.typeAlias) =
named ~name (Type (typ type_))
;;
let enumeration { doc = _; name; supportsCustomValues = _; type_ = _; values } =
named ~name
@@ Enum_anon
(List.map values ~f:(fun ({ name; value; doc = _ } : enumerationEntry) ->
let case : Enum.case =
match value with
| `Int i -> Literal (Int i)
| `String s -> Literal (String s)
in
name, case))
;;
let of_metamodel (m : Metamodel.t) : Ts_types.Unresolved.t list =
let structures = List.map m.structures ~f:structure in
let type_aliases = List.map m.typeAliases ~f:typeAlias in
let enumerations = List.map m.enumerations ~f:enumeration in
List.concat [ structures; type_aliases; enumerations ]
;;

7
thirdparty/lsp/lsp/bin/typescript/typescript.mli vendored Normal file
View file

@ -0,0 +1,7 @@
open Import
val of_metamodel : Metamodel.t -> Ts_types.Unresolved.t list
val resolve_all
: Ts_types.Unresolved.t list
-> Ts_types.Resolved.t list * Ts_types.Ident.t String.Map.t

76
thirdparty/lsp/lsp/src/array_view.ml vendored Normal file
View file

@ -0,0 +1,76 @@
type 'a t =
{ arr : 'a array
; start : int
; end_excl : int
}
let make ?len arr ~pos =
let arr_len = Array.length arr in
if pos < 0 || pos > Array.length arr
then
invalid_arg
(Printf.sprintf
"Array_view.make: expected pos to be in [0, %d] but received %d"
arr_len
pos);
let length = Option.value len ~default:(arr_len - pos) in
let view_last_idx = pos + length in
if view_last_idx > arr_len
then
invalid_arg
(Printf.sprintf
"Array_view.make: view's last idx = %d occurs after the array length = %d"
view_last_idx
arr_len);
{ arr; start = pos; end_excl = pos + length }
;;
let offset_index t i =
let ix = t.start + i in
if ix < t.end_excl then ix else invalid_arg "subarray index out of bounds"
;;
let get t i = t.arr.(offset_index t i)
let set t i x = t.arr.(offset_index t i) <- x
let length t = t.end_excl - t.start
let is_empty t = length t = 0
let common_suffix_len ai aj =
if length ai = 0 || length aj = 0
then 0
else (
let i = ref (length ai - 1) in
let j = ref (length aj - 1) in
while !i >= 0 && !j >= 0 && get ai !i = get aj !j do
decr i;
decr j
done;
length ai - !i - 1)
;;
let fold_left =
let rec loop arr acc f j i =
if Int.equal i j then acc else loop arr (f acc arr.(i)) f j (i + 1)
in
fun t ~init ~f -> loop t.arr init f t.end_excl t.start
;;
let iteri t ~f =
for i = 0 to t.end_excl - t.start - 1 do
f i t.arr.(t.start + i)
done
;;
let sub t ~pos ~len =
assert (len <= length t);
let pos = t.start + pos in
make t.arr ~pos ~len
;;
let blit t arr ~pos =
let len = t.end_excl - t.start in
ArrayLabels.blit ~src:t.arr ~src_pos:t.start ~dst:arr ~dst_pos:pos ~len
;;
let copy t = Array.init (t.end_excl - t.start) (fun i -> t.arr.(t.start + i))
let backing_array_pos t p = t.start + p

24
thirdparty/lsp/lsp/src/array_view.mli vendored Normal file
View file

@ -0,0 +1,24 @@
type 'a t
(** [make arr ~pos ~len] can be thought of a new array for which the 0-th
element is [arr.(pos)] and has length [len] if specified. If [len] is
omitted, [Array.length arr - pos] is taken as the length. Importantly, the
"new array" does not copy but simply references [arr]. Hence, creating views
is constant time. However, keep in mind that since a view references an
array, the array will be alive in memory as long as the view is alive.
@raise Invalid_argument
if [pos + len > Array.length arr] or [pos < 0 || pos >= Array.length arr]*)
val make : ?len:int -> 'a array -> pos:int -> 'a t
val get : 'a t -> int -> 'a
val set : 'a t -> int -> 'a -> unit
val is_empty : 'a t -> bool
val length : 'a t -> int
val common_suffix_len : 'a t -> 'a t -> int
val fold_left : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc
val iteri : 'a t -> f:(int -> 'a -> unit) -> unit
val sub : 'a t -> pos:int -> len:int -> 'a t
val blit : 'a t -> 'a array -> pos:int -> unit
val copy : 'a t -> 'a array
val backing_array_pos : _ t -> int -> int

11
thirdparty/lsp/lsp/src/cancel_request.ml vendored Normal file
View file

@ -0,0 +1,11 @@
open Import
let meth_ = "$/cancelRequest"
let t_of_yojson json =
match json with
| `Assoc fields -> Json.field_exn fields "id" Jsonrpc.Id.t_of_yojson
| _ -> Json.error "invalid id" json
;;
let yojson_of_t id = `Assoc [ "id", Jsonrpc.Id.yojson_of_t id ]

5
thirdparty/lsp/lsp/src/cancel_request.mli vendored Normal file
View file

@ -0,0 +1,5 @@
open Import
val meth_ : string
include Json.Jsonable.S with type t := Jsonrpc.Id.t

73
thirdparty/lsp/lsp/src/cli.ml vendored Normal file
View file

@ -0,0 +1,73 @@
module Channel = struct
type t =
| Stdio
| Pipe of string
| Socket of int
end
module Arg = struct
type t =
{ mutable pipe : string option
; mutable port : int option
; mutable stdio : bool
; mutable spec : (string * Arg.spec * string) list
; mutable clientProcessId : int option
}
let port t ~name ~description =
( name
, Arg.Int
(fun p ->
match t.port with
| Some _ -> raise @@ Arg.Bad "port is already set once"
| None -> t.port <- Some p)
, description )
;;
let create () =
let t =
{ pipe = None; port = None; stdio = false; spec = []; clientProcessId = None }
in
let spec =
[ "--pipe", Arg.String (fun p -> t.pipe <- Some p), "set pipe path"
; port t ~name:"--socket" ~description:"set the port"
; port t ~name:"--port" ~description:"synonym for --socket"
; "--stdio", Arg.Unit (fun () -> t.stdio <- true), "set stdio"
; ( "--node-ipc"
, Arg.Unit (fun () -> raise @@ Arg.Bad "node-ipc isn't supported")
, "not supported" )
; ( "--clientProcessId"
, Arg.Int (fun pid -> t.clientProcessId <- Some pid)
, "set the pid of the lsp client" )
]
in
t.spec <- spec;
t
;;
let spec t = t.spec
let clientProcessId t = t.clientProcessId
let channel { pipe; port; stdio; spec = _; clientProcessId = _ }
: (Channel.t, string) result
=
match pipe, port, stdio with
| None, None, _ -> Ok Stdio
| Some p, None, false -> Ok (Pipe p)
| None, Some s, false -> Ok (Socket s)
| _, _, _ -> Error "invalid arguments"
;;
end
let args ?channel ?clientProcessId () =
let args =
match clientProcessId with
| None -> []
| Some pid -> [ "--clientProcessId"; string_of_int pid ]
in
match (channel : Channel.t option) with
| None -> args
| Some Stdio -> "--stdio" :: args
| Some (Pipe pipe) -> "--pipe" :: pipe :: args
| Some (Socket port) -> "--socket" :: string_of_int port :: args
;;

34
thirdparty/lsp/lsp/src/cli.mli vendored Normal file
View file

@ -0,0 +1,34 @@
(** Handling of standard lsp server command line arguments *)
module Channel : sig
(** The channel the server shold use to listen for connections *)
type t =
| Stdio
| Pipe of string (** A path to the unix domain socket or windows pipe *)
| Socket of int (** A tcp connection on localhost with the port number *)
end
module Arg : sig
(** Parsing of the standard commnad line arguments using [Stdlib.Arg] *)
type t
(** [create ()] create a new record for arguments *)
val create : unit -> t
(** [spec t] returns the spec that should be provided to [Stdlib.Arg] to
populate [t] using the interpreted cli args *)
val spec : t -> (string * Arg.spec * string) list
(** [channel t] return the channel if correctly supplied. An error if the
arguments were provided incorrectly. *)
val channel : t -> (Channel.t, string) result
(** Return the process id of the client used to run the lsp server if it was
provided *)
val clientProcessId : t -> int option
end
(** generate command line arguments that can be used to spawn an lsp client *)
val args : ?channel:Channel.t -> ?clientProcessId:int -> unit -> string list

161
thirdparty/lsp/lsp/src/client_notification.ml vendored Normal file
View file

@ -0,0 +1,161 @@
open Import
open Types
type t =
| TextDocumentDidOpen of DidOpenTextDocumentParams.t
| TextDocumentDidClose of DidCloseTextDocumentParams.t
| TextDocumentDidChange of DidChangeTextDocumentParams.t
| DidSaveTextDocument of DidSaveTextDocumentParams.t
| WillSaveTextDocument of WillSaveTextDocumentParams.t
| DidChangeWatchedFiles of DidChangeWatchedFilesParams.t
| DidCreateFiles of CreateFilesParams.t
| DidDeleteFiles of DeleteFilesParams.t
| DidRenameFiles of RenameFilesParams.t
| ChangeWorkspaceFolders of DidChangeWorkspaceFoldersParams.t
| ChangeConfiguration of DidChangeConfigurationParams.t
| Initialized
| Exit
| CancelRequest of Jsonrpc.Id.t
| WorkDoneProgressCancel of WorkDoneProgressCancelParams.t
| SetTrace of SetTraceParams.t
| WorkDoneProgress of Progress.t ProgressParams.t
| NotebookDocumentDidOpen of DidOpenNotebookDocumentParams.t
| NotebookDocumentDidChange of DidChangeNotebookDocumentParams.t
| NotebookDocumentDidSave of DidSaveNotebookDocumentParams.t
| NotebookDocumentDidClose of DidCloseNotebookDocumentParams.t
| UnknownNotification of Jsonrpc.Notification.t
let method_ = function
| TextDocumentDidOpen _ -> "textDocument/didOpen"
| TextDocumentDidChange _ -> "textDocument/didChange"
| TextDocumentDidClose _ -> "textDocument/didClose"
| Exit -> "exit"
| Initialized -> "initialized"
| ChangeWorkspaceFolders _ -> "workspace/didChangeWorkspaceFolders"
| ChangeConfiguration _ -> "workspace/didChangeConfiguration"
| WillSaveTextDocument _ -> "textDocument/willSave"
| DidSaveTextDocument _ -> "textDocument/didSave"
| DidChangeWatchedFiles _ -> "workspace/didChangeWatchedFiles"
| DidCreateFiles _ -> "workspace/didCreateFiles"
| DidDeleteFiles _ -> "workspace/didDeleteFiles"
| DidRenameFiles _ -> "workspace/didRenameFiles"
| SetTrace _ -> "$/setTrace"
| CancelRequest _ -> Cancel_request.meth_
| WorkDoneProgressCancel _ -> "window/workDoneProgress/cancel"
| WorkDoneProgress _ -> Progress.method_
| NotebookDocumentDidOpen _ -> "notebookDocument/didOpen"
| NotebookDocumentDidChange _ -> "notebookDocument/didChange"
| NotebookDocumentDidSave _ -> "notebookDocument/didSave"
| NotebookDocumentDidClose _ -> "notebookDocument/didClose"
| UnknownNotification n -> n.method_
;;
let yojson_of_t = function
| TextDocumentDidOpen params -> Some (DidOpenTextDocumentParams.yojson_of_t params)
| TextDocumentDidChange params -> Some (DidChangeTextDocumentParams.yojson_of_t params)
| TextDocumentDidClose params -> Some (DidCloseTextDocumentParams.yojson_of_t params)
| Exit -> None
| Initialized -> None
| ChangeWorkspaceFolders params ->
Some (DidChangeWorkspaceFoldersParams.yojson_of_t params)
| ChangeConfiguration params -> Some (DidChangeConfigurationParams.yojson_of_t params)
| WillSaveTextDocument params -> Some (WillSaveTextDocumentParams.yojson_of_t params)
| DidSaveTextDocument params -> Some (DidSaveTextDocumentParams.yojson_of_t params)
| DidChangeWatchedFiles params -> Some (DidChangeWatchedFilesParams.yojson_of_t params)
| DidCreateFiles params -> Some (CreateFilesParams.yojson_of_t params)
| DidDeleteFiles params -> Some (DeleteFilesParams.yojson_of_t params)
| DidRenameFiles params -> Some (RenameFilesParams.yojson_of_t params)
| CancelRequest params -> Some (Cancel_request.yojson_of_t params)
| WorkDoneProgressCancel params ->
Some (WorkDoneProgressCancelParams.yojson_of_t params)
| SetTrace params -> Some (SetTraceParams.yojson_of_t params)
| WorkDoneProgress params ->
Some ((ProgressParams.yojson_of_t Progress.yojson_of_t) params)
| NotebookDocumentDidOpen params ->
Some (DidOpenNotebookDocumentParams.yojson_of_t params)
| NotebookDocumentDidClose params ->
Some (DidCloseNotebookDocumentParams.yojson_of_t params)
| NotebookDocumentDidChange params ->
Some (DidChangeNotebookDocumentParams.yojson_of_t params)
| NotebookDocumentDidSave params ->
Some (DidSaveNotebookDocumentParams.yojson_of_t params)
| UnknownNotification n -> (n.params :> Json.t option)
;;
let of_jsonrpc (r : Jsonrpc.Notification.t) =
let open Result.O in
let params = r.params in
match r.method_ with
| "textDocument/didOpen" ->
let+ params = Json.message_params params DidOpenTextDocumentParams.t_of_yojson in
TextDocumentDidOpen params
| "textDocument/didChange" ->
let+ params = Json.message_params params DidChangeTextDocumentParams.t_of_yojson in
TextDocumentDidChange params
| "textDocument/didClose" ->
let+ params = Json.message_params params DidCloseTextDocumentParams.t_of_yojson in
TextDocumentDidClose params
| "exit" -> Ok Exit
| "initialized" -> Ok Initialized
| "workspace/didChangeWorkspaceFolders" ->
let+ params =
Json.message_params params DidChangeWorkspaceFoldersParams.t_of_yojson
in
ChangeWorkspaceFolders params
| "workspace/didChangeConfiguration" ->
let+ params = Json.message_params params DidChangeConfigurationParams.t_of_yojson in
ChangeConfiguration params
| "textDocument/willSave" ->
let+ params = Json.message_params params WillSaveTextDocumentParams.t_of_yojson in
WillSaveTextDocument params
| "textDocument/didSave" ->
let+ params = Json.message_params params DidSaveTextDocumentParams.t_of_yojson in
DidSaveTextDocument params
| "workspace/didChangeWatchedFiles" ->
let+ params = Json.message_params params DidChangeWatchedFilesParams.t_of_yojson in
DidChangeWatchedFiles params
| "workspace/didCreateFiles" ->
let+ params = Json.message_params params CreateFilesParams.t_of_yojson in
DidCreateFiles params
| "workspace/didDeleteFiles" ->
let+ params = Json.message_params params DeleteFilesParams.t_of_yojson in
DidDeleteFiles params
| "workspace/didRenameFiles" ->
let+ params = Json.message_params params RenameFilesParams.t_of_yojson in
DidRenameFiles params
| m when m = Cancel_request.meth_ ->
let+ params = Json.message_params params Cancel_request.t_of_yojson in
CancelRequest params
| "window/workDoneProgress/cancel" ->
let+ params = Json.message_params params WorkDoneProgressCancelParams.t_of_yojson in
WorkDoneProgressCancel params
| "$/setTrace" ->
let+ params = Json.message_params params SetTraceParams.t_of_yojson in
SetTrace params
| "notebookDocument/didOpen" ->
let+ params = Json.message_params params DidOpenNotebookDocumentParams.t_of_yojson in
NotebookDocumentDidOpen params
| "notebookDocument/didClose" ->
let+ params = Json.message_params params DidCloseNotebookDocumentParams.t_of_yojson in
NotebookDocumentDidClose params
| "notebookDocument/didSave" ->
let+ params = Json.message_params params DidSaveNotebookDocumentParams.t_of_yojson in
NotebookDocumentDidSave params
| "notebookDocument/didChange" ->
let+ params =
Json.message_params params DidChangeNotebookDocumentParams.t_of_yojson
in
NotebookDocumentDidChange params
| m when m = Progress.method_ ->
let+ params =
Json.message_params params (ProgressParams.t_of_yojson Progress.t_of_yojson)
in
WorkDoneProgress params
| _ -> Ok (UnknownNotification r)
;;
let to_jsonrpc t =
let method_ = method_ t in
let params = yojson_of_t t |> Option.map Jsonrpc.Structured.t_of_yojson in
{ Jsonrpc.Notification.params; method_ }
;;

29
thirdparty/lsp/lsp/src/client_notification.mli vendored Normal file
View file

@ -0,0 +1,29 @@
open! Import
open Types
type t =
| TextDocumentDidOpen of DidOpenTextDocumentParams.t
| TextDocumentDidClose of DidCloseTextDocumentParams.t
| TextDocumentDidChange of DidChangeTextDocumentParams.t
| DidSaveTextDocument of DidSaveTextDocumentParams.t
| WillSaveTextDocument of WillSaveTextDocumentParams.t
| DidChangeWatchedFiles of DidChangeWatchedFilesParams.t
| DidCreateFiles of CreateFilesParams.t
| DidDeleteFiles of DeleteFilesParams.t
| DidRenameFiles of RenameFilesParams.t
| ChangeWorkspaceFolders of DidChangeWorkspaceFoldersParams.t
| ChangeConfiguration of DidChangeConfigurationParams.t
| Initialized
| Exit
| CancelRequest of Jsonrpc.Id.t
| WorkDoneProgressCancel of WorkDoneProgressCancelParams.t
| SetTrace of SetTraceParams.t
| WorkDoneProgress of Progress.t ProgressParams.t
| NotebookDocumentDidOpen of DidOpenNotebookDocumentParams.t
| NotebookDocumentDidChange of DidChangeNotebookDocumentParams.t
| NotebookDocumentDidSave of DidSaveNotebookDocumentParams.t
| NotebookDocumentDidClose of DidCloseNotebookDocumentParams.t
| UnknownNotification of Jsonrpc.Notification.t
val of_jsonrpc : Jsonrpc.Notification.t -> (t, string) result
val to_jsonrpc : t -> Jsonrpc.Notification.t

706
thirdparty/lsp/lsp/src/client_request.ml vendored Normal file
View file

@ -0,0 +1,706 @@
open! Import
open Types
open Extension
type _ t =
| Shutdown : unit t
| Initialize : InitializeParams.t -> InitializeResult.t t
| TextDocumentHover : HoverParams.t -> Hover.t option t
| TextDocumentDefinition : DefinitionParams.t -> Locations.t option t
| TextDocumentDeclaration : TextDocumentPositionParams.t -> Locations.t option t
| TextDocumentTypeDefinition : TypeDefinitionParams.t -> Locations.t option t
| TextDocumentImplementation : ImplementationParams.t -> Locations.t option t
| TextDocumentCompletion :
CompletionParams.t
-> [ `CompletionList of CompletionList.t | `List of CompletionItem.t list ] option t
| TextDocumentCodeLens : CodeLensParams.t -> CodeLens.t list t
| InlayHint : InlayHintParams.t -> InlayHint.t list option t
| InlayHintResolve : InlayHint.t -> InlayHint.t t
| TextDocumentDiagnostic : DocumentDiagnosticParams.t -> DocumentDiagnosticReport.t t
| TextDocumentInlineCompletion :
InlineCompletionParams.t
-> [ `InlineCompletion of InlineCompletionList.t
| `InlineCompletionItem of InlineCompletionItem.t list
]
option
t
| TextDocumentInlineValue : InlineValueParams.t -> InlineValue.t list option t
| TextDocumentCodeLensResolve : CodeLens.t -> CodeLens.t t
| TextDocumentPrepareCallHierarchy :
CallHierarchyPrepareParams.t
-> CallHierarchyItem.t list option t
| TextDocumentPrepareTypeHierarchy :
TypeHierarchyPrepareParams.t
-> TypeHierarchyItem.t list option t
| TextDocumentPrepareRename : PrepareRenameParams.t -> Range.t option t
| TextDocumentRangeFormatting :
DocumentRangeFormattingParams.t
-> TextEdit.t list option t
| TextDocumentRangesFormatting :
DocumentRangesFormattingParams.t
-> TextEdit.t list option t
| TextDocumentRename : RenameParams.t -> WorkspaceEdit.t t
| TextDocumentLink : DocumentLinkParams.t -> DocumentLink.t list option t
| TextDocumentLinkResolve : DocumentLink.t -> DocumentLink.t t
| TextDocumentMoniker : MonikerParams.t -> Moniker.t list option t
| DocumentSymbol :
DocumentSymbolParams.t
-> [ `DocumentSymbol of DocumentSymbol.t list
| `SymbolInformation of SymbolInformation.t list
]
option
t
| WorkspaceSymbol : WorkspaceSymbolParams.t -> SymbolInformation.t list option t
| WorkspaceSymbolResolve : WorkspaceSymbol.t -> WorkspaceSymbol.t t
| DebugEcho : DebugEcho.Params.t -> DebugEcho.Result.t t
| DebugTextDocumentGet :
DebugTextDocumentGet.Params.t
-> DebugTextDocumentGet.Result.t t
| TextDocumentReferences : ReferenceParams.t -> Location.t list option t
| TextDocumentHighlight : DocumentHighlightParams.t -> DocumentHighlight.t list option t
| TextDocumentFoldingRange : FoldingRangeParams.t -> FoldingRange.t list option t
| SignatureHelp : SignatureHelpParams.t -> SignatureHelp.t t
| CodeAction : CodeActionParams.t -> CodeActionResult.t t
| CodeActionResolve : CodeAction.t -> CodeAction.t t
| CompletionItemResolve : CompletionItem.t -> CompletionItem.t t
| WillSaveWaitUntilTextDocument :
WillSaveTextDocumentParams.t
-> TextEdit.t list option t
| TextDocumentFormatting : DocumentFormattingParams.t -> TextEdit.t list option t
| TextDocumentOnTypeFormatting :
DocumentOnTypeFormattingParams.t
-> TextEdit.t list option t
| TextDocumentColorPresentation :
ColorPresentationParams.t
-> ColorPresentation.t list t
| TextDocumentColor : DocumentColorParams.t -> ColorInformation.t list t
| SelectionRange : SelectionRangeParams.t -> SelectionRange.t list t
| ExecuteCommand : ExecuteCommandParams.t -> Json.t t
| SemanticTokensFull : SemanticTokensParams.t -> SemanticTokens.t option t
| SemanticTokensDelta :
SemanticTokensDeltaParams.t
-> [ `SemanticTokens of SemanticTokens.t
| `SemanticTokensDelta of SemanticTokensDelta.t
]
option
t
| SemanticTokensRange : SemanticTokensRangeParams.t -> SemanticTokens.t option t
| LinkedEditingRange : LinkedEditingRangeParams.t -> LinkedEditingRanges.t option t
| CallHierarchyIncomingCalls :
CallHierarchyIncomingCallsParams.t
-> CallHierarchyIncomingCall.t list option t
| CallHierarchyOutgoingCalls :
CallHierarchyOutgoingCallsParams.t
-> CallHierarchyOutgoingCall.t list option t
| WillCreateFiles : CreateFilesParams.t -> WorkspaceEdit.t option t
| WillDeleteFiles : DeleteFilesParams.t -> WorkspaceEdit.t option t
| WillRenameFiles : RenameFilesParams.t -> WorkspaceEdit.t option t
| WorkspaceDiagnostic : WorkspaceDiagnosticParams.t -> WorkspaceDiagnosticReport.t t
| TypeHierarchySubtypes :
TypeHierarchySubtypesParams.t
-> TypeHierarchyItem.t list option t
| TypeHierarchySupertypes :
TypeHierarchySupertypesParams.t
-> TypeHierarchyItem.t list option t
| UnknownRequest :
{ meth : string
; params : Jsonrpc.Structured.t option
}
-> Json.t t
let yojson_of_DocumentSymbol ds : Json.t =
Json.Option.yojson_of_t
(function
| `DocumentSymbol ds -> Json.To.list DocumentSymbol.yojson_of_t ds
| `SymbolInformation si -> Json.To.list SymbolInformation.yojson_of_t si)
ds
;;
let yojson_of_Completion ds : Json.t =
Json.Option.yojson_of_t
(function
| `CompletionList cs -> CompletionList.yojson_of_t cs
| `List xs -> `List (List.map xs ~f:CompletionItem.yojson_of_t))
ds
;;
let yojson_of_SemanticTokensDelta ds : Json.t =
Json.Option.yojson_of_t
(function
| `SemanticTokens st -> SemanticTokens.yojson_of_t st
| `SemanticTokensDelta st -> SemanticTokensDelta.yojson_of_t st)
ds
;;
let yojson_of_TextDocumentInlineCompletion t : Json.t =
Json.Option.yojson_of_t
(function
| `InlineCompletion t -> InlineCompletionList.yojson_of_t t
| `InlineCompletionItem t -> `List (List.map ~f:InlineCompletionItem.yojson_of_t t))
t
;;
let yojson_of_result (type a) (req : a t) (result : a) =
match req, result with
| Shutdown, () -> `Null
| Initialize _, result -> InitializeResult.yojson_of_t result
| TextDocumentDeclaration _, result ->
Json.Conv.yojson_of_option Locations.yojson_of_t result
| TextDocumentHover _, result -> Json.Option.yojson_of_t Hover.yojson_of_t result
| TextDocumentDefinition _, result ->
Json.Option.yojson_of_t Locations.yojson_of_t result
| TextDocumentTypeDefinition _, result ->
Json.Option.yojson_of_t Locations.yojson_of_t result
| TextDocumentImplementation _, result ->
Json.Option.yojson_of_t Locations.yojson_of_t result
| TextDocumentCompletion _, result -> yojson_of_Completion result
| TextDocumentCodeLens _, result -> Json.To.list CodeLens.yojson_of_t result
| TextDocumentCodeLensResolve _, result -> CodeLens.yojson_of_t result
| TextDocumentPrepareCallHierarchy _, result ->
Json.Option.yojson_of_t (Json.To.list CallHierarchyItem.yojson_of_t) result
| TextDocumentPrepareTypeHierarchy _, result ->
Json.Option.yojson_of_t (Json.To.list TypeHierarchyItem.yojson_of_t) result
| TextDocumentPrepareRename _, result ->
Json.Option.yojson_of_t Range.yojson_of_t result
| TextDocumentRangeFormatting _, result ->
Json.Option.yojson_of_t (Json.To.list TextEdit.yojson_of_t) result
| TextDocumentRangesFormatting _, result ->
Json.Option.yojson_of_t (Json.To.list TextEdit.yojson_of_t) result
| TextDocumentRename _, result -> WorkspaceEdit.yojson_of_t result
| DocumentSymbol _, result -> yojson_of_DocumentSymbol result
| DebugEcho _, result -> DebugEcho.Result.yojson_of_t result
| DebugTextDocumentGet _, result -> DebugTextDocumentGet.Result.yojson_of_t result
| TextDocumentReferences _, result ->
Json.Option.yojson_of_t (Json.To.list Location.yojson_of_t) result
| TextDocumentHighlight _, result ->
Json.Option.yojson_of_t (Json.To.list DocumentHighlight.yojson_of_t) result
| TextDocumentFoldingRange _, result ->
Json.Option.yojson_of_t (Json.To.list FoldingRange.yojson_of_t) result
| TextDocumentMoniker _, result ->
Json.Option.yojson_of_t (Json.To.list Moniker.yojson_of_t) result
| SignatureHelp _, result -> SignatureHelp.yojson_of_t result
| CodeAction _, result -> CodeActionResult.yojson_of_t result
| CodeActionResolve _, result -> CodeAction.yojson_of_t result
| CompletionItemResolve _, result -> CompletionItem.yojson_of_t result
| WillSaveWaitUntilTextDocument _, result ->
Json.Option.yojson_of_t (Json.To.list TextEdit.yojson_of_t) result
| TextDocumentOnTypeFormatting _, result ->
Json.Option.yojson_of_t (Json.To.list TextEdit.yojson_of_t) result
| TextDocumentFormatting _, result ->
Json.Option.yojson_of_t (Json.To.list TextEdit.yojson_of_t) result
| TextDocumentLink _, result ->
Json.Option.yojson_of_t (Json.To.list DocumentLink.yojson_of_t) result
| TextDocumentLinkResolve _, result -> DocumentLink.yojson_of_t result
| WorkspaceSymbol _, result ->
Json.Option.yojson_of_t (Json.To.list SymbolInformation.yojson_of_t) result
| TextDocumentColorPresentation _, result ->
Json.To.list ColorPresentation.yojson_of_t result
| TextDocumentColor _, result -> Json.To.list ColorInformation.yojson_of_t result
| SelectionRange _, result -> Json.yojson_of_list SelectionRange.yojson_of_t result
| SemanticTokensFull _, result ->
Json.Option.yojson_of_t SemanticTokens.yojson_of_t result
| SemanticTokensDelta _, result -> yojson_of_SemanticTokensDelta result
| SemanticTokensRange _, result ->
Json.Option.yojson_of_t SemanticTokens.yojson_of_t result
| LinkedEditingRange _, result ->
Json.Option.yojson_of_t LinkedEditingRanges.yojson_of_t result
| CallHierarchyIncomingCalls _, result ->
Json.Option.yojson_of_t (Json.To.list CallHierarchyIncomingCall.yojson_of_t) result
| CallHierarchyOutgoingCalls _, result ->
Json.Option.yojson_of_t (Json.To.list CallHierarchyOutgoingCall.yojson_of_t) result
| WillCreateFiles _, result -> Json.Option.yojson_of_t WorkspaceEdit.yojson_of_t result
| WillDeleteFiles _, result -> Json.Option.yojson_of_t WorkspaceEdit.yojson_of_t result
| WillRenameFiles _, result -> Json.Option.yojson_of_t WorkspaceEdit.yojson_of_t result
| ExecuteCommand _, result -> result
| InlayHint _, result ->
Json.Option.yojson_of_t (Json.To.list InlayHint.yojson_of_t) result
| InlayHintResolve _, result -> InlayHint.yojson_of_t result
| TextDocumentDiagnostic _, result -> DocumentDiagnosticReport.yojson_of_t result
| TextDocumentInlineCompletion _, result ->
yojson_of_TextDocumentInlineCompletion result
| TextDocumentInlineValue _, result ->
Json.Option.yojson_of_t (Json.To.list InlineValue.yojson_of_t) result
| WorkspaceDiagnostic _, result -> WorkspaceDiagnosticReport.yojson_of_t result
| WorkspaceSymbolResolve _, result -> WorkspaceSymbol.yojson_of_t result
| TypeHierarchySubtypes _, result ->
Json.Option.yojson_of_t (Json.To.list TypeHierarchyItem.yojson_of_t) result
| TypeHierarchySupertypes _, result ->
Json.Option.yojson_of_t (Json.To.list TypeHierarchyItem.yojson_of_t) result
| UnknownRequest _, resp -> resp
;;
type packed = E : 'r t -> packed
let of_jsonrpc (r : Jsonrpc.Request.t) =
let open Result.O in
let parse f = Json.message_params r.params f in
match r.method_ with
| "initialize" ->
let+ params = parse InitializeParams.t_of_yojson in
E (Initialize params)
| "shutdown" -> Ok (E Shutdown)
| "textDocument/completion" ->
let+ params = parse CompletionParams.t_of_yojson in
E (TextDocumentCompletion params)
| "completionItem/resolve" ->
let+ params = parse CompletionItem.t_of_yojson in
E (CompletionItemResolve params)
| "textDocument/documentSymbol" ->
let+ params = parse DocumentSymbolParams.t_of_yojson in
E (DocumentSymbol params)
| "textDocument/hover" ->
let+ params = parse HoverParams.t_of_yojson in
E (TextDocumentHover params)
| "textDocument/definition" ->
let+ params = parse DefinitionParams.t_of_yojson in
E (TextDocumentDefinition params)
| "textDocument/typeDefinition" ->
let+ params = parse TypeDefinitionParams.t_of_yojson in
E (TextDocumentTypeDefinition params)
| "textDocument/implementation" ->
let+ params = parse ImplementationParams.t_of_yojson in
E (TextDocumentImplementation params)
| "textDocument/references" ->
let+ params = parse ReferenceParams.t_of_yojson in
E (TextDocumentReferences params)
| "textDocument/codeLens" ->
let+ params = parse CodeLensParams.t_of_yojson in
E (TextDocumentCodeLens params)
| "textDocument/inlayHint" ->
let+ params = parse InlayHintParams.t_of_yojson in
E (InlayHint params)
| "textDocument/prepareCallHierarchy" ->
let+ params = parse CallHierarchyPrepareParams.t_of_yojson in
E (TextDocumentPrepareCallHierarchy params)
| "textDocument/prepareRename" ->
let+ params = parse PrepareRenameParams.t_of_yojson in
E (TextDocumentPrepareRename params)
| "textDocument/rangeFormatting" ->
let+ params = parse DocumentRangeFormattingParams.t_of_yojson in
E (TextDocumentRangeFormatting params)
| "textDocument/rangesFormatting" ->
let+ params = parse DocumentRangesFormattingParams.t_of_yojson in
E (TextDocumentRangesFormatting params)
| "textDocument/rename" ->
let+ params = parse RenameParams.t_of_yojson in
E (TextDocumentRename params)
| "textDocument/documentHighlight" ->
let+ params = parse DocumentHighlightParams.t_of_yojson in
E (TextDocumentHighlight params)
| "textDocument/foldingRange" ->
let+ params = parse FoldingRangeParams.t_of_yojson in
E (TextDocumentFoldingRange params)
| "textDocument/signatureHelp" ->
let+ params = parse SignatureHelpParams.t_of_yojson in
E (SignatureHelp params)
| "textDocument/codeAction" ->
let+ params = parse CodeActionParams.t_of_yojson in
E (CodeAction params)
| "codeAction/resolve" ->
let+ params = parse CodeAction.t_of_yojson in
E (CodeActionResolve params)
| "debug/echo" ->
let+ params = parse DebugEcho.Params.t_of_yojson in
E (DebugEcho params)
| "debug/textDocument/get" ->
let+ params = parse DebugTextDocumentGet.Params.t_of_yojson in
E (DebugTextDocumentGet params)
| "textDocument/onTypeFormatting" ->
let+ params = parse DocumentOnTypeFormattingParams.t_of_yojson in
E (TextDocumentOnTypeFormatting params)
| "textDocument/formatting" ->
let+ params = parse DocumentFormattingParams.t_of_yojson in
E (TextDocumentFormatting params)
| "textDocument/documentLink" ->
let+ params = parse DocumentLinkParams.t_of_yojson in
E (TextDocumentLink params)
| "documentLink/resolve" ->
let+ params = parse DocumentLink.t_of_yojson in
E (TextDocumentLinkResolve params)
| "workspace/symbol" ->
let+ params = parse WorkspaceSymbolParams.t_of_yojson in
E (WorkspaceSymbol params)
| "textDocument/colorPresentation" ->
let+ params = parse ColorPresentationParams.t_of_yojson in
E (TextDocumentColorPresentation params)
| "textDocument/documentColor" ->
let+ params = parse DocumentColorParams.t_of_yojson in
E (TextDocumentColor params)
| "textDocument/declaration" ->
let+ params = parse TextDocumentPositionParams.t_of_yojson in
E (TextDocumentDeclaration params)
| "textDocument/selectionRange" ->
let+ params = parse SelectionRangeParams.t_of_yojson in
E (SelectionRange params)
| "workspace/executeCommand" ->
let+ params = parse ExecuteCommandParams.t_of_yojson in
E (ExecuteCommand params)
| "textDocument/semanticTokens/full" ->
let+ params = parse SemanticTokensParams.t_of_yojson in
E (SemanticTokensFull params)
| "textDocument/semanticTokens/full/delta" ->
let+ params = parse SemanticTokensDeltaParams.t_of_yojson in
E (SemanticTokensDelta params)
| "textDocument/semanticTokens/range" ->
let+ params = parse SemanticTokensRangeParams.t_of_yojson in
E (SemanticTokensRange params)
| "textDocument/linkedEditingRange" ->
let+ params = parse LinkedEditingRangeParams.t_of_yojson in
E (LinkedEditingRange params)
| "callHierarchy/incomingCalls" ->
let+ params = parse CallHierarchyIncomingCallsParams.t_of_yojson in
E (CallHierarchyIncomingCalls params)
| "callHierarchy/outgoingCalls" ->
let+ params = parse CallHierarchyOutgoingCallsParams.t_of_yojson in
E (CallHierarchyOutgoingCalls params)
| "workspace/willCreateFiles" ->
let+ params = parse CreateFilesParams.t_of_yojson in
E (WillCreateFiles params)
| "workspace/willDeleteFiles" ->
let+ params = parse DeleteFilesParams.t_of_yojson in
E (WillDeleteFiles params)
| "workspace/willRenameFiles" ->
let+ params = parse RenameFilesParams.t_of_yojson in
E (WillRenameFiles params)
| "textDocument/moniker" ->
let+ params = parse MonikerParams.t_of_yojson in
E (TextDocumentMoniker params)
| "codeLens/resolve" ->
let+ params = parse CodeLens.t_of_yojson in
E (TextDocumentCodeLensResolve params)
| "textDocument/willSaveWaitUntil" ->
let+ params = parse WillSaveTextDocumentParams.t_of_yojson in
E (WillSaveWaitUntilTextDocument params)
| "textDocument/inlineValue" ->
let+ params = parse InlineValueParams.t_of_yojson in
E (TextDocumentInlineValue params)
| "inlayHint/resolve" ->
let+ params = parse InlayHint.t_of_yojson in
E (InlayHintResolve params)
| "textDocument/diagnostic" ->
let+ params = parse DocumentDiagnosticParams.t_of_yojson in
E (TextDocumentDiagnostic params)
| "textDocument/inlineCompletion" ->
let+ params = parse InlineCompletionParams.t_of_yojson in
E (TextDocumentInlineCompletion params)
| "workspace/diagnostic" ->
let+ params = parse WorkspaceDiagnosticParams.t_of_yojson in
E (WorkspaceDiagnostic params)
| "workspaceSymbol/resolve" ->
let+ params = parse WorkspaceSymbol.t_of_yojson in
E (WorkspaceSymbolResolve params)
| "typeHierarchy/supertypes" ->
let+ params = parse TypeHierarchySupertypesParams.t_of_yojson in
E (TypeHierarchySupertypes params)
| "typeHierarchy/subtypes" ->
let+ params = parse TypeHierarchySubtypesParams.t_of_yojson in
E (TypeHierarchySubtypes params)
| meth -> Ok (E (UnknownRequest { meth; params = r.params }))
;;
let method_ (type a) (t : a t) =
match t with
| Shutdown -> "shutdown"
| Initialize _ -> "initialize"
| TextDocumentCompletion _ -> "textDocument/completion"
| CompletionItemResolve _ -> "completionItem/resolve"
| DocumentSymbol _ -> "textDocument/documentSymbol"
| TextDocumentHover _ -> "textDocument/hover"
| TextDocumentDefinition _ -> "textDocument/definition"
| TextDocumentTypeDefinition _ -> "textDocument/typeDefinition"
| TextDocumentImplementation _ -> "textDocument/implementation"
| TextDocumentReferences _ -> "textDocument/references"
| TextDocumentCodeLens _ -> "textDocument/codeLens"
| TextDocumentCodeLensResolve _ -> "codeLens/resolve"
| TextDocumentPrepareCallHierarchy _ -> "textDocument/prepareCallHierarchy"
| TextDocumentPrepareTypeHierarchy _ -> "textDocument/prepareTypeHierarchy"
| TextDocumentPrepareRename _ -> "textDocument/prepareRename"
| TextDocumentRangeFormatting _ -> "textDocument/rangeFormatting"
| TextDocumentRangesFormatting _ -> "textDocument/rangesFormatting"
| TextDocumentRename _ -> "textDocument/rename"
| TextDocumentHighlight _ -> "textDocument/documentHighlight"
| TextDocumentFoldingRange _ -> "textDocument/foldingRange"
| SignatureHelp _ -> "textDocument/signatureHelp"
| CodeAction _ -> "textDocument/codeAction"
| CodeActionResolve _ -> "codeAction/resolve"
| DebugEcho _ -> "debug/echo"
| DebugTextDocumentGet _ -> "debug/textDocument/get"
| TextDocumentOnTypeFormatting _ -> "textDocument/onTypeFormatting"
| TextDocumentFormatting _ -> "textDocument/formatting"
| TextDocumentLink _ -> "textDocument/documentLink"
| TextDocumentLinkResolve _ -> "documentLink/resolve"
| WorkspaceSymbol _ -> "workspace/symbol"
| TextDocumentColorPresentation _ -> "textDocument/colorPresentation"
| TextDocumentColor _ -> "textDocument/documentColor"
| TextDocumentDeclaration _ -> "textDocument/declaration"
| SelectionRange _ -> "textDocument/selectionRange"
| ExecuteCommand _ -> "workspace/executeCommand"
| SemanticTokensFull _ -> "textDocument/semanticTokens/full"
| SemanticTokensDelta _ -> "textDocument/semanticTokens/full/delta"
| SemanticTokensRange _ -> "textDocument/semanticTokens/range"
| LinkedEditingRange _ -> "textDocument/linkedEditingRange"
| CallHierarchyIncomingCalls _ -> "callHierarchy/incomingCalls"
| CallHierarchyOutgoingCalls _ -> "callHierarchy/outgoingCalls"
| WillCreateFiles _ -> "workspace/willCreateFiles"
| WillDeleteFiles _ -> "workspace/willDeleteFiles"
| WillRenameFiles _ -> "workspace/willRenameFiles"
| TextDocumentMoniker _ -> "textDocument/moniker"
| WillSaveWaitUntilTextDocument _ -> "textDocument/willSaveWaitUntil"
| InlayHint _ -> "textDocument/inlayHint"
| InlayHintResolve _ -> "inlayHint/resolve"
| TextDocumentDiagnostic _ -> "textDocument/diagnostic"
| TextDocumentInlineCompletion _ -> "textDocument/inlineCompletion"
| TextDocumentInlineValue _ -> "textDocument/inlineValue"
| WorkspaceDiagnostic _ -> "workspace/diagnostic"
| WorkspaceSymbolResolve _ -> "workspaceSymbol/resolve"
| TypeHierarchySupertypes _ -> "typeHierarchy/supertypes"
| TypeHierarchySubtypes _ -> "typeHierarchy/subtypes"
| UnknownRequest { meth; _ } -> meth
;;
let params =
let ret x = Some (Jsonrpc.Structured.t_of_yojson x) in
fun (type a) (t : a t) ->
match t with
| Shutdown -> None
| Initialize params -> ret (InitializeParams.yojson_of_t params)
| TextDocumentCompletion params -> ret (CompletionParams.yojson_of_t params)
| CompletionItemResolve params -> ret (CompletionItem.yojson_of_t params)
| DocumentSymbol params -> ret (DocumentSymbolParams.yojson_of_t params)
| TextDocumentHover params -> ret (HoverParams.yojson_of_t params)
| TextDocumentDefinition params -> ret (DefinitionParams.yojson_of_t params)
| TextDocumentTypeDefinition params -> ret (TypeDefinitionParams.yojson_of_t params)
| TextDocumentImplementation params -> ret (ImplementationParams.yojson_of_t params)
| TextDocumentReferences params -> ret (ReferenceParams.yojson_of_t params)
| TextDocumentCodeLens params -> ret (CodeLensParams.yojson_of_t params)
| TextDocumentPrepareCallHierarchy params ->
ret (CallHierarchyPrepareParams.yojson_of_t params)
| TextDocumentPrepareTypeHierarchy params ->
ret (TypeHierarchyPrepareParams.yojson_of_t params)
| TextDocumentPrepareRename params -> ret (PrepareRenameParams.yojson_of_t params)
| TextDocumentRangeFormatting params ->
ret (DocumentRangeFormattingParams.yojson_of_t params)
| TextDocumentRangesFormatting params ->
ret (DocumentRangesFormattingParams.yojson_of_t params)
| TextDocumentRename params -> ret (RenameParams.yojson_of_t params)
| TextDocumentHighlight params -> ret (DocumentHighlightParams.yojson_of_t params)
| TextDocumentFoldingRange params -> ret (FoldingRangeParams.yojson_of_t params)
| SignatureHelp params -> ret (SignatureHelpParams.yojson_of_t params)
| CodeAction params -> ret (CodeActionParams.yojson_of_t params)
| CodeActionResolve params -> ret (CodeAction.yojson_of_t params)
| DebugEcho params -> ret (DebugEcho.Params.yojson_of_t params)
| DebugTextDocumentGet params -> ret (DebugTextDocumentGet.Params.yojson_of_t params)
| TextDocumentOnTypeFormatting params ->
ret (DocumentOnTypeFormattingParams.yojson_of_t params)
| TextDocumentFormatting params -> ret (DocumentFormattingParams.yojson_of_t params)
| TextDocumentLink params -> ret (DocumentLinkParams.yojson_of_t params)
| TextDocumentLinkResolve params -> ret (DocumentLink.yojson_of_t params)
| WorkspaceSymbol params -> ret (WorkspaceSymbolParams.yojson_of_t params)
| TextDocumentColorPresentation params ->
ret (ColorPresentationParams.yojson_of_t params)
| TextDocumentColor params -> ret (DocumentColorParams.yojson_of_t params)
| TextDocumentDeclaration params ->
ret (TextDocumentPositionParams.yojson_of_t params)
| SelectionRange params -> ret (SelectionRangeParams.yojson_of_t params)
| ExecuteCommand params -> ret (ExecuteCommandParams.yojson_of_t params)
| SemanticTokensFull params -> ret (SemanticTokensParams.yojson_of_t params)
| SemanticTokensDelta params -> ret (SemanticTokensDeltaParams.yojson_of_t params)
| SemanticTokensRange params -> ret (SemanticTokensRangeParams.yojson_of_t params)
| LinkedEditingRange params -> ret (LinkedEditingRangeParams.yojson_of_t params)
| CallHierarchyIncomingCalls params ->
ret (CallHierarchyIncomingCallsParams.yojson_of_t params)
| CallHierarchyOutgoingCalls params ->
ret (CallHierarchyOutgoingCallsParams.yojson_of_t params)
| WillCreateFiles params -> ret (CreateFilesParams.yojson_of_t params)
| WillDeleteFiles params -> ret (DeleteFilesParams.yojson_of_t params)
| WillRenameFiles params -> ret (RenameFilesParams.yojson_of_t params)
| TextDocumentMoniker params -> ret (MonikerParams.yojson_of_t params)
| TextDocumentCodeLensResolve params -> ret (CodeLens.yojson_of_t params)
| WillSaveWaitUntilTextDocument params ->
ret (WillSaveTextDocumentParams.yojson_of_t params)
| InlayHint params -> ret (InlayHintParams.yojson_of_t params)
| InlayHintResolve params -> ret (InlayHint.yojson_of_t params)
| TextDocumentDiagnostic params -> ret (DocumentDiagnosticParams.yojson_of_t params)
| TextDocumentInlineValue params -> ret (InlineValueParams.yojson_of_t params)
| TextDocumentInlineCompletion params ->
ret (InlineCompletionParams.yojson_of_t params)
| WorkspaceDiagnostic params -> ret (WorkspaceDiagnosticParams.yojson_of_t params)
| WorkspaceSymbolResolve params -> ret (WorkspaceSymbol.yojson_of_t params)
| TypeHierarchySubtypes params -> ret (TypeHierarchySubtypesParams.yojson_of_t params)
| TypeHierarchySupertypes params ->
ret (TypeHierarchySupertypesParams.yojson_of_t params)
| UnknownRequest { params; _ } -> params
;;
let to_jsonrpc_request t ~id =
let method_ = method_ t in
let params = params t in
Jsonrpc.Request.create ~id ~method_ ?params ()
;;
let response_of_json (type a) (t : a t) (json : Json.t) : a =
let open Json.Conv in
match t with
| Shutdown -> unit_of_yojson json
| Initialize _ -> InitializeResult.t_of_yojson json
| TextDocumentHover _ -> option_of_yojson Hover.t_of_yojson json
| TextDocumentDefinition _ -> option_of_yojson Locations.t_of_yojson json
| TextDocumentDeclaration _ -> option_of_yojson Locations.t_of_yojson json
| TextDocumentTypeDefinition _ -> option_of_yojson Locations.t_of_yojson json
| TextDocumentImplementation _ -> option_of_yojson Locations.t_of_yojson json
| TextDocumentCompletion _ ->
option_of_yojson
(Json.Of.untagged_union
"completion_list"
[ (fun json -> `CompletionList (CompletionList.t_of_yojson json))
; (fun json -> `List (list_of_yojson CompletionItem.t_of_yojson json))
])
json
| TextDocumentCodeLens _ -> list_of_yojson CodeLens.t_of_yojson json
| TextDocumentCodeLensResolve _ -> CodeLens.t_of_yojson json
| TextDocumentPrepareCallHierarchy _ ->
option_of_yojson (list_of_yojson CallHierarchyItem.t_of_yojson) json
| TextDocumentPrepareRename _ -> option_of_yojson Range.t_of_yojson json
| TextDocumentRangeFormatting _ ->
option_of_yojson (list_of_yojson TextEdit.t_of_yojson) json
| TextDocumentRangesFormatting _ ->
option_of_yojson (list_of_yojson TextEdit.t_of_yojson) json
| TextDocumentRename _ -> WorkspaceEdit.t_of_yojson json
| TextDocumentLink _ -> option_of_yojson (list_of_yojson DocumentLink.t_of_yojson) json
| TextDocumentLinkResolve _ -> DocumentLink.t_of_yojson json
| TextDocumentMoniker _ -> option_of_yojson (list_of_yojson Moniker.t_of_yojson) json
| DocumentSymbol _ ->
option_of_yojson
(Json.Of.untagged_union
"document_symbols"
[ (fun json -> `DocumentSymbol (list_of_yojson DocumentSymbol.t_of_yojson json))
; (fun json ->
`SymbolInformation (list_of_yojson SymbolInformation.t_of_yojson json))
])
json
| WorkspaceSymbol _ ->
option_of_yojson (list_of_yojson SymbolInformation.t_of_yojson) json
| DebugEcho _ -> DebugEcho.Result.t_of_yojson json
| DebugTextDocumentGet _ -> DebugTextDocumentGet.Result.t_of_yojson json
| TextDocumentReferences _ ->
option_of_yojson (list_of_yojson Location.t_of_yojson) json
| TextDocumentHighlight _ ->
option_of_yojson (list_of_yojson DocumentHighlight.t_of_yojson) json
| TextDocumentFoldingRange _ ->
option_of_yojson (list_of_yojson FoldingRange.t_of_yojson) json
| SignatureHelp _ -> SignatureHelp.t_of_yojson json
| CodeAction _ -> CodeActionResult.t_of_yojson json
| CodeActionResolve _ -> CodeAction.t_of_yojson json
| CompletionItemResolve _ -> CompletionItem.t_of_yojson json
| WillSaveWaitUntilTextDocument _ ->
option_of_yojson (list_of_yojson TextEdit.t_of_yojson) json
| TextDocumentFormatting _ ->
option_of_yojson (list_of_yojson TextEdit.t_of_yojson) json
| TextDocumentOnTypeFormatting _ ->
option_of_yojson (list_of_yojson TextEdit.t_of_yojson) json
| TextDocumentColorPresentation _ -> list_of_yojson ColorPresentation.t_of_yojson json
| TextDocumentColor _ -> list_of_yojson ColorInformation.t_of_yojson json
| SelectionRange _ -> list_of_yojson SelectionRange.t_of_yojson json
| ExecuteCommand _ -> json
| SemanticTokensFull _ -> option_of_yojson SemanticTokens.t_of_yojson json
| SemanticTokensDelta _ ->
option_of_yojson
(Json.Of.untagged_union
"semantic_tokens"
[ (fun json -> `SemanticTokens (SemanticTokens.t_of_yojson json))
; (fun json -> `SemanticTokensDelta (SemanticTokensDelta.t_of_yojson json))
])
json
| SemanticTokensRange _ -> option_of_yojson SemanticTokens.t_of_yojson json
| LinkedEditingRange _ -> option_of_yojson LinkedEditingRanges.t_of_yojson json
| CallHierarchyIncomingCalls _ ->
option_of_yojson (list_of_yojson CallHierarchyIncomingCall.t_of_yojson) json
| CallHierarchyOutgoingCalls _ ->
option_of_yojson (list_of_yojson CallHierarchyOutgoingCall.t_of_yojson) json
| WillCreateFiles _ -> option_of_yojson WorkspaceEdit.t_of_yojson json
| WillDeleteFiles _ -> option_of_yojson WorkspaceEdit.t_of_yojson json
| WillRenameFiles _ -> option_of_yojson WorkspaceEdit.t_of_yojson json
| WorkspaceSymbolResolve _ -> WorkspaceSymbol.t_of_yojson json
| WorkspaceDiagnostic _ -> WorkspaceDiagnosticReport.t_of_yojson json
| TypeHierarchySubtypes _ ->
option_of_yojson (Json.Of.list TypeHierarchyItem.t_of_yojson) json
| TypeHierarchySupertypes _ ->
option_of_yojson (Json.Of.list TypeHierarchyItem.t_of_yojson) json
| InlayHint _ -> option_of_yojson (list_of_yojson InlayHint.t_of_yojson) json
| InlayHintResolve _ -> InlayHint.t_of_yojson json
| TextDocumentDiagnostic _ -> DocumentDiagnosticReport.t_of_yojson json
| TextDocumentInlineCompletion _ ->
option_of_yojson
(Json.Of.untagged_union
"inline_completions"
[ (fun json -> `InlineCompletion (InlineCompletionList.t_of_yojson json))
; (fun json ->
`InlineCompletionItem (Json.Of.list InlineCompletionItem.t_of_yojson json))
])
json
| TextDocumentInlineValue _ ->
option_of_yojson (Json.Of.list InlineValue.t_of_yojson) json
| TextDocumentPrepareTypeHierarchy _ ->
option_of_yojson (Json.Of.list TypeHierarchyItem.t_of_yojson) json
| UnknownRequest _ -> json
;;
let text_document (type a) (t : a t) f : TextDocumentIdentifier.t option =
match t with
| CompletionItemResolve _ -> None
| TextDocumentLinkResolve _ -> None
| ExecuteCommand _ -> None
| TextDocumentCodeLensResolve _ -> None
| WorkspaceSymbol _ -> None
| DebugEcho _ -> None
| Shutdown -> None
| Initialize _ -> None
| TextDocumentHover r -> Some r.textDocument
| TextDocumentDefinition r -> Some r.textDocument
| TextDocumentDeclaration r -> Some r.textDocument
| TextDocumentTypeDefinition r -> Some r.textDocument
| TextDocumentImplementation r -> Some r.textDocument
| TextDocumentCompletion r -> Some r.textDocument
| TextDocumentCodeLens r -> Some r.textDocument
| TextDocumentPrepareCallHierarchy r -> Some r.textDocument
| TextDocumentPrepareTypeHierarchy r -> Some r.textDocument
| TextDocumentPrepareRename r -> Some r.textDocument
| TextDocumentRangeFormatting r -> Some r.textDocument
| TextDocumentRangesFormatting r -> Some r.textDocument
| TextDocumentRename r -> Some r.textDocument
| TextDocumentLink r -> Some r.textDocument
| DocumentSymbol r -> Some r.textDocument
| DebugTextDocumentGet r -> Some r.textDocument
| TextDocumentReferences r -> Some r.textDocument
| TextDocumentHighlight r -> Some r.textDocument
| TextDocumentFoldingRange r -> Some r.textDocument
| TextDocumentMoniker r -> Some r.textDocument
| SignatureHelp r -> Some r.textDocument
| CodeAction r -> Some r.textDocument
| CodeActionResolve _ -> None
| WillSaveWaitUntilTextDocument r -> Some r.textDocument
| TextDocumentFormatting r -> Some r.textDocument
| TextDocumentOnTypeFormatting r -> Some r.textDocument
| TextDocumentColorPresentation r -> Some r.textDocument
| TextDocumentColor r -> Some r.textDocument
| SelectionRange r -> Some r.textDocument
| SemanticTokensFull r -> Some r.textDocument
| SemanticTokensDelta r -> Some r.textDocument
| SemanticTokensRange r -> Some r.textDocument
| LinkedEditingRange r -> Some r.textDocument
| InlayHint r -> Some r.textDocument
| TextDocumentDiagnostic p -> Some p.textDocument
| TextDocumentInlineCompletion p -> Some p.textDocument
| TextDocumentInlineValue p -> Some p.textDocument
| TypeHierarchySubtypes _ -> None
| TypeHierarchySupertypes _ -> None
| WorkspaceSymbolResolve _ -> None
| WorkspaceDiagnostic _ -> None
| InlayHintResolve _ -> None
| CallHierarchyIncomingCalls _ -> None
| CallHierarchyOutgoingCalls _ -> None
| WillCreateFiles _ -> None
| WillDeleteFiles _ -> None
| WillRenameFiles _ -> None
| UnknownRequest { meth; params } -> f ~meth ~params
;;

124
thirdparty/lsp/lsp/src/client_request.mli vendored Normal file
View file

@ -0,0 +1,124 @@
open! Import
open Types
open Extension
type _ t =
| Shutdown : unit t
| Initialize : InitializeParams.t -> InitializeResult.t t
| TextDocumentHover : HoverParams.t -> Hover.t option t
| TextDocumentDefinition : DefinitionParams.t -> Locations.t option t
| TextDocumentDeclaration : TextDocumentPositionParams.t -> Locations.t option t
| TextDocumentTypeDefinition : TypeDefinitionParams.t -> Locations.t option t
| TextDocumentImplementation : ImplementationParams.t -> Locations.t option t
| TextDocumentCompletion :
CompletionParams.t
-> [ `CompletionList of CompletionList.t | `List of CompletionItem.t list ] option t
| TextDocumentCodeLens : CodeLensParams.t -> CodeLens.t list t
| InlayHint : InlayHintParams.t -> InlayHint.t list option t
| InlayHintResolve : InlayHint.t -> InlayHint.t t
| TextDocumentDiagnostic : DocumentDiagnosticParams.t -> DocumentDiagnosticReport.t t
| TextDocumentInlineCompletion :
InlineCompletionParams.t
-> [ `InlineCompletion of InlineCompletionList.t
| `InlineCompletionItem of InlineCompletionItem.t list
]
option
t
| TextDocumentInlineValue : InlineValueParams.t -> InlineValue.t list option t
| TextDocumentCodeLensResolve : CodeLens.t -> CodeLens.t t
| TextDocumentPrepareCallHierarchy :
CallHierarchyPrepareParams.t
-> CallHierarchyItem.t list option t
| TextDocumentPrepareTypeHierarchy :
TypeHierarchyPrepareParams.t
-> TypeHierarchyItem.t list option t
| TextDocumentPrepareRename : PrepareRenameParams.t -> Range.t option t
| TextDocumentRangeFormatting :
DocumentRangeFormattingParams.t
-> TextEdit.t list option t
| TextDocumentRangesFormatting :
DocumentRangesFormattingParams.t
-> TextEdit.t list option t
| TextDocumentRename : RenameParams.t -> WorkspaceEdit.t t
| TextDocumentLink : DocumentLinkParams.t -> DocumentLink.t list option t
| TextDocumentLinkResolve : DocumentLink.t -> DocumentLink.t t
| TextDocumentMoniker : MonikerParams.t -> Moniker.t list option t
| DocumentSymbol :
DocumentSymbolParams.t
-> [ `DocumentSymbol of DocumentSymbol.t list
| `SymbolInformation of SymbolInformation.t list
]
option
t
| WorkspaceSymbol : WorkspaceSymbolParams.t -> SymbolInformation.t list option t
| WorkspaceSymbolResolve : WorkspaceSymbol.t -> WorkspaceSymbol.t t
| DebugEcho : DebugEcho.Params.t -> DebugEcho.Result.t t
| DebugTextDocumentGet :
DebugTextDocumentGet.Params.t
-> DebugTextDocumentGet.Result.t t
| TextDocumentReferences : ReferenceParams.t -> Location.t list option t
| TextDocumentHighlight : DocumentHighlightParams.t -> DocumentHighlight.t list option t
| TextDocumentFoldingRange : FoldingRangeParams.t -> FoldingRange.t list option t
| SignatureHelp : SignatureHelpParams.t -> SignatureHelp.t t
| CodeAction : CodeActionParams.t -> CodeActionResult.t t
| CodeActionResolve : CodeAction.t -> CodeAction.t t
| CompletionItemResolve : CompletionItem.t -> CompletionItem.t t
| WillSaveWaitUntilTextDocument :
WillSaveTextDocumentParams.t
-> TextEdit.t list option t
| TextDocumentFormatting : DocumentFormattingParams.t -> TextEdit.t list option t
| TextDocumentOnTypeFormatting :
DocumentOnTypeFormattingParams.t
-> TextEdit.t list option t
| TextDocumentColorPresentation :
ColorPresentationParams.t
-> ColorPresentation.t list t
| TextDocumentColor : DocumentColorParams.t -> ColorInformation.t list t
| SelectionRange : SelectionRangeParams.t -> SelectionRange.t list t
| ExecuteCommand : ExecuteCommandParams.t -> Json.t t
| SemanticTokensFull : SemanticTokensParams.t -> SemanticTokens.t option t
| SemanticTokensDelta :
SemanticTokensDeltaParams.t
-> [ `SemanticTokens of SemanticTokens.t
| `SemanticTokensDelta of SemanticTokensDelta.t
]
option
t
| SemanticTokensRange : SemanticTokensRangeParams.t -> SemanticTokens.t option t
| LinkedEditingRange : LinkedEditingRangeParams.t -> LinkedEditingRanges.t option t
| CallHierarchyIncomingCalls :
CallHierarchyIncomingCallsParams.t
-> CallHierarchyIncomingCall.t list option t
| CallHierarchyOutgoingCalls :
CallHierarchyOutgoingCallsParams.t
-> CallHierarchyOutgoingCall.t list option t
| WillCreateFiles : CreateFilesParams.t -> WorkspaceEdit.t option t
| WillDeleteFiles : DeleteFilesParams.t -> WorkspaceEdit.t option t
| WillRenameFiles : RenameFilesParams.t -> WorkspaceEdit.t option t
| WorkspaceDiagnostic : WorkspaceDiagnosticParams.t -> WorkspaceDiagnosticReport.t t
| TypeHierarchySubtypes :
TypeHierarchySubtypesParams.t
-> TypeHierarchyItem.t list option t
| TypeHierarchySupertypes :
TypeHierarchySupertypesParams.t
-> TypeHierarchyItem.t list option t
| UnknownRequest :
{ meth : string
; params : Jsonrpc.Structured.t option
}
-> Json.t t
val yojson_of_result : 'a t -> 'a -> Json.t
type packed = E : 'r t -> packed
val of_jsonrpc : Jsonrpc.Request.t -> (packed, string) Result.t
val to_jsonrpc_request : _ t -> id:Jsonrpc.Id.t -> Jsonrpc.Request.t
val response_of_json : 'a t -> Json.t -> 'a
val text_document
: _ t
-> (meth:string
-> params:Jsonrpc.Structured.t option
-> TextDocumentIdentifier.t option)
-> TextDocumentIdentifier.t option

165
thirdparty/lsp/lsp/src/diff.ml vendored Normal file
View file

@ -0,0 +1,165 @@
open Import
module TextEdit = Types.TextEdit
module Position = Types.Position
module Range = Types.Range
module Simple_diff = struct
(* based on *)
(* https://github.com/paulgb/simplediff/blob/031dc772ca6795cfdfed27384a6b79e772213233/python/simplediff/__init__.py *)
type diff =
| Deleted of { lines : int }
| Added of Substring.t Array_view.t
| Equal of { lines : int }
let line_map old_lines new_lines =
let _, map =
Array.fold_left old_lines ~init:(0, Substring.Map.empty) ~f:(fun (i, m) line ->
( i + 1
, Substring.Map.update m ~key:line ~f:(function
| None -> Some [ i ]
| Some xs -> Some (i :: xs)) ))
in
Array.map new_lines ~f:(fun x ->
Substring.Map.find_opt x map |> Option.value ~default:[])
;;
let longest_subsequence (map : int list array) old_lines new_lines =
let overlap = ref Int.Map.empty in
let sub_start_old = ref 0 in
let sub_start_new = ref 0 in
let sub_length = ref 0 in
let old_lines_pos = Array_view.backing_array_pos old_lines 0 in
let old_len = Array_view.length old_lines in
Array_view.iteri new_lines ~f:(fun inew _v ->
let overlap' = ref Int.Map.empty in
(* where does the new line appear in the old text *)
let old_indices = map.(Array_view.backing_array_pos new_lines inew) in
List.iter old_indices ~f:(fun iold ->
let iold = iold - old_lines_pos in
if iold >= 0 && iold < old_len
then (
let o = 1 + (Int.Map.find_opt (iold - 1) !overlap |> Option.value ~default:0) in
overlap' := Int.Map.add !overlap' ~key:iold ~data:o;
if o > !sub_length
then (
sub_length := o;
sub_start_old := iold - o + 1;
sub_start_new := inew - o + 1)));
overlap := !overlap');
!sub_start_new, !sub_start_old, !sub_length
;;
let get_diff old_lines new_lines =
let old_lines = Array.of_list old_lines in
let new_lines = Array.of_list new_lines in
let map = line_map old_lines new_lines in
let rec get_diff' old_lines new_lines =
match Array_view.is_empty old_lines, Array_view.is_empty new_lines with
| true, true -> []
| false, true -> [ Deleted { lines = Array_view.length old_lines } ]
| true, false -> [ Added new_lines ]
| false, false ->
let sub_start_new, sub_start_old, sub_length =
longest_subsequence map old_lines new_lines
in
if sub_length = 0
then [ Deleted { lines = Array_view.length old_lines }; Added new_lines ]
else (
let old_lines_presubseq = Array_view.sub ~pos:0 ~len:sub_start_old old_lines in
let new_lines_presubseq = Array_view.sub ~pos:0 ~len:sub_start_new new_lines in
let old_lines_postsubseq =
let start_index = sub_start_old + sub_length in
let len = Array_view.length old_lines - start_index in
Array_view.sub ~pos:start_index ~len old_lines
in
let new_lines_postsubseq =
let start_index = sub_start_new + sub_length in
let len = Array_view.length new_lines - start_index in
Array_view.sub ~pos:start_index ~len new_lines
in
List.concat
[ get_diff' old_lines_presubseq new_lines_presubseq
; [ Equal { lines = sub_length } ]
; get_diff' old_lines_postsubseq new_lines_postsubseq
])
in
let make a = Array_view.make ~pos:0 a in
get_diff' (make old_lines) (make new_lines)
;;
end
type edit =
| Insert of Substring.t Array_view.t
| Replace of
{ deleted : int
; added : Substring.t Array_view.t
}
| Delete of { lines : int }
let text_edit ~line edit =
let deleted_lines, added_lines =
match edit with
| Insert adds -> 0, Some adds
| Replace { deleted; added } -> deleted, Some added
| Delete { lines } -> lines, None
in
let start = { Position.character = 0; line } in
let end_ = { Position.character = 0; line = line + deleted_lines } in
let range = { Range.start; end_ } in
let newText =
match added_lines with
| None -> ""
| Some adds -> Substring.concat adds
in
{ TextEdit.newText; range }
;;
let split_lines =
let rec loop acc s len i =
if i >= len
then acc
else (
match String.index_from_opt s i '\n' with
| None -> Substring.of_slice s ~pos:i ~len:(len - i) :: acc
| Some j ->
let acc = Substring.of_slice s ~pos:i ~len:(j - i + 1) :: acc in
loop acc s len (j + 1))
in
fun s -> List.rev @@ loop [] s (String.length s) 0
;;
let edit ~from:orig ~to_:formatted : TextEdit.t list =
let line, prev_deleted_lines, edits_rev =
let orig_lines = split_lines orig in
let formatted_lines = split_lines formatted in
Simple_diff.get_diff orig_lines formatted_lines
|> List.fold_left
~init:(0, 0, [])
~f:(fun (line, prev_deleted_lines, edits_rev) edit ->
match (edit : Simple_diff.diff) with
| Deleted { lines = deleted_lines } ->
line, deleted_lines + prev_deleted_lines, edits_rev
| Added added_lines ->
let edit =
text_edit
~line
(if prev_deleted_lines > 0
then Replace { deleted = prev_deleted_lines; added = added_lines }
else Insert added_lines)
in
line + prev_deleted_lines, 0, edit :: edits_rev
| Equal { lines } ->
let edits_rev =
if prev_deleted_lines > 0
then text_edit ~line (Delete { lines = prev_deleted_lines }) :: edits_rev
else edits_rev
in
line + prev_deleted_lines + lines, 0, edits_rev)
in
List.rev
@@
if prev_deleted_lines > 0
then text_edit ~line (Delete { lines = prev_deleted_lines }) :: edits_rev
else edits_rev
;;

1
thirdparty/lsp/lsp/src/diff.mli vendored Normal file
View file

@ -0,0 +1 @@
val edit : from:string -> to_:string -> Types.TextEdit.t list

16
thirdparty/lsp/lsp/src/dune vendored Normal file
View file

@ -0,0 +1,16 @@
(include_subdirs unqualified)
(library
(name lsp)
(public_name lsp)
(libraries jsonrpc ppx_yojson_conv_lib uutf yojson)
(lint
(pps ppx_yojson_conv))
(instrumentation
(backend bisect_ppx)))
(cinaps
(files types.ml types.mli)
(libraries lsp_gen))
(ocamllex uri_lexer)

108
thirdparty/lsp/lsp/src/extension.ml vendored Normal file
View file

@ -0,0 +1,108 @@
open Import
open Json.Conv
module DebugEcho = struct
module T = struct
type t = { message : string } [@@deriving_inline yojson]
let _ = fun (_ : t) -> ()
let t_of_yojson =
(let _tp_loc = "lsp/src/extension.ml.DebugEcho.T.t" in
function
| `Assoc field_yojsons as yojson ->
let message_field = ref Ppx_yojson_conv_lib.Option.None
and duplicates = ref []
and extra = ref [] in
let rec iter = function
| (field_name, _field_yojson) :: tail ->
(match field_name with
| "message" ->
(match Ppx_yojson_conv_lib.( ! ) message_field with
| Ppx_yojson_conv_lib.Option.None ->
let fvalue = string_of_yojson _field_yojson in
message_field := Ppx_yojson_conv_lib.Option.Some fvalue
| Ppx_yojson_conv_lib.Option.Some _ ->
duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
| _ ->
if
Ppx_yojson_conv_lib.( ! )
Ppx_yojson_conv_lib.Yojson_conv.record_check_extra_fields
then extra := field_name :: Ppx_yojson_conv_lib.( ! ) extra
else ());
iter tail
| [] -> ()
in
iter field_yojsons;
(match Ppx_yojson_conv_lib.( ! ) duplicates with
| _ :: _ ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_duplicate_fields
_tp_loc
(Ppx_yojson_conv_lib.( ! ) duplicates)
yojson
| [] ->
(match Ppx_yojson_conv_lib.( ! ) extra with
| _ :: _ ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_extra_fields
_tp_loc
(Ppx_yojson_conv_lib.( ! ) extra)
yojson
| [] ->
(match Ppx_yojson_conv_lib.( ! ) message_field with
| Ppx_yojson_conv_lib.Option.Some message_value ->
{ message = message_value }
| _ ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_undefined_elements
_tp_loc
yojson
[ ( Ppx_yojson_conv_lib.poly_equal
(Ppx_yojson_conv_lib.( ! ) message_field)
Ppx_yojson_conv_lib.Option.None
, "message" )
])))
| _ as yojson ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom _tp_loc yojson
: Ppx_yojson_conv_lib.Yojson.Safe.t -> t)
;;
let _ = t_of_yojson
let yojson_of_t =
(function
| { message = v_message } ->
let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
let bnds =
let arg = yojson_of_string v_message in
("message", arg) :: bnds
in
`Assoc bnds
: t -> Ppx_yojson_conv_lib.Yojson.Safe.t)
;;
let _ = yojson_of_t
[@@@deriving.end]
end
module Params = T
module Result = T
end
module DebugTextDocumentGet = struct
module Params = Types.TextDocumentPositionParams
module Result = struct
type t = string option
let yojson_of_t = function
| None -> `Null
| Some s -> `String s
;;
let t_of_yojson = function
| `Null -> None
| `String s -> Some s
| json -> Json.error "DebugTextDocumentGet" json
;;
end
end

29
thirdparty/lsp/lsp/src/extension.mli vendored Normal file
View file

@ -0,0 +1,29 @@
(** Protocol extensions that aren't part of the spec *)
open Import
module DebugEcho : sig
module Params : sig
type t = { message : string }
include Json.Jsonable.S with type t := t
end
module Result : sig
type t = Params.t = { message : string }
include Json.Jsonable.S with type t := t
end
end
module DebugTextDocumentGet : sig
module Params : sig
include module type of Types.TextDocumentPositionParams
end
module Result : sig
type t = string option
include Json.Jsonable.S with type t := t
end
end

39
thirdparty/lsp/lsp/src/header.ml vendored Normal file
View file

@ -0,0 +1,39 @@
type t =
{ content_length : int
; content_type : string
}
let content_type t = t.content_type
let content_length t = t.content_length
module Private = struct
module Key = struct
let content_length = "Content-Length"
let content_type = "Content-Type"
end
end
open Private
let crlf = "\r\n"
let to_string { content_length; content_type } =
let b = Buffer.create 64 in
let add = Buffer.add_string b in
let line k v =
add k;
add ": ";
add v;
add crlf
in
line Key.content_length (string_of_int content_length);
line Key.content_type content_type;
add crlf;
Buffer.contents b
;;
let default_content_type = "application/vscode-jsonrpc; charset=utf-8"
let create ?(content_type = default_content_type) ~content_length () =
{ content_length; content_type }
;;

15
thirdparty/lsp/lsp/src/header.mli vendored Normal file
View file

@ -0,0 +1,15 @@
open! Import
type t
val content_length : t -> int
val content_type : t -> string
val create : ?content_type:string -> content_length:int -> unit -> t
val to_string : t -> string
module Private : sig
module Key : sig
val content_length : string
val content_type : string
end
end

271
thirdparty/lsp/lsp/src/import.ml vendored Normal file
View file

@ -0,0 +1,271 @@
module List = Stdlib.ListLabels
module Option = Stdlib.Option
module Array = Stdlib.ArrayLabels
module Bytes = Stdlib.BytesLabels
module Map = Stdlib.MoreLabels.Map
module Result = struct
include Stdlib.Result
module O = struct
let ( let+ ) x f = Stdlib.Result.map f x
end
end
let sprintf = Printf.sprintf
module String = struct
include StringLabels
let index = index_opt
let is_empty s = length s = 0
let rec check_prefix s ~prefix len i =
i = len || (s.[i] = prefix.[i] && check_prefix s ~prefix len (i + 1))
;;
let lsplit2 s ~on =
match index s on with
| None -> None
| Some i -> Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1))
;;
let is_prefix s ~prefix =
let len = length s in
let prefix_len = length prefix in
len >= prefix_len && check_prefix s ~prefix prefix_len 0
;;
let add_prefix_if_not_exists s ~prefix = if is_prefix s ~prefix then s else prefix ^ s
let next_occurrence ~pattern text from =
let plen = String.length pattern in
let last = String.length text - plen in
let i = ref from
and j = ref 0 in
while !i <= last && !j < plen do
if text.[!i + !j] <> pattern.[!j]
then (
incr i;
j := 0)
else incr j
done;
if !j < plen then raise Not_found else !i
;;
let replace_all ~pattern ~with_ text =
if pattern = ""
then text
else (
match next_occurrence ~pattern text 0 with
| exception Not_found -> text
| j0 ->
let buffer = Buffer.create (String.length text) in
let rec aux i j =
Buffer.add_substring buffer text i (j - i);
Buffer.add_string buffer with_;
let i' = j + String.length pattern in
match next_occurrence ~pattern text i' with
| exception Not_found ->
Buffer.add_substring buffer text i' (String.length text - i')
| j' -> aux i' j'
in
aux 0 j0;
Buffer.contents buffer)
;;
module Map = MoreLabels.Map.Make (String)
end
module Int = struct
include Int
module Map = MoreLabels.Map.Make (Int)
end
module Json = struct
type t = Ppx_yojson_conv_lib.Yojson.Safe.t
let to_string t = Yojson.Safe.to_string t
let of_string s = Yojson.Safe.from_string s
let yojson_of_t x = x
let t_of_yojson x = x
let error = Ppx_yojson_conv_lib.Yojson_conv.of_yojson_error
let yojson_of_list = Ppx_yojson_conv_lib.Yojson_conv.yojson_of_list
module Jsonable = Ppx_yojson_conv_lib.Yojsonable
let bool b = `Bool b
let field fields name conv = List.assoc_opt name fields |> Option.map conv
let field_exn fields name conv =
match field fields name conv with
| Some f -> f
| None -> error ("missing field: " ^ name) (`Assoc fields)
;;
module Conv = struct
include Ppx_yojson_conv_lib.Yojson_conv
end
module O = struct
let ( <|> ) c1 c2 json =
match c1 json with
| s -> s
| (exception Jsonrpc.Json.Of_json (_, _)) | (exception Conv.Of_yojson_error (_, _))
-> c2 json
;;
end
module Object = struct
type json = t
type nonrec t = (string * t) list
let yojson_of_t t : json = `Assoc t
let t_of_yojson (t : json) : t =
match t with
| `Assoc t -> t
| json -> error "object expected" json
;;
end
module Option = struct
type 'a t = 'a option
let yojson_of_t f = function
| None -> `Null
| Some x -> f x
;;
let t_of_yojson f = function
| `Null -> None
| json -> Some (f json)
;;
end
module Of = struct
let list = Ppx_yojson_conv_lib.Yojson_conv.list_of_yojson
let pair f g json =
match json with
| `List [ x; y ] -> f x, g y
| json -> error "pair" json
;;
let int_pair =
let int = Ppx_yojson_conv_lib.Yojson_conv.int_of_yojson in
pair int int
;;
let untagged_union (type a) name (xs : (t -> a) list) (json : t) : a =
match
List.find_map xs ~f:(fun conv ->
try Some (conv json) with
| Ppx_yojson_conv_lib.Yojson_conv.Of_yojson_error (_, _) -> None)
with
| None -> error name json
| Some x -> x
;;
let literal_field
(type a)
(name : string)
(k : string)
(v : string)
(f : t -> a)
(json : t)
: a
=
match json with
| `Assoc xs ->
let ks, xs =
List.partition_map xs ~f:(fun (k', v') ->
if k = k'
then
if `String v = v'
then Left k
else error (sprintf "%s: incorrect key %s" name k) json
else Right (k', v'))
in
(match ks with
| [] -> error (sprintf "%s: key %s not found" name k) json
| [ _ ] -> f (`Assoc xs)
| _ :: _ -> error (sprintf "%s: multiple keys %s" name k) json)
| _ -> error (sprintf "%s: not a record (key: %s)" name k) json
;;
end
module To = struct
let list f xs = `List (List.map ~f xs)
let literal_field (type a) (k : string) (v : string) (f : a -> t) (t : a) : t =
match f t with
| `Assoc xs -> `Assoc ((k, `String v) :: xs)
| _ -> invalid_arg "To.literal_field"
;;
let int_pair (x, y) = `List [ `Int x; `Int y ]
end
module Nullable_option = struct
type 'a t = 'a option
let t_of_yojson f = function
| `Null -> None
| json -> Some (f json)
;;
let yojson_of_t f = function
| None -> assert false
| Some s -> f s
;;
end
module Assoc = struct
type ('a, 'b) t = ('a * 'b) list
let yojson_of_t f g xs =
let f k =
match f k with
| `String s -> s
| json -> error "Json.Assoc.yojson_of_t not a string key" json
in
`Assoc (List.map xs ~f:(fun (k, v) -> f k, g v))
;;
let t_of_yojson f g json =
let f s = f (`String s) in
match json with
| `Assoc xs -> List.map xs ~f:(fun (k, v) -> f k, g v)
| _ -> error "Json.Assoc.t_of_yojson: not an object" json
;;
end
module Void = struct
type t
let t_of_yojson = error "Void.t"
let yojson_of_t (_ : t) = assert false
end
let read_json_params f v =
match f (Jsonrpc.Structured.yojson_of_t v) with
| r -> Ok r
| exception Ppx_yojson_conv_lib.Yojson_conv.Of_yojson_error (Failure msg, _) ->
Error msg
;;
let require_params json =
match json with
| None -> Error "params are required"
| Some params -> Ok params
;;
let message_params params f =
match require_params params with
| Error e -> Error e
| Ok x -> read_json_params f x
;;
end
let sprintf = Printf.sprintf

116
thirdparty/lsp/lsp/src/io.ml vendored Normal file
View file

@ -0,0 +1,116 @@
open Import
exception Error of string
let () =
Printexc.register_printer (function
| Error msg -> Some ("Error: " ^ msg)
| _ -> None)
;;
let caseless_equal a b =
if a == b
then true
else (
let len = String.length a in
len = String.length b
&&
let stop = ref false in
let idx = ref 0 in
while (not !stop) && !idx < len do
let c1 = String.unsafe_get a !idx in
let c2 = String.unsafe_get b !idx in
if Char.lowercase_ascii c1 <> Char.lowercase_ascii c2 then stop := true;
incr idx
done;
not !stop)
;;
let content_type_lowercase = String.lowercase_ascii Header.Private.Key.content_type
let content_length_lowercase = String.lowercase_ascii Header.Private.Key.content_length
module Make
(Io : sig
type 'a t
val return : 'a -> 'a t
val raise : exn -> 'a t
module O : sig
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
end
end)
(Chan : sig
type input
type output
val read_line : input -> string option Io.t
val read_exactly : input -> int -> string option Io.t
val write : output -> string list -> unit Io.t
end) =
struct
open Io.O
let read_header =
let init_content_length = -1 in
let rec loop chan content_length content_type =
let* line = Chan.read_line chan in
match line with
| None -> Io.return None
| Some "" | Some "\r" -> Io.return (Some (content_length, content_type))
| Some line ->
(match String.lsplit2 ~on:':' line with
| None -> loop chan content_length content_type
| Some (k, v) ->
let k = String.trim k in
if
caseless_equal k content_length_lowercase
&& content_length = init_content_length
then (
let content_length = int_of_string_opt (String.trim v) in
match content_length with
| None -> Io.raise (Error "Content-Length is invalid")
| Some content_length -> loop chan content_length content_type)
else if caseless_equal k content_type_lowercase && content_type = None
then (
let content_type = String.trim v in
loop chan content_length (Some content_type))
else loop chan content_length content_type)
in
fun chan ->
let open Io.O in
let* res = loop chan init_content_length None in
match res with
| None -> Io.return None
| Some (content_length, content_type) ->
let+ () =
if content_length = init_content_length
then Io.raise (Error "content length absent")
else Io.return ()
in
Some (Header.create ?content_type ~content_length ())
;;
let read chan =
let* header = read_header chan in
match header with
| None -> Io.return None
| Some header ->
let len = Header.content_length header in
let* buf = Chan.read_exactly chan len in
(match buf with
| None -> Io.raise (Error "unable to read json")
| Some buf ->
let json = Json.of_string buf in
Io.return (Some (Jsonrpc.Packet.t_of_yojson json)))
;;
let write chan packet =
let json = Jsonrpc.Packet.yojson_of_t packet in
let data = Json.to_string json in
let content_length = String.length data in
let header = Header.create ~content_length () in
Chan.write chan [ Header.to_string header; data ]
;;
end

27
thirdparty/lsp/lsp/src/io.mli vendored Normal file
View file

@ -0,0 +1,27 @@
(** Low level module for sending/receiving jsonrpc packets across channels *)
exception Error of string
module Make
(Io : sig
type 'a t
val return : 'a -> 'a t
val raise : exn -> 'a t
module O : sig
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
end
end)
(Chan : sig
type input
type output
val read_line : input -> string option Io.t
val read_exactly : input -> int -> string option Io.t
val write : output -> string list -> unit Io.t
end) : sig
val read : Chan.input -> Jsonrpc.Packet.t option Io.t
val write : Chan.output -> Jsonrpc.Packet.t -> unit Io.t
end

Some files were not shown because too many files have changed in this diff Show more