diff --git a/.gitmodules b/.gitmodules index e69de29bb..4b3a2be17 100644 --- a/.gitmodules +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "ocaml-lsp-server/vendor/merlin"] + path = ocaml-lsp-server/vendor/merlin + url = https://github.com/rgrinberg/merlin diff --git a/CHANGES.md b/CHANGES.md index a0577ae07..6f3d45f67 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -12,6 +12,8 @@ - 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 diff --git a/flake.lock b/flake.lock index b04aad6b0..79cddd1ef 100644 --- a/flake.lock +++ b/flake.lock @@ -46,23 +46,6 @@ "type": "github" } }, - "git-subrepo-src": { - "flake": false, - "locked": { - "lastModified": 1598529383, - "narHash": "sha256-tOCAB4wV/ZSVqNJ01iuEqTdY2QNzuWnQmUoCg4ZsVWQ=", - "owner": "rgrinberg", - "repo": "git-subrepo", - "rev": "8fb6be3fb1500ab845081fc26ecdb950e9c0438c", - "type": "github" - }, - "original": { - "owner": "rgrinberg", - "repo": "git-subrepo", - "rev": "8fb6be3fb1500ab845081fc26ecdb950e9c0438c", - "type": "github" - } - }, "mirage-opam-overlays": { "flake": false, "locked": { @@ -193,7 +176,6 @@ "root": { "inputs": { "flake-utils": "flake-utils", - "git-subrepo-src": "git-subrepo-src", "nixpkgs": "nixpkgs", "opam-nix": "opam-nix", "opam-repository": "opam-repository" diff --git a/flake.nix b/flake.nix index c67af0eb1..4003147b3 100644 --- a/flake.nix +++ b/flake.nix @@ -10,11 +10,6 @@ url = "github:ocaml/opam-repository"; flake = false; }; - git-subrepo-src = { - url = - "github:rgrinberg/git-subrepo?rev=8fb6be3fb1500ab845081fc26ecdb950e9c0438c"; - flake = false; - }; }; outputs = { self, flake-utils, opam-nix, opam-repository, nixpkgs, ... }@inputs: @@ -58,8 +53,6 @@ # the scope don't leak into dependent derivations doNixSupport = false; }); - git-subrepo = prev.git-subrepo.overrideAttr - (old: { src = inputs.git-subrepo-src; }); }; in scope.overrideScope' overlay @@ -75,7 +68,6 @@ buildInputs = (with pkgs; [ # dev tools - git-subrepo ocamlformat_0_21_0 yarn dune-release diff --git a/ocaml-lsp-server/vendor/merlin b/ocaml-lsp-server/vendor/merlin new file mode 160000 index 000000000..1385c29fd --- /dev/null +++ b/ocaml-lsp-server/vendor/merlin @@ -0,0 +1 @@ +Subproject commit 1385c29fd9d0b825bee3778fa69866693098685b diff --git a/ocaml-lsp-server/vendor/merlin/.gitattributes b/ocaml-lsp-server/vendor/merlin/.gitattributes deleted file mode 100644 index 1f54ecd3f..000000000 --- a/ocaml-lsp-server/vendor/merlin/.gitattributes +++ /dev/null @@ -1,12 +0,0 @@ -configure eol=lf -*.sh eol=lf -*.patch eol=lf -tests/merlin-wrapper eol=lf - -src/ocaml/preprocess/menhirLib.ml text eol=lf -src/ocaml/preprocess/menhirLib.mli text eol=lf -src/ocaml/preprocess/parser_explain.ml text eol=lf -src/ocaml/preprocess/parser_printer.ml text eol=lf -src/ocaml/preprocess/parser_raw.ml text eol=lf -src/ocaml/preprocess/parser_raw.mli text eol=lf -src/ocaml/preprocess/parser_recover.ml text eol=lf diff --git a/ocaml-lsp-server/vendor/merlin/.github/workflows/emacs-lint.yml b/ocaml-lsp-server/vendor/merlin/.github/workflows/emacs-lint.yml deleted file mode 100644 index eccd0f0a6..000000000 --- a/ocaml-lsp-server/vendor/merlin/.github/workflows/emacs-lint.yml +++ /dev/null @@ -1,40 +0,0 @@ -name: Emacs lint - -on: - push: - paths: - - 'emacs/**' - pull_request: - paths: - - 'emacs/**' - -jobs: - build: - runs-on: ubuntu-latest - strategy: - matrix: - emacs_version: - #- 25.1 - #- 25.2 - #- 25.3 - #- 26.1 - #- 26.2 - #- 26.3 - #- 27.1 - - 27.2 - - snapshot - # include: - # - emacs_version: 24.1 - # lint_ignore: 1 - # - emacs_version: 24.2 - # lint_ignore: 1 - env: - EMACS_LINT_IGNORE: ${{ matrix.lint_ignore }} - steps: - - uses: purcell/setup-emacs@master - with: - version: ${{ matrix.emacs_version }} - - - uses: actions/checkout@v2 - - name: Run tests - run: 'cd emacs && ./check.sh' diff --git a/ocaml-lsp-server/vendor/merlin/.github/workflows/main.yml b/ocaml-lsp-server/vendor/merlin/.github/workflows/main.yml deleted file mode 100644 index 82c780bd1..000000000 --- a/ocaml-lsp-server/vendor/merlin/.github/workflows/main.yml +++ /dev/null @@ -1,77 +0,0 @@ -# This is a basic workflow to help you get started with Actions - -name: CI - -# Controls when the action will run. Triggers the workflow on push or pull request -# events but only for the master branch -on: - push: - branches: [ master ] - paths-ignore: - - '**.md' - - '**.txt' - - '.git*' - - 'doc/**' - - 'emacs/**' - - 'vim/**' - pull_request: - branches: [ master ] - paths-ignore: - - '**.md' - - '**.txt' - - '.git*' - - 'doc/**' - - 'emacs/**' - - 'vim/**' - schedule: - - cron: '0 12 */6 * *' - -# A workflow run is made up of one or more jobs that can run sequentially or in parallel -jobs: - # This workflow contains a single job called "build" - build: - strategy: - fail-fast: false - matrix: - os: - - macos-latest - - ubuntu-latest - - windows-latest - ocaml-compiler: - - 4.14.x - # The type of runner that the job will run on - runs-on: ${{ matrix.os }} - - # Steps represent a sequence of tasks that will be executed as part of the job - steps: - # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - - uses: actions/checkout@v3 - - - name: Set up OCaml ${{ matrix.ocaml-compiler }} - uses: ocaml/setup-ocaml@v2 - with: - # Version of the OCaml compiler to initialise - ocaml-compiler: ${{ matrix.ocaml-compiler }} - - - name: Install dependencies - run: | - opam depext conf-jq --yes # opam depext bug - opam pin menhirLib 20201216 --no-action - opam install . --deps-only --with-test --yes - - - name: Build and test in release mode (windows) - if: matrix.os == 'windows-latest' - run: | - opam exec -- dune runtest -p merlin-lib,dot-merlin-reader,merlin - - - name: Build and test in release mode (macos/linux) - if: matrix.os != 'windows-latest' - run: | - opam install . --with-test --yes - - - name: Build in dev mode to check parser changes - if: matrix.os == 'ubuntu-latest' - run: | - opam exec -- dune clean - opam exec -- dune build - git diff --exit-code diff --git a/ocaml-lsp-server/vendor/merlin/.gitignore b/ocaml-lsp-server/vendor/merlin/.gitignore deleted file mode 100644 index a585db3c6..000000000 --- a/ocaml-lsp-server/vendor/merlin/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -_build -_opam -.merlin -jbuild-workspace -dune-workspace -*.install -*.tar.gz -*.pyc -*.cmly -*.elc - -/ocamlmerlin -/ocamlmerlin-server -/ocamlmerlin-lsp -/dot-merlin-reader - -# Ignore garbage files from editors -*.un~ -*.swp -*.swo diff --git a/ocaml-lsp-server/vendor/merlin/.gitrepo b/ocaml-lsp-server/vendor/merlin/.gitrepo deleted file mode 100644 index 395048854..000000000 --- a/ocaml-lsp-server/vendor/merlin/.gitrepo +++ /dev/null @@ -1,12 +0,0 @@ -; DO NOT EDIT (unless you know what you are doing) -; -; This subdirectory is a git "subrepo", and this file is maintained by the -; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme -; -[subrepo] - remote = https://github.com/rgrinberg/merlin - branch = master - commit = 4c0d662f5eaa91bae68d6b04e4c4c2ab54e3e1c7 - parent = 9b96d5f237da97122e3b6830080fc85e73eb582e - method = rebase - cmdver = 0.4.1 diff --git a/ocaml-lsp-server/vendor/merlin/CHANGES.md b/ocaml-lsp-server/vendor/merlin/CHANGES.md deleted file mode 100644 index 02360e265..000000000 --- a/ocaml-lsp-server/vendor/merlin/CHANGES.md +++ /dev/null @@ -1,1134 +0,0 @@ -merlin 4.6 -========== -Thu Jun 30 14:51:42 CEST 2022 - - + merlin binary - - make most library public and split merlin in two packages: the - `merlin-lib` package that exposes merlin's internals and the `merlin` - package with the frontend. (#1448, #1455, #1457, #1497, @rgrinberg, - @tmattio, @kit-ty-kate) - - Type printing: use best_module_path for paths from Mty_alias (#1470) - - Attempt at finding the 'real' capitalization of files on windows (#1462 by - @mlasson) - - Use newer `Seq`-based API of Yojson 2.0, avoiding the need for the - deprecated `Stream` module (#1475 by @Leonidas-from-XIV) - - unify parsing of `MERLIN_LOG` (#1480 by @ulugbekna) - - Fix type deduplication in `type-enclosing` results (#1483, fixes #1477) - - Only weakly reduce the shapes to speed up the new Merlin locate - implementation. (#1488) - - Ignore unknown configuration tags from dune configuration provider but not - from dot-merlin-reader (#1486) - - typing recovery: recover at the granularity of `core_type` (#1484) - + editor modes - - add method imenu items for emacs (#1481, @mndrix) - - emacs: Make the prefix argument to `merlin-locate` optional, both for - consistency with Emacs convention and for backwards compatibility. (#1476, - @antalsz) - - emacs: fix duplicated prefix path in imenu entries (#1495, @bcc32) - -merlin 4.5 -========== -Tue Apr 5 20:51:42 CEST 2022 - - + merlin binary - - don't reset the environment when running merlin in single mode so that the - parent environment is forwarded the the child processes (#1425) - - filter dups in source paths (#1218) - - improve load path performance (#1323) - - fix handlink of ppx's under Windows (#1413) - - locate: look for original source files before looking for preprocessed - files (#1219 by @ddickstein, fixes #894) - - handle `=` syntax in compiler flags (#1409) - - expose all destruct exceptions in the api (#1437) - - fix superfluous break in error reporting (#1432) - - recognise binding operators in locate and occurrences (#1398, @mattiase) - - remove dependency on Result (#1441, @kit-ty-kate) - - use the new "shapes" generated by the compiler to perform precise - jump-to-definition (#1431) - + editor modes - - fix an issue in Neovim where the current line jumps to the top of the - window on repeated calls to `MerlinTypeOf` (#1433 by @ddickstein, fixes - #1221) - - add module, module type, and class imenu items for emacs (#1244, @ivg) - - add prefix argument to force or prevent opening in a new buffer in locate - command (#1426, @panglesd) - - add type-on-hover functionality for vim (#1439, @nilsbecker) - - add a dedicated buffer `*merlin-errors*` containing the last viewed error - (#1414, @panglesd) - + test suite - - make `merlin-wrapper` create a default `.merlin` file only when there is - no `dune-project` to let tests use `dune ocaml-merlin` reader. (#1425) - - cover locate calls on module aliases with and without dune - - Add a test expliciting the interaction between locate and Dune's generated - source files (#1444) - -merlin 4.4 -========== -Mon Jul 26 11:12:21 PM CET 2021 - - + ocaml support - - add support for 4.13 - - stopped actively supporting version older than 4.12 - + merlin binary - - Mbrowse.select_leaf: correctly ignore merlin.hide (#1376) - - enable `occurences` to work when looking for locally abstract types - (#1382) - - handle `-alert` compiler flag (#1401) - - avoid a race condition when the process started to read a configuration - file crashes/is not found (#1378, @antalsz) - - log the backtrace even when the exception is a Failure (#1377, @antalsz) - - ignore `-error-style` compiler flag (#1402, @nojb) - - fix handling of record field expressions (#1375) - - allow -pp to return an AST (#1394) - - fix merlin crashing due to short-paths (#1334, fixes #1322) - + editor modes - - update quick setup instructions for emacs (#1380, @ScriptDevil) - + test suite - - improve record field destruction testing (#1375) - -merlin 4.3.1 -============ -Mon Jul 26 04:45:37 PM CET 2021 - - + merlin binary - - recover ill-typed patterns (#1317, #1342) - - more accurate type-enclosing for methods (#1328, fixes #1124) - - fix location of patterns in Occurrences (#1324, fixes ocaml/ocaml-lsp#375) - - fix location of module definitions done via functors (#1329, fixes #1199) - - fix -cmt-path dirs mistakenly added to build path (#1330) - - add new module holes that can replace module expressions (#1333) - - add a new command `construct` that builds a list of possible terms when - called on a typed hole (#1318) - - `refactor-open` improvements (#1313, #1314, #1366, #1372) - - do not make paths absolute, simply prefix with the identifier under - the cursor - ```ocaml - open Foo (* calling refactor-open qualify on this open *) - let _ = Foo.bar (* previously could result in [Dune__exe.Foo.bar] *) - ``` - - do not return identical (duplicate) edits - - do not return unnecessary edits that when applied do not change - the document - - handle record fields properly - - handle multi-line paths - - `unqualify` should not qualify - - Handle `Persistent_env.Error` in `Typemod.initial_env` (#1355) - - locate: reset global state from all entry points (#1364) - - Windows: replace user name by its SID in socketnames (#1345, @ttamttam) - + editor modes - - vim: add a simple interface to the new `construct` command: - `MerlinConstruct`. When several results are suggested, `` - and `` can be use to change the depth of the recursive - construction. (#1318) - - vim: add support for the `merlin-locate-type` command: - `MerlinLocateType` (#1359) - - emacs: add a simple interface to the new `construct` command: - `merlin-construct`. (#1352) - - emacs: add support for the `merlin-locate-type` command. (#1359) - - emacs: fix issue with `merlin--highlight` and various minor improvements - (#1367, @mattiase) - + test suite - - cover the new `construct` command (#1318) - - disable tests failing in Opam's CI due to nested dune projects (#1373) - -merlin 4.2 -========== -Tue Apr 12 11:44:22 AM CET 2021 - - + merlin binary - - external configuration reading: - + use relative paths to communicate with Dune when possible. This solves - issues related to symlinks on Unix and improve Windows support (#1271, - fixes #1288) - + make the `workdir` configuration value when using the - `dune ocaml-merlin` configuration provider the same as when using - `dot-merlin-reader` so that ppxes behaves in the same way as before - (#1284, fixes ocaml/dune#4479, discussion in #1292) - - destruct: - + improve prefixing of generated constructors in Destruct by filtering - opened modules (#1277) - + make the destruct command more resilient to ill-typed expressions and - when called without nodes (#1304, fixes #1300) - - reintroduce some record recovery and improve completion (#1276) - - introduce a new AST node for holes (`_`), allow correct typing of these - holes and add a new `holes` command that returns the locations of all - holes in the current file along with their types (#1242, #1289) - - Mppx: don't restore cookies after invocation. Ppx are invoked only once - so there is no need to manage cookies. This small change should increase - performance and should not change any other behavior (#1309) - - Windows: system command variant: do not open a window console when - launching a ppx (#1270, fixes #714) - - fix same file documentation bug (#1265 by @ulugbekna, fixes #1261) - + editor modes - - vim: Add `MerlinNextHole` and `MerlinPreviousHole` commands to navigate - between holes. Jump to the first hole after destruct (#1287, #1303) - - emacs: Add `merlin-next-hole` and `merlin-previous-hole` commands to - navigate holes. Jump to the first hole after calling destruct. (#1291) - - emacs: modernization of the elisp code and conformance with coding - guidelines (#1247, #1310 by Steve Purcell ) - - vim & emacs : new client-side "merlin use package" commands, restoring - previous behavior (#1272, fixes #1191) - + test suite - - cover constructor disambiguation and record fields (#1276) - - cover the new `holes` command and AST node (#1242, #1289) - - cover the document fix (#1265, #1315) - -merlin 4.1 -========== -Tue Feb 16 10:33:11 AM CET 2021 - - + merlin binary: - - fix windows paths canonicalization (#1254) - - fix hanging on windows (#1256, #1263) - -merlin 4.0 -========== -Tue Feb 2 03:13:37 PM CET 2021 - - + ocaml support - Detailed list of changes on - https://tarides.com/blog/2021-01-26-recent-and-upcoming-changes-to-merlin#dropping-support-for-old-versions-of-ocaml - Summary: - - any revision of Merlin now only supports one version of OCaml. Support for - other versions will be found in other branches - - stopped actively supporting version older than 4.11 - - add support for 4.12 - + merlin binary - - add keyword completion (disabled by default) (#1243) - - fix a bug which caused type-enclosing to sometimes look at an incorrect - node (#1232, fixes #1226) - - properly report leaked parsing error (#1223, fixes #1222) - - wrap `merlin_analysis` and `merlin_utils` library - + editor modes - - emacs: add missing mandatory argument for define-obsolete-function-alias - (#1250, by Atharva Shukla, fixes #1234) - - emacs: use "opam var" instead of "opam config var" (#1249, by Raja Boujbel) - - vim: fix CursorMoved semantics (#1213, by @ddickstein) - - vim: add :MerlinLocateImpl and :MerlinLocateIntf (#1208 by Matthew Ryan) - + test suite - - replace mdx usage by dune's cram mechanism - -merlin 3.4.2 -============ -Fri Nov 13 12:16:42 CEST 2020 - - + merlin binary - - simplify local store implementation and API (#1188, #1184) - - fix a destruct issue allowing ill-typed match completions (#1194) - -merlin 3.4.1 -============ -Thu Oct 1 15:31:42 CEST 2020 - - + dot-merlin-reader - - fix issue when multiple packages with pxxes are declared in the - configuration. (#1181, fixes #1179) - -merlin 3.4.0 -============ -Wed Sep 16 15:00:42 CEST 2020 - - + merlin binary - - fix completion of pattern matchings with exception patterns (#1169) - - delegate configuration reading to external programs via a simple protocol - and create a new package `dot-merlin-reader` with a binary that reads - `.merlin` files. (#1123, #1152) - -merlin 3.3.8 -============ -Thu Aug 27 14:48:42 CEST 2020 - - + merlin binary - - dune: restore compatibility with dune 1.8.0 (#1157, #1153) - -merlin 3.3.7 -============ -Tue Aug 25 15:13:42 CEST 2020 - - + ocaml support - - full support from OCaml 4.02 to OCaml 4.11 (#1153) - -merlin 3.3.6 -============ -Fri Jun 12 10:51:42 CEST 2020 - - + merlin binary - - dune: remove duplicated rules for profile=release (#1143) - + test suite - - fix a test that required Dune 2.5 (#1146) - - fix another test that lacked reproducibility (#1146) - -merlin 3.3.5 -============ -Tue Jun 9 15:13:42 CEST 2020 - - + ocaml support - - alerts are no-more ignored and are reported as warnings (#1138) - + merlin binary - - fix completion of names containing `-` (#1142) - - fix several type-enclosing bugs by performing context-analysis (#1108) - - lsp: add deprecation flag to outline items (#1087) - - lsp: add go-to typedef (`Locate_type`) (#1067) - -merlin 3.3.4 -============ -Tue Apr 14 15:25:05 CEST 2020 - - + ocaml support - - full support from OCaml 4.02 to OCaml 4.10 (#1117, #1127) - - fix desynchronized cache (#1120) - - short path for OCaml 4.09 and OCaml 4.10 (#1082, #1117) - - catch and test environment initialization errors (#1083, #1130) - - restore type levels after recovery (#1092) - + merlin binary - - fix syntax errors in 4.08 and 4.09 (#1081) - - complete-prefix command accepts -kind option to filter results (#1071) - - code cleanup (#1093, #1079, #1112) - - better handling of expression and pattern extra nodes during browse tree - traversal (#1091, #1121) - - improve context detection (e.g. appropriate namespace for lookup) for - various queries (#1104, #1110) - - add stdlib to locate source path (#1085) - + editor modes - - vim: tweak heuristic to select python version (#1111) - - emacs: marlin/call - - lsp: move server to its own repository (#1069), - https://github.com/ocaml/ocaml-lsp - + test suite - - dune rules for the test suite are now generated, deterministic and - can be run individually (#1068, #1070, #1072) - - fix incorrect command-line arguments in tests (#1073) - - better coverage of frontend features (#1075, #1078, #1088, #1089, #1126) - -Build no longer relies on implicit transitive_deps (#1065). - -merlin 3.3.4~4.10preview1 -========================= -Mon Mar 2 14:26:32 CET 2020 - -This is a preview release that adds support for OCaml 4.10. -Short-path is disabled. Other versions of OCaml are not supported. - -merlin 3.3.3 -============ -Fri Nov 29 17:35:58 CET 2019 - - + backend - - support OCaml 4.09 (#1055) - - fix parse errors in 4.08 (#1037) - - update 4.08 support to OCaml 4.08.1 (#1053) - - support `without_cmis` - - separate reading from caching in file-cache, use caching in - `Env.check_state_consistency` (#1044) - - simplify compiler state management (#1056, #1059) - - fix creation of initial environment, improve compatibility with - upstream 4.08 (#1052) - + frontend - - code re-organization (#1042) - - error command: select which kind of errors to show (#995) - - print value types in outline (#1014) - - fix process handling in windows (#1005) - + editor modes - - emacs - + bugfixes in merlin-imenu, merlin-xref (#1000, #1021, #1001) - + show types in merlin-imenu (#1013) - + reset buffer local configurations when resetting server (#1004) - + remove merlin-use-tuareg-imenu - + fix stack overflow (#1024) - + fix merlin-occurrence (#1043) - - vim - + display warn-error warnings as errors (#1009) - + testsuite - - cover file-cache and `check_state_consistency` (#1044) - - check inconsistent assumptions, test server versus single modes (#1047) - -merlin 3.3.2 -============ -Mon Jul 15 11:10:35 CEST 2019 - - + backend - - `**` globbing in .merlin won't look into hidden directories - (starting with a '.') (by Daniel Bünzli, #990) - - fallback to "/dev/null" configuration for findlib - - better 4.08 support: - + support for letop (let+, and+, ...) (#986) - + fix parsing recovery for 4.08 constructions (#987) - + catch an exception raised by 4.08 Printtyp trying to rename a - persistent identifier (#991) - - locate: treat local locations differently from external locations (coming - from a cmi), this fixes "jump to definition" on mutually recursive - bindings (#984) - - when completing an infix operator in a sub-module, wrap with () (#992) - - disable arity checks on externals (for Bucklescript compatibility) - - remove parser preprocessing (simplify compilation for OCaml < 4.08) (#997) - + editor modes - - emacs - + fix position computation in presence of tabs or multi-byte characters (#981) - + log arguments in "merlin-debug-last-commands" (#981) - - vim - + install reason.vim file (by Hezekiah M. Carty, #974) - -merlin 3.3.1 -============ -Mon Jun 17 17:13:33 CEST 2019 - - + backend - - catch findlib initialization failures and keep going on - -merlin 3.3.0 -============ -Fri May 31 11:09:08 BST 2019 - - + backend - - interpret `-pp` flag - - backtrack warnings in all versions, not just 4.06 - - silence C compiler warnings (by David Allsopp and Bernhard Schommer) - - remove sturgeon support - - allow to select sections to log - - better error message on ocaml version mismatch - - locate: - + handle functors and functor applications - + do not use the location coming from the environment - - tweaked caching policy - - fix environment when a file disappears - - fix -short-paths handling of classes and class types (by Leo White) - - don't select deprecated paths in -short-paths (by Leo White) - - return type info in outline query (by Andrey Popp) - - properly handle new lines in the lexer - - better tracking of errors reported by the parser and by preprocessors - - add support for OCaml 4.08 - - tweaked the recovery strategy in presence of syntax errors - - timing information in replies now includes wall clock time. - - dump command can new dump the parsetree post preprocessing - - + editors modes - - emacs - + fix merlin-xref.el install (by Emilio Jesus Gallego Arias) - + keep labels matching the prefix the user has typed rather than - dropping them (by Mitchell Plamann) - + remove unused `merlin--overlay` function (by Wilfred Hughes) - + show the number of errors in the modline (by Wilfred Hughes) - + call a logger on the client side if one is defined - + allow user to disable completion inside comments and strings - + show errors and types even when buffer is narrowed (by Wilfred Hughes) - + make sure PATH is updated when merlin-command is 'opam - - - vim - + better FindBinary - + make the log buffer a scratch buffer (by Tom Johnson) - + execute buffer switching silently (by Fabian) - + restore view after updating merlin type buffer (by Fabian) - - + testsuite - - Switched to mdx with cram syntax. - -Special thanks to Rudi Grinberg for helping us in reviewing and merging -pull-requests. - -merlin 3.2.2 -============ -Tue Oct 9 11:25:12 BST 2018 - -Update cmt magic number for 4.07.1 - -merlin 3.2.1 -============ -Mon Oct 8 11:44:16 BST 2018 - -Fix build on OCaml 4.02 to 4.04 - -merlin 3.2.0 -============ -Mon Oct 8 10:41:24 BST 2018 - -Switched build to dune (thanks to @nojb). -Added support for 4.07.1 -Various bugfixes in the backend and in the editor modes. - - -merlin 3.1.0 -============ -Wed Jun 20 14:05:04 BST 2018 - - + backend - - new "polarity search" feature: provides a Hoogle-like type-based search - for libraries that are in merlin's scope. - See https://github.com/ocaml/merlin/blob/master/doc/features.md#polarity-search - - new "open refactoring" feature: helps cleaning the code in the scope of an - open statement. - See https://github.com/ocaml/merlin/blob/master/doc/features.md#open-refactoring - - spell-checking: a simple spell-checker has been added to suggest - corrections when nothing can be directly completed. - - type-driven record completion: merlin will now make use of type - information from the context for narrowing and refining completion - candidates. - - support for `#require` directive in a source file, and will treat it as a - package use - - Add support for OCaml 4.07 - - locate: various minor bugfixes, as well as the following general - improvements: - + improved context detection - + better tracking of namespaces - + fixed support for local bindings - + fixed support of disambiguated record fields and variant constructors - + improved support for functors: merlin will now jump through functor - application to the functor definitions and in some cases go back to the - argument that was given (if it is simply reexported). - - backport fixes of OCaml 4.06.1 to the 4.06 backend - - various minor bugfixes - - + editor modes - - emacs - + proper handling of multibyte strings (by @Chris00) - + bind "q" to close type buffer (by @MiloDavis) - + make goto-point encoding independent - + add reason-mode to the guessed favorite mode list (by @Khady) - + sped up some tight loops (by @rgrinberg) - + add support for x-ref backend (by @rgrinberg) - - vim - + fix support for Neomake (by @bobbypriambodo and @statianzo) - + fix encoding issues in filepaths (by @Thelyria) - + fix handling of enclosing-type cache (by @ELLIOTTCABLE) - + add to prevent flashing when highlighting an enclosing (by @bluddy) - -Thanks to the people who contributed to this release: ELLIOTTCABLE, Louis Roché, -Rudi Grinberg, Yotam Barnoy, Leo White, Daniel Below, Andreas Hauptmann, -Christophe Troestler, Bobby Priambodo, Milo Davis. - -merlin 3.0.5 -============ -Mon Nov 13 18:30:02 CET 2017 - -Fix magic numbers for 4.06 (issue #749, reported by @Fourchaux). - -merlin 3.0.4 -============ -Sun Nov 12 10:14:03 CET 2017 - -Add support for 4.06. -Use Leo White's short-path for 4.05. -Various bug fixes (in locate, in emacs serialization). - -merlin 3.0.3 -============ -Mon Oct 2 12:56:23 CEST 2017 - -The major change Windows support is contributed by David Allsopp. - -Other changes are a bunch of fixes: -- compilation on FreeBSD contributed by Malcolm Matalka -- improvement to emacs mode contributed by Olivier Andrieu, Christophe - Troestler and Steve Purcell -- improvement to vim mode by Fabian Hemmer and Gregory Nisbet -- fixes to ppx invocation by Keigo Imai -- fixes to Merlin s-expr dialect to bring UTF-8 compatibility with Emacs (WIP) - -merlin 3.0.2 -============ -Wed Aug 2 15:09:07 CEST 2017 - -Bug fix after 3.0.1: -- CMT magic number for 4.05 was wrong -- handle merlin.focus, merlin.ignore, merlin.loc/merlin.relaxed-loc and merlin.syntax-error -- missing include preventing build on some platforms contributed by Bernhard Schommer - -merlin 3.0.1 -============ -Wed Jul 26 18:25:23 CEST 2017 - -Bug fix release after 3.0.0 major release: -- portability fixes by David Allsop in configure script and vim mode - (tough Windows support is not ready yet) -- preliminary support for findlib toolchains with FINDLIB_TOOLCHAIN .merlin - directive -- make ocamlmerlin.c frontend more portable -- various fixes to the frontend - -merlin 3.0.0 -============ -Mon Jul 24 11:21:58 CEST 2017 - -The major change is a new protocol that moves process management inside Merlin -codebase, saving a lot of pain in Emacs and Vim. There are not much new user -facing features. - -Windows support is not yet available. - -In editor configuration is now done with merlin-flags, merlin-extensions and -merlin-use in Emacs and :MerlinFlags, :MerlinExtensions and :MerlinPackages in -Vim. -In previous versions, enabled extensions, flags and packages were retained -while now only the last command is remembered. - -"M-x merlin-use a", "M-x merlin-use b" should be replaced by "M-x merlin-use a,b". -":MerlinUse a", ":MerlinUse b" should be replaced by ":MerlinUse a b". - -The old protocol is still supported, so existing editor modes should not be -affected (tested with Atom, Visual Studio and Sublime-text). - -Other main changes: -- Support for OCaml 4.05 was added -- Merlin uses a new implementation of short-path by Leo White which addresses - performance problems -- Merlin now works with the upstream version of Menhir -- numerous cleanup and refactoring to decrease the amount of changes to - upstream typechecker -- emacs-imenu feature was contributed by tddsg. It is similar the "outline" - feature in vim for navigating in a buffer. - -Thanks to the many contributors (Jochen Bartl, tddsg, Ximin Luo, Jason Staten, -Leo White, Leandro Ostera, Jacob Bass, Xavier Guérin, Yotam Barnoy, Jacques -Pascal Deplaix, David Allsopp, ...). - -merlin 2.5.5 -============ -Wed Jun 14 14:54:32 CEST 2017 - -Minor release: -- fix flag parsing in .merlin (#661) - -merlin 2.5.4 -============ -Tue Apr 25 15:07:18 CEST 2017 - -Minor release: -- handle hole in 4.04 -- bug fixes in emacs mode -- introduce merlin-imenu - -merlin 2.5.3 -============ -Mon Nov 28 09:54:57 CET 2016 - -Minor release: -- fix Windows build with MSVC (#605). -- fix module level errors escaping - -merlin 2.5.2 -============ -Wed Nov 16 14:44:19 CET 2016 - -This release mainly brings support for OCaml 4.04. -Internal code was simplified and bugs were fixed in the meantime (cache -invalidation, ast traversal, type error recovery, certain cases of completion, -ppx working directory, locate, ...). - -merlin 2.5.1 -============ -Tue Oct 18 12:04:19 CEST 2016 - -Bug fix release before major version. - - - reintroduce lazy substitution to fix performance issue - - add "FINDLIB_PATH" directive to .merlin (contributed by Gerd Stolpmann) - - relax arity checks on externals (harmless, requested by Hongbo Zang) - - handle case insensitivity of OS X (fix longstanding bug) - - fix build under Cygwin - - minor cleanup, portability and usability improvements in build system and - editor modes - -merlin 2.5.0 -============ -Mon Jun 13 22:26:33 CEST 2016 - - + frontend: - - now all commands can take a context, this reduce the amount of state - in the command interpreter. Long term goal is to make protocol stateless - - merlin now supports customizable "readers": processes responsible for - parsing and pretty-printing. Main use-case is Reason, cppo/optcomp support - might be added later - + backend: - - drop support for 4.00 / 4.01 - - support for 4.03 has been added - - new implementation of type recovery, should diverge less from upstream - - support for 4.02 was reimplemented to use the same design - - menhir's fork has been synchronized with upstream, recovery algorithm - is completely new - + vim: add support for python3, update to new protocol - + emacs: update to new protocol, bug fixes - -merlin 2.3.1 -============ -Wed Nov 25 15:01:47 CET 2015 - -Bug fix release, fix builds under Mac OS X and Windows. - - + backend: - - improve support for module aliases in completion, locate and short-path - - change management of flags - - Cuillère ou Dorade - - fix grammar for 4.02.3, support attributes on core_types - - + emacs & vim: minor fixes - -merlin 2.3 -========== -Wed Oct 28 14:32:48 CET 2015 - - + backend: - - locate: fix assert failure on first class modules inclusion - - outline: add support for classes and object types - - nonrec: enable by default for OCaml >= 4.02.2 - - error reporting: less aggressive filtering on ghost locs - - finer-grained tracking of usage (values, opened modules, etc) - - significant improvement in the handling of PPX extensions: - + fix shell commandline and working directory - + normalize parsetree locations - + implement caching of intermediate rewriting - - merged support for MetaOCaml - - path to the standard library can now be specified with STDLIB command - in .merlin - - BrowseT: split into Browse_node (OCaml version specific) and - Merlin_browse, extract recursion scheme - - add Jump command, contributed by Tomasz Kołodziejski - - contextual-commands: optionnally specify the context (file, project) - in which each command is interpreted - - better support for trunk - - many bugfixes - - + documentation: - - update ARCHITECTURE and PROTOCOL documentations - - + emacs: - - make use of contextual-commands, non backward compatible protocol change - - new merlin-set-flags command - - split into multiple files - - cleanup symbol namespaces: - + merlin- for user targeted definitions - + merlin-- for internal definitions, - + merlin/ for API definitions - - usability tweaks, notably on error display and navigation - - general cleanup and bugfixes - - + vim: - - expose custom .merlin loading through buffer variable - - cleanup and bugfixes, notably process liveness check and restart - -This release also contains contributions from: Rudi Grinberg, Fourchaux, -Christopher Reichert, David Allsopp, Nick Borden, Mario Rodas, @Twinside, -Pierre Chambart, Philipp Haselwarter, Tomasz Kołodziejski and Syohei Yoshida. - -merlin 2.2 -========== -Wed May 20 09:44:55 EDT 2015 - - + backend: - - completion - + return the type of the expected argument when completing an - application. - This allows us to offer completion for named and optional parameters, - as well as polymorphic variants - + optionally associates ocamldoc comments to candidates - + adds field completion inside records ( #296 ) - - locate: - + partially rewritten, introduces a new kind of cache - (so potentially noticeably bigger memory consumption) - + better handling of functors - + handle local modules - + fix occasional "inconsistent assumptions" - - error reporting: - + handle environment errors (inconsistent assumptions, …) - + filter duplicated messages - + fix type error reporting: - "this expression has type t = t but an expression was expected of - type u = u" - we now only print the equality when it adds some information - + less noisy pattern recovery: when every pattern is recovered, consider - that the matched expression is the the source of the problem, and - retry typing with "'a" as the type of the matched expression. - - add support for trunk - - add a "document" command: takes an ident and return its documentation (if - any) - - destruct: use more precise environments ( #389 ) - - warnings: - + check signature inclusion to prevent spurious warnings about unused - declarations - + backport 4.02-style warning management - + add a dump command - - nonrec: update implementation to more-or-less match the upstream one - (upstream >= 4.02.2) - - parser: improve marking heuristic in presence of ;; or toplevel - directives. - - typeof: during verbose expansion, also print the type declaration if we - have a type constructor - - + emacs: - - fix bindings of every completion backend - - bind ocamldoc comments to company (optional) - - detect race conditions when running synchronous commands - - cleanup "merlin-process-started-p" - - locate error messages were silently ignored, they are now printed - - drop text properties from commands sent to merlin (pull request #383 by - milanst) - - Tell merlin the content of the buffer when opening a new buffer. - This allows merlin idle-job to preload content if nothing else is - requested. - - remove call to merlin from the lighter - - + vim: - - fix ctrlp binding for locate - - add (dwim) completion on :TypeOf - - while completing, candidates documentation can be displayed in the - "preview" window - - prefix every command name by "Merlin" ( #379 ) - - Tell merlin the content of the buffer when opening a new buffer. - This allows merlin idle-job to preload content if nothing else is - requested. - -merlin 2.1.2 -============ -Tue Mar 3 12:20:08 UTC 2015 - - Main new feature is a faster short-path, and also a lot of buxfixes. - - + backend: - - merge new implementation of short-path - - infrastructure for doing background computations - - fix exhaustivity checking of GADTs - - fix Typecore error reporting in 4.00.1 & 4.01.0 - - delayed checks are now enabled (e.g warnings) - - special handling of "myocamlbuild.ml" (issue #363) - - better sharing/caching of global modules - - more customizable .merlin loading - - minor fixes (better error messages, typos, "fake" extensions) - - + build system: - - allow bytecode builds, support OpenBSD (pull request #364 by madroach) - - Refuse/Resist... environment variables redefinition - - + vim: - - fix charset/encoding detection (pull request #352 by rgrinberg) - - minor fixes and simplification - - + emacs: - - better integration with emacs error management and asynchronous handling - - expose custom .merlin loading in merlin-grouping-function - - fixes, printf-debugging cleanup - -merlin 2.1.1 -============ -Wed Jan 28 08:59:20 GMT 2015 - - + backend: - - locate: merlin refused to locate things when it had no context (happens - when the buffer didn't parse for example) claiming it was at the - "definition point". Fixed. - - locate: use the cmt path when no ml file was found in the source path - (this might not be such a good idea, the cases when this work are the ones - where the user configuration is wrong...) - - destruct: qualify introduced constructors - - destruct: eliminate "impossible" GADT branches - - parser: handle '%' as an operator for 4.00 and 4.01 ( #345 ) - - + fake: - - add typerep support - - never generate `'_` type variables. - - + vim: - - show duplicated outlines in CtrlP - - sort outlines by name length in CtrlP - - when split method is set to 'tab' *always* open a new tab. - -merlin 2.1 -=========== -Sun Jan 11 22:20:23 CET 2015 - - + backend: - - add PPX support - - make use of context before locating (#308, #316, #318). - - generate match patterns for arbitrary expressions and missing patterns - for incomplete matchings (#123). - - reintroduce type expansion (asking the times of the same expression - several times will resolve type aliases). - - "smart" (a.k.a "do what I mean") completion: - `L.m` will expand to `List.map ; List.m... ; ListLabels.map ; ...` if - `L` doesn't exist. - - simplify incremental parser and typer interfaces - - locate: better handling of packed modules (supposedly) - - more precise recovery on patterns (before the recovery was done at the - expression level, so the whole match was discarded, now only the pattern - is) - - + emacs: - - don't use fringe in emacs23 (broken) - - remove obsolete aliases: - merlin-occurences => merlin-occurrences - merlin-to-end => merlin-error-check - - disable merlin-mode on type buffer - - require caml-types (needed for highlighting) (#331). - - + misc: - - update README (#301). - - + vim: - - add a type history buffer (#313, #322) -- only available for vim > 7.3. - - highlight types when displaying them in the command line -- only for vim > - 7.3 - - add tab completion for the argument of the `:Locate` command - - add support for text objects based on type enclosing - - introduce an interactive version of `:Rename` - - locate results can now be shown in a new or existing tab (#335) - - use `fileencoding` where necessary (#332) - - ctrlp bindings for outline and locate - -This release also contains contributions from: Geoff Gole, Rudi Grinberg, Markus -Mottl, Roman Vorobets and Arthur Wendling. - -merlin 2.0 -========== -Fri Oct 31 11:04:21 CET 2014 - -This is a major release which we worked on for several months, rewriting many -parts of the codebase. An exhaustive list of changes is therefore impossible to -give, but here are some key points (from an user perspective): - - - support for OCaml 4.02.{0,1} - - more precise recovery in presence of syntax errors - - more user-friendly messages for syntax errors - - locate now works on MLI files - - automatic reloading of .merlin files (when they are update or created), it - is no longer necessary to restart merlin - - introduced a small refactoring command: rename, who renames all occurrences - of an identifier. See: http://yawdp.com/~def/rename.webm - - -This release also contains contributions from: Yotam Barnoy, Jacques-Pascal -Deplaix, Geoff Gole, Rudi Grinberg, Steve Purcell and Jan Rehders. - -merlin 1.7.1 -============ -Fri Aug 22 10:01:58 CEST 2014 - -Minor update to installation procedure - -merlin 1.7 -========== -Mon Aug 18 17:08:00 BST 2014 - -This release also marks the apparition of a proper opam install script. - - + backend: - - fixes on locate - - print manifests even when -short-paths is set - - add an "occurrences" command to list every occurrence of an identifier ( #156 ) - - new "version" command ( #180 ) - - add CPU time to log files ( #192 ) - - better error reporting from locate ( #190 ) - - + documentation: - - update vim doc file ( #204 ) - - typo correction in the README by Philippe Wang ( #195 ) - - + emacs: - - fix most byte compilation warnings, by Geoff Gole ( #209 ) - - numerous fixes - - + vim: - - add error list independent from syntastic - - fix completion for vim<=703 (#223) - -merlin 1.6 -========== -Tue Mar 11 14:33:55 CET 2014 - - + backend: - - small memory leak fix - - major improvements and bugfixes for locate (i.e. "jump to definition") - - + emacs: - - fixed bug preventing merlin restart ( #167 ) - - removed keybindings reserved to users ( #170 ) - the full list is: - + `C-c l` previously bound to `merlin-use` - + `C-c r` previously bound to `merlin-restart-process` - + `C-c t` previously bound to `merlin-type-expr` - - removed keybindings on `C-` and `C-` as these already have a - meaning in emacs ( #129 ) - They were bound to `merlin-type-enclosing-go-up` and - `merlin-type-enclosing-go-down` respectively. - - the emacs mode is now compiled (contribution from Jacques-Pascal Deplaix - #158 , with a follow up from Rudy Grinberg #165 ) - - improved efficiency of completion at point - - + extensions: - - added support for variantslib ( #132 ) - - updated fieldslib support ( #169 , #185 ) - - fix pa_lwt translation ( #182 ) - - added support for pa_enumerate ( #187 ) - - + vim: - - the split method for locate can now be configured - -merlin 1.5 -========== -Sat Dec 14 19:45:06 CET 2013 - - + backend: - - better handling of paths (both sources and build) - - split build path into cmi and cmt path. - New directives "CMI" and "CMT" are now available in .merlin files ("B" - still works as previously) - - doesn't get confused anymore when the user switch between buffers (the - state is cleaned) - - + emacs: - - adds ability to enable/disable extensions manually - - adds a command to clear all the errors from a buffer - - displaying of errors can now be disabled - - + extensions - - updated bin_prot for version >= 109.45.00 - - bugfix for [with compare] in presence of parametrized types - - added support for "here" (when activated adds - [val _here_ : Lexing.position]) - - added support for [assert_lwt] - - fixed typing of [while_lwt] - - + vim: - - vim plugin can be installed into a custom directory and has its own - makefile target (contribution from Vsevolod Velichko) - - added "ClearEnclosing" command to remove merlin's overlay after a call to - TypeOf. - -merlin 1.4.1 -============ -Thu Sep 26 21:29:56 BST 2013 - - + documentation: - - updates of the emacs section of the readme by Ronan Lehy. - - + emacs: - - bugfix for ac-mode: merlin-ac-prefix wasn't called. - - better formatting for completion suggestions. - - + vim: - - bugfix for the "selectPhrase" command, an overflow on 32b plateform was - causing complete desynchronisation between vim and merlin. - - better formatting for completion suggestions. - -merlin 1.4.0 -============ -Tue Sep 24 23:02:04 BST 2013 - - + backend: - - lazy processing of open directives makes merlin much faster - - simplified buffer management - - tweak signal handling to improve windows compatibility - - track verbosity of query: repeated queries are considered more "verbose" - - type expansion: expand type aliases for verbose query - - add support for OUnit-like Benchmark extension - - more tolerant type checker, to provide completion on ill-typed - expressions - - proper version reporting with git revision - - refactored logging subsystem - - add support "val constructs" in implementation: report errors but add - definition to current environment - - add FLG, EXT and PRJ in .merlin - - "locate" command now works in much more situations - - one distribution for 4.00 and 4.01, introduced common interface between - both, typers now live in https://github.com/def-lkb/merlin-typers - - new implementation of the main merlin state tracking ast & types - - better error reporting thanks to a contribution from Ronan Lehy - - + documentation: - - started a wiki (https://github.com/def-lkb/merlin/wiki) - - wrote 'from-scratch' guides to ease setting-up merlin in your editor - - + emacs - - during completion with auto-complete, you can hit C-c C-l on a candidate - to jump on its definition - - made communication with merlin asynchronous (using transfer queues) hence - improving responsiveness - - when running a merlin command, the errors present in all phrases but the - current one are displayed - - fixed buffer cleaning - - successive call to C-c C-t do not climb the typed tree but improve merlin's - verbosity. To move inside the tree use C-down and C-up (which implements - phrase movement if there is no enclosing started). - - customize data for merlin - - refactoring and numerous bugfixes - - -merlin 1.3.1 -============ - - - Minor release, but merlin is now compatible with ocaml versions > 4.00.1. - The only noticeable changes since 1.3 is the use of short paths even with - version 4.00.1 of ocaml. - -merlin 1.3 -========== - - + backend: - - added a "locate" command to find the definition location of the given - identifier - works on the local buffer out of the box and at project level if it the - build directories contain cmt files - - + emacs: - - various bugfixes - - aesthetic changes for highlighting - - introduced "semantic movements": - add commands (and keybindings) to go to the next/previous phrase - - support for completion in emacs 23 - - reporting of syntax errors - - removed "idle-typing" feature - - asynchronous fetching of types so that long signatures - won't make emacs hang - - + extensions: - - add support for "type nonrec" declaration - - add support for "with compare" from type-conv - - add partial support for "with fields" from type-conv - - + misc: - - added specific support for omake's polling mode - - + vim: - - ':TypeOf' command now accepts an (optional) argument and tries to type it - in the current context (i.e. at cursor position) - - better catching of errors - -merlin 1.2 -========== - - + emacs: - - add ML, MLI and merlin-goto-project-file commands - - prints the type of completed entry on completion - - various bugfixes - - + extensions: - - merged support for ignoring P4_QUOTATION - - merged support for js_of_ocaml syntax - - support top-level lwt binding - - merged support for oUnit - - + misc: - - introduced 'REC' flag in .merlin: - tells merlin to concatenate the current .merlin with the ones present in - parents directories - - added specific support for omake's polling mode. - - + vim: - - bugfix for omnicompletion on versions <= 703 - -merlin 1.1 -========== - - + emacs: - - Ported the completion to the usual `completion-at-point' system, disabled - auto-complete-mode-by-default - - reset now tells merlin about the current buffer name - - merlin-mode comes with a menu - - improved documentation of the mode - - + backend: - - code cleanup - - method completion - - + vim plugin: refactored synchronization code out - -merlin 1.0 -========== -First release diff --git a/ocaml-lsp-server/vendor/merlin/LICENSE b/ocaml-lsp-server/vendor/merlin/LICENSE deleted file mode 100644 index c334d320c..000000000 --- a/ocaml-lsp-server/vendor/merlin/LICENSE +++ /dev/null @@ -1,19 +0,0 @@ -Copyright (C) 2013 Frédéric Bour, Thomas Refis and Simon Castellan. - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/ocaml-lsp-server/vendor/merlin/Makefile b/ocaml-lsp-server/vendor/merlin/Makefile deleted file mode 100644 index fbec14008..000000000 --- a/ocaml-lsp-server/vendor/merlin/Makefile +++ /dev/null @@ -1,21 +0,0 @@ -all: build ocamlmerlin ocamlmerlin-server dot-merlin-reader - -build: - dune build --always-show-command-line - -ocamlmerlin ocamlmerlin-server dot-merlin-reader: - ln -s _build/install/default/bin/$@ ./$@ - -clean: - dune clean - -test: build - dune runtest - -preprocess: - dune build --always-show-command-line @preprocess - -promote: - dune promote - -.PHONY: all build dev clean test promote diff --git a/ocaml-lsp-server/vendor/merlin/README.md b/ocaml-lsp-server/vendor/merlin/README.md deleted file mode 100644 index 16b5140f3..000000000 --- a/ocaml-lsp-server/vendor/merlin/README.md +++ /dev/null @@ -1,339 +0,0 @@ -![merlin completion in vim](https://github.com/ocaml/merlin/wiki/vim_complete.png) - -[Merlin](https://ocaml.github.io/merlin/) is an editor service that provides modern IDE features for OCaml. - -Emacs and Vim support is provided out-of-the-box. To get editor support with Merlin in -other editors, see [this](#other-editors). - -Easy installation with Opam -=========================== - -If you have a working [Opam](https://opam.ocaml.org/) installation, install Merlin running the following two commands in terminal: - -```shell -opam install merlin -opam user-setup install -``` - -[opam-user-setup](https://github.com/OCamlPro/opam-user-setup) takes care of configuring Emacs and Vim to make best use of your current install. You can also [configure the editor](#editor-setup) yourself, if you prefer. - -Manually building and installing Merlin -======================================= - -Since version 4.0, merlin's repository has a dedicated branch per version of -OCaml, and the branch name consist of the concatenation of OCaml major version -and minor version. So, for instance, `OCaml 4.11.*` maps to branch `411`. -The main branch is usually synchronized with the branch compatible with the -latest (almost-)released version of OCaml. - -Note: if you're using an older version of OCaml (between 4.02 and 4.10) you will -want to build the 3.4 branch, although it won't contain the most recent -features. - -Compilation ------------ - -Dependencies: ocamlfind, yojson >= 2.0.0, dune >= 2.7. - -```shell -dune build -p dot-merlin-reader,merlin -``` - -Note: if you want to work on merlin, you'll want to avoid the `-p merlin`, to -build in dev mode, with some extra warnings enabled. In that case you'll also -need an extra dependency: menhir. - -Installation ------------- - -If you haven't encountered any errors in the previous step, just run: - -```shell -dune install -p dot-merlin-reader,merlin -``` - -You can pass an explicit prefix to dune, using `--prefix`. It defaults to -your current opam switch. - -Editor setup -============ - -To set up Emacs and Vim, you need to instruct them to run the appropriate script when an OCaml file is opened. - -In the rest of the document, \ refers to the directory where Merlin data files are installed. - -It will usually be: - -- printed by the command `opam var share`, if you used opam -- "\/share" if you explicitly specified a prefix when configuring Merlin - -### Vim setup - -Makes sure that ocamlmerlin binary can be found in PATH. - -The only setup needed is to have the following directory in vim runtime path (append this to your .vimrc): - - :set rtp+=/merlin/vim - -The default configuration can be seen in: - - /merlin/vim/plugin/merlin.vim - -After adding merlin to vim runtime path, you will probably want to run `:helptags /merlin/vim/doc` to register Merlin documentation inside vim. - -A more comprehensive documentation can be found on the [vim-from-scratch wiki](https://github.com/ocaml/merlin/wiki/vim-from-scratch). - -### Emacs setup - -#### Manual setup - -Merlin comes with an emacs library (file: emacs/merlin.el) that implements a minor-mode that is supposed to be used on top of tuareg-mode. - -All you need to do is add the following to your .emacs: - -```emacs -(push "/emacs/site-lisp" load-path) ; directory containing merlin.el -(setq merlin-command "/ocamlmerlin") ; needed only if ocamlmerlin not already in your PATH -(autoload 'merlin-mode "merlin" "Merlin mode" t) -(add-hook 'tuareg-mode-hook #'merlin-mode) -(add-hook 'caml-mode-hook #'merlin-mode) -;; Uncomment these lines if you want to enable integration with the corresponding packages -;; (require 'merlin-iedit) ; iedit.el editing of occurrences -;; (require 'merlin-company) ; company.el completion -;; (require 'merlin-ac) ; auto-complete.el completion -``` - -A more comprehensive documentation can be found on the [emacs-from-scratch wiki](https://github.com/ocaml/merlin/wiki/emacs-from-scratch). - -#### Setup via package.el - -An installable core `merlin` package is available via -[MELPA](https://melpa.org), along with further small integration -packages `merlin-company`, `merlin-iedit` and `merlin-ac` which users -can install according to their needs. - -Having installed the required packages, the following code in your -emacs startup file is sufficient: - -```el -(setq merlin-command "/ocamlmerlin") ; needed only if ocamlmerlin not already in your PATH -(add-hook 'tuareg-mode-hook #'merlin-mode) -(add-hook 'caml-mode-hook #'merlin-mode) -;; Uncomment these lines if you want to enable integration with the corresponding packages -;; (require 'merlin-iedit) ; iedit.el editing of occurrences -;; (require 'merlin-company) ; company.el completion -;; (require 'merlin-ac) ; auto-complete.el completion -``` - -### Other editors - -Merlin only supports Vim and Emacs out-of-the-box. This section describes shortly how to get -merlin-based editor support in other editors. - -#### Visual Studio Code - -OCaml has official support for Visual Studio Code through an extension called `OCaml Platform` available in the [Visual Studio Marketplace](https://marketplace.visualstudio.com/items?itemName=ocamllabs.ocaml-platform). Project source is available [here](https://github.com/ocamllabs/vscode-ocaml-platform). -*Note* that it requires [OCaml-LSP](https://github.com/ocaml/ocaml-lsp), an official -[Language Server Protocol(LSP)](https://microsoft.github.io/language-server-protocol/specifications/specification-current/) -implementation for OCaml based on merlin. It can be installed by running `opam install ocaml-lsp-server`. - -#### Editors without official support - -Consider using [OCaml-LSP](https://github.com/ocaml/ocaml-lsp) along with your editor's -plugin for LSP if there is one. - -The wiki also contains pages for: - -- [Acme](https://github.com/ocaml/merlin/wiki/acme-from-scratch) -- [Atom](https://github.com/ocaml/merlin/wiki/atom-from-scratch) -- [Spacemacs](https://github.com/ocaml/merlin/wiki/spacemacs-from-scratch) - -External contributors have implemented modes for more editors: - -- [ocaml-merlin package for Atom](https://atom.io/packages/ocaml-merlin) -- [nuclide for Atom](https://nuclide.io/) includes Merlin support -- [Sublime Text 3](https://github.com/cynddl/sublime-text-merlin) - - -Merlin as a library -=================== - -Merlin can also be used as a library. Some projects already rely on this: - -- [OCaml LSP](https://github.com/ocaml/ocaml-lsp) - The official OCaml's Language Server Protocol implementation - -If you're building editor tools, you might also want to use Merlin as a library! - -Note, however, that Merlin's public API is not stable and we don't guarantee backward-compatibility between releases. -If you're a Merlin user and depend on our public API, we recommend that you contact us or open an issue. - -Next steps -========== - -To use Merlin with a multi-file project, it is necessary to have a [.merlin](https://github.com/ocaml/merlin/wiki/project-configuration) file -unless your project is built using dune. -Note that, in a project using Dune, user-created `.merlin` files will take precedence over the configuration provided by Dune to Merlin. - -Read more in the [wiki](https://github.com/ocaml/merlin/wiki) to learn how to make full use of Merlin in your projects. - -Development of Merlin -===================== - -Most of the development happens through the [github page](https://github.com/ocaml/merlin). - -The [mailing list](https://lists.forge.ocamlcore.org/cgi-bin/listinfo/merlin-discuss) welcomes general questions and discussions. - -Merlin Labels -------------- - -[Area/Emacs](https://github.com/ocaml/merlin/labels/Area%2FEmacs): Related to Emacs - -[Area/Vim](https://github.com/ocaml/merlin/labels/Area%2FVim): Related to Vim - -[Kind/Bug](https://github.com/ocaml/merlin/labels/Kind%2FBug): This issue describes a problem - -[Kind/Docs](https://github.com/ocaml/merlin/labels/Kind%2FDocs): This issue describes a documentation change - -[Kind/Feature-Request](https://github.com/ocaml/merlin/labels/Kind%2FFeature-request): Solving this issue requires implementing a new feature - -[Kind/To-discuss](https://github.com/ocaml/merlin/labels/Kind%2FTo-discuss): Discussion needed to converge on a solution; often aesthetic. See mailing list for discussion - -[Status/0-More-info-needed](https://github.com/ocaml/merlin/labels/Status%2F0-More-info-needed): More information is needed before this issue can be triaged - -[Status/0-Triage](https://github.com/ocaml/merlin/labels/Status%2F0-Triage): This issue needs triaging - -[Status/1-Acknowledged](https://github.com/ocaml/merlin/labels/Status%2F1-Acknowledged): This issue has been triaged and is being investigated - -[Status/2-Regression](https://github.com/ocaml/merlin/labels/Status%2F2-Regression): Known workaround to be applied and tested - -[Status/3-Fixed-need-test](https://github.com/ocaml/merlin/labels/Status%2F3-Fixed-need-test): This issue has been fixed and needs checking - -[Status/4-Fixed](https://github.com/ocaml/merlin/labels/Status%2F4-Fixed): This issue has been fixed! - -[Status/5-Awaiting-feedback](https://github.com/ocaml/merlin/labels/Status%2F5-Awaiting-feedback): This issue requires feedback on a previous fix - -You can see current areas of development in our [Merlin Project Roadmaps](https://github.com/ocaml/merlin/projects) that we keep up to date. - -Contributing to Merlin ----------------------- - -Merlin needs your help and contributions! - -### Reporting Issues - -When you encounter an issue, please report it with as much detail as possible. A thorough bug report is always appreciated :) - -Check that our issue database doesn't already include that problem/suggestion. You can click "subscribe" on issues to follow their progress and updates. - -When reporting issues, please include: - -- steps to reproduce the problem, if possible with some code triggering the issue, -- version of the tools you are using: operating system, editor, OCaml. - -Try to be as specific as possible: - -- avoid generic phrasing such as "doesn't work", explain *what* is happening (editor is freezing, you got an error message, the answer is not what was expected, ...) -- include the content of error messages if there are any. - -If it seems relevant, also include information about your development environment: - -- the Opam version and switch in use, -- other toolchains involved (OCaml flavors, cygwin, C compiler, shell, ...), -- how the editor was setup. - -### Pull Requests - -Found a bug and know how to fix it? Or have a feature you can implement directly? We appreciate pull requests to improve Merlin, and any significant fix should start life as an issue first. - -### Documentation and wiki - -Help is greatly appreciated, the wiki needs love. - -If the wiki didn't cover a topic and you found out the answer, updating the page or pointing out the issue will be very useful for future users. - -### Discussing with other Merlin users and contributors - -Together with commenting on issues with direct feedback and relevant information, we use the [mailing list](https://lists.forge.ocamlcore.org/cgi-bin/listinfo/merlin-discuss) to discuss ideas and current designs/implementations. User input helps us to converge on solutions, especially those for aesthetic and user-oriented topics. - -List of Contributors --------------------- - -We would like to thank all people who contributed to Merlin. - -Main collaborators: -* [Frédéric Bour](https://github.com/let-def), main developer -* [Thomas Refis](https://github.com/trefis), main developer -* [Gemma Gordon](https://github.com/GemmaG), project manager -* [Simon Castellan](https://github.com/asmanur), contributed the initial Emacs mode - -Contributors: -* [Andrew Noyes](https://github.com/atn34) -* [Andrey Popp](https://github.com/andreypopp) -* [Anil Madhavapeddy](https://github.com/avsm) -* [Anton Bachin](https://github.com/aantron) -* [Armaël Guéneau](https://github.com/Armael) -* [Arthur Wendling](https://github.com/art-w) -* [Benjamin San Souci](https://github.com/bsansouci) -* [Bernhard Schommer](https://github.com/bschommer) -* [Bobby Priambodo](https://github.com/bobbypriambodo) -* [Bryan Phelps](https://github.com/bryphe) -* [Chris Konstad](https://github.com/chriskonstad) -* [Christopher Reichert](https://github.com/creichert) -* [Christophe Troestler](https://github.com/Chris00) -* [David Allsopp](https://github.com/dra27) -* [Fabian Hemmer](https://github.com/copy) -* [Fourchaux](https://github.com/Fourchaux) -* [Gabriel Scherer](https://github.com/gasche) -* [Geoff Gole](https://github.com/gsg) -* [Gerd Stolpmann](https://github.com/gerdstolpmann) -* [Gregory Nisbet](https://github.com/gregory-nisbet) -* [Jacob Bass](https://github.com/bassjacob) -* [Jacques-Pascal Deplaix](https://github.com/jpdeplaix) -* [Jah Rehders](https://github.com/sheijk) -* [Jason Staten](https://github.com/statianzo) -* [Jochen Bartl](https://github.com/verbosemode) -* [Jordan Walke](https://github.com/jordwalke) -* [Keigo Imai](https://github.com/keigoi) -* [Leandro Ostera](https://github.com/ostera) -* [Leo White](https://github.com/lpw25]) -* [Madroach](https://github.com/madroach) -* [Malcolm Matalka](https://github.com/orbitz) -* [Marc Weber](https://github.com/MarcWeber) -* [Mario Rodas](https://github.com/marsam) -* [Markus Mottl](https://github.com/mmottl) -* [Milo Davis](https://github.com/MiloDavis) -* [Nick Borden](https://github.com/hcwndbyw) -* [Nicolás Ojeda Bar](https://github.com/nojb) -* [Olivier Andrieu](https://github.com/oandrieu) -* [Philipp Haselwarter](https://github.com/haselwarter) -* [Pierre Chambart](https://github.com/chambart) -* [Raman Varabets](https://github.com/cyberhuman) -* [Raphaël Proust](https://github.com/raphael-proust) -* [Ronan Le Hy](https://github.com/lehy-probayes) [(2)](https://github.com/lehy) -* [Rudi Grinberg](https://github.com/rgrinberg) -* [Steve Purcell](https://github.com/purcell) -* [Syohei Yoshida](https://github.com/syohex) -* ["tddsg"](https://github.com/tddsg) -* [Tomasz Kołodziejski](https://github.com/neojski) -* [Velichko Vsevolod](https://github.com/torkve) -* [Vincent / Twinside](https://github.com/Twinside) -* [Xavier Guérin](https://github.com/xguerin) -* [Ximin Luo](https://github.com/infinity0) -* [Yotam Barnoy](https://github.com/bluddy) - -### Sponsoring and donations - -We would like to thank [Jane Street](https://www.janestreet.com) for sponsoring and [OCaml Labs](https://github.com/ocamllabs) for providing support and management. - -And many thanks to our [Bountysource](https://www.bountysource.com/teams/the-lambda-church/backers) backers. - -### Other acknowledgements - -Distribution and configuration: -* [Louis Gesbert](https://github.com/AltGr), [opam-user-setup](https://github.com/OCamlPro/opam-user-setup), out-of-the-box setup for Vim and Emacs -* [Edgar Aroutinian](https://github.com/fxfactorial), [ocaml-starterkit](https://github.com/fxfactorial/ocaml-starterkit), collection of tools for beginners in OCaml - -Support for other editors: -* [Luc Rocher](https://github.com/cynddl), [Sublime Text 3](https://github.com/cynddl/sublime-text-merlin) -* [Pieter Goetschalckx](https://github.com/314eter), [ocaml-merlin package for Atom](https://atom.io/packages/ocaml-merlin) -* various contributors, [nuclide package for Atom](https://nuclide.io/) diff --git a/ocaml-lsp-server/vendor/merlin/appveyor.cmd b/ocaml-lsp-server/vendor/merlin/appveyor.cmd deleted file mode 100644 index 70dfb9d40..000000000 --- a/ocaml-lsp-server/vendor/merlin/appveyor.cmd +++ /dev/null @@ -1,37 +0,0 @@ -@setlocal -@echo off - -set Path=C:\cygwin\bin;%Path% -set OCAML_PREV_PATH=%PATH% -set OCAML_PREV_LIB=%LIB% -set OCAML_PREV_INCLUDE=%INCLUDE% - -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare mingw" -if errorlevel 1 exit /b 1 -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare mingw64" -if errorlevel 1 exit /b 1 -call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86 /release -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare msvc" -if errorlevel 1 exit /b 1 -set PATH=%OCAML_PREV_PATH% -set LIB=%OCAML_PREV_LIB% -set INCLUDE=%OCAML_PREV_INCLUDE% -call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x64 /release -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh prepare msvc64" -if errorlevel 1 exit /b 1 -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh matrix" -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build msvc64" -if errorlevel 1 exit /b 1 -set PATH=%OCAML_PREV_PATH% -set LIB=%OCAML_PREV_LIB% -set INCLUDE=%OCAML_PREV_INCLUDE% -call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86 /release -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build msvc" -if errorlevel 1 exit /b 1 -set PATH=%OCAML_PREV_PATH% -set LIB=%OCAML_PREV_LIB% -set INCLUDE=%OCAML_PREV_INCLUDE% -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build mingw" -if errorlevel 1 exit /b 1 -bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor.sh build mingw64" -if errorlevel 1 exit /b 1 diff --git a/ocaml-lsp-server/vendor/merlin/appveyor.sh b/ocaml-lsp-server/vendor/merlin/appveyor.sh deleted file mode 100644 index efedbf3ca..000000000 --- a/ocaml-lsp-server/vendor/merlin/appveyor.sh +++ /dev/null @@ -1,251 +0,0 @@ -#!/bin/bash - -TERM=st - -MODE=$1 -PORT=$2 - -OCAML_VERSIONS="4.02.3 4.03.0 4.04.2 4.05.0" -# Increment whenever the OCaml version or a package is updated to invalidate the caches -SERIAL=1 -# Set to 0 if the testsuite may fail -TESTSUITE_SOUND=0 - -ROOT=C:/OCaml -ROOT_CYG=$(echo $ROOT| cygpath -f -) -APPVEYOR_BUILD_FOLDER=$(echo $APPVEYOR_BUILD_FOLDER| cygpath -f -) - -ERRORS_ALLOWED=0 -function quietly_log { - if ! script --quiet --return --append --command "$1" $LOG_FILE > /dev/null 2>&1 ; then - cat $LOG_FILE - if ((ERRORS_ALLOWED)) ; then - return 1 - else - exit 1 - fi - fi -} - -function msvs_promote_path { - if [[ ${1%64} = "msvc" ]] ; then - eval $($ROOT_CYG/msvs-promote-path) - fi -} - -case $MODE in - prepare) - BUILT_SOMETHING=0 - for OCAML_VERSION in $OCAML_VERSIONS ; do - OCAML_BRANCH=${OCAML_VERSION%.*} - if ! cat $APPVEYOR_BUILD_FOLDER/appveyor.yml | tr -d '\015' | sed -e '1,/^cache:/d' -e '/^$/,$d' | grep -q "^ \+- \+C:\\\\OCaml\\\\$OCAML_BRANCH$" ; then - echo "$(tput setf 4)ERROR$(tput sgr0) C:\\OCaml\\$OCAML_BRANCH doesn't appear to be cached in appveyor.yml" - exit 1 - fi - - if [[ ! -e $ROOT_CYG/$OCAML_BRANCH/$PORT/bin/ocamlopt.exe || ! -e $ROOT_CYG/$OCAML_BRANCH/version || $(cat $ROOT_CYG/$OCAML_BRANCH/version) != "$OCAML_VERSION-$SERIAL" ]] ; then - if [[ -e $ROOT_CYG/$OCAML_BRANCH/version && $(cat $ROOT_CYG/$OCAML_BRANCH/version) != "$OCAML_VERSION-$SERIAL" ]] ; then - echo "Build cache for $OCAML_BRANCH has serial $(cat $ROOT_CYG/$OCAML_BRANCH/version); should be $OCAML_VERSION-$SERIAL -- clearing" - rm -rf $ROOT_CYG/$OCAML_BRANCH - elif [[ ! -e $ROOT_CYG/$OCAML_BRANCH/version ]] ; then - rm -rf $ROOT_CYG/$OCAML_BRANCH - fi - - if ((BUILT_SOMETHING)) ; then - if [[ $PORT = "mingw" ]] ; then - appveyor AddMessage "OCaml $OCAML_VERSION needs to be built, but this run has already built a compiler set." -Detail "Assuming the build completes successfully, use the Re-build Commit option" -Category Warning - fi - else - PREFIX=$ROOT_CYG/$OCAML_BRANCH/$PORT - ROOT=$ROOT/$OCAML_BRANCH/$PORT - OCAML_BRANCH=${OCAML_BRANCH/.} - - if [[ ! -d $APPVEYOR_BUILD_FOLDER/../src ]] ; then - mkdir -p $APPVEYOR_BUILD_FOLDER/../src - cd $APPVEYOR_BUILD_FOLDER/../src - git clone https://github.com/ocaml/ocaml.git - cd ocaml - mkdir -p $PREFIX - cp tools/msvs-promote-path $ROOT_CYG/ - cd .. - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.35.zip" -FileName flexdll-bin-0.35.zip - appveyor DownloadFile "https://github.com/mjambon/biniou/archive/v1.2.0.tar.gz" -FileName biniou-1.2.0.tar.gz - appveyor DownloadFile "https://github.com/mjambon/cppo/archive/v1.5.0.tar.gz" -FileName cppo-1.5.0.tar.gz - appveyor DownloadFile "https://github.com/mjambon/easy-format/archive/v1.2.0.tar.gz" -FileName easy-format-1.2.0.tar.gz - appveyor DownloadFile "http://download.camlcity.org/download/findlib-1.7.3.tar.gz" -FileName findlib-1.7.3.tar.gz - appveyor DownloadFile "https://github.com/ocaml/dune/releases/download/1.0.1/dune-1.0.1.tbz" -FileName dune-1.0.1.tbz - appveyor DownloadFile "https://github.com/ocaml/ocamlbuild/archive/0.11.0.tar.gz" -FileName ocamlbuild-0.11.0.tar.gz - appveyor DownloadFile "https://github.com/ocaml-community/yojson/archive/v1.6.0.tar.gz" -FileName yojson-1.6.0.tar.gz - cp $APPVEYOR_BUILD_FOLDER/appveyor/*.patch $APPVEYOR_BUILD_FOLDER/../src/ - [[ -e $PREFIX/../version ]] || echo $OCAML_VERSION-$SERIAL> $PREFIX/../version - fi - - export PATH=$PREFIX/bin:$PATH - - cd $APPVEYOR_BUILD_FOLDER/../src/ocaml - git checkout $OCAML_VERSION - git worktree add ../$OCAML_VERSION/$PORT/ocaml -b build-$OCAML_VERSION-$PORT - if [[ $OCAML_BRANCH -ge 403 ]] ; then - pushd ../$OCAML_VERSION/$PORT/ocaml - git submodule update --init - popd - fi - cd ../$OCAML_VERSION/$PORT/ocaml - if [[ $OCAML_BRANCH -ge 406 ]] ; then - cp config/s-nt.h byterun/caml/s.h - cp config/m-nt.h byterun/caml/m.h - else - cp config/s-nt.h config/s.h - cp config/m-nt.h config/m.h - fi - if [[ $OCAML_BRANCH -ge 405 ]] ; then - POST_WORLD=flexlink.opt - else - POST_WORLD= - fi - if [[ $OCAML_BRANCH -lt 403 ]] ; then - mkdir -p $PREFIX/bin - pushd $PREFIX/bin - case $PORT in - msvc) - MANIFEST=default.manifest;; - msvc64) - MANIFEST=default_amd64.manifest;; - *) - MANIFEST=;; - esac - unzip $APPVEYOR_BUILD_FOLDER/../src/flexdll-bin-0.35.zip flexdll_*$PORT.* flexdll.h flexlink.exe $MANIFEST - popd - PRE_WORLD= - else - PRE_WORLD=flexdll - fi - sed -e "s|PREFIX=[^\r]*|PREFIX=$ROOT|" config/Makefile.$PORT > config/Makefile - msvs_promote_path $PORT - cd .. - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/findlib-1.7.3.tar.gz - cd findlib-1.7.3 - # Upstreamed; not merged - patch -p1 -i $APPVEYOR_BUILD_FOLDER/../src/findlib-1.7.3.patch - # Not yet upstreamed - sed -i -e 's/\.a/$(LIB_SUFFIX)/g' src/findlib/Makefile - cd .. - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/dune-1.0.1.tbz - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/easy-format-1.2.0.tar.gz - cd easy-format-1.2.0 - # Upstreaming not required: master has been converted to jbuilder - patch -p1 -i $APPVEYOR_BUILD_FOLDER/../src/easy-format-1.2.0.patch - cd .. - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/biniou-1.2.0.tar.gz - if [[ $OCAML_BRANCH -ge 403 ]] ; then - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/ocamlbuild-0.11.0.tar.gz - cd ocamlbuild-0.11.0 - # Manually apply fix from a8d2e8 - sed -i -e 's/pack\.o/pack$(EXT_OBJ)/g' Makefile - cd .. - fi - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/cppo-1.5.0.tar.gz - tar -xzf $APPVEYOR_BUILD_FOLDER/../src/yojson-1.6.0.tar.gz - cd ocaml - - LOG_FILE=OCaml-$OCAML_VERSION-$PORT.log - echo "Building OCaml $OCAML_VERSION for $PORT" | tee $LOG_FILE - echo "Please see $LOG_FILE for further information" - LOG_FILE="$APPVEYOR_BUILD_FOLDER/$LOG_FILE" - quietly_log "make -f Makefile.nt $PRE_WORLD world.opt $POST_WORLD install" - # Remove unnecessary executables to keep the build cache size down - # These are removed here to ensure findlib doesn't configure itself - # to use .opt commands - if [[ $OCAML_BRANCH -ge 404 ]] ; then - rm $PREFIX/bin/*.byte.exe $PREFIX/bin/*.opt.exe - else - for i in $PREFIX/bin/*.opt.exe ; do - rm ${i%.opt.exe}.exe - mv $i ${i%.opt.exe}.exe - done - fi - cd ../findlib-1.7.3 - quietly_log "./configure && make all opt && make install" - cd ../dune-1.0.1 - quietly_log "ocaml bootstrap.ml && ./boot.exe && cp _build/default/bin/main.exe $PREFIX/bin/dune.exe" - cd ../easy-format-1.2.0 - quietly_log "make && make install" - cd ../biniou-1.2.0 - quietly_log "make && ocamlfind install biniou _build/install/default/lib/biniou/*" - if [[ $OCAML_BRANCH -ge 403 ]] ; then - cd ../ocamlbuild-0.11.0 - quietly_log "make -f configure.make all OCAMLBUILD_PREFIX=$PREFIX OCAMLBUILD_BINDIR=$PREFIX/bin OCAMLBUILD_LIBDIR=$(ocamlfind printconf path) OCAML_NATIVE=true OCAML_NATIVE_TOOLS=false && make all findlib-install" - rm $PREFIX/bin/ocamlbuild.{byte,native}.exe - fi - cd ../cppo-1.5.0 - quietly_log "make PREFIX=$PREFIX opt install-bin" - cd ../yojson-1.6.0 - quietly_log "make && ocamlfind install yojson _build/install/default/lib/yojson/*" - # Remove unnecessary commands to keep the build cache size down - rm $PREFIX/bin/{ocaml,ocamlcp,ocamldebug,ocamldoc,ocamlmktop,ocamlobjinfo,ocamloptp,ocamlprof}.exe $PREFIX/lib/{expunge,extract_crc,objinfo_helper}.exe - # Remove unnecessary files - if [[ $OCAML_BRANCH -lt 405 && $OCAML_BRANCH -gt 402 ]] ; then - rm $PREFIX/*.txt - fi - find $PREFIX -name *.cmt* | xargs rm - find $PREFIX -name *.ml* | xargs rm - rm -f $PREFIX/lib/compiler-libs/*.cmx* $PREFIX/lib/compiler-libs/*.{lib,a} $PREFIX/lib/compiler-libs/ocamloptcomp.cma - echo "Complete" - appveyor PushArtifact $(echo $LOG_FILE| cygpath -m -f -) - BUILT_SOMETHING=1 - fi - fi - done - ;; - matrix) - for OCAML_VERSION in $OCAML_VERSIONS ; do - OCAML_BRANCH=${OCAML_VERSION%.*} - for PORT in mingw mingw64 msvc msvc64 ; do - if [[ -e $ROOT_CYG/$OCAML_BRANCH/$PORT/bin/ocamlopt.exe ]] ; then - OUTCOME=None - else - OUTCOME=NotRunnable - fi - appveyor AddTest "OCaml $OCAML_VERSION ($PORT)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Outcome $OUTCOME - done - done - ;; - build) - msvs_promote_path $PORT - ORIG_PATH=$PATH - for OCAML_VERSION in $OCAML_VERSIONS ; do - OCAML_BRANCH=${OCAML_VERSION%.*} - if [[ -e $ROOT_CYG/$OCAML_BRANCH/$PORT/bin/ocamlopt.exe ]] ; then - echo "Building Merlin $PORT on $OCAML_VERSION" - SECONDS=0 - appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Running -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration 0 - export PATH=$ROOT_CYG/$OCAML_BRANCH/$PORT/bin:$ORIG_PATH - mkdir -p $APPVEYOR_BUILD_FOLDER/../merlin-$OCAML_VERSION - cp -a $APPVEYOR_BUILD_FOLDER $APPVEYOR_BUILD_FOLDER/../merlin-$OCAML_VERSION/$PORT - cd $APPVEYOR_BUILD_FOLDER/../merlin-$OCAML_VERSION/$PORT - LOG_FILE=$APPVEYOR_BUILD_FOLDER/build-$OCAML_VERSION-$PORT.log - rm -f $LOG_FILE - ERRORS_ALLOWED=1 - if quietly_log "./configure --prefix $ROOT_CYG/$OCAML_BRANCH/$PORT && make" ; then - appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Running -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000)) - if quietly_log "make test" ; then - # Full pass - appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Passed -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000)) - elif ((!TESTSUITE_SOUND)) ; then - # Permitted fail - appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Passed -StdOut "$(tail -10 $LOG_FILE)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000)) - else - # Failure - appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Failed -StdOut "$(tail -10 $LOG_FILE)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000)) - fi - else - # Build failure - appveyor UpdateTest "OCaml $OCAML_VERSION ($PORT)" -Outcome Failed -StdOut "$(tail -10 $LOG_FILE)" -Framework "OCaml $OCAML_VERSION" -Filename "ocamlmerlin-test.exe" -Duration $((SECONDS * 1000)) - fi - appveyor PushArtifact $(echo $LOG_FILE| cygpath -m -f -) - else - echo "OCaml $OCAML_VERSION for $PORT does not appear to have been built -- skipping" - fi - done - ;; -esac diff --git a/ocaml-lsp-server/vendor/merlin/appveyor.yml b/ocaml-lsp-server/vendor/merlin/appveyor.yml deleted file mode 100644 index 698e0c81b..000000000 --- a/ocaml-lsp-server/vendor/merlin/appveyor.yml +++ /dev/null @@ -1,26 +0,0 @@ -platform: - - x64 - -clone_depth: 1 - -environment: - global: - CYG_ROOT: C:/cygwin - CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/ - CYG_CACHE: C:/cygwin/var/cache/setup - -cache: -# - C:\cygwin\var\cache\setup - - C:\OCaml\4.02 - - C:\OCaml\4.03 - - C:\OCaml\4.04 - - C:\OCaml\4.05 - - C:\OCaml\msvs-promote-path - -install: - - '%CYG_ROOT%\bin\bash -lc "date; cygcheck -dc cygwin"' - - '"%CYG_ROOT%\setup-x86.exe" --quiet-mode --no-shortcuts --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --packages diffutils,patch,make,mingw64-i686-gcc-core,mingw64-x86_64-gcc-core,unzip > NUL' - - '%CYG_ROOT%\bin\bash -lc "date; cygcheck -dc cygwin"' - -build_script: - - call "%APPVEYOR_BUILD_FOLDER%\appveyor.cmd" diff --git a/ocaml-lsp-server/vendor/merlin/appveyor/easy-format-1.2.0.patch b/ocaml-lsp-server/vendor/merlin/appveyor/easy-format-1.2.0.patch deleted file mode 100644 index cb0ace3c2..000000000 --- a/ocaml-lsp-server/vendor/merlin/appveyor/easy-format-1.2.0.patch +++ /dev/null @@ -1,29 +0,0 @@ -diff -Naur a/Makefile b/Makefile ---- a/Makefile 2015-12-07 21:58:29.000000000 +0000 -+++ b/Makefile 2017-07-21 14:19:28.720009800 +0100 -@@ -3,6 +3,7 @@ - - NATDYNLINK := $(shell if [ -f `ocamlfind ocamlc -where`/dynlink.cmxa ]; \ - then echo YES; else echo NO; fi) -+EXT_OBJ = $(shell ocamlc -config | sed -ne "s/ext_obj: //p" | tr -d '\r') - - ifeq "${NATDYNLINK}" "YES" - CMXS=easy_format.cmxs -@@ -53,7 +54,7 @@ - caml2html easy_format_example.ml -t -o easy_format_example.html - - soft-clean: -- rm -f *.cm[iox] *.cmxs *.o *.annot \ -+ rm -f *.cm[iox] *.cmxs *.o *.obj *.annot \ - test_easy_format lambda_example simple_example \ - bytecode nativecode - -@@ -65,7 +66,7 @@ - - COMMON_INSTALL_FILES = META easy_format.cmi easy_format.mli - BC_INSTALL_FILES = easy_format.cmo --NC_INSTALL_FILES = easy_format.cmx easy_format.o $(CMXS) -+NC_INSTALL_FILES = easy_format.cmx easy_format$(EXT_OBJ) $(CMXS) - - install: - echo "version = \"$(VERSION)\"" > META; cat META.tpl >> META diff --git a/ocaml-lsp-server/vendor/merlin/appveyor/findlib-1.7.3.patch b/ocaml-lsp-server/vendor/merlin/appveyor/findlib-1.7.3.patch deleted file mode 100644 index 84954d68f..000000000 --- a/ocaml-lsp-server/vendor/merlin/appveyor/findlib-1.7.3.patch +++ /dev/null @@ -1,22 +0,0 @@ -diff --git a/configure b/configure -index 34c5115..e801760 100755 ---- a/configure -+++ b/configure -@@ -191,7 +191,7 @@ for tool in sed awk ocaml ocamlc uname rm make cat m4 dirname basename; do - fi - done - --lib_suffix=`ocamlc -config 2>/dev/null|grep '^ext_lib'|sed 's/ext_lib: //'` -+lib_suffix=`ocamlc -config 2>/dev/null|tr -d '\015'|sed -n -e 's/^ext_lib: //p'` - - # Check for Cygwin: - -@@ -225,7 +225,7 @@ use_cygpath=0 - # Whether we have to translate Unix paths to/from Windows paths. - - if [ -z "$system" ]; then -- system=`ocamlc -config 2>/dev/null|grep '^system'|sed 's/system: //'` -+ system=`ocamlc -config 2>/dev/null|tr -d '\015'|sed -n -e 's/^system: //p'` - # This may be - # - mingw or mingw64 - # - win32 diff --git a/ocaml-lsp-server/vendor/merlin/doc/dev/ARCHITECTURE.md b/ocaml-lsp-server/vendor/merlin/doc/dev/ARCHITECTURE.md deleted file mode 100644 index 4c14f4122..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/dev/ARCHITECTURE.md +++ /dev/null @@ -1,200 +0,0 @@ -Architecture ------------- - -### src/frontend - -`ocamlmerlin.c` implements the `ocamlmerlin` wrapper that takes care of -spawning a server if necessary and passing queries. See [SERVER.md](SERVER.md). - -`ocamlmerlin_server.ml` is the entry point of `ocamlmerlin-server` binary. It -reads argument from the command-line and decides which mode to start -(old-protocol, single query or query server). - -`query_protocol.mli` defines the type of all queries and their results. - -`query_json.ml` implements conversion of results to a JSON-like type. Yojson or -Sexp can be used for turning these into strings. - -`query_commands.ml` executes the queries defined by the protocol. It uses -`src/kernel` for parse and typing. Then it uses `src/analysis` to get some -results. - -`new/` implements a UNIX-like frontend: parametrized by arguments, reading -content from stdin, outputting answer to stdout and logging to stderr. -Command-line is turned into a `Query_protocol.t` query and executed with -`Query_commands`. - -`old/` does the same job but for the previous, synchronous, version of the -protocol (see [OLD-PROTOCOL.ml](OLD-PROTOCOL.md)). - -`test/ocamlmerlin_test.ml` implements the `ocamlmerlin-test` binary that runs a -testsuite of queries. - -Summary: -* manage communication with outside world -* get a query from the user by some mean, turn it into a `Query_protocol.t` -* execute the query with `Query_commands` -* return the result by some mean - -### src/kernel - -Kernel wraps the OCaml frontend into an incremental and error-resilient -library. - -`mconfig.ml` defines a big record that contains all settings affecting Merlin -behavior, as well as a setting parser and dumper. - -`mconfig_dot.ml` is used by `Mconfig` to process `.merlin` files - -`mocaml.ml` interfaces with the OCaml typechecker. It setup and restore state -when entering/exiting the typechecker. - -`mpipeline.ml` implements a few high-level primitives that connect all pieces -together - -`mppx.ml`: implements ppx rewriting, directed by an `Mconfig.t` - -`msource.ml`: represents is the representation of a source file in Merlin. It -also computes the positions of contents in the source file. - -`mreader.ml`: abstracts the parser of Merlin. It turns an `Msource.t` into an -AST. `mreader_*` implement a parser for normal OCaml files. - -`mreader_extent.ml`: a parser that delegates the work to (compatible) external -commands. Mainly used by Reason. See `src/extend/`. - -`mreader_lexer.ml`, `mreader_parser.ml`, `mreader_recover.ml`, -`mreader_explain.ml`: a parser for standard OCaml files. Main addition is -recovery from syntax errors. - -`mbrowse.ml`: uniform navigation in typedtree, mainly answering "what is around -this position?" - -`mtyper.ml`: wraps the OCaml typechecker, to type the ASTs produced by -`mreader.ml` - -`extension.ml`: defines some OCaml dialects (lwt camlp4 and meta-ocaml) - -Summary: -* isolate state of OCaml typechecker -* maintain multiple parsing and typing contexts in parallel -* robust to syntax and type errors - -### src/analysis - -Analysis offers different tools to work with the result of typechecking -(produced by the kernel). -These are independent of an OCaml version. A typechecker comes with modules to -abstract the differences. - -`browse_misc.ml`: tools too small to deserve their own module (tail calls -annotations, printing ...) - -`browse_tree.ml`: uniform traversal of typedtree, wrapping `Browse_raw` - -`ocamldoc.ml`: get documentation associated to a definition - -`typedtrie.ml`: a trie representation of a compilation unit, allowing quick lookup of OCaml paths - -`type_utils.ml`: light wrapper over some functions of OCaml typer - -`completion.ml`: generate list of completions - -`expansion.ml`: like completion, but generate fuzzy/spell corrected suggestions rather than type-directed - -`destruct.ml`: expand incomplete or coarse-grained patterns into more cases - -`outline.ml`: produce an overview of an OCaml module's structure and definitions - -`locate.ml`: implement a jump-to-definition/declaration feature - -`jump.ml`: implement convenient navigation commands - -### src/ocaml/support - -Definitions useful to all versions of the typechecker. - -`clflags.ml`: compiler flags, unified between all versions - -`tbl.ml`, `identifiable.ml`: needed by all OCaml typecheckers - -`cmi_cache.ml`, `cmt_cache.ml`: cache for \*.cmi and \*.cmt files - -`fake.ml`: generate fake pieces of AST that implement the semantics of -extensions from `src/kernel/extensions.ml` - -`msupport.ml`: bridge between extensions to OCaml typecheker and Merlin kernel. -Mainly for warning and location management, capture of type errors and -annotation of erroneous AST nodes - -`location_aux.ml`: small functions missing from location.ml (management of -character ranges) - -`path_aux.ml`: small functions missing from path.ml (management of qualified -identifiers) - -`preprocess/lexer_ident.mll`: a subset of the OCaml lexer to find identifiers -in the middle of arbitrary text. - -### src/ocaml/typer (\_402, \_403, \_404) - -Wraps a version of the OCaml typechecker for Merlin. -src/ocaml is a symlink to a concrete version selected at configure-time. - -`typing/`, `parsing/`: typechecker from upstream OCaml, with merlin-specific patches - -`browse_raw.ml`: fold over Typedtree in a uniform way - -`parser_raw.ml`, `parser_recover.ml`, `parser_explain.ml`, `parser_recover.ml`: -an OCaml parser with extra information for recovery, produced by menhir and -with custom preprocessors (see `preprocessors/`) - -`preprocess/lexer_raw.mll`: OCaml lexer, to be processed by `ocamllex` - -`printf_compat.ml`: fix a too restrictive signature of OCaml 4.02, empty in -later versions - -`raw_compat.ml`: compatibility layer to process typechecker output, masking differences between versions - -`typer_raw.ml`: wrapper to invoke the typechecker, masking differences between versions - -`tail_analysis.ml`: low-level functions for determining tail-call positions - -`tast_helper.ml`: a few functions for manually producing pieces of typed AST - -### src/platform - -Modules and stub to deal with platform specific features. - -`fs_case.c`: primitive to handle case insensitivity of macOS - -`os_ipc_stub.c`, `os_ipc.ml`: implements UNIX Domain Socket IPC for -`ocamlmerlin-server` - -### src/sturgeon (\_null, \_stub) - -Abstraction of [sturgeon](https://github.com/let-def/sturgeon) UI. - -### src/utils - -Miscellaneous types and functions. - -`file_cache.ml`: generic caching infrastructure - -`local_store.ml`: snapshot and restore mutable state - -`logger.ml`: generic logging functions - -`marg.ml`: generic commandline-like argument parsing (merlin gets arguments -from different places) - -`misc.ml`, `std.ml`: standard library complements - -`menhirLib.ml`: patched menhir interpreter - -`ppxsetup.ml`: keep track of ppx preprocessors with their flags - -`sexp.ml`: a s-expression reader/writer - -`trace.ml`: log information structured as a trace (with enter and exit of -sub-routines) diff --git a/ocaml-lsp-server/vendor/merlin/doc/dev/CACHING.md b/ocaml-lsp-server/vendor/merlin/doc/dev/CACHING.md deleted file mode 100644 index 4f237121e..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/dev/CACHING.md +++ /dev/null @@ -1,92 +0,0 @@ -# File\_id - -The basic abstraction to check if a file has changed on disk is `File_id.t`. - -These can be computed using `File_id.get`. After that, `File_id.check` returns -true if and only if the contents of the file didn't change: -- file was missing and is still missing, -- contents of the file changed. - -## Caching file identities - -Since the state of the disk is not supposed during the execution of a command, -the results of `File_id.get` can be cached in some scope. - -Using `File_id.with_cache (fun () -> )`, the results of calls to -`File_id.get` will be memoized during the execution of ``. - -# Caching file contents, the `File_cache` functor - -The `File_cache` functor caches the contents of a computation based on a -filename for as long as the file don't change (as determined by `File_id`). - -For instance `Cmi_format.read` loads a cmi file from the disk. The OCaml -compiler calls it directly as a cmi is not supposed to change while the -compiler is working. - -Merlin will live for a long time and should reload files that have changed on -disk. At the same time, not reloading files that haven't changed provide a -significant speed up. - -`File_cache.Make(Cmi_format)` gives just that. - -- for .cmi, there is `Cmi_cache = File_cache.Make(Cmi_format)` -- for .cmt, there is `Cmt_cache = File_cache.Make(Cmt_format)` -- for .merlin, there is `Mconfig_dot.Cache` -- existence of files (see below), there is `Misc.Exists_in_directory` - -# File existence - -To discover files on disk, Merlin follow OCaml approach of checking the load -path in order for file existence. - -Doing this results in the lookup phase being quadratic: with n modules and m -paths, there can be up to n * m calls to stat/file\_exists. - -In normal cases, a call to stat is cheap and this is insignificant. However, -under some cicumstances this degenerates: -- in some configurations (selinux?) we observed stat being up to two magnitude - orders more expensive (the same applies to NFS and other networked, although - supporting this situation is not of prime importance) -- big projects with a naive .merlin tend to have a huge load path (hundreds of - entries, in part because of .merlin lack of expressivity). - -To speed up computations, determination of file existence is split in two steps: -- first the `File_id` of the directory in which the file is stored is computed -- the existence of the file is cached based on the id of the directory. - -While in the worst case this doesn't bring back a linear behavior, as most -directories don't change this is fast enough in practice (the quadratic part -happens all in memory). - -The important parts: -- existence of a file depends on the id of its parent directory (because adding - or removing a file affect the contents of the directory) -- contents of a file depends on the id of the file itself. - -# Refreshing cache - -A new function `Env.check_state_consistency` compares all global modules loaded -in the environment to the version on disk. If it returns false, the `Env.t` -should be discarded and recomputed from zero. - -# Cache flush policy - -As time passes, the cache grows. Some files are kept in memory but aren't going -to be used anymore. - -`Mocaml.flush_caches` remove all files that have changed on disk or that -haven't been used for some time. By default, `ocamlmerlin_server` remove -entries that haven't been used in the last 300 seconds. - -Since this involve stating each entry, the check is done after answering. - -The policy is still quite naive, improvements are welcome (IDEA?). - -# Type environment cache - -Since the user is likely to ask many queries on the same environment in a row, -the last 5 environments are cached (`Mtyper.cache`). - -This number might be adjusted... ? Also, entries could be filtered by time of -last use. diff --git a/ocaml-lsp-server/vendor/merlin/doc/dev/OLD-PROTOCOL.md b/ocaml-lsp-server/vendor/merlin/doc/dev/OLD-PROTOCOL.md deleted file mode 100644 index e0c7df573..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/dev/OLD-PROTOCOL.md +++ /dev/null @@ -1,462 +0,0 @@ -This document describes Merlin protocol version 2. - -During a Merlin session, the editor launches an ocamlmerlin process and communicates with it by writing queries on stdin and reading responses on stdout. - -Merlin processes queries synchronously, reading them one by one and writing a response for each query, in the same order. It will wait for more queries until stdin reaches end-of-file. - -The complete set of commands is defined in `src/frontend/protocol.ml`. - -Queries and responses can be serialized in two different formats: -- JSON, defined in `src/frontend/IO.ml`; -- SEXP, defined in `src/frontend/IO_sexp.ml`. - -JSON is the default, SEXP can be selected by passing `-protocol sexp` to Merlin process. - -The rest of the document will describe sample sessions and commands using JSON format. The SEXP format is mechanically derived from JSON, flow is the same. - -# Merlin commands - -Commands can be classified in three categories: -- _synchronization_, to share and update the content of the editor - buffer; -- _query_, to ask Merlin for information (type, completion, documentation); -- _context_, to describe the file being worked on and how it is - related to the environment (dependencies, include paths, ...). - -The basic workflow for an editor is to synchronize then run a query each time Merlin is invoked. - -When working on a project with multiple files, context becomes useful to switch between buffers. - -A simple session (user-commands prefixed by >, Merlin responses by <): - -```javascript -> ["tell","start","end","let f x = x let () = ()"] -< ["return",true] -> ["type","expression","f","at","end"] -< ["return","'a -> 'a"] -``` - - -## Responses - -Responses are always of the form `[kind,payload]` where `payload` depends on the value of `kind`, which can be: - -`"return"` when the command succeeded, `payload` depends on the command being responded to. - -`"failure"` when Merlin was used in an incorrect way (e.g command was malformed or unknown), `payload` is a string describing the failure. Editor mode should be fixed. - -`"error"` when something wrong prevented Merlin from answering: invalid files (for instance wrong OCaml version), missing packages, etc. `payload` is a string describing the error, user should be notified to fix the environment. - -`"exception"` when something unexpected happened. Merlin should be fixed, please report the error. `payload` is an arbitrary json value. - - -## Synchronization - -Merlin maintains a copy of the buffer from your editor. -Synchronization is done by replacing chunks of text from this copy by fresh content. - -### Position - -Most commands need to refer to a position in the buffer. All positions are interpreted on the copy of the buffer, make sure Merlin is synchronized with the editor when you need to share a position. -A position is a JSON value that can be one of : - -```javascript -"start" // first position of the buffer -"end" // last position of the buffer -1234 // An integer is an offset, in bytes, from the beginning of the buffer -{"line":12, "col":34} // Alternatively, you can specify a position as a line (first line is 1) and a column (indexed from 0). -``` - -### Tell - -All telling commands return a cursor state. - -```javascript -["tell",start_pos,end_pos,"source"] -``` - -Replace the content between the two positions by `"source"`. - -The simplest way to synchronize your editor is to use `["tell","start","end","... full content of the buffer"]`. It will update the whole buffer every time. - -### Configuration - -#### Flags - -```javascript -["flags","set",["-rectypes", "-safe-string", ...]] -``` - -Set the flags you would pass to the OCaml compiler. Run `ocamlmerlin -help` to get a list of known flags. - -Returns `{"result":true}` if everything went well or `{"failures":string list, "result":true}` in case of error. - - -```javascript -["flags","get"] -``` - -Returns the `string list` (eg `["-rectypes","-safe-string"]`) that was set by previous invocation of `["flags","set",[...]]`. - -#### Findlib packages - -```javascript -["find","use",["lwt","yojson",...]] -``` - -Load findlib packages in current buffer. -Returns `{"result":true}` if everything went well or `{"failures":string list, "result":true}` in case of error. - - -```javascript -["find","list"] -``` - -Returns a `string list` of all known packages. - -#### Syntax extensions - -```javascript -["extension","enable",["lwt","js",...]] -["extension","disable",["lwt","js",...]] -``` - -Enable or disable syntax extensions in current buffer. - - -```javascript -["extension","list"] -["extension","list","enabled"] -["extension","list","disabled"] -``` - -List all known / currently enabled / currently disabled extensions as a `string list`. - -#### Paths - -```javascript -["path","add","source",[path1, path2, ...]] -["path","add","build",[path1, path2, ...]] -["path","remove","source",[path1, path2, ...]] -["path","remove","build",[path1, path2, ...]] -``` - -Merlin maintains different list of paths to process buffer and queries. -`"source"` is where `.ml` and `.mli` files are searched for, `"build"` is for `.cmi` and `.cmt`. - - -```javascript -["path","list","source"] -["path","list","build"] -``` - -Get current value of path variables as a `string list`. - - -```javascript -["path","reset"] -``` - -Reset path variables to default value (by default just the standard library and the buffer directory). - -### Queries - -#### Type-checking - -```javascript -["type","expression",string,"at",position] -``` - -Returns the type of the expression when typechecked in the environment around the specified position. - - -```javascript -["type","enclosing","at",position] -["type","enclosing",{"expr":string,"offset":int},position] -``` - -Returns a list of type information for all expressions at given position, sorted by increasing size. -That is asking for type enlosing around `2` in `string_of_int 2` will return the types of `2 : int` and `string_of_int 2 : string`. - -The `{"expr":string,"offset":int}` variant expects the string under cursor and the offset of the cursor in this string, to return more specific information. - -The result is returned as a list of: -```javascript -{ - "start": position, - "end": position, - "type": string, - // is this expression not in tail position, in tail position, or even a tail call? - "tail": ("no" | "position" | "call") -} -``` - - -```javascript -["case","analysis","from",position,"to",position] -``` - -Try to destruct patterns in the specified range. -It returns a value with the shape `[{"start": position, "end": position}, content]`. The editor is expected to replace content between `start` and `end` by `content`. - -#### Completion - -```javascript -["complete","prefix",string,"at",position] -["complete","prefix",string,"at",position,"with","doc"] -["expand","prefix",string,"at",position] -``` - -These functions complete an identifier that the user started to type. -They all return a list of possible completion. The "with doc" variant also try to lookup OCamldoc, which is slightly more time consuming. - -The expand function also try to complete partial or incorrect prefixes. For instance, `L.ma` can get expanded to `List.map`. This function is a useful fallback if normal completion gave no results. -Be careful that it always return fully qualified paths, whereas normal completion only completes an identifier (last part of a module path). - -The result has the form: -```javascript -{ - context: (null | ["application",{"argument_type": string, "labels": [{"name":string,"type":string}]}]), - entries: [{"name":string,"kind":string,"desc":string,"info":string}] -} -``` - -Context describe where completion is occurring. Only application is distinguished now: that's when one is completing the arguments to a function call. In this case, one gets the type expected at the cursor as well as the other labels. - -Entries is the list of possible completion. Each entry is made of: -- a name, the text that should be put in the buffer if selected -- a kind, one of `"value"`, `"variant"`, `"constructor"`, `"label"`, `"module"`, `"signature"`, `"type"`, `"method"`, `"#"` (for method calls), `"exn"`, `"class"` -- a description, most of the time a type or a definition line, to be put next to the name in completion box -- optional information which might not fit in the completion box, like signatures for modules or documentation string. - - -```javascript -["document",string,"at",position] -["document",null,"at",position] -``` - -Returns OCamldoc documentation as a string, either for the given qualified identifier or the one under cursor. - -#### Navigation - -```javascript -["occurrences","ident","at",position] -``` - -Returns a list of locations `{"start": position, "end": position}` of all occurrences in current buffer of the entity at the specified position. - - -```javascript -["locate",string,"ml","at",position] -["locate",null,"ml","at",position] -["locate",string,"mli","at",position] -["locate",null,"mli","at",position] -``` - -Finds the declaration of entity at the specified position, or referred to by specified string. -Returns either: -- if location failed, a `string` describing the reason to the user, -- `{"pos": position}` if the location is in the current buffer, -- `{"file": string, "pos": position}` if definition is located in a different file. - - -```javascript -["which","path",string list] -``` - -Returns the full path of the first file with a name listed in the argument. -E.g. `["which","path",["list.ml","list.mli"]]` should return the path of the standard _List_ implementation, unless another _List_ is defined in a user directory. - - -```javascript -["which","with_ext",string list] -``` - -Returns a list of module names for which a file exists in the path with an extension listed in the argument. - -`["which","with_ext",[".ml",".mli"]]` lists all top modules with either a signature or an implementation in current project. -You can then use `["which","path",[module + ".ml", module + ".mli"]]` to open of them (in this case favoring implementations over interfaces). - - -```javascript -["outline"] -``` - -Returns a tree of objects `{"start": position, "end": position, "name": string, "kind": string, "children": subnodes}` describing the content of the buffer. - - -```javascript -["enclosing",position] -``` - -Returns a list of locations `{"start": position, "end": position}` in increasing size of all entities surrounding the position. Like s-exps around position but following OCaml syntax. - -#### Error management - -```javascript -["errors"] -``` - -Returns a list of errors in current buffer. -The value is a list where each item as the shape: - -```javascript -{ - "start" : position, - "end" : position, - "valid" : bool, - "message" : string, - "type" : ("type"|"parser"|"env"|"warning"|"unknown") -} -``` - -`start` and `end` are omitted if error has no location (e.g. wrong file format), otherwise the editor should probably highlight / mark this range. -`type` is an attempt to classify the error. -`valid` is here mostly for informative purpose. It reflects whether Merlin was expecting such an error to be possible or not, and is useful for debugging purposes. -`message` is the error description to be shown to the user. - - -```javascript -["project","get"] -``` - -Returns an object `{"result":string list,"failures":string list}` listing all _.merlin_ files loaded for current buffer and a list of failures that might have happened during loading (missing package for instance, ill-formed .merlin, etc). -The `"failures"` field can be omitted if there has been no error. - -### Context - -Merlin keep tracks of multiple buffer. All commands apply to the active buffer. -`"checkout"` command allows to change the active buffer. -It returns a `cursor state` object describind the state of the checked out buffer (see `"tell"` command). - - -```javascript -["checkout", "ml"] -["checkout", "mli"] -``` - -Switch to "default" buffer for "ml", "mli". -It will be in the state you left it last time it was used, unless Merlin decided to garbage collect because of memory pressure (any buffer left in background is either untouched or reset because of collection). - - -```javascript -["checkout", "auto", string] -["checkout", "ml" , string] -["checkout", "mli" , string] -``` - -Checkout buffer at a given path, interpreting it as an ml, an mli, or infer that from path extension (defaulting to ml). -File at path is not loaded, path is only used as a key to refer to the buffer and look for _.merlin_ files. - - -```javascript -["checkout", "dot_merlin", string list, "auto", string] -["checkout", "dot_merlin", string list, "ml" , string] -["checkout", "dot_merlin", string list, "mli" , string] -``` - -Same as `["checkout", _, string]`, but rather than inferring the _.merlin_ from the path, use the explicit list of files. - -#### Contextual commands - -An important variant of this scheme are the _contextual commands_. -All Merlin commands except `"checkout"` can be wrapped in a dictionary looking like: - -```javascript -{ - "context": context, - "query": command -} -``` - -Where `command` is a Merlin command and context would be the list of arguments passed to `"checkout"`. - -This has the same effect as executing: - -```javascript -["checkout", context...] -[command...] -``` - -This is useful to prevent race conditions resulting from concurrent manipulations of different buffers in the editor, by making sure each command is interpreted in the appropriate context. - -### Versioning - -```javascript -["protocol","version",n] -``` - -This command notifies Merlin that the editor wants to communicate with protocol version `n`, where `n` is an integer. - -Merlin will answer with a triple `{"selected": n0, "latest": n1, "merlin": "Version string"}`, where: -- `n0` is the version that will be used for the rest of this session, -- `n1` is the most recent version the local distribution of Merlin is able to use, -- "Version string" is a human readable string describing the local installation of Merlin. - -```javascript -["protocol","version"] -``` - -This command will return the same answer as the previous one, but won't try to select a protocol version. - -```javascript -["version"] -``` - -Returns a string describing Merlin version. - -### Debugging Merlin - -Dump command allow to observe internal structures of Merlin. -Result is an arbitrary json object, targeted toward human readers. - -```javascript -["dump","env"] -["dump","env","at",position] -["dump","full_env"] -["dump","full_env","at",position] -``` - -Dump content of environment. -`"env"` is limited to local definition, `"full_env"` also includes `Pervasives` and default environment. - - -```javascript -["dump","sig"] -``` - -Dump definitions in environment as an ML signature. - - -```javascript -["dump","tokens"] -["dump","parser"] -["dump","recover"] -``` - -Dump output of the lexer, state of the parser and possible recoveries. - - -```javascript -["dump","browse"] -["dump","typer","input"] -["dump","typer","output"] -``` - -Dump state of typechecker. -`"input"` is the AST has seen by the typer. -`"output"` is the annotated AST produced by the typer. -`"browse"` is a json-based tree built out of the `"output"`. - - -```javascript -["dump","flags"] -["dump","warnings"] -``` - -List of the flags and warnings set for current buffers. - -# TODO - -Logging infrastructure. -Explain responses verbosity. diff --git a/ocaml-lsp-server/vendor/merlin/doc/dev/PROTOCOL.md b/ocaml-lsp-server/vendor/merlin/doc/dev/PROTOCOL.md deleted file mode 100644 index 8981f7bf3..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/dev/PROTOCOL.md +++ /dev/null @@ -1,487 +0,0 @@ -# Merlin 3 protocol documentation - - -## Changes from merlin 2 - -The communication protocol was redesigned between merlin 2 and 3. Answers have -the same format, but merlin is no longer invoked as an asynchronous process: a -new merlin process is started for each query. Under the hood, merlin will make -its best to manage resources in an efficient way (via a resident process called -*ocamlmerlin-server*). - -In other word, editor modes no longer have to do process management. - -Finally, commands no longer maintain state on merlin side. In previous -versions, buffer specific settings (compiler flags, findlib packages, syntax -extensions, ...) were set by calling the appropriate commands. State was split -between merlin and the editor, which was hard to track and could cause -desynchronization. - -In this version, all this settings are passed on the command line. Arguments -look a lot like the ocaml compiler ones. - -Try calling: -- `ocamlmerlin single -help` for general information -- `ocamlmerlin single -flags-help` for a detailed list of accepted flags -- `ocamlmerlin single -commands-help` for a list of supported commands - -### Backward compatibility - -This change is made in a backward compatible way: sessions that worked with -merlin 2 should give the same answer with merlin 3. -This new protocol is only enabled if a command is passed on the commandline. - -Two binaries are distributed: `ocamlmerlin` and `ocamlmerlin-server`. -`ocamlmerlin` is a lightweight wrapper that will call the server in the way it -determined to be appropriate. - -In simple cases, a new instance of ocamlmerlin-server is ran for each query. A -more efficient but more complex setup is to reuse an existing instance. The -wrapper will take care of that transparently. - -`ocamlmerlin` is the only binary one should execute. `ocamlmerlin-server` will -be used by the wrapper if necessary and should never be executed manually. - -The first argument passed to `ocamlmerlin` determines how merlin will behave: - -- `old-protocol` executes the merlin frontend from previous version. It is a - top level reading and writing commands in a JSON form. - -- `single` is a simpler frontend that reads input from stdin, processes a - single query and outputs result on stdout. - -- `server` works like `single`, but uses a background process to speedup - processing. - -If the first argument is not one of these, Merlin fallbacks to `old-protocol` -for compatibility. The new protocol is enabled only with `single` and `server`. - -Finally, `ocamlmerlin server stop-server` is a special case to shutdown the -background server, if it is running. - -During development or debugging of the editor mode, one can use the single mode -and switch to server mode for deployment: visible behavior shouldn't differ, -the merlin server will be managed automatically. - -## Getting started - -You can play with Merlin from the commandline. This can give you a feeling of -how Merlin could be driven from an editor: - -```shell -$ cat test.ml -let x = 5 -let y = 3.0 *. x -$ ocamlmerlin single type-enclosing -position '1:5' -filename test.ml < test.ml -{ - "class" : "return", - "value" : [ - { - "tail" : "no", - "end" : { - "line" : 1, - "col" : 5 - }, - "type" : "int", - "start" : { - "line" : 1, - "col" : 4 - } - } - ] -} -$ ocamlmerlin single complete-prefix -prefix 'List.m' -position '2:14' -filename test.ml < test.ml -{ - "class" : "return", - "value" : { - "entries" : [ - { - "info" : "", - "name" : "map", - "kind" : "Value", - "desc" : "('a -> 'b) -> 'a list -> 'b list" - }, - { - "info" : "", - "name" : "map2", - "kind" : "Value", - "desc" : "('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list" - }, - { - "name" : "mapi", - "info" : "", - "desc" : "(int -> 'a -> 'b) -> 'a list -> 'b list", - "kind" : "Value" - }, - { - "name" : "mem", - "info" : "", - "desc" : "'a -> 'a list -> bool", - "kind" : "Value" - }, - ... - ], - "context" : null - } -} -$ ocamlmerlin single errors -filename test.ml < test.ml -{ - "class" : "return", - "value" : [ - { - "message" : "Unbound value List.m", - "valid" : true, - "end" : { - "line" : 2, - "col" : 14 - }, - "sub" : [], - "type" : "error", - "start" : { - "col" : 8, - "line" : 2 - } - } - ] -} -``` - -## Anatomy of command line arguments - -Merlin command line looks like: - -```shell -$ ocamlmerlin < ml-source.ml -``` - -Command flags are described below. Global and compilers flags are described by -`ocamlmerlin single -flags-help`. - -## Answers - -Merlin answers always have the same shape: - -```javascript -{ - "class": "return" | "failure" | "error" | "exception", - "value": , - "notifications": string list -} -``` - -If processing succeeded, class is "return" and "value" is defined by the -command. Otherwise, value is a string: -- "exception" means something bad happened to Merlin, you should fill a bug - report -- "failure" means that Merlin couldn't understand your request, maybe there is - a typo, an argument missing, etc. -- "error" means Merlin couldn't process the query because of some problem with - the setup: wrong OCaml version, missing file, etc. - -Notifications are messages to be reported to the user. For instance if there is -a typo in the `.merlin` file, Merlin will generate a notification then ignore -the error and continue processing. - -## Commands - -### `case-analysis -start -end ` - - -start Where analysis starts - -end Where analysis ends - -When the range determined by (-start, -end) positions is an expression, -this command replaces it with [match expr with _] expression where a branch is introduced for each immediate value constructor of the type that was determined for expr. -When it is a variable pattern, it is further expanded and new branches are introduced for each possible immediate constructor of this variable. -The return value has the shape `[{'start': position, 'end': position}, content]`, where content is string. - - -### `complete-prefix -position [ -doc ] -prefix [ -types ]` - - -position Position to complete - -doc Add docstring to entries (default is false) - -prefix Prefix to complete - -types Report type information (default is true) - -This functions completes an identifier that the user started to type. -It returns a list of possible completions. -With '-types y' (default), each completion comes with type information. -With '-doc y' it tries to lookup OCamldoc, which is slightly more time consuming. - -The result has the form: -```javascript -{ - 'context': (null | ['application',{'argument_type': string, 'labels': [{'name':string,'type':string}]}]), - 'entries': [{'name':string,'kind':string,'desc':string,'info':string}] -} -``` - -Context describe where completion is occurring. Only application is distinguished now: that's when one is completing the arguments to a function call. In this case, one gets the type expected at the cursor as well as the other labels. - -Entries is the list of possible completion. Each entry is made of: -- a name, the text that should be put in the buffer if selected -- a kind, one of `'value'`, `'variant'`, `'constructor'`, `'label'`, `'module'`, `'signature'`, `'type'`, `'method'`, `'#'` (for method calls), `'exn'`, `'class'` -- a description, most of the time a type or a definition line, to be put next to the name in completion box -- optional information which might not fit in the completion box, like signatures for modules or documentation string. - -### `construct -position [ -with-values -depth ]` - - -position Position where construct should happen - -with-values Use values from the environment - (experimental, defaults to none) - -depth Depth of the search (defaults to 1) - -When the position determined by `-position` is a hole (`_`), this command - returns a list of possible terms that could replace it given its type. -When `-with-values` is set to local, values in the current environment will be - used in the constructed terms. This feature is still under development. - -### `document -position [ -identifier ]` - - -position Position to complete - -identifier Identifier - -Returns OCamldoc documentation as a string. -If `-identifier ident` is specified, documentation for this ident is looked up from environment at `-position`. -Otherwise, Merlin looks for the documentation for the entity under the cursor (at `-position`). - -### `enclosing -position ` - - -position Position to complete - -Returns a list of locations `{'start': position, 'end': position}` in increasing size of all entities surrounding the position. -(In a lisp, this would be the locations of all s-exps that contain the cursor.) - -### `errors` - - -Returns a list of errors in current buffer. -The value is a list where each item as the shape: - -```javascript -{ -'start' : position, -'end' : position, -'valid' : bool, -'message' : string, -'sub' : sub_error list, -'type' : ('type'|'parser'|'lexer'|'env'|'warning'|'unknown') -} - -sub_error ::= -{ - 'start' : position, - 'end' : position, - 'message' : string -} -``` - -`start` and `end` are omitted if error has no location (e.g. wrong file format), otherwise the editor should probably highlight / mark this range. -`type` is an attempt to classify the error. -`valid` is here mostly for informative purpose. It reflects whether Merlin was expecting such an error to be possible or not, and is useful for debugging purposes. -`message` is the error description to be shown to the user. -`sub` is an experimental extension to put more detailed information about type errors (for instance the location of the field that mismatches between an interface and an implementation). - -### `expand-prefix -position -prefix [ -types ]` - - -position Position to complete - -prefix Prefix to complete - -types Report type information (default is false) - - -The function behaves like `complete-prefix`, but it also handles partial, incorrect, or wrongly spelled prefixes (as determined by some heuristic). -For instance, `L.ma` can get expanded to `List.map`. This function is a useful fallback if normal completion gave no results. -Be careful that it always return fully qualified paths, whereas normal completion only completes an identifier (last part of a module path). - -### `extension-list [ -status ]` - --status Filter extensions - -List all known / currently enabled / currently disabled extensions as a list of strings. - -### `findlib-list` - - -Returns all known findlib packages as a list of string. - -### `flags-list` - - -Returns supported compiler flags.The purpose of this command is to implement interactive completion of compiler settings in an IDE. - -### `holes` - -This command will return the ordered list of the positions and types of all -holes in the current document. - -### `jump -target -position ` - - -target Entity to jump to - -position Position to complete - -This command can be used to assist navigation in a source code buffer. -Target is a string that can contain one or more of the 'fun', 'let', 'module' and 'match' words. -It returns the starting position of the function, let definition, module or match expression that contains the cursor - - -### `phrase -target -position ` - - -target Entity to jump to - -position Position to complete - -Returns the position of the next or previous phrase (top-level definition or module definition). - -### `list-modules [ -ext -ext ... ]` - - -ext file extensions to look for - -Looks into project source paths for files with an extension matching and prints the corresponding module name. - -### `locate [ -prefix ] -position [ -look-for ]` - - -prefix Prefix to complete - -position Position to complete --look-for Prefer opening interface or implementation - -Finds the declaration of entity at the specified position, Or referred to by specified string. -Returns either: -- if location failed, a `string` describing the reason to the user, -- `{'pos': position}` if the location is in the current buffer, -- `{'file': string, 'pos': position}` if definition is located in a different file. - -### `occurrences -identifier-at ` - --identifier-at Position to complete - -Returns a list of locations `{'start': position, 'end': position}` of all occurrences in current buffer of the entity at the specified position. - -### `outline` - - -Returns a tree of objects `{'start': position, 'end': position, 'name': string, 'kind': string, 'children': subnodes}` describing the content of the buffer. - -### `path-of-source -file ` - - -file filename to look for in project paths - -Looks for first file with a matching name in the project source and build paths - -### `shape -position ` - - -position Position - -This command can be used to assist navigation in a source code buffer. -It returns a tree of all relevant locations around the cursor. -It is similar to outline without telling any information about the entity at a given location. -```javascript -shape = -{ - 'start' : position, - 'end' : position, - 'children' : [shape] -} -``` - - -### `type-enclosing -position [ -expression ] [ -cursor ] [ -index ]` - - -position Position to complete - -expression Expression to type - -cursor Position of the cursor inside expression - -index Only print type of 'th result - -Returns a list of type information for all expressions at given position, sorted by increasing size. -That is asking for type enlosing around `2` in `string_of_int 2` will return the types of `2 : int` and `string_of_int 2 : string`. - -If `-expression` and `-cursor` are specified, the first result will be the type -relevant to the prefix ending at the `cursor` offset. - -`-index` can be used to print only one type information. This is useful to -query the types lazily: normally, Merlin would return the signature of all -enclosing modules, which can be very expensive. - -The result is returned as a list of: -```javascript -{ - 'start': position, - 'end': position, - 'type': string, - // is this expression not in tail position, in tail position, or even a tail call? - 'tail': ('no' | 'position' | 'call') -} -``` - -### `type-expression -position -expression ` - - -position Position to complete - -expression Expression to type - -Returns the type of the expression when typechecked in the environment around the specified position. - -### `check-configuration` - - -This command checks that merlin project and options are correct. -The return value has the shape: -```javascript -{ - 'dot_merlins': [path], // a list of string - 'failures': [message] // a list of string -} -``` - -## Details about the client/server protocol - -single mode - -the wrapper -socket rendez vous -stopping server -passing command line arguments -passing environment variable - -## Miscellaneous - -`__MERLIN_MASTER_PID` environment variable is set in processes invoked by -merlin. - -For PPX writers, the tool name is set to "merlin". - -### Locations in PPX rewriters - -FIXME: this should go somewhere else. - -When trying to match a location with an AST node, Merlin traverses the tree -from the root, descending into all nodes that overlaps the location. - -The most important part is that the locations of the rewritten AST nodes -actually form a tree. - -A few attributes can be added on AST nodes to guide Merlin. - -#### `[@merlin.loc]` - -The location of "merlin.loc" will be used instead of the normal location of the -node when traversing the AST. This is useful to extend the range of nodes. - -For instance in the AST for `let x = y in z` nothing can be said about the -location of `in` as it doesn't appear in the abstract syntax. - -Thus if the cursor is after `y` and before `z`, merlin cannot tell which node -to chose (should the completion use the context `y`, where `x` doesn't appear, -or the context of `z` ?). - -This is solved by tweaking the parser to add `[@merlin.loc]` attributes, with -the locations marked by `[]`: `let x =[ y ]in[ z]`. - -This way, merlin will pick `z` node after `in` and `y` node before. - -#### `[@merlin.hide]` and `[@merlin.focus]` - -PPX rewriters sometime generate codes that need to be given a location so that -errors are reported appropriately but for which other Merlin features are not -meaningful (completion or type-enclosing). - -`[@merlin.hide]` attribute causes merlin to ignore a branch of the AST. - -When multiple branches overlap a location, `[@merlin.focus]` attribute forces -merlin to select a single branch and ignore the others. diff --git a/ocaml-lsp-server/vendor/merlin/doc/dev/SERVER.md b/ocaml-lsp-server/vendor/merlin/doc/dev/SERVER.md deleted file mode 100644 index d1cd785e7..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/dev/SERVER.md +++ /dev/null @@ -1,29 +0,0 @@ -Merlin now implements a server. This simplify implementation of editor modes by -allowing synchronous process executions. - -The `ocamlmerlin` binary is a wrapper, written in C, that redirects queries to -`ocamlmerlin-server`. - -It can be used in a few different ways. - -`old-protocol` works as a repl: one writes a query (formatted as a json value) -and reads an answer (also json). It is the protocol of merlin 1.x and 2.x. -When detecting old-protocol, `ocamlmerlin` wrapper simply executes the -ocamlmerlin-server. It is documented in [OLD-PROTOCOL.md](OLD-PROTOCOL.md). - -With the new protocol, the query is specified on the command-line and the -content is read from standard input. Merlin can now be used like a regular -UNIX command. Answers are written on standard output as JSON-values (or -optionally, S-expression). - -In `single` mode, the wrapper executes `ocamlmerlin-server` and processes a -single query. -In `server` mode, the wrapper looks for an existing server. If none are found, -it executes a new one. Then it redirects the query to the server, wait for an -answer and terminates. - -The editor plugin does the same work in both cases, caching & calling the -server is transparent. - -Mode is specified as the first argument to `ocamlmerlin` binary, and defaults to -`old-protocol` for compatibility with previous versions. diff --git a/ocaml-lsp-server/vendor/merlin/doc/features.md b/ocaml-lsp-server/vendor/merlin/doc/features.md deleted file mode 100644 index e03ec480c..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/features.md +++ /dev/null @@ -1,59 +0,0 @@ -# Polarity search - -A Hoogle-like type-based search for libraries that are in merlin's scope. - -The commands `:MerlinSearch` (vim) / `merlin-search` (emacs) take a search query -and return the list of identifiers that satisfy this query. - -The query language is simply a list of path identifiers prefixed by `+` or `-`, -e.g. `-int`, `-int +string`, `-Hashtbl.t +int`. - -`-` is interpreted as "consuming" and `+` as "producing": `-int +string` looks -for functions consuming an `int` and producing a `string`. - -The search algorithm uses type variance to filter results. Thus, search will -proceed inside abstract types, continuation-passing-style, ... as long as -variance annotations are available. - -# Open refactoring - -Merlin provides a pair of commands to help cleaning the code in the scope of an -`open` statement. - -Two new commands (`:MerlinRefactorOpen`, `:MerlinRefactorOpenQualify` in vim, -and `merlin-refactor-open`, `merlin-refactor-open-qualify` in Emacs) help -cleaning the code in the scope of an `open` statement. - -When the cursor is on an open statement: -- `:MerlinRefactorOpen` (vim) / `merlin-refactor-open` (emacs) will remove - references to the path of the open that are made useless -- `:MerlinRefactorOpenQualify` (vim) / `merlin-refactor-open-qualify` (emacs) - will always add references to this path - -Starting from: - -```ocaml -open Unix - -let times = Unix.times () -let f x = x.Unix.tms_stime, x.Unix.tms_utime -``` - -Calling `:MerlinRefactorOpen` 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 `:MerlinRefactorOpenQualify` will restore: - -```ocaml -open Unix - -let times = Unix.times () -let f x = x.Unix.tms_stime, x.Unix.tms_utime -``` diff --git a/ocaml-lsp-server/vendor/merlin/doc/next/Protocol.wiki b/ocaml-lsp-server/vendor/merlin/doc/next/Protocol.wiki deleted file mode 100644 index 086583a9f..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/next/Protocol.wiki +++ /dev/null @@ -1,42 +0,0 @@ -Next merlin protocol should be stateless. -Also worth taking a look: [[https://github.com/Microsoft/language-server-protocol|Microsoft/language-server-protocol]]. - -The protocol is still implemented as a series of request/answer. - -{{{ - request-format: - { - uri: "path to current document", - source: "full source text", - setup: merlin-setup, - query: merlin-query, - configuration: { - terminal_width: int, - verbosity: int, - }, - } - - answer-format: - { - class: "return" | "failure" | "error" | "exception", - value: , - notifications: string list - } - - merlin-query: - ... - - merlin-setup: - { - build_path: string list, - source_path: string list, - cmi_path: string list, - cmt_path: string list, - findlib: string, - stdlib: string, - packages: string list, - flags: string list, - reader: string list, - suffixes: (string * string) list - } -}}} diff --git a/ocaml-lsp-server/vendor/merlin/doc/next/RATIONALE.wiki b/ocaml-lsp-server/vendor/merlin/doc/next/RATIONALE.wiki deleted file mode 100644 index f1c624813..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/next/RATIONALE.wiki +++ /dev/null @@ -1,151 +0,0 @@ -== Performance == - -Merlin put a close attention on performance. All was done to provide answer -below reaction time for common queries. - -The idea was that the work done for answering should be proportional to the -diff since the last query rather than the whole buffer size. - -To this end, the design was a bit more complex than necessary and didn't evolve -well as new features were integrated. - -A recent requirement put the final nail in the coffin for this principle: -syntax extensions expect to see the whole file at once, effectively defeating -the purpose of sub-linear optimizations. - -This is the opportunity to redesign Merlin, in the hope of simplifying the work -for all components involved in the toolchain: the core of Merlin, the OCaml -typechecker, editors integration. - -== Protocol == - -A new protocol will be designed. For compatibility reason, the old one will -still be provided on top, but the expectation is that editor modes will be -migrated to the new one over time. - -The main idea behind the new protocol is that queries should be self-contained: -no implicit state is assumed between queries. - -Executing a query on an existing process and on a fresh one should lead to the -same result, performance aside. - -Intended benefits: - -- reproducibility and stability; restarting always lead to the same - behavior, otherwise it is a bug - -- clear separation of responsibility; in particular buffer local state is - managed by the editor, and not split between processes - -- implementation is pure and performance comes from a memoization layer; the - pure layer offers a reference implementation, memoization shouldn't be - observable. - -== Asynchronicity: editors requirements == - -NOTE: some of this might not be true in all circumstances, but would result in -twisted implementation or editor specific design. - -*Vim* cannot do asynchronous operations. *Emacs* cannot most of the time. -Otherwise it can be implemented in CPS-style but we have to be very careful. -*Neovim* and *Atom* should have no problem dealing with that. - -As a consequence protocol is synchronous by default (Merlin will anyway process -queries serially) but editors can tweak the integration to provide better -experience. - -== Asynchronicity: for optimization == - -A different kind of optimization can be explored later: refining results -asynchronously. - -The idea is that for completion, changes that happened in the last second might -not be relevant for the query. Merlin could give an immediate answer from the -out-of-date cache, and refine it after recomputation. - -The user always get a result in real-time, and potentially better suggestions -after a reasonable latency (the normal one). - -The drawback is that this introduces more complexity on editor side. Not all -editor can support that kind of interactions: -- vim is out of scope, -- emacs will be hard to get right, -- modern editors such as Neovim and Atom should be easy, -- not sure about Sublime Text. - -== Debugging == - -In the current version of Merlin, debugging can be done in two ways: -- via MERLIN_LOG file, where the whole communication is logged & some feature - specific Printf-debugging is available -- via `dump` command, which exposes some internal structures. - -The stateless protocol should help debugging and reporting bug: -- only the last command needs to be reported, -- users can first check the output in a fresh process. - -The printf-debugging is feature specific and hardly readable. The new -intention is to produce a human-readable trace at the same time the code is -executed, explaining intermediate decisions -- a dynamic counterpart to -literate programming. - -As such, all internal structures will come with a human-friendly printer. - -The trace should help *profiling*, by tracking times between steps. The trace -should allow working at different level of precision, by unfolding sub parts of -the computation. At the basic level, no internal decisions are printed and so -the cost should be negligible. At the most verbose level, all steps are -printed, which is probably expensive but shouldn't matter in debug mode. - -FIXME: -- explore using sturgeon for interactive tracing -- should we use ppx for deriving printers and logging code? - -== Documentation & testing == - -Both are hard to achieve after the facts. Each time a feature is ported to the -new implementation, documentation and testing should be added. - -Documentation should not necessarily target the end-user but should explain -design rationale and intended use cases, so that end-user documentation is easy -to derive. - -I don't know how to do proper tests... When a feature seems hard to properly -test, this should at least be documented, e.g. in a TODO file. Otherwise, -tests should embed as most state as possible and not rely on external files -(OCaml / Opam setup, findlib packages, etc...). - -=== Editor integration === - -Even more important is to do this when adding a feature in a specific mode. - -Most users won't care about actual implementation details but will care about -how the feature is made accessible in their editor (prototypical example: local -type-enclosing keymap with C-up C-down C-w in emacs). - -=== Documentation medium === - -Another question worth asking is how the documentation is provided and written. - -For individual files, I am comfortable with markdown. Other text-based file -formats are welcome too if they prove more appropriate. - -For multiple or structures files, I am considering directly using wiki -language, or markdown-like wiki. - -== OCaml support == - -In current Merlin, OCaml frontend received a non-negligible quantity of -patches. - -Recent changes in the OCaml compiler made integration easier, mainly -attributes/extensions and lazy substitution. The switch to PPX made support for -CamlP4 less relevant, most built-in extensions will be removed. - -Merlin will still use a patched version of the compiler, but will try to stay -close to upstream. - -Also some changes should be upstreamed soon: -- custom short-path implementation -- bidirectional typechecking of arguments -- state isolation diff --git a/ocaml-lsp-server/vendor/merlin/doc/next/merlin.wiki b/ocaml-lsp-server/vendor/merlin/doc/next/merlin.wiki deleted file mode 100644 index bc45e73ca..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/next/merlin.wiki +++ /dev/null @@ -1,21 +0,0 @@ -@let-def: this design document gathers requirements and ideas for the next - version of merlin. The purpose is to consolidate features that were added - lately and cleanup legacy cruft. - -== TL;DR == - -* simpler & stateless protocol -* pure implementation for reference -* performance added on top, memoization & asynchronicity -* traceability, log all decisions and print internal structures -* maintenability, minimize change to OCaml codebase - -See [[RATIONALE]]. - -== Implementation == - -Merlin is split in three main components: - -* [[Protocol]], communicates with outside world -* [[Kernel]], wraps the OCaml frontend -* [[Analysis]], answers specific questions on the codebase diff --git a/ocaml-lsp-server/vendor/merlin/doc/pres/pres-meetup-21-05-13.tex b/ocaml-lsp-server/vendor/merlin/doc/pres/pres-meetup-21-05-13.tex deleted file mode 100644 index f64082df2..000000000 --- a/ocaml-lsp-server/vendor/merlin/doc/pres/pres-meetup-21-05-13.tex +++ /dev/null @@ -1,207 +0,0 @@ -% Copyright 2013 Frederic Bour, all rights reserved -\documentclass{beamer} - -\usepackage[french]{babel} -\usepackage[utf8x]{inputenc} -\usepackage[T1]{fontenc} -\usepackage{default} -\usepackage{tikz} - -\newcommand{\sectitle}{\frametitle{\insertsection}} - -\title{Merlin, an OCaml assistant} -\author{Frédéric \bsc{Bour}} -\date{May 21, 2013} - -\usetheme{Warsaw} - -\AtBeginSection[] { - \begin{frame}[plain] - \frametitle{Plan} - \tableofcontents[currentsection] - \end{frame} - \addtocounter{framenumber}{-1} -} - -\newcommand{\Simley}[1]{% -\begin{tikzpicture}[scale=0.11] - \newcommand*{\SmileyRadius}{1.0}% - \draw [fill=brown!10] (0,0) circle (\SmileyRadius)% outside circle - %node [yshift=-0.22*\SmileyRadius cm] {\tiny #1}% uncomment this to see the smile factor - ; - - \pgfmathsetmacro{\eyeX}{0.5*\SmileyRadius*cos(30)} - \pgfmathsetmacro{\eyeY}{0.5*\SmileyRadius*sin(30)} - \draw [fill=cyan,draw=none] (\eyeX,\eyeY) circle (0.15cm); - \draw [fill=cyan,draw=none] (-\eyeX,\eyeY) circle (0.15cm); - - \pgfmathsetmacro{\xScale}{2*\eyeX/180} - \pgfmathsetmacro{\yScale}{1.0*\eyeY} - \draw[color=red, domain=-\eyeX:\eyeX] - plot ({\x},{ - -0.1+#1*0.15 % shift the smiley as smile decreases - -#1*1.75*\yScale*(sin((\x+\eyeX)/\xScale))-\eyeY}); -\end{tikzpicture}% -}% -\newcommand{\smiley}{\Simley{0.5}} - -\begin{document} - -\begin{frame} - \titlepage -\end{frame} - -% \begin{frame}{Table des matières} -% \tableofcontents -% \end{frame} - -\section{An assistant in your editor} - -\subsection{The usual toplevel} - -\begin{frame} - \sectitle - - The toplevel as a tool to interact with OCaml during edition. - - \pause - - \begin{itemize} - \item Side-effects when evaluating phrases - \pause - \item Phrases evaluated in arbitrary order - \pause \\ - (name shadowing, arbitrary scoping...) - \end{itemize} -\end{frame} - -\subsection{Merlin} - -\begin{frame} - \sectitle - - Merlin improves on this situation. - \pause - - \begin{itemize} - \item Checks syntax and typing, but doesn't evaluate. - \pause - \item Works incrementally, in document order - (if you know Coq, think of ``Proof-General for OCaml''). - \pause - \item Resilient to syntax and typing errors (experimental). - \end{itemize} -\end{frame} - -\section{In practice} - -\subsection{Upsides} - -\begin{frame} - \frametitle{Upsides} - - \begin{block}{Typing information} - \begin{itemize} - \item completion at point, sensitive to the current typing environment - \pause - \item type of (sub)expressions at point - \pause - \item foundations are there for all kind of type-directed - feedback and analyses - \pause - \end{itemize} - \end{block} - - \begin{block}{Instant feedback} - \begin{itemize} - \item Direct error feedback in the editor - \pause - \item can be a distraction \smiley - \pause - \end{itemize} - \end{block} - - No surprise: the scoping, typing rules are exactly those of the - compiler. -\end{frame} - -\subsection{(Current) Limitations} - -\begin{frame} - \frametitle{(Current) Limitations} - \begin{block}{Syntax extensions} - \begin{itemize} - \item No support for camlp4 planned - \pause - \item but we hard-code quotations and specific extensions \\ - (\texttt{lwt}, \texttt{type-conv}, ...) - \pause - \end{itemize} - \end{block} - - \begin{block}{Hard language constructs} - \begin{itemize} - \item recursive definitions - \pause - \item first-class modules, OOP, etc. - \pause - \item[$\Rightarrow$] hard to provide feedback on those when code - is not valid - \end{itemize} - \end{block} -\end{frame} - -\subsection{Features} - -\begin{frame} - \sectitle - - From both Vim and Emacs : - - \begin{itemize} - \item identifier completion, - \item type feedback, - \item integrated error messages, - \item \texttt{ocamlfind} integration \\ - {\small {\tt .merlin} file for projects}, - \item a few syntax extensions. - \end{itemize} - -\end{frame} - -\subsection{The future} - -\begin{frame} - \frametitle{The future} - - Short- to long-term. - - \begin{itemize} - \item work on handling of syntax errors - \pause - \item coordination with other tools (\texttt{spotter}, \texttt{ocamldoc}), - \pause - \item more extensions. \\ - {\small \texttt{js\_of\_ocaml} in experimental branch} - \end{itemize} - -\end{frame} - -\section*{Demo} - -\begin{frame} - \sectitle - - Thanks for your attention. - - \vfill - - For more information : {\tt http://github.com/def-lkb/merlin} - - \vfill - - And now for a small demo... - -\end{frame} - -\end{document} diff --git a/ocaml-lsp-server/vendor/merlin/dot-merlin-reader.opam b/ocaml-lsp-server/vendor/merlin/dot-merlin-reader.opam deleted file mode 100644 index 2784f3c56..000000000 --- a/ocaml-lsp-server/vendor/merlin/dot-merlin-reader.opam +++ /dev/null @@ -1,21 +0,0 @@ -opam-version: "2.0" -maintainer: "defree@gmail.com" -authors: "The Merlin team" -synopsis: "Reads config files for merlin" -homepage: "https://github.com/ocaml/merlin" -bug-reports: "https://github.com/ocaml/merlin/issues" -dev-repo: "git+https://github.com/ocaml/merlin.git" -license: "MIT" -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] -] -depends: [ - "ocaml" {>= "4.08" & < "5.0.0"} - "dune" {>= "2.9.0"} - "merlin-lib" {>= "4.6"} - "ocamlfind" {>= "1.6.0"} -] -description: - "Helper process: reads .merlin files and outputs the normalized content to - stdout." diff --git a/ocaml-lsp-server/vendor/merlin/dune-project b/ocaml-lsp-server/vendor/merlin/dune-project deleted file mode 100644 index 9b5b3afca..000000000 --- a/ocaml-lsp-server/vendor/merlin/dune-project +++ /dev/null @@ -1,7 +0,0 @@ -(lang dune 2.9) -(name merlin) -(using menhir 2.0) - -(cram enable) -(formatting disabled) -(implicit_transitive_deps false) diff --git a/ocaml-lsp-server/vendor/merlin/dune-release.sh b/ocaml-lsp-server/vendor/merlin/dune-release.sh deleted file mode 100755 index ab80ae25d..000000000 --- a/ocaml-lsp-server/vendor/merlin/dune-release.sh +++ /dev/null @@ -1,32 +0,0 @@ -#!/bin/sh - -TAG="$1" -VER="$2" - -if [ -z "$TAG" ]; then - printf "Usage: ./dune-release.sh []\n" - printf "Please make sure that dune-release is available.\n" - exit 1 -fi - -FLAGS="-t $TAG" - -if [ -n "$VER" ]; then - FLAGS="$FLAGS --pkg-version=$VER" -fi - -step() -{ - printf "Continue? [Yn] " - read action - if [ "x$action" == "xn" ]; then exit 2; fi - if [ "x$action" == "xN" ]; then exit 2; fi -} - -dune-release distrib -p merlin -n merlin $FLAGS --skip-tests #--skip-lint -step -dune-release publish distrib -p merlin -n merlin $FLAGS -step -dune-release opam pkg -p merlin -n merlin $FLAGS -step -dune-release opam submit -p merlin -n merlin $FLAGS diff --git a/ocaml-lsp-server/vendor/merlin/emacs/check.sh b/ocaml-lsp-server/vendor/merlin/emacs/check.sh deleted file mode 100755 index b72a473ab..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/check.sh +++ /dev/null @@ -1,47 +0,0 @@ -#!/bin/sh -e - -# Adapted from https://github.com/purcell/package-lint/blob/master/run-tests.sh -EMACS="${EMACS:=emacs}" - -NEEDED_PACKAGES="package-lint company iedit auto-complete" - -TO_CHECK=*.el - -INIT_PACKAGE_EL="(progn \ - (require 'package) \ - (add-to-list 'package-archives \ - '(\"melpa\" . \"https://melpa.org/packages/\") t) \ - (package-initialize) \ - (package-refresh-contents) \ - (dolist (pkg '(${NEEDED_PACKAGES})) \ - (unless (package-installed-p pkg) \ - (package-install pkg))))" - -# Refresh package archives, because the test suite needs to see at least -# package-lint and cl-lib. -"$EMACS" -Q -batch \ - --eval "$INIT_PACKAGE_EL" - -# Byte compile, failing on byte compiler errors, or on warnings unless ignored -if [ -n "${EMACS_LINT_IGNORE+x}" ]; then - ERROR_ON_WARN=nil -else - ERROR_ON_WARN=t -fi - -"$EMACS" -Q -batch \ - -L . \ - --eval "$INIT_PACKAGE_EL" \ - --eval "(setq byte-compile-error-on-warn ${ERROR_ON_WARN})" \ - -f batch-byte-compile \ - ${TO_CHECK} - -# Lint failures are ignored if EMACS_LINT_IGNORE is defined, so that lint -# failures on Emacs 24.2 and below don't cause the tests to fail, as these -# versions have buggy imenu that reports (defvar foo) as a definition of foo. -"$EMACS" -Q -batch \ - --eval "$INIT_PACKAGE_EL" \ - -L . \ - --eval "(require 'package-lint)" \ - -f package-lint-batch-and-exit \ - ${TO_CHECK} || [ -n "${EMACS_LINT_IGNORE+x}" ] diff --git a/ocaml-lsp-server/vendor/merlin/emacs/dune b/ocaml-lsp-server/vendor/merlin/emacs/dune deleted file mode 100644 index 03631594e..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/dune +++ /dev/null @@ -1,11 +0,0 @@ -(install - (package merlin) - (section share_root) - (files (merlin-ac.el as emacs/site-lisp/merlin-ac.el) - (merlin-cap.el as emacs/site-lisp/merlin-cap.el) - (merlin-company.el as emacs/site-lisp/merlin-company.el) - (merlin-iedit.el as emacs/site-lisp/merlin-iedit.el) - (merlin-imenu.el as emacs/site-lisp/merlin-imenu.el) - (merlin-xref.el as emacs/site-lisp/merlin-xref.el) - (merlin.el as emacs/site-lisp/merlin.el))) - diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin-ac.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin-ac.el deleted file mode 100644 index 64032d562..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin-ac.el +++ /dev/null @@ -1,166 +0,0 @@ -;;; merlin-ac.el --- Merlin and auto-complete integration. -*- coding: utf-8; lexical-binding: t -*- -;; Licensed under the MIT license. - -;; Author: Simon Castellan -;; Frédéric Bour -;; Thomas Refis -;; Created: 15 May 2015 -;; Version: 0.1 -;; Keywords: ocaml languages -;; Package-Requires: ((emacs "25.1") (merlin "3") (auto-complete "1.5")) -;; URL: http://github.com/ocaml/merlin - -;;; Commentary: - -;; To integrate this auto-complete backend with Merlin, just (require -;; 'merlin-ac) in your Emacs configuration files. When `merlin-mode' -;; is subsequently enabled in buffers, auto-complete will be set up -;; too. Some auto-complete settings will be overridden: to avoid this -;; for finer control, customize the variable `merlin-ac-setup'. - -;;; Code: - -(require 'merlin) -(require 'auto-complete) - -;; Customization group - -(defgroup merlin-ac nil - "Merlin integration to auto-complete" - :group 'merlin :prefix "merlin-ac-") - -(defcustom merlin-ac-setup 'easy - "Determine how `merlin' integrates with `auto-complete'." - :group 'merlin-ac - :type '(choice (const :tag "Integrate with auto-complete" t) - (const :tag "Integrate with auto-complete, use sane default options" easy) - (const :tag "Don't integrate with auto-complete" nil))) - -(defcustom merlin-ac-prefix-size 0 - "If non-nil, specify the minimum number of characters to wait before allowing -auto-complete" - :group 'merlin-ac :type 'integer) - -(defcustom merlin-ac-use-summary t - "Display types in :summary" - :group 'merlin-ac :type 'boolean) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Internal variables - -(defvar-local merlin-ac--point nil - "Stores the point of last completion (beginning of the prefix).") - -(defvar-local merlin-ac--cache nil - "Hold a table mapping completion cache for auto-complete.") - -(defvar-local merlin-ac--prefix "" - "The cache of the prefix for completion") - -(defvar-local merlin-ac--ac-prefix "" - "The original value of ac-prefix used when computing merlin-ac--prefix") - -;; Internal functions - -(defun merlin-ac--make-popup-item (data) - "Create a popup item from data DATA." - (let ((desc (merlin-completion-entry-short-description data))) - (popup-make-item - ;; Note: ac refuses to display an item if merlin-ac--ac-prefix is not a - ;; prefix the item. So "dwim" completion won't work with ac. - (merlin-completion-entry-text merlin-ac--prefix data) - :summary (when (and merlin-completion-types merlin-ac-use-summary) desc) - :symbol (format "%c" (elt (cdr (assoc 'kind data)) 0)) - :document (let ((doc (cdr-safe (assoc 'info data)))) - (unless (equal doc "") doc))))) - -(defun merlin-ac--source-refresh-cache () - "Refresh the cache of completion." - (setq merlin-ac--prefix (merlin-completion-prefix ac-prefix)) - (setq merlin-ac--ac-prefix ac-prefix) - (setq merlin-ac--cache (mapcar #'merlin-ac--make-popup-item - (merlin-complete merlin-ac--prefix)))) - -(defun merlin-ac--source-init () - "Initialize the cache for `auto-complete' completion. -Called at the beginning of a completion to fill the cache (the -variable `merlin-ac--cache')." - (setq merlin-ac--point ac-point) - (merlin-ac--source-refresh-cache)) - -(defun merlin-ac--prefix () - "Retrieve the prefix for completion with merlin." - (let* ((bounds (merlin-completion-bounds)) - (start (car-safe bounds)) - (end (cdr-safe bounds))) - (unless (and bounds (< (- end start) merlin-ac-prefix-size)) - start))) - -(defun merlin-ac--fetch-type () - "Prints the type of the selected candidate" - (let ((candidate (merlin-buffer-substring merlin-ac--point (point)))) - (when merlin-completion-types - (mapc (lambda (item) - (when (string-equal candidate item) - (message "%s: %s" candidate (popup-item-summary item)))) - merlin-ac--cache)))) - -(defun merlin-ac--candidates () - "Return the candidates for auto-completion with auto-complete. If the cache is -wrong then recompute it." - (unless (and (equal (merlin-completion-prefix ac-prefix) merlin-ac--prefix) - (string-prefix-p merlin-ac--ac-prefix ac-prefix)) - (merlin-ac--source-refresh-cache)) - merlin-ac--cache) - -;; Public functions - -;;;###autoload -(defun merlin-ac-setup-easy () - "Integrate merlin to auto-complete with sane defaults" - (auto-complete-mode t) - (local-set-key (kbd "C-c C-l") 'ac-merlin-locate) - (set (make-local-variable 'ac-auto-show-menu) t) - (set (make-local-variable 'ac-auto-start) nil) - (set (make-local-variable 'ac-delay) 0.0) - (set (make-local-variable 'ac-expand-on-auto-complete) nil) - (set (make-local-variable 'ac-ignore-case) nil) - (set (make-local-variable 'ac-trigger-commands) nil)) - -;; I don't like it beginning by "ac" but it is the only way I found to get it -;; working (otherwise the completion menu just closes itself) -(defun ac-merlin-locate () - "Locate the identifier currently selected in the ac-completion." - (interactive) - (when (ac-menu-live-p) - (when (popup-hidden-p ac-menu) - (ac-show-menu)) - (let ((merlin-locate-in-new-window 'always)) - (merlin-call-locate (ac-selected-candidate))) - (ac-show-menu))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Register into auto-complete and merlin ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar merlin-ac-source '((init . merlin-ac--source-init) - (candidates . merlin-ac--candidates) - (action . merlin-ac--fetch-type) - (prefix . merlin-ac--prefix))) - -(ac-define-source "merlin" merlin-ac-source) - -(defun merlin-ac--setup () - (when merlin-ac-setup - (if (equal merlin-ac-setup 'easy) - (merlin-ac-setup-easy) - (auto-complete-mode t)) - (add-to-list 'ac-sources 'merlin-ac-source))) - -(add-hook 'merlin-mode-hook #'merlin-ac--setup) - -(provide 'merlin-ac) -;;; merlin-ac.el ends here diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin-cap.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin-cap.el deleted file mode 100644 index 114043fb0..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin-cap.el +++ /dev/null @@ -1,85 +0,0 @@ -;;; merlin-cap.el --- Merlin and completion-at-point integration. -*- coding: utf-8; lexical-binding: t -*- -;; Licensed under the MIT license. - -;; Author: Simon Castellan -;; Frédéric Bour -;; Thomas Refis -;; Created: 15 May 2015 -;; Version: 0.1 -;; Keywords: ocaml languages -;; URL: http://github.com/ocaml/merlin - -(require 'merlin) - -;; Call merlin-completion-at-point when you want merlin guided completion-at-point. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Internal variables - -(defvar-local merlin-cap--table nil - "Hold a table mapping completion candidates to their types.") - -(defvar-local merlin-cap--cache (cons "" 0) - "The cache for calls to completion-at-point so that it does not -trigger useless merlin calls.") - -;; Internal functions - -(defun merlin-cap--lookup (string _state) - "Lookup the entry STRING inside the completion table." - (let ((ret (assoc string merlin-cap--table))) - (if ret (message "%s%s" (car ret) (cdr ret))))) - -(defun merlin-cap--annotate (candidate) - "Retrieve the annotation for candidate CANDIDATE in -`merlin-completion-annotate-table'." - (cdr (assoc candidate merlin-cap--table))) - -(defun merlin-cap--table (string pred action) - "Implement completion for merlin using `completion-at-point' API." - (if (eq 'metadata action) - (when merlin-completion-types - '(metadata ((annotation-function . merlin-cap--annotate) - (exit-function . merlin-cap--lookup)))) - (complete-with-action action merlin-cap--table string pred))) - - -;; Public functions - -(defun merlin-cap () - "Perform completion at point with merlin." - (let* - ((bounds (merlin-completion-bounds)) - (start (car bounds)) - (end (cdr bounds)) - (prefix (merlin-buffer-substring start end)) - (compl-prefix (merlin-completion-prefix prefix))) - (when (or (not merlin-cap--cache) - (not (equal (cons prefix start) merlin-cap--cache))) - (setq merlin-cap--cache (cons prefix start)) - (setq merlin-cap--table - (mapcar - (lambda (a) - (cons (merlin-completion-entry-text compl-prefix a) - (concat ": " (merlin-completion-entry-short-description a)))) - (merlin-complete prefix)))) - (list start end #'merlin-cap--table - . (:exit-function #'merlin-cap--lookup - :annotation-function #'merlin-cap--annotate)))) - -(defalias 'merlin-completion-at-point 'merlin-cap) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Register into completion-at-point ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin-cap--setup () - (add-hook 'completion-at-point-functions #'merlin-completion-at-point nil 'local)) - -(add-hook 'merlin-mode-hook #'merlin-cap--setup) -(when merlin-mode (merlin-cap--setup)) - -(provide 'merlin-cap) -;;; merlin-cap.el ends here diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin-company.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin-company.el deleted file mode 100644 index c3956304a..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin-company.el +++ /dev/null @@ -1,141 +0,0 @@ -;;; merlin-company.el --- Merlin and company mode integration. -*- coding: utf-8; lexical-binding: t -*- -;; Licensed under the MIT license. - -;; Author: Simon Castellan -;; Frédéric Bour -;; Thomas Refis -;; Created: 15 May 2015 -;; Version: 0.1 -;; Keywords: ocaml languages -;; Package-Requires: ((emacs "25.1") (merlin "3") (company "0.9")) -;; URL: http://github.com/ocaml/merlin - -;;; Commentary: - -;; (require 'merlin-company) should be enough to get merlin to work within -;; company. -;; -;; If you always want company-mode to be available, consider adding: -;; (add-hook 'after-init-hook #'global-company-mode) -;; in your .emacs. - -;;; Code: - -(require 'merlin) -(require 'company) -(require 'cl-lib) - -;; It would be nice to define a proper (somewhat stable) interface in merlin.el -;; to be used by other modules. - -(defcustom merlin-company-everywhere t - "Non-nil to offer completions in comments and strings." - :type 'boolean - :group 'merlin) - -;; Internal functions - -(defun merlin-company--get-candidate-type (candidate) - (get-text-property 0 'merlin-compl-type candidate)) - -(defun merlin-company--get-candidate-doc (candidate) - (get-text-property 0 'merlin-compl-doc candidate)) - -(defun merlin-company--is-module (candidate) - (string-equal (merlin-company--get-candidate-type candidate) " ")) - -(defun merlin-company--has-doc (candidate) - (not (or (string-equal (merlin-company--get-candidate-doc candidate) "") - (merlin-company--is-module candidate)))) - -(defun merlin-company--doc-buffer (candidate) - "Computes the /doc/ of CANDIDATE and returns the buffer where it printed it" - (cond - ((merlin-company--has-doc candidate) - (let* ((doc (merlin-company--get-candidate-doc candidate)) - ; We add (** and *) around documentation so we can reuse the type buffer - ; without getting some weird highlighting. - (doc (concat - "val " candidate " : " - (merlin-company--get-candidate-type candidate) - "\n\n(** " doc " *)"))) - (merlin-display-in-type-buffer doc))) - - ((merlin-company--is-module candidate) - (merlin-display-in-type-buffer - (merlin-call "type-expression" - "-position" (merlin-unmake-point (point)) - "-expression" (substring-no-properties candidate)))) - - (t (merlin-display-in-type-buffer - (merlin-company--get-candidate-type candidate)))) - (get-buffer merlin-type-buffer-name)) - -(defun merlin-company--meta (candidate) - "Computes the information to display in the minibuffer for CANDIDATE" - (let* ((arg-type (get-text-property 0 'merlin-arg-type candidate)) - (entry-ty (merlin-company--get-candidate-type candidate)) - (default (if (and merlin-completion-arg-type arg-type) - (concat "Expected argument type: " arg-type) - entry-ty))) - (cond - ((merlin-company--has-doc candidate) - (concat default " (press F1 to display documentation of " candidate ")")) - ((merlin-company--is-module candidate) - (concat "Press F1 to display the signature of module " candidate - " (successive calls will expand aliases)")) - (t default)))) - -;; Public functions -;;;###autoload -(defun merlin-company-backend (command &optional arg &rest ignored) - (interactive (list 'interactive)) - (when merlin-mode - (cl-case command - (interactive (company-begin-backend 'merlin-company-backend)) - (prefix - (let* ((bounds (merlin-completion-bounds)) - (result (merlin-buffer-substring (car bounds) (cdr bounds)))) - (when (and (boundp 'company-candidates-cache) - (or (string-match-p "\\.$" result) - (member '("" "") company-candidates-cache))) - ;; for some reason, company doesn't always clear its cache - (setq company-candidates-cache nil)) - result)) - (no-cache t) - (sorted t) - (init t) - (require-match 'never) - (doc-buffer (merlin-company--doc-buffer arg)) - (location - (ignore-errors - (let ((data (merlin-call-locate arg))) - (when (listp data) - (let ((filename (merlin-lookup 'file data (buffer-file-name))) - (linum (cdr (assoc 'line (assoc 'pos data))))) - (cons filename linum)))))) - (candidates - (when (or merlin-company-everywhere (not (company-in-string-or-comment))) - (let ((prefix (merlin-completion-prefix arg))) - (cl-loop for x in (merlin-complete arg) - collect - (propertize (merlin-completion-entry-text prefix x) - 'merlin-compl-type - (merlin-completion-entry-short-description x) - 'merlin-arg-type (cdr (assoc 'argument_type x)) - 'merlin-compl-doc (cdr (assoc 'info x))))))) - (post-completion - (let ((minibuffer-message-timeout nil)) - (minibuffer-message "%s : %s" arg (merlin-company--get-candidate-type arg)))) - (meta (merlin-company--meta arg)) - (annotation - (concat " : " (merlin-company--get-candidate-type arg)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Register into company-mode ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(add-to-list 'company-backends 'merlin-company-backend) - -(provide 'merlin-company) -;;; merlin-company.el ends here diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin-iedit.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin-iedit.el deleted file mode 100644 index aaafc7c3d..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin-iedit.el +++ /dev/null @@ -1,66 +0,0 @@ -;;; merlin-iedit.el --- Merlin and iedit integration. -*- coding: utf-8; lexical-binding: t -*- -;; Licensed under the MIT license. - -;; Author: Simon Castellan -;; Frédéric Bour -;; Thomas Refis -;; Created: 27 June 2014 -;; Version: 0.1 -;; Keywords: ocaml languages -;; Package-Requires: ((emacs "25.1") (merlin "3") (iedit "0.9")) -;; URL: http://github.com/ocaml/merlin - -;;; Commentary: - -;; Provides the command `merlin-iedit-occurrences', which allows the -;; user to edit all the occurrences of the identifier at point using -;; `iedit'. - -;;; Code: - -(require 'merlin) -(require 'cl-lib) -(require 'iedit) - -(defun merlin-iedit--printable (&rest _args) - "Stub substituting `iedit-printable' during merlin-iedit-occurrences." - "merlin-iedit-occurrences") - -(defun merlin-iedit--make-occurrences-overlays (occurrences) - "Stub substituting `iedit-make-occurrences-overlays' during -merlin-iedit-occurrences." - (setq iedit-aborting nil) - (setq iedit-occurrences-overlays nil) - (setq iedit-read-only-occurrences-overlays nil) - (save-excursion - (save-window-excursion - (dolist (pos occurrences) - (let* ((start (assoc 'start pos)) - (end (assoc 'end pos)) - (beginning (merlin-make-point start)) - (ending (merlin-make-point end))) - (if (text-property-not-all beginning ending 'read-only nil) - (push (iedit-make-read-only-occurrence-overlay beginning ending) - iedit-read-only-occurrences-overlays) - (push (iedit-make-occurrence-overlay beginning ending) - iedit-occurrences-overlays)))))) - (length occurrences)) - -;;;###autoload -(defun merlin-iedit-occurrences () - "Edit occurrences of identifier under cursor using `iedit'." - (interactive) - (if iedit-mode (iedit-mode -1) - (let ((r (merlin-call "occurrences" - "-identifier-at" (merlin-unmake-point (point))))) - (when r - (if (listp r) - (cl-letf (((symbol-function 'iedit-printable) #'merlin-iedit--printable) - ((symbol-function 'iedit-make-occurrences-overlays) - (lambda (a _b _c) - (merlin-iedit--make-occurrences-overlays a)))) - (iedit-start r (point-min) (point-max))) - (message r)))))) - -(provide 'merlin-iedit) -;;; merlin.el ends here diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin-imenu.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin-imenu.el deleted file mode 100644 index 4e916af07..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin-imenu.el +++ /dev/null @@ -1,117 +0,0 @@ -;;; merlin-imenu.el --- Merlin and imenu integration. -*- coding: utf-8; lexical-binding: t -*- -;; Licensed under the MIT license. - -;; Author: tddsg (Ta Quang Trung) -;; Version: 0.3 -;; Release log: -;; - v0.1: July 2016 -;; - v0.2: 27 April 2017 -;; - v0.3: 21 August 2019 -;; Keywords: ocaml, imenu, merlin -;; URL: - -(require 'imenu) -(require 'subr-x) -(require 'merlin) - -;; lists of different outline items -(defvar-local merlin-imenu--value-list nil) -(defvar-local merlin-imenu--type-list nil) -(defvar-local merlin-imenu--exception-list nil) -(defvar-local merlin-imenu--module-list nil) -(defvar-local merlin-imenu--signature-list nil) -(defvar-local merlin-imenu--class-list nil) -(defvar-local merlin-imenu--method-list nil) - -(defun merlin-imenu-compute-position (line col) - "Get location of the item." - (save-excursion - (condition-case nil - (progn - (goto-char (point-min)) - (forward-line (- line 1)) - (move-to-column col) - (point)) - (error -1)))) - -(defun merlin-imenu-create-entry (prefix name type kind line col) - (let* ((name (concat prefix name)) - (type (cond ((not (string= kind "Value")) "null") - ((not (string= type "null")) type) - (t (let* ((types (merlin-call - "type-enclosing" - "-position" (format "%d:%d" line col) - "-expression" name))) - (cdr (nth 3 (car types))))))) - (type (replace-regexp-in-string "\n" " " type)) - (type (propertize type 'face 'font-lock-doc-face))) - (if (string= type "null") name (concat name " : " type)))) - -(defun merlin-imenu-parse-outline (prefix outline) - (dolist (item outline) - (let* ((line (cdr (assoc 'line (assoc 'start item)))) - (col (cdr (assoc 'col (assoc 'start item)))) - (name (cdr (assoc 'name item))) - (kind (cdr (assoc 'kind item))) - (type (cdr (assoc 'type item))) - (sub-trees (cdr (assoc 'children item))) - (entry (merlin-imenu-create-entry prefix name type kind line col)) - (position (merlin-imenu-compute-position line col)) - (marker (cons entry (set-marker (make-marker) position)))) - (cond ((string= kind "Value") - (setq merlin-imenu--value-list (cons marker merlin-imenu--value-list))) - ((string= kind "Type") - (setq merlin-imenu--type-list (cons marker merlin-imenu--type-list))) - ((string= kind "Module") - (setq merlin-imenu--module-list (cons marker merlin-imenu--module-list))) - ((string= kind "Signature") - (setq merlin-imenu--signature-list (cons marker merlin-imenu--signature-list))) - ((string= kind "Class") - (setq merlin-imenu--class-list (cons marker merlin-imenu--class-list))) - ((string= kind "Method") - (setq merlin-imenu--method-list (cons marker merlin-imenu--method-list))) - ((string= kind "Exn") - (setq merlin-imenu--exception-list (cons marker merlin-imenu--exception-list)))) - (when sub-trees - (merlin-imenu-parse-outline (concat entry ".") sub-trees))))) - -(defun merlin-imenu-create-index () - "Create data for imenu using the merlin outline feature." - ;; Reset local vars - (setq merlin-imenu--value-list nil - merlin-imenu--type-list nil - merlin-imenu--module-list nil - merlin-imenu--signature-list nil - merlin-imenu--class-list nil - merlin-imenu--method-list nil - merlin-imenu--exception-list nil) - ;; Read outline tree - (merlin-imenu-parse-outline "" (merlin-call "outline")) - (let ((index nil)) - (when merlin-imenu--value-list - (push (cons "Value" merlin-imenu--value-list) index)) - (when merlin-imenu--exception-list - (push (cons "Exception" merlin-imenu--exception-list) index)) - (when merlin-imenu--type-list - (push (cons "Type" merlin-imenu--type-list) index)) - (when merlin-imenu--module-list - (push (cons "Module" merlin-imenu--module-list) index)) - (when merlin-imenu--signature-list - (push (cons "Signature" merlin-imenu--signature-list) index)) - (when merlin-imenu--class-list - (push (cons "Class" merlin-imenu--class-list) index)) - (when merlin-imenu--method-list - (push (cons "Method" merlin-imenu--method-list) index)) - index)) - -;;;###autoload -(defun merlin-use-merlin-imenu () - "Merlin: use the custom imenu feature from Merlin" - (interactive) - ;; change the index function and force a rescan of imenu-index - (setq imenu-create-index-function 'merlin-imenu-create-index) - (imenu--cleanup) - (setq imenu--index-alist nil)) - -(provide 'merlin-imenu) -;;; merlin-imenu.el ends here diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin-xref.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin-xref.el deleted file mode 100644 index 31f23f332..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin-xref.el +++ /dev/null @@ -1,38 +0,0 @@ -;; -*- lexical-binding: t -*- -(require 'cl-lib) -(require 'xref) -(require 'merlin) - -;;;###autoload -(defun merlin-xref-backend () - "Merlin backend for Xref." - 'merlin-xref) - -(defun merlin-xref--line (loc) - (save-excursion - (goto-char loc) - (buffer-substring (line-beginning-position) (line-end-position)))) - -(cl-defmethod xref-backend-references ((_backend (eql merlin-xref)) _symbol) - (mapcar - (lambda (loc) - (let ((pt (merlin-make-point (alist-get 'start loc)))) - (xref-make (merlin-xref--line pt) - (xref-make-buffer-location (current-buffer) pt)))) - (merlin--occurrences))) - -(cl-defmethod xref-backend-definitions ((_backend (eql merlin-xref)) _symbol) - (let* ((loc (merlin-call-locate)) - (file (alist-get 'file loc)) - (pos (alist-get 'pos loc)) - (line (alist-get 'line pos)) - (col (alist-get 'col pos))) - (save-excursion - (find-file file) - (let ((desc (merlin-xref--line (merlin-make-point pos)))) - (list (xref-make desc (xref-make-file-location file line col))))))) - -(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql merlin-xref))) - nil) - -(provide 'merlin-xref) diff --git a/ocaml-lsp-server/vendor/merlin/emacs/merlin.el b/ocaml-lsp-server/vendor/merlin/emacs/merlin.el deleted file mode 100644 index 74dc9d868..000000000 --- a/ocaml-lsp-server/vendor/merlin/emacs/merlin.el +++ /dev/null @@ -1,2066 +0,0 @@ -;;; merlin.el --- Mode for Merlin, an assistant for OCaml -*- coding: utf-8; lexical-binding: t -*- - -;; Licensed under the MIT license. - -;; Author: Frédéric Bour -;; Created: 30 August 2016 -;; Version: 3.0 -;; Keywords: ocaml languages -;; Package-Requires: ((emacs "25.1")) -;; URL: https://github.com/ocaml/merlin - -;;; Commentary: -;; merlin-mode is an Emacs interface to merlin. It allows you to perform -;; queries such as getting the type of an expression, completion, and so on. - -;; Installation: -;; You need merlin installed on your system (ocamlmerlin binary) for merlin-mode -;; to work. - -;;; Usage: -;; TODO - -;;; Code: - -(require 'cl-lib) -(require 'crm) ;; for completing-read-multiple -;; caml-types for highlighting -;; (https://github.com/ocaml/merlin/issues/331) -(require 'caml-types nil 'noerror) - -;; silence free variable warning -(defvar merlin-mode) - -(defgroup merlin nil - "merlin binding mode allowing completion and typing in OCaml files." - :group 'languages :prefix "merlin-") - -;; -;; Faces -;; - -(defface merlin-type-face - '((t :inherit caml-types-expr-face)) - "Face for highlighting a typed expr." - :group 'merlin) - -(defface merlin-compilation-warning-face - '((t :inherit compilation-warning)) - "Face to use to highlight merlin warnings." - :group 'merlin) - -(defface merlin-compilation-error-face - '((t :inherit compilation-error)) - "Face to use to highlight merlin errors." - :group 'merlin) - -;; -;; Customizable vars -;; - -(defcustom merlin-show-instance-in-lighter t - "Show the current instance of the buffer in the lighter." - :group 'merlin :type 'boolean) - -(defcustom merlin-report-errors-in-lighter nil - "Report absence of .merlin or errors in .merlin in the lighter." - :group 'merlin :type 'boolean) - -(defcustom merlin-client-log-function nil - "The function takes four arguments: - - the path to the merlin binary - - the name of the command - - the total time spent in the server (or -1 if that information - is not available) - - the resulting state (\"return\", \"failure\" or \"interrupted\") -Its return value is ignored." - :group 'merlin :type 'symbol) - -(defcustom merlin-configuration-function nil - "The function takes no argument and returns the configuration for the current -buffer, in a form suitable for `merlin-buffer-configuration'." - :group 'merlin :type 'symbol) - -(defcustom merlin-grouping-function nil - "Deprecated, see `merlin-configuration-function'." - :group 'merlin :type 'symbol) - -(defcustom merlin-command 'opam - "The path to merlin in your installation." - :group 'merlin :type '(choice (file :tag "Filename (default binary is \"ocamlmerlin\")") - (function :tag "Function returning path to the binary") - (const :tag "Use current opam switch" opam))) - -(defcustom merlin-completion-with-doc nil - "If non-nil, tries to retrieve ocamldoc comments associated with each -completion candidate." - :group 'merlin :type 'boolean) - -(defcustom merlin-completion-dwim t - "If non-nil, fallback to fuzzier completion when normal completion gives -no result." - :group 'merlin :type 'boolean) - -(defcustom merlin-completion-types t - "If non-nil, print the types of the variables during completion." - :group 'merlin :type 'boolean) - -(defcustom merlin-completion-arg-type t - "If non-nil, print the type of the expected argument during completion -on an application." - :group 'merlin :type 'boolean) - -(defcustom merlin-debug nil - "If non-nil, log the data sent and received from merlin into -`merlin-log-buffer-name' buffer." - :group 'merlin :type 'boolean) - -(defcustom merlin-report-warnings t - "If non-nil, report warnings, otherwise ignore them." - :group 'merlin :type 'boolean) - -(defcustom merlin-occurrences-buffer-name "*merlin-occurrences*" - "The name of the buffer listing occurrences of an identifier after -a call to `merlin-occurrences'." - :group 'merlin :type 'string) - -(defcustom merlin-type-buffer-name "*merlin-types*" - "The name of the buffer storing module signatures." - :group 'merlin :type 'string) - -(defcustom merlin-error-buffer-name "*merlin-errors*" - "The name of the buffer storing module signatures." - :group 'merlin :type 'string) - -(defcustom merlin-log-buffer-name "*merlin-log*" - "The name of the buffer storing log messages and debug information. -See `merlin-debug'." - :group 'merlin :type 'string) - -(defcustom merlin-favourite-caml-mode nil - "The OCaml mode to use for the *merlin-types* buffer." - :group 'merlin :type 'symbol) - -(defcustom merlin-error-after-save '("ml" "mli") - "Determines whether merlin should check for errors after saving. -If t, always check for errors after saving. -If nil, never check. -If a string list, check only if the extension of the buffer-file-name - is in the list." - :group 'merlin :type '(choice (repeat string) boolean)) - -(defcustom merlin-error-in-fringe (>= emacs-major-version 24) - "If non-nil, display errors in fringe" - :group 'merlin :type 'boolean) - -(defcustom merlin-error-on-single-line nil - "Only highlight first line of multi-line error messages" - :group 'merlin :type 'boolean) - -(defcustom merlin-error-check-then-move t - "If t, merlin-error-next and merlin-error-prev first update the errors -then move the cursor. -If nil, they both update and move at the same time." - :group 'merlin :type 'boolean) - -(defcustom merlin-default-flags nil - "The flags to pass to ocamlmerlin." - :group 'merlin :type '(repeat string)) - -(defcustom merlin-occurrences-show-buffer 'other - "Determine how to display the occurrences list after a call to -`merlin-occurrences'." - :group 'merlin :type '(choice (const :tag "Don't show list" never) - (const :tag "Show in the current window" same) - (const :tag "Show in another window" other))) - -(defcustom merlin-locate-in-new-window 'diff - "Determine whether to display results of `merlin-locate' in -a new window or not." - :group 'merlin :type '(choice (const :tag "Always open a new window" always) - (const :tag "Never open a new window" never) - (const :tag "Open a new window only if the target file is different from current buffer." diff))) - -(defcustom merlin-locate-preference 'ml - "Determine whether locate should in priority look in ml or mli files." - :group 'merlin :type '(choice (const :tag "Look at implementation" ml) - (const :tag "Look at interfaces" mli))) - -(defcustom merlin-locate-focus-new-window t - "If non-nil, when locate opens a new window it will give it the focus." - :group 'merlin :type 'boolean) - -(defcustom merlin-logfile nil - "If non-nil, use this file for the log file (should be an absolute path)." - :group 'merlin :type 'filename) - -(defcustom merlin-arrow-keys-type-enclosing t - "If non-nil, after a type enclosing, C-up and C-down are used -to go up and down the AST. In addition, C-w copies the type to the -kill ring and C-d destructures the expression." - :group 'merlin :type 'boolean) - -(defcustom merlin-type-after-locate nil - "If non-nil, use type-enclosing after locate." - :group 'merlin :type 'boolean) - -(defcustom merlin-allow-sit-for t - "When user attention is required, merlin will use `sit-for' only if -`merlin-allow-sit-for' is `t'." - :group 'merlin :type 'boolean) - -(defalias 'merlin-find-file 'find-file-other-window - "The function called when merlin try to open a file (doesn't apply to -merlin-locate, see `merlin-locate-in-new-window').") - -;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Buffer local settings ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar-local merlin-buffer-configuration nil - "An association list describing the configuration of merlin binary for the -current buffer. Customize `merlin-configuration-function` to initialize it. -The association list can contain the following optional keys: -- `flags': extra flags to give merlin - -- `command': command to run - -- `env': list of strings (of the shape VARIABLE=FOO) (see -`process-environment') that will be prepended to the environment of merlin - -- `dot-merlin': path to a .merlin file - -- `logfile': path to the logfile - -- `name': a short name for this configuration, displayed in user notifications. - -- `do-not-cache-config': if set, refreshes the config on every command") - -(defvar-local merlin-buffer-packages nil - "List of packages loaded in the buffer") - -(defvar-local merlin-buffer-packages-path nil - "List of path of packages loaded in the buffer") - -(defvar-local merlin-buffer-extensions nil - "List of syntax extensions active in the buffer") - -(defvar-local merlin-buffer-flags "" - "Additional flags to pass to merlin") - -;;;;;;;;;;;;;;;;;;;;;;;; -;; Internal variables ;; -;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar merlin-opam-bin-path nil) - -;; If user did not specify its merlin-favourite-caml-mode, try to guess it from -;; the buffer being edited -(defvar merlin-guessed-favorite-caml-mode nil) - -(defvar merlin--idle-timer nil) - -;; Errors related variables - -(defvar-local merlin-erroneous-buffer nil - "Whether the buffer is erroneous or not") - -(defvar merlin-highlight-overlay nil - "Merlin overlay used for highlights.") - -;; Type related variables - -(defvar-local merlin-enclosing-types nil - "List containing the enclosing type.") - -(defvar-local merlin-enclosing-offset nil - "Current offset in `merlin-enclosing-types'.") - -;; Locate - -(defvar merlin-position-stack nil) - -;; Verbosity - -(defconst merlin-verbosity-context nil - "If non-nil, a simple key used to determine verbosity") - -(defvar-local merlin--verbosity-cache nil - "Cache last command to determine verbosity level") - -(defvar-local merlin-debug-last-commands nil - "Last merlin commands (for debugging)") - -;; Misc - -(defvar-local merlin--project-cache nil - "Cache for merlin--project-get") - -(defvar-local merlin--dwimed nil - "Remember if we used dwim for the current completion or not") - -;;;;;;;;;;; -;; UTILS ;; -;;;;;;;;;;; - -(defun merlin--completion-map-with-space (&optional map) - "Return a map suitable for `minibuffer-local-completion-map' -but not overriding SPC binding." - (unless map (setq map minibuffer-local-completion-map )) - (setq map (make-composed-keymap nil map)) - (define-key map (kbd "SPC") nil) - map) - -(defun merlin-debug (message &rest args) - "Output S to `merlin-log-buffer-name' if `merlin-debug' is non-nil -in the current buffer." - (when merlin-debug - (with-current-buffer (get-buffer-create merlin-log-buffer-name) - (goto-char (point-max)) - (if args (insert (apply 'format message args)) - (insert message))))) - -(defun merlin-enable-debug () - "Start recording merlin debug information to `merlin-log-buffer-name'." - (interactive) - (setq merlin-debug t) - (message "merlin: logging to %S buffer" merlin-log-buffer-name)) - -(defun merlin-disable-debug () - "Stop recording debug information." - (interactive) - (setq merlin-debug nil)) - -(defun merlin-debug-last-commands () - "Display last commands executed and their result (if any)" - (interactive) - (let (buf) - (dolist (command merlin-debug-last-commands) - (push (concat "- result: " (or (cdr command) "failed")) buf) - (push (mapconcat 'identity - (merlin--map-flatten-to-string "command: " (car command)) - " ") buf)) - (message "Last commands executed, most recent at the end:\n%s" - (mapconcat 'identity buf "\n")))) - -(defun merlin-buffer-substring (start end) - "Return content of buffer between two points or empty string -if points are not valid." - (if (< start end) (buffer-substring-no-properties start end) "")) - -(defsubst merlin-lookup (key list &optional default) - "Lookup KEY in LIST which is a list of pairs. If not found, -return DEFAULT or the value associated to KEY." - (assoc-default key list nil default)) - -(defun merlin--differs-from-current-file (path) - (not (string-equal path (buffer-file-name)))) - -(defun merlin--rev-map-flatten (f xs &optional acc) - (while (consp xs) - (setq acc (if (listp (car xs)) - (merlin--rev-map-flatten f (car xs) acc) - (cons (funcall f (car xs)) acc))) - (setq xs (cdr xs))) - (when xs - (setq acc (cons xs acc))) - acc) - -(defun merlin--map-flatten (f &rest xs) - (nreverse (merlin--rev-map-flatten f xs))) - -(defun merlin--map-flatten-to-string (&rest xs) - (merlin--map-flatten - (lambda (x) (if (stringp x) x (prin1-to-string x))) xs)) - -(defun merlin--goto-file-and-point (data) - "Go to the file and position indicated by DATA which is an assoc list -containing fields file, line and col." - (let* ((file (assoc 'file data)) - (open-window (cond ((equal merlin-locate-in-new-window 'never) nil) - ((equal merlin-locate-in-new-window 'always)) - (file (merlin--differs-from-current-file (cdr file))))) - (filename (if file (cdr file) (buffer-file-name (buffer-base-buffer)))) - (focus-window (or (not open-window) merlin-locate-focus-new-window)) - (do-open (lambda () - (push-mark) - (if open-window - (find-file-other-window filename) - (find-file filename)) - (merlin--goto-point (cdr (assoc 'pos data)))))) - (if focus-window - (progn - (push (cons (buffer-name) (point)) merlin-position-stack) - (funcall do-open) - (message "Use %s to go back." - (substitute-command-keys "\\[merlin-pop-stack]"))) - (save-excursion (save-selected-window (funcall do-open)))))) - -(defun merlin-add-display-properties (overlay bitmap string &optional face) - "Add the necessary properties to OVERLAY to display it nicely." - (let ((prop (if window-system - `(left-fringe ,bitmap . ,(if face (list face) nil)) - `((margin left-margin) ,string)))) - (when face (overlay-put overlay 'face face)) - (overlay-put overlay 'before-string - (propertize " " 'display prop)))) - -(defun merlin--highlight (bounds face) - "Create an overlay on BOUNDS (of the form (START . END)) and give it FACE." - (remove-overlays nil nil 'merlin-kind 'highlight) - (let ((overlay (make-overlay (car bounds) (cdr bounds)))) - (overlay-put overlay 'face face) - (overlay-put overlay 'merlin-kind 'highlight) - (if merlin-allow-sit-for - (unwind-protect (sit-for 60) (delete-overlay overlay)) - (run-with-idle-timer 0.5 nil - (lambda () (delete-overlay overlay)))))) - -;; Position management - -(defun merlin--goto-point (data) - "Go to the point indicated by DATA which must be an assoc list with fields -line and col. If narrowing is in effect, widen if DATA is outside the visible -region." - (let ((target-pos (merlin--point-of-pos data))) - ;; If our target position is outside the narrowed region, we'll - ;; have to widen. - (when (or (< target-pos (point-min)) - (> target-pos (point-max))) - (widen)) - (goto-char target-pos))) - -(defun merlin--point-of-pos (data) - "Transform DATA (a remote merlin position) into a point. -DATA must be an assoc list with fields line and col." - (let ((line-num (merlin-lookup 'line data 0)) - (col-byte-offset (merlin-lookup 'col data 0))) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- line-num)) - ;; Find the target position, converting the byte position to a - ;; character offset. - (let* ((bol-offset (position-bytes (point))) - (col-offset (max 0 col-byte-offset)) - (target-off (+ bol-offset col-offset))) - (byte-to-position target-off)))))) - -(defun merlin-make-point (data) - "Transform DATA (a remote merlin position) into a point." - (merlin--point-of-pos data)) - -(defun merlin-unmake-point (point) - "Destruct POINT to line / col." - (save-excursion - (save-restriction - (widen) - (goto-char point) - (format "%d:%d" (line-number-at-pos) - (- (position-bytes (point)) - (position-bytes (line-beginning-position))))))) - -(define-obsolete-function-alias 'merlin/unmake-point 'merlin-unmake-point "2021-01-27") - -(defun merlin--make-bounds (data) - "From a remote merlin object DATA {\"start\": LOC1; \"end\": LOC2}, -return (LOC1 . LOC2)." - (cons - (merlin-make-point (cdr (assoc 'start data))) - (merlin-make-point (cdr (assoc 'end data))))) - -;;;;;;;;;;;;;;;;;;;;;;;; -;; PROCESS MANAGEMENT ;; -;;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin--call-process (path args) - "Some workarounds for piping buffer content to a process" - (merlin-debug "# calling binary: %S with arguments: %S.\n" path args) - (let ((ib (current-buffer)) - (tmp (when merlin-debug (make-temp-file "merlin"))) - (wd (expand-file-name default-directory)) - result) - (with-temp-buffer - (let ((ob (current-buffer))) - (with-current-buffer ib - (save-restriction - (widen) - (let ((default-directory wd)) - (apply 'call-process-region (point-min) (point-max) path nil - (list ob tmp) nil args))))) - (setq result (buffer-string)) - (merlin-debug "# stdout\n%s" result) - (when tmp - (with-demoted-errors "Error when trying to read merlin log: %S" - (with-current-buffer merlin-log-buffer-name - (goto-char (point-max)) - (insert "# stderr\n") - (insert-file-contents tmp) - (delete-file tmp)))) - result))) - -(defun merlin--call-merlin (command &rest args) - "Invoke merlin binary with the proper setup to execute the command passed as -argument (lookup appropriate binary, setup logging, pass global settings)" - ;; Really start process - (let ((binary (merlin-command)) - ;; (flags (merlin-lookup 'flags merlin-buffer-configuration)) - (process-environment (cl-copy-list process-environment)) - (dot-merlin (merlin-lookup 'dot-merlin merlin-buffer-configuration)) - ;; FIXME use logfile - ;; (logfile (or (merlin-lookup 'logfile merlin-buffer-configuration) - ;; merlin-logfile)) - (extensions (merlin--map-flatten (lambda (x) (cons "-extension" x)) - merlin-buffer-extensions)) - (packages (merlin--map-flatten (lambda (x) (cons "-I" x)) - merlin-buffer-packages-path)) - (filename (buffer-file-name (buffer-base-buffer)))) - ;; Update environment - (dolist (binding (merlin-lookup 'env merlin-buffer-configuration)) - (let* ((equal-pos (string-match-p "=" binding)) - (prefix (if equal-pos - (substring binding 0 (1+ equal-pos)) - binding)) - (is-prefix (lambda (x) (string-prefix-p prefix x)))) - (setq process-environment (cl-delete-if is-prefix process-environment)) - (when equal-pos - (setq process-environment (cons binding process-environment))))) - ;; Compute verbosity - (when (eq merlin-verbosity-context t) - (setq merlin-verbosity-context (cons command args))) - (if (not merlin-verbosity-context) - (setq merlin--verbosity-cache nil) - (if (equal merlin-verbosity-context (car-safe merlin--verbosity-cache)) - (setcdr merlin--verbosity-cache (1+ (cdr merlin--verbosity-cache))) - (setq merlin--verbosity-cache (cons merlin-verbosity-context 0)))) - ;; Compute full command line. - (setq args (merlin--map-flatten-to-string - "server" command "-protocol" "sexp" - (when dot-merlin - (list "-dot-merlin" dot-merlin)) - ;; Is debug mode enabled - (when merlin-debug '("-log-file" "-")) - ;; If command is repeated, increase verbosity - (when merlin-verbosity-context - (list "-verbosity" (cdr merlin--verbosity-cache))) - packages - extensions - (unless (string-equal merlin-buffer-flags "") - (cons "-flags" merlin-buffer-flags)) - (when filename - (cons "-filename" filename)) - args)) - ;; Log last commands - (setq merlin-debug-last-commands - (cons (cons (cons binary args) nil) merlin-debug-last-commands)) - (let ((cdr (nthcdr 5 merlin-debug-last-commands))) - (when cdr (setcdr cdr nil))) - ;; Call merlin process - (setcdr (car merlin-debug-last-commands) (merlin--call-process binary args)))) - -(defun merlin-client-logger (binary cmd timing result) - (when merlin-client-log-function - (funcall merlin-client-log-function binary cmd timing result))) - -(defun merlin-call (command &rest args) - "Execute a command and parse output: return an sexp on success or throw an error" - (let* ((binary (merlin-command)) - (result (merlin--call-merlin command args))) - (condition-case err - (setq result (car (read-from-string result))) - (error - (merlin-client-logger binary command -1 "failure") - (error "merlin: error %s trying to parse answer: %s" - err result)) - (quit - (merlin-client-logger binary command -1 "interrupted"))) - (let* ((notifications (cdr-safe (assoc 'notifications result))) - (timing (cdr-safe (assoc 'timing result))) - (class (cdr-safe (assoc 'class result))) - (value (cdr-safe (assoc 'value result)))) - (merlin-client-logger binary command timing class) - (dolist (notification notifications) - (message "(merlin) %s" notification)) - (pcase class - ("return" value) - ("failure" (error "merlin-mode failure: %s" value)) - ("error" (error "merlin: %s" value)) - (_ (error "unknown answer: %S:%S" class value)))))) - -(define-obsolete-function-alias 'merlin/call 'merlin-call "2021-01-27") - -(defun merlin-stop-server () - "Shutdown merlin server." - (interactive) - (unless merlin-mode (message "Buffer is not managed by merlin.")) - (when merlin-mode - (merlin--call-merlin "stop-server") - ;; These are buffer-local variables, so reset them in all buffers. - (dolist (buf (buffer-list)) - (with-current-buffer buf - (kill-local-variable 'merlin-buffer-configuration) - (kill-local-variable 'merlin-erroneous-buffer))))) - -;;;;;;;;;;;;;;;;;;;; -;; FILE SWITCHING ;; -;;;;;;;;;;;;;;;;;;;; - -(defun merlin-switch-list-by-ext (&rest exts) - "List filenames ending by any of EXTS in the path." - (merlin-call "list-modules" - (merlin--map-flatten (lambda (x) (cons "-ext" x)) exts))) - -(defun merlin-switch-to (name &rest exts) - "Switch to NAME.EXTS." - (let ((file (merlin-call "path-of-source" - (merlin--map-flatten - (lambda (ext) (cons "-file" (concat name ext))) exts)))) - (when file (merlin-find-file file)))) - -(defun merlin-switch-to-ml (name) - "Switch to the ML file corresponding to the module NAME -(fallback to MLI if no ML is provided)." - (interactive (list (ido-completing-read "Module: " - (merlin-switch-list-by-ext '(".ml" ".mli"))))) - (merlin-switch-to name '(".ml" ".mli"))) - -(defun merlin-switch-to-mli (name) - "Switch to the MLI file corresponding to the module NAME -(fallback to ML if no MLI is provided)." - (interactive (list (ido-completing-read "Module: " - (merlin-switch-list-by-ext '(".mli" ".ml"))))) - (merlin-switch-to name '(".mli" ".ml"))) - -;;;;;;;;;;;;;;;;;; -;; ERROR BUFFER ;; -;;;;;;;;;;;;;;;;;; - -(defvar merlin-error-buffer-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map special-mode-map) - (define-key map "g" nil) - map) - "Keymap for error buffer.") - -(defun merlin-display-in-error-buffer (text) - "Change content of error-buffer." - (let ((curr-dir default-directory)) - (with-current-buffer (get-buffer-create merlin-error-buffer-name) - (read-only-mode 0) - (erase-buffer) - (insert text) - (goto-char (point-min)) - (read-only-mode 1) - (use-local-map merlin-error-buffer-map) - ;; finally make sure that the error buffer directory is the same as the - ;; last (ml) buffer we were in. - ;; Indeed if people move to that buffer and start looking for a file we - ;; want them to be in the directory they were in when they last requested a - ;; type, not in the directory they were in when they first requested a - ;; type (for long lived emacs sessions that directory might not even exist - ;; anymore). - (setq default-directory curr-dir)))) - -(defun merlin--error-display (err) - "Display the error ERR." - (if (not err) - (message "") - (merlin-display-in-error-buffer err) - (message "%s" err))) - -;;;;;;;;;;;;;;;;;; -;; ERROR REPORT ;; -;;;;;;;;;;;;;;;;;; - -(defvar-local merlin--last-edit nil - "Coordinates (start . end) of last edit or nil, to prevent error messages -from flickering when cursor is around the edit.") - -(defun merlin--on-edit (start end _length) - "Memorize coordinates of last edition to avoid flickering error messages -around the cursor" - (setq merlin--last-edit (cons start end))) - -(defun merlin--error-position-delta (point err) - "Distance between point and error." - (setq err (cdr (assoc 'bounds err))) - (cond ((< point (car err)) (cons (- (car err) point) 0)) - ((> point (cdr err)) (cons (- point (cdr err)) 0)) - (t (cons 0 (min (- (cdr err) point) (- point (car err))))))) - -(defun merlin--error-at-position (point errors) - "Returns error from ERRORS list most relevant at POINT" - (let ((err nil) (d nil)) - (dolist (err- errors err) - (let ((d- (merlin--error-position-delta point err-))) - (when (or (not err) (< (car d-) (car d)) - (and (= (car d-) (car d)) (< (cdr d-) (cdr d)))) - (setq d d-) (setq err err-)))))) - -(defun merlin-show-error-on-current-line () - "Show the error of the current line in the echo area. -If there is no error, do nothing." - (when (and merlin-mode (not (current-message))) - (let* ((errors (overlays-in (line-beginning-position) (line-end-position))) - (err nil)) - (when (or (not merlin--last-edit) - (not (or (= (point) (car merlin--last-edit)) - (= (point) (cdr merlin--last-edit))))) - (setq errors (remove nil (mapcar 'merlin--overlay-pending-error errors))) - (setq err (merlin--error-at-position (point) errors)) - (when err (merlin--error-display (cdr (assoc 'message err)))))))) - -(defun merlin--overlay-next-property-set (point prop &optional limit) - "Find next point where PROP is set. -(Like `next-single-char-property-change' but ensure that prop is not-nil)." - (setq point (next-single-char-property-change point prop nil limit)) - (unless (cl-find-if (lambda (a) (overlay-get a prop)) (overlays-at point)) - (setq point (next-single-char-property-change point prop nil limit))) - point) - -(defun merlin--overlay-previous-property-set (point prop &optional limit) - "Find previous point where PROP is set. -(Like `previous-single-char-property-change' but ensure that prop is not-nil)." - (setq point (previous-single-char-property-change point prop nil limit)) - (unless (cl-find-if (lambda (a) (overlay-get a prop)) (overlays-at point)) - (setq point (previous-single-char-property-change point prop nil limit))) - point) - -(defun merlin--has-error-group-overlay-at-point (point group) - (cl-some (lambda (err) (eq (overlay-get err 'merlin-error-group) group)) - (overlays-at point))) - -(defun merlin--error-group-next (point group &optional limit) - (let ((point (merlin--overlay-next-property-set point 'merlin-pending-error limit))) - (when group - (while (not (or (eq point (point-max)) - (merlin--has-error-group-overlay-at-point point group))) - (setq point (merlin--overlay-next-property-set point 'merlin-pending-error limit)))) - point)) - -(defun merlin--error-group-prev (point group &optional limit) - (let ((point (merlin--overlay-previous-property-set point 'merlin-pending-error limit))) - (when group - (while (not (or (eq point (point-min)) - (merlin--has-error-group-overlay-at-point point group))) - (setq point (merlin--overlay-next-property-set point 'merlin-pending-error limit)))) - point)) - -(defun merlin--errors-at-position (point) - (remove nil (mapcar 'merlin--overlay-pending-error (overlays-at point)))) - -(defun merlin--error-prev-cycle (group) - "Returns previous error, cycling when reaching beginning of buffer" - (let ((point (point)) (errors nil) (err nil)) - (setq point (merlin--error-group-prev point group)) - (unless (eq point (point)) (setq errors (merlin--errors-at-position point)) - (unless errors - (setq point (merlin--error-group-prev (point-max) group (point))) - (setq errors (merlin--errors-at-position point))) - (setq err (merlin--error-at-position point errors)) - (if err (cons point err) nil)))) - -(defun merlin--error-next-cycle (group) - "Returns next error, cycling when reaching end of buffer" - (let ((point (point)) (errors nil) (err nil)) - (setq point (merlin--error-group-next point group)) - (when (eq point (point-max)) - (setq point (point-min)) - (setq errors (merlin--errors-at-position point)) - (unless errors - (setq point (merlin--error-group-next (point-min) group (point))))) - (unless errors - (setq errors (merlin--errors-at-position point))) - (setq err (merlin--error-at-position point errors)) - (if err (cons point err) nil))) - -(defun merlin--after-save () - (when (and merlin-mode merlin-error-after-save) (merlin-error-check))) - -(defadvice basic-save-buffer (after merlin--after-save activate) - "The save hook is called only if buffer was modified, but user might want fresh errors anyway" - (merlin--after-save)) - -(defun merlin-error-prev (&optional group) - "Jump back to previous error." - (interactive) - (let ((old-errors merlin-erroneous-buffer)) - (merlin--error-check nil) - (let ((err (merlin--error-prev-cycle group))) - (unless (or err merlin-erroneous-buffer) (message "No errors")) - (when err - (if (and merlin-error-check-then-move - (not (equal old-errors merlin-erroneous-buffer))) - (message "(%d pending errors, use %s to jump)" - (length merlin-erroneous-buffer) - (substitute-command-keys "\\[merlin-error-prev]")) - (goto-char (car err)) - (message "%s" (cdr (assoc 'message (cdr err)))) - (merlin--highlight (cdr (assoc 'bounds (cdr err))) 'next-error)))))) - -(defun merlin-error-next (&optional group) - "Jump to next error." - (interactive) - (let ((old-errors merlin-erroneous-buffer)) - (merlin--error-check nil) - (let ((err (merlin--error-next-cycle group))) - (unless (or err merlin-erroneous-buffer) (message "No errors")) - (when err - (if (and merlin-error-check-then-move - (not (equal old-errors merlin-erroneous-buffer))) - (message "(%d pending errors, use %s to jump)" - (length merlin-erroneous-buffer) - (substitute-command-keys "\\[merlin-error-next]")) - (goto-char (car err)) - (message "%s" (cdr (assoc 'message (cdr err)))) - (merlin--highlight (cdr (assoc 'bounds (cdr err))) 'next-error)))))) - -(defun merlin-error-next-in-group () - "Jump to next error in same group, if any, next error otherwise." - (interactive) - (let ((err (merlin--error-at-position - (point) (merlin--errors-at-position (point))))) - (merlin-error-next (when err (overlay-get err 'merlin-error-group))))) - -(defun merlin-error-prev-in-group () - "Jump to previous error in same group, if any, previous error otherwise." - (interactive) - (let ((err (merlin--error-at-position - (point) (merlin--errors-at-position (point))))) - (merlin-error-prev (when err (overlay-get err 'merlin-error-group))))) - -(defun merlin--error-warning-p (msg) - "Tell if the message MSG is a warning." - (string-match-p "^Warning" msg)) - -(defun merlin-error-reset () - "Clear error list." - (interactive) - (setq merlin-erroneous-buffer nil) - (remove-overlays nil nil 'merlin-kind 'error)) - -(defun merlin--overlay-pending-error (overlay) - "Returns non-nil if OVERLAY is about a pending error." - (if overlay (overlay-get overlay 'merlin-pending-error) nil)) - -(defun merlin--kill-error-if-edited (overlay is-after _beg _end &optional _length) - "Remove an error from the pending error lists if it is edited by the user." - (when is-after (delete-overlay overlay))) - -(defun merlin--transform-add-error-bounds (err) - (let ((bounds (merlin--make-bounds err)) - (subs (cdr-safe (assoc 'sub err)))) - (when merlin-error-on-single-line - (setq bounds (cons (car bounds) - (min (cdr bounds) - (save-excursion - (goto-char (car bounds)) - (line-end-position)))))) - (when (= (car bounds) (cdr bounds)) - (setq bounds (if (> (car bounds) (point-min)) - (cons (1- (car bounds)) (cdr bounds)) - (cons (car bounds) (1+ (cdr bounds)))))) - (setq bounds (cons (copy-marker (car bounds)) - (copy-marker (cdr bounds)))) - (cl-acons 'sub (mapcar 'merlin--transform-add-error-bounds subs) - (cl-acons 'bounds bounds err)))) - -(defun merlin-transform-display-errors (errors) - "Populate the error list with ERRORS, transformed into an emacs-friendly -form. Do display of error list." - (setq errors (mapcar 'merlin--transform-add-error-bounds errors)) - (dolist (main errors) - (let ((subs (cdr-safe (assoc 'sub main)))) - (dolist (err (cons main subs)) - (let* ((bounds (cdr (assoc 'bounds err))) - (overlay (make-overlay (car bounds) (cdr bounds)))) - (overlay-put overlay 'merlin-kind 'error) - (overlay-put overlay 'merlin-pending-error err) - (overlay-put overlay 'merlin-error-group main) - (push #'merlin--kill-error-if-edited - (overlay-get overlay 'modification-hooks)) - (when (and merlin-error-in-fringe - (not (and (eq err main) subs))) - (if (merlin--error-warning-p (cdr (assoc 'message err))) - (merlin-add-display-properties overlay - 'question-mark - "?" - 'merlin-compilation-warning-face) - (merlin-add-display-properties overlay - 'exclamation-mark - "!" - 'merlin-compilation-error-face))))))) - errors) - -(defun merlin--error-check (view-errors-p) - "Check for errors. -Return t if there were not any or nil if there were. Moreover, it displays the -errors in the fringe. If VIEW-ERRORS-P is non-nil, display a count of them." - (merlin-error-reset) - (let* ((errors (merlin-call "errors")) - (no-loc (cl-remove-if (lambda (e) (assoc 'start e)) errors))) - (setq errors (cl-remove-if-not (lambda (e) (assoc 'start e)) errors)) - (unless merlin-report-warnings - (setq errors (cl-remove-if (lambda (e) - (or - (eq (cdr-safe (assoc 'message e)) "warning") - (merlin--error-warning-p (cdr (assoc 'message e))))) - errors))) - (setq merlin-erroneous-buffer (or errors no-loc)) - (dolist (e no-loc) - (message "%s" (cdr (assoc 'message e)))) - (merlin-transform-display-errors errors) - (when view-errors-p - (let ((prefix (current-message))) - (setq prefix (if prefix (concat prefix " ") "")) - (if merlin-erroneous-buffer - (message "%s(%d pending errors, use %s to jump)" - prefix - (length errors) - (substitute-command-keys "\\[merlin-error-next]")) - (message "%sNo errors" prefix)))))) - -(defun merlin-error-after-save () - "Determine whether the buffer should be checked for errors depending on -the value of merlin-error-after-save setting." - (cond - ((equal merlin-error-after-save t) t) - ((equal merlin-error-after-save nil) nil) - ((and (listp merlin-error-after-save) - (buffer-file-name (buffer-base-buffer))) - (member (file-name-extension (buffer-file-name (buffer-base-buffer))) - merlin-error-after-save)))) - -(defun merlin-toggle-view-errors () - "Toggle the viewing of errors in the buffer." - (interactive) - (setq merlin-error-after-save (not (merlin-error-after-save))) - (if (merlin-error-after-save) - (progn - (merlin--after-save) - (message "Errors are now reported. Use %s to stop reporting them." - (substitute-command-keys "\\[merlin-toggle-view-errors]"))) - (progn - (merlin-error-reset) - (message "Errors are not reported anymore. Use %s to start again reporting them." - (substitute-command-keys "\\[merlin-toggle-view-errors]"))))) - -;;;;;;;;;;;;;;;;;;;;;;;; -;; COMPLETION HELPERS ;; -;;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin-completion-entry-short-description (entry) - "Return a short string describing the content a completion entry (e.g kind of -identifier, type of a value, etc)." - (let* ((kind (cdr (assoc 'kind entry))) - (desc (or (cdr (assoc 'desc entry)) (cdr (assoc 'type entry)))) - (type (cond ((member kind '("Module" "module")) " ") - ((string-equal kind "Type") (format " [%s]" desc)) - (t desc)))) - (replace-regexp-in-string "[\n ]+" " " type))) - -(defun merlin-completion-entry-text (compl-prefix entry) - "Return the text that should replace COMPL-PREFIX in the buffer if the user -chooses this completion entry. -COMPL-PREFIX is the prefix that was used to start completion." - (let ((entry-name (cdr (assoc 'name entry)))) - (if merlin--dwimed entry-name (concat compl-prefix entry-name)))) - -(defun merlin-completion-prefix (ident) - "Compute the prefix of IDENT. The prefix of `Foo.bar' is `Foo.' and the -prefix of `bar' is `'." - (car (merlin-completion-split-ident ident))) - -(defun merlin-completion-split-ident (ident) - "Split IDENT into a (cons prefix suffix). See merlin-completion-prefix." - (let* ((l (split-string ident "\\.")) - (s (mapconcat 'identity (butlast l) ".")) - (suffix (if l (car (last l)) ident)) - (prefix (if (string-equal s "") s (concat s ".")))) - (cons prefix suffix))) - -(defun merlin--completion-prepare-labels (labels prefix) - ;; Remove non-matching entry, adjusting optional labels if needed - (cl-loop for x in labels - for name = (cdr (assoc 'name x)) - when (or (string-prefix-p prefix name) - (when (equal (aref name 0) ??) - (aset name 0 ?~) - (string-prefix-p prefix name))) - collect (append x '((kind . "Label") (info . nil))))) - -(defun merlin-complete (ident) - "Return the data for completion of IDENT, i.e. a list of tuples of the form - '(NAME TYPE KIND INFO)." - (setq-local merlin--dwimed nil) - (let* ((merlin-verbosity-context t) ; increase verbosity level if necessary - (ident- (merlin-completion-split-ident ident)) - (suffix (cdr ident-)) - (data (merlin-call "complete-prefix" - "-position" (merlin-unmake-point (point)) - "-prefix" ident - "-doc" (if merlin-completion-with-doc "y" "n"))) - ;; all classic entries - (entries (cdr (assoc 'entries data))) - ;; context is 'null or ('application ...) - (context (cdr (assoc 'context data))) - (application (and (listp context) - (equal (car context) "application") - (cadr context))) - ;; Argument-type - (expected-ty (and application - (not (string-equal "'_a" - (cdr (assoc 'argument_type application)))) - (cdr (assoc 'argument_type application)))) - ;; labels - (labels (and application (cdr (assoc 'labels application))))) - (setq labels (merlin--completion-prepare-labels labels suffix)) - ;; DWIM completion - (when (and merlin-completion-dwim (not labels) (not entries)) - (setq data (merlin-call "expand-prefix" - "-position" (merlin-unmake-point (point)) - "-prefix" ident)) - (setq entries (cdr (assoc 'entries data))) - (setq-local merlin--dwimed t)) - ;; Concat results - (let ((result (append labels entries))) - (if expected-ty - (cl-loop for x in result - collect (append x `((argument_type . ,expected-ty)))) - result)))) - -;; FIXME: merlin shouldn't rely on editor to compute bounds -(defun merlin-bounds-of-ocaml-atom-at-point () - "Return the start and end points of an ocaml atom near point. -An ocaml atom is any string containing [a-z_0-9A-Z`.]." - (save-excursion - (skip-chars-backward "a-z0-9A-Z_'.") - (skip-chars-backward "~?`" (1- (point))) - (save-match-data - (if (or (looking-at "[~?`]?['a-z_0-9A-Z.]*['a-z_A-Z0-9]") - (looking-at "[~?`]")) - (cons (point) (match-end 0)) ; returns the bounds - nil)))) ; no atom at point - -(put 'ocaml-atom 'bounds-of-thing-at-point - 'merlin-bounds-of-ocaml-atom-at-point) - -(defun merlin-completion-bounds () - "Returns a pair (start . end) of the content to complete" - (let ((bounds (bounds-of-thing-at-point 'ocaml-atom))) - (cons (if bounds (car bounds) (point)) - (point)))) - -;;;;;;;;;;;;;;;;;;;;; -;; POLARITY SEARCH ;; -;;;;;;;;;;;;;;;;;;;;; - -(defun merlin--search (query) - (merlin-call "search-by-polarity" - "-query" query - "-position" (merlin-unmake-point (point)))) - -(defun merlin-search (query) - (interactive "sSearch pattern: ") - (let* ((result (merlin--search query)) - (entries (cdr (assoc 'entries result))) - (transform - (lambda (entry) - (let ((text (merlin-completion-entry-text "" entry)) - (desc (merlin-completion-entry-short-description entry))) - (vector (concat text " : " desc) - `(lambda () (insert ,text))))))) - (popup-menu (easy-menu-create-menu "Results" (mapcar transform entries))))) - -;;;;;;;;;;;;;;;;; -;; TYPE BUFFER ;; -;;;;;;;;;;;;;;;;; - -(defun merlin--is-short (text) - (let ((count 0) - (pos 0)) - (save-match-data - (while (and (<= count 8) - (string-match "\n" text pos)) - (setq pos (match-end 0)) - (setq count (1+ count)))) - (<= count 8))) - -(defvar merlin-types-buffer-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map special-mode-map) - (define-key map "g" nil) - map) - "Keymap for types buffer.") - -(defun merlin-display-in-type-buffer (text) - "Change content of type-buffer." - (let ((curr-dir default-directory)) - (with-current-buffer (get-buffer-create merlin-type-buffer-name) - (when (member major-mode '(nil fundamental-mode)) - ;; Guess value for merlin-favourite-caml-mode - (let ((caml-mode (or merlin-favourite-caml-mode - merlin-guessed-favorite-caml-mode))) - (when caml-mode - (with-demoted-errors "Error when setting up merlin type-buffer: %S" - (funcall caml-mode))))) - (read-only-mode 0) - (erase-buffer) - (insert text) - (goto-char (point-min)) - (read-only-mode 1) - (use-local-map merlin-types-buffer-map) - ;; finally make sure that the type buffer directory is the same as the last - ;; (ml) buffer we were in. - ;; Indeed if people move to that buffer and start looking for a file we - ;; want them to be in the directory they were in when they last requested a - ;; type, not in the directory they were in when they first requested a - ;; type (for long lived emacs sessions that directory might not even exist - ;; anymore). - (setq default-directory curr-dir)))) - -(define-obsolete-function-alias 'merlin/display-in-type-buffer 'merlin-display-in-type-buffer "2021-01-27") - - -;;;;;;;;;;;;;;;;;;;;;;; -;; EXPRESSION TYPING ;; -;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin--type-expression (exp callback-if-success &optional _callback-if-exn) - "Get the type of EXP inside the local context." - (when exp - (funcall callback-if-success - (merlin-call "type-expression" - "-position" (merlin-unmake-point (point)) - "-expression" exp)) - ;; FIXME: callback-if-exn - )) - -(defun merlin--type-display (bounds type &optional quiet) - "Display the type TYPE of the expression occurring at BOUNDS. -If QUIET is non nil, then an overlay and the merlin types can be used." - (if (not type) - (unless quiet (message "")) - (merlin-display-in-type-buffer type) - (if (merlin--is-short type) - (message "%s" - (with-current-buffer merlin-type-buffer-name - (font-lock-fontify-region (point-min) (point-max)) - (buffer-string))) - (display-buffer merlin-type-buffer-name)) - (if (and (not quiet) bounds) - (merlin--highlight bounds 'merlin-type-face)))) - -(defun merlin--type-region () - "Show the type of the region." - (let* - ((substring (merlin-buffer-substring (region-beginning) (region-end))) - (on-success (lambda (type) (merlin--type-display nil type nil))) - (on-error (lambda (err) - (let ((msg (assoc 'message err)) - (typ (assoc 'type err))) - (cond ((and typ (equal (cdr typ) "parser")) - (message "Error: the content of the region failed to parse.")) - (msg (message "Error: %s" (cdr msg))) - (t - (message "Unexpected error"))))))) - (merlin--type-expression substring on-success on-error))) - -(defun merlin-type-expr (exp) - "Prompt the user for expression EXP, then show its type." - (interactive "s# ") - (let ((on-success (lambda (type) (merlin--type-display nil type nil))) - (on-error (lambda (err) - (let ((msg (assoc 'message err))) - (if msg (message "Error: %s" (cdr msg)) - (message "unknown error")))))) - (merlin--type-expression exp on-success on-error))) - -(defvar merlin-type-enclosing-map - (let ((keymap (make-sparse-keymap))) - (define-key keymap (kbd "C-") #'merlin-type-enclosing-go-up) - (define-key keymap (kbd "C-") #'merlin-type-enclosing-go-down) - (define-key keymap (kbd "C-d") #'merlin-destruct-enclosing) - (define-key keymap (kbd "C-w") #'merlin-copy-enclosing) - keymap) - "The local map to navigate type enclosing.") - -(defun merlin--type-enclosing-reset () - "Clear enclosing information, necessary for destruct" - (setq merlin-enclosing-types nil) - (setq merlin-enclosing-offset -1)) - -(defun merlin--type-enclosing-reset-hooked () - "Reimplement on-exit logic from set-temporary-overlay-map for emacs pre 24.4" - (let ((map merlin-type-enclosing-map)) - (unless (or (not (eq map (cadr overriding-terminal-local-map))) - (eq this-command (lookup-key map (this-command-keys-vector)))) - (merlin--type-enclosing-reset) - (remove-hook 'pre-command-hook #'merlin--type-enclosing-reset-hooked)))) - -(defun merlin--type-enclosing-text (item) - (if (stringp (car item)) - (car item) - (with-demoted-errors "Error retrieving type enclosing: %S" - (let* ((key (car item)) - (index (elt key 0)) - (position (elt key 1)) - (tail (elt key 2)) - (verbosity (elt key 3)) - (types (merlin-call - "type-enclosing" "-position" position "-index" index - (when verbosity (cons "-verbosity" verbosity)))) - (obj (elt types index)) - (type (cdr (assoc 'type obj)))) - (setcar item (concat type tail))) - (car item)))) - -(defun merlin--type-enclosing-query () - "Get the enclosings around point from merlin and sets MERLIN-ENCLOSING-TYPES." - (merlin--type-enclosing-reset) - (let* ((merlin-verbosity-context t) ; increase verbosity level if necessary - (position (merlin-unmake-point (point))) - (verbosity (cdr-safe merlin--verbosity-cache)) - (types (merlin-call "type-enclosing" "-position" position "-index" 0)) - (types (ignore-errors - (mapcar (lambda (obj) - (let* ((tail (cdr (assoc 'tail obj))) - (tail (cond ((equal tail "position") - " (* tail position *)") - ((equal tail "call") - " (* tail call *)") - (t ""))) - (type (cdr (assoc 'type obj)))) - (cons (if (stringp type) (concat type tail) - (list type position tail verbosity)) - (merlin--make-bounds obj)))) - types))) - (types (delq nil types))) - (when types - (setq merlin-enclosing-types types) - (setq merlin-enclosing-offset -1) - merlin-enclosing-types))) - -(defun merlin--type-enclosing-go () - "Highlight the given corresponding enclosing data (of the form (TYPE . BOUNDS)." - (let ((data (elt merlin-enclosing-types merlin-enclosing-offset))) - (if (cddr data) - (merlin--type-display (cdr data) (merlin--type-enclosing-text data))))) - -(defun merlin-type-enclosing-go-up () - "Go up in the enclosing type list." - (interactive) - (when merlin-enclosing-types - (if (>= merlin-enclosing-offset (1- (length merlin-enclosing-types))) - (setq merlin-enclosing-offset -1)) - (setq merlin-enclosing-offset (1+ merlin-enclosing-offset)) - (merlin--type-enclosing-go))) - -(defun merlin-type-enclosing-go-down () - "Go down in the enclosing type list." - (interactive) - (when merlin-enclosing-types - (if (<= merlin-enclosing-offset 0) - (setq merlin-enclosing-offset (length merlin-enclosing-types))) - (setq merlin-enclosing-offset (1- merlin-enclosing-offset)) - (merlin--type-enclosing-go))) - -(defun merlin-copy-enclosing () - (interactive) - (let ((data (elt merlin-enclosing-types merlin-enclosing-offset))) - (when (cddr data) - (setq data (merlin--type-enclosing-text data)) - (message "Copied %s to kill-ring" data) - (kill-new data)))) - -(defun merlin--type-enclosing-after () - (when (and (fboundp 'set-temporary-overlay-map) - merlin-arrow-keys-type-enclosing) - (if (version< emacs-version "24.4") - (progn - (set-temporary-overlay-map merlin-type-enclosing-map t) - (add-hook 'pre-command-hook #'merlin--type-enclosing-reset-hooked)) - (set-temporary-overlay-map merlin-type-enclosing-map t - 'merlin--type-enclosing-reset)))) - -(defun merlin-type-enclosing () - "Print the type of the expression under point (or of the region, if it exists). -If called repeatedly, increase the verbosity of the type shown." - (interactive) - (if (region-active-p) - (merlin--type-region) - (when (merlin--type-enclosing-query) - (merlin-type-enclosing-go-up) - (merlin--type-enclosing-after)))) - -(defun merlin--find-extents (list low high) - "Return the smallest extent in LIST that LOW and HIGH fit -strictly within, or nil if there is no such element." - (cl-find-if (lambda (extent) - (let ((start (merlin--point-of-pos (assoc 'start extent))) - (end (merlin--point-of-pos (assoc 'end extent)))) - (or (and (> low start) - (<= high end)) - (and (< high end) - (>= low start))))) - list)) - -(defun merlin-enclosing-expand () - "Select the construct enclosing point (or the region, if it is active)." - (interactive) - (let* ((enclosing-extents - (merlin-call "enclosing" - "-position" (merlin-unmake-point (point)))) - (extents (if (use-region-p) - (merlin--find-extents enclosing-extents - (region-beginning) - (region-end)) - (cl-first enclosing-extents)))) - (if (not extents) - (error "No enclosing construct") - (merlin--goto-point (cdr (assoc 'start extents))) - (push-mark (merlin--point-of-pos (cdr (assoc 'end extents))) - t t)))) - -;;;;;;;;;;; -;; HOLES ;; -;;;;;;;;;;; - -(defun merlin--holes () - "Query the list of holes (and their types)" - (merlin-call "holes")) - -(defun merlin--first-hole-aux (holes current-point comp) - "Returns the first `hole` of the list such that - `(funcall comp hole current-point)`" - (when holes - (let* ((head (car holes)) - (tail (cdr holes)) - (start (merlin-lookup 'start head)) - (hole-point (merlin-make-point start))) - (if (funcall comp hole-point current-point) - head - (merlin--first-hole-aux tail current-point comp))))) - -(defun merlin--first-hole (holes current-point comp) - "Returns the first `hole` of the list that such that - `(funcall comp hole current-point)`. If no hole match - that condition the first one of the list is returned." - (let ((hole (merlin--first-hole-aux holes current-point comp))) - (if hole hole (car holes)))) - -(defun merlin-previous-hole () - "Jump to the previous hole and print its type" - (interactive) - (let* ((current-point (point)) - (holes (reverse (merlin--holes))) - (hole (merlin--first-hole holes current-point '<))) - (when hole - (progn - (merlin--goto-point (merlin-lookup 'start hole)) - (message "%s" (merlin-lookup 'type hole)))))) - -(defun merlin--next-hole-between (pmin pmax) - "Jump to the next hole and print its type only if it is in the given range" - (let* ((current-point (point)) - (hole (merlin--first-hole (merlin--holes) current-point '>))) - (when hole - (let* ((start (merlin-lookup 'start hole)) - (typ (merlin-lookup 'type hole)) - (hole-point (merlin-make-point start))) - (if (and - (>= hole-point pmin) - (<= hole-point pmax)) - (progn - (merlin--goto-point start) - (message "%s" typ))))))) - -(defun merlin--first-hole-between (pmin pmax) - "Jump to the first hole in the given range and prints its type" - (let* ((hole (merlin--first-hole (merlin--holes) pmin '>))) - (when hole - (let* ((start (merlin-lookup 'start hole)) - (typ (merlin-lookup 'type hole)) - (hole-point (merlin-make-point start))) - (if (<= hole-point pmax) - (progn - (merlin--goto-point start) - (message "%s" typ))))))) - -(defun merlin-next-hole () - "Jump to the next hole and print its type" - (interactive) - (let* ((current-point (point)) - (hole (merlin--first-hole (merlin--holes) current-point '>))) - (when hole - (progn - (merlin--goto-point (merlin-lookup 'start hole)) - (message "%s" (merlin-lookup 'type hole)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; DESTRUCT / CASE ANALYSIS ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin--replace-buff-portion (start stop txt) - (let ((start (merlin--point-of-pos start)) - (stop (merlin--point-of-pos stop))) - (progn - (save-excursion - (delete-region start stop) - (goto-char start) - (insert txt) - (indent-region start (point))) - (merlin--next-hole-between start (+ start (length txt)))))) - -(defun merlin--destruct-bounds (bounds) - "Execute a case analysis on BOUNDS" - (let ((result (merlin-call "case-analysis" - "-start" (merlin-unmake-point (car bounds)) - "-end" (merlin-unmake-point (cdr bounds))))) - (when result - (let* ((loc (car result)) - (start (cdr (assoc 'start loc))) - (stop (cdr (assoc 'end loc)))) - (merlin--replace-buff-portion start stop (cadr result)))) - (merlin--type-enclosing-reset))) - -(defun merlin-destruct-enclosing () - "Case analyse the current type enclosing" - (interactive) - (merlin--destruct-bounds - (cdr (elt merlin-enclosing-types merlin-enclosing-offset)))) - -(defun merlin-destruct () - "Case analyse the current point or region" - (interactive) - (merlin--destruct-bounds (if (region-active-p) - (cons (region-beginning) (region-end)) - (cons (point) (point))))) - -;;;;;;;;;;;;;;; -;; CONSTRUCT ;; -;;;;;;;;;;;;;;; - - -(defun merlin--construct-complete (start stop results) - (let ((start (merlin--point-of-pos start)) - (stop (merlin--point-of-pos stop))) - (cl-labels ((insert-choice (_b _e newtext) - (completion--replace start stop newtext) - (merlin--first-hole-between start (+ start (length newtext))))) - (if (= (length results) 1) - (insert-choice 0 0 (car results)) - (with-output-to-temp-buffer "*Constructions*" - (progn - (with-current-buffer "*Constructions*" - (setq-local - completion-list-insert-choice-function - #'insert-choice)) - (display-completion-list results))))))) - -(defun merlin--construct-point (point) - "Execute a construct on POINT" - (progn - (ignore point) ; Without this Emacs bytecode compiler complains about an - ; unused variable. This may be a bug in the compiler - (let ((result (merlin-call "construct" - "-position" (merlin-unmake-point (point))))) - (when result - (let* ((loc (car result)) - (start (cdr (assoc 'start loc))) - (stop (cdr (assoc 'end loc)))) - (merlin--construct-complete start stop (cadr result))))))) - -(defun merlin-construct () - "Construct over the current hole" - (interactive) - (merlin--construct-point (cons (point) (point)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; PACKAGE, PROJECT AND FLAGS MANAGEMENT ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin-get-packages () - "Get the list of available findlib package." - (let* ((packages-string (shell-command-to-string "ocamlfind list")) - (packages-list (split-string packages-string "\n"))) - (mapcar 'car (mapcar 'split-string packages-list)))) - -(defun merlin--project-get () - "Returns a pair of two string lists (dot_merlins . failures) with a list of -.merlins file loaded and a list of error messages, if any error occurred during -loading" - (let ((ret (merlin-call "check-configuration"))) - (setq merlin--project-cache - (cons (cdr (assoc 'dot_merlins ret)) - (cdr (assoc 'failures ret)))))) - -(defun merlin-use (&rest pkgs) - "Load PKGS in merlin." - (interactive - (list (let ((crm-separator "[ ]*[, ][ ]*") - (crm-local-completion-map - (merlin--completion-map-with-space crm-local-completion-map))) - (completing-read-multiple - "Packages to use: " (merlin-get-packages) nil nil - (mapconcat 'identity merlin-buffer-packages " "))))) - (setq merlin-buffer-packages - (delete-dups (merlin--map-flatten 'identity pkgs))) - (let* ((arguments (cons "ocamlfind query" merlin-buffer-packages)) - (command (mapconcat 'identity arguments " ")) - (paths (shell-command-to-string command))) - (setq merlin-buffer-packages-path (split-string paths "\n"))) - (merlin-error-reset) - (merlin-configuration-check t)) - -(defun merlin-extensions (&rest extensions) - "Enable EXTENSIONS in merlin." - (interactive - (list (completing-read-multiple - "Enabled extensions (separate with ','): " - (merlin-call "extension-list") nil nil - (mapconcat 'identity merlin-buffer-extensions ",")))) - (setq merlin-buffer-extensions - (delete-dups (merlin--map-flatten 'identity extensions))) - (merlin-error-reset) - (merlin-configuration-check t)) - -(defun merlin-goto-project-file () - "Goto the merlin file corresponding to the current file." - (interactive) - (let ((dot_merlins (car (merlin--project-get)))) - (if (consp dot_merlins) - (merlin-find-file (car dot_merlins)) - (message "No project file for the current buffer.")))) - -(defun merlin-flags (&rest flags) - "Set user flags for current buffer." - (interactive (list - (let ((crm-separator " ") - (crm-local-completion-map - (merlin--completion-map-with-space crm-local-completion-map))) - (completing-read-multiple - "Flags: " (merlin-call "flags-list") nil nil - merlin-buffer-flags)))) - (setq merlin-buffer-flags - (mapconcat 'identity (merlin--map-flatten 'identity flags) " ")) - (merlin-error-reset) - (merlin-configuration-check t)) - -;;;;;;;;;;;; -;; LOCATE ;; -;;;;;;;;;;;; - -(defun merlin-call-locate (&optional ident) - "Locate the identifier IDENT at point." - (let ((result (merlin-call "locate" - (when ident (list "-prefix" ident)) - "-position" (merlin-unmake-point (point)) - "-look-for" merlin-locate-preference))) - (unless result - (error "Not found. (Check *Messages* for potential errors)")) - (unless (listp result) - (user-error "%s" result)) - result)) - -(defun merlin--locate-result (result) - "Default actions after getting results from locate" - (merlin--goto-file-and-point result) - (when merlin-type-after-locate (merlin-type-enclosing))) - -(defun merlin-locate-ident (ident) - "Locate the inputted identifier" - (interactive "s> ") - (merlin--locate-result (merlin-call-locate ident))) - -(defun merlin-locate (&optional in-new-window) - "Locate the identifier at point. - -Whether the result appears in a new window is controlled by -`merlin-locate-in-new-window', but can be overridden with a -prefix argument (IN-NEW-WINDOW): if prefixed once with -\\[universal-argument], the result appears in the current window; -if prefixed twice with \\[universal-argument], the result appears -in a new window; otherwise, `merlin-locate-in-new-window' is -obeyed." - (interactive "P") - (cl-letf ((merlin-locate-in-new-window - (cond - ((equal in-new-window '(4)) 'never) - ((equal in-new-window '(16)) 'always) - (t merlin-locate-in-new-window)))) - (merlin--locate-result (merlin-call-locate)))) - -(defun merlin-locate-type () - "Locate the type of the expression under point." - (interactive) - (let ((result (merlin-call "locate-type" - "-position" (merlin-unmake-point (point))))) - (unless result - (error "Not found. (Check *Messages* for potential errors)")) - (unless (listp result) - (user-error "%s" result)) - (merlin--goto-file-and-point result))) - -(defun merlin-pop-stack () - "Go back to the last position where the user did a locate." - (interactive) - (let ((r (pop merlin-position-stack))) - (cond ((not r) (message "empty stack")) - ((equal merlin-locate-in-new-window 'never) - (switch-to-buffer (car r))) - ((or (equal merlin-locate-in-new-window 'always) - (not (equal (buffer-name) (car r)))) - (select-window (display-buffer (car r))))) - (when r (goto-char (cdr r))))) - -;;;;;;;;;; -;; JUMP ;; -;;;;;;;;;; - -(defun merlin-call-jump (&optional target) - "Jump to the TARGET" - (if (or (not target) (equal target "")) - (setq target "fun let module match")) - (let ((result (merlin-call "jump" - "-position" (merlin-unmake-point (point)) - "-target" target))) - (unless result - (error "Not found. (Check *Messages* for potential errors)")) - (unless (listp result) - (user-error "%s" result)) - result)) - -(defun merlin-jump (&optional target) - "Jump to enclosing fun, let, module or match. - -Any combination of the above may be entered, separated by spaces, ex.: - -fun let or module or module fun match - -Empty string defaults to jumping to all these." - (interactive "sfun, let, module or match > ") - (merlin--goto-file-and-point (merlin-call-jump target))) - -(defun merlin-call-phrase (target) - "Move to next phrase (TARGET = 'next) or previous phrase (TARGET = 'prev)" - (if (or (not target) (equal target "")) - (setq target "fun let module match")) - (let ((result (merlin-call "phrase" - "-position" (merlin-unmake-point (point)) - "-target" target))) - (unless result - (error "Not found. (Check *Messages* for potential errors)")) - (unless (listp result) - (error result)) - result)) - -(defun merlin-phrase-next () - "Go to the beginning of the next phrase." - (interactive) - (merlin--goto-file-and-point (merlin-call-phrase 'next))) - -(defun merlin-phrase-prev () - "Go to the beginning of the previous phrase." - (interactive) - (merlin--goto-file-and-point (merlin-call-phrase 'prev))) - -;;;;;;;;;;;;;; -;; DOCUMENT ;; -;;;;;;;;;;;;;; - -(defun merlin--document-pos (ident) - "Document the identifier IDENT at point and return the result." - (merlin-call "document" - "-position" (merlin-unmake-point (point)) - (when ident (cons "-identifier" ident)))) - -(defun merlin--document-pure (&optional ident) - "Document the identifier IDENT at point." - (let* ((raw-doc (merlin--document-pos ident)) - (doc (concat "(*" raw-doc "*)"))) - (merlin-display-in-type-buffer doc) - (with-current-buffer merlin-type-buffer-name - (if (> (line-number-at-pos (point-max)) 8) - (display-buffer merlin-type-buffer-name) - (font-lock-fontify-region (point-min) (point-max)) - (message "%s" (buffer-string)))))) - -(defun merlin-document () - "Document the identifier under point" - (interactive) - (merlin--document-pure)) - -;;;;;;;;;;;;;;;;; -;; OCCURRENCES ;; -;;;;;;;;;;;;;;;;; - -(defun merlin--occurrence-text (line-num marker start end source-buf) - (concat (propertize (format "%7d:" line-num) - 'font-lock-face 'shadow - 'occur-prefix t - 'occur-target marker - 'follow-link t - 'front-sticky t - 'rear-nonsticky t - 'mouse-face '(highlight)) - (propertize (replace-regexp-in-string - "\n" - "\n :" - (with-current-buffer source-buf - (buffer-substring - (progn - (goto-char start) - (line-beginning-position)) - (progn - (goto-char end) - (line-end-position))))) - 'follow-link t - 'mouse-face '(highlight) - 'occur-target marker) - (propertize "\n" 'occur-target marker))) - -(defun merlin--get-occ-buff () - (get-buffer-create merlin-occurrences-buffer-name)) - -(defun merlin-occurrences-populate-buffer (lst) - (let ((src-buff (buffer-name)) - (occ-buff (merlin--get-occ-buff)) - (positions - (mapcar (lambda (pos) - (cons - (cons 'marker - (copy-marker - (merlin--point-of-pos (assoc 'start pos)))) - pos)) - lst))) - (with-current-buffer occ-buff - (let ((inhibit-read-only t) - (buffer-undo-list t) - (pending-line) - (pending-lines-text)) - (erase-buffer) - (occur-mode) - (insert (propertize (format "%d occurrences in buffer: %s" - (length lst) - src-buff) - 'font-lock-face list-matching-lines-buffer-name-face - 'read-only t - 'occur-title (get-buffer src-buff))) - (insert "\n") - (dolist (pos positions) - (let* ((marker (cdr (assoc 'marker pos))) - (start (assoc 'start pos)) - (end (assoc 'end pos)) - (line (cdr (assoc 'line start))) - (start-buf-pos (with-current-buffer src-buff - (merlin--point-of-pos start))) - (end-buf-pos (with-current-buffer src-buff - (merlin--point-of-pos end))) - (prefix-length 8) - (start-offset (+ prefix-length - (cdr (assoc 'col start)))) - (lines-text - (if (equal line pending-line) - pending-lines-text - (merlin--occurrence-text line - marker - start-buf-pos - end-buf-pos - src-buff)))) - - ;; Insert the critical text properties that occur-mode - ;; makes use of - (add-text-properties start-offset - (+ start-offset - (- end-buf-pos start-buf-pos)) - (list 'occur-match t - 'face list-matching-lines-face) - lines-text) - - ;; Inserting text is delayed until non-equal lines are - ;; found in order to accumulate multiple matches within - ;; one line. - (when (and pending-lines-text - (not (equal line pending-line))) - (insert pending-lines-text)) - (setq pending-line line) - (setq pending-lines-text lines-text))) - - ;; Catch final pending text - (when pending-lines-text - (insert pending-lines-text)) - (goto-char (point-min)))))) - -(defun merlin-occurrences-list (lst) - (save-excursion - (merlin-occurrences-populate-buffer lst) - (cl-case merlin-occurrences-show-buffer - ('same - (switch-to-buffer (merlin--get-occ-buff))) - ('other - (switch-to-buffer-other-window (merlin--get-occ-buff))) - (t nil)))) - -(defun merlin--occurrences () - (merlin-call "occurrences" "-identifier-at" (merlin-unmake-point (point)))) - -(defun merlin-occurrences () - "List all occurrences of identifier under cursor in buffer." - (interactive) - (let ((r (merlin--occurrences))) - (when r - (if (listp r) - (merlin-occurrences-list r) - (error "%s" r))))) - -;;;;;;;;;;;;;;;;;;; -;; OPEN REFACTOR ;; -;;;;;;;;;;;;;;;;;;; - -(defun merlin--refactor-open (mode) - "Refactor open statement under cursor. mode can be 'qualify or 'unqualify" - (save-excursion - (dolist (occurrence (nreverse (merlin-call - "refactor-open" - "-position" (merlin-unmake-point (point)) - "-action" mode))) - (let ((bounds (merlin--make-bounds occurrence)) - (content (cdr (assoc 'content occurrence)))) - (unless (equal content (buffer-substring (car bounds) (cdr bounds))) - (goto-char (car bounds)) - (delete-char (- (cdr bounds) (car bounds))) - (insert content)))))) - -(defun merlin-refactor-open () - "Refactor open statement under cursor: unqualify paths" - (interactive) - (merlin--refactor-open 'unqualify)) - -(defun merlin-refactor-open-qualify () - "Refactor open statement under cursor: qualify paths" - (interactive) - (merlin--refactor-open 'qualify)) - -;;;;;;;;;;;;;;;;;;;;;;; -;; SEMANTIC MOVEMENT ;; -;;;;;;;;;;;;;;;;;;;;;;; - -(defun merlin-error-check () - "Update merlin to the end-of-file, reporting errors." - (interactive) - (when merlin-mode (merlin--error-check t))) - -(defun merlin-configuration-check (&optional only-failures) - "Display loaded .merlin files and eventual errors." - (interactive) - (let* ((project (merlin--project-get)) - (dot_merlins (car project)) - (messages (cdr project))) ; failures list - (unless only-failures - (when merlin-buffer-configuration - (push (format "Custom merlin setup: %S" merlin-buffer-configuration) - messages)) - (push (format - "Custom buffer settings:\n- packages: %S\n- flags: %S\n- extensions: %S" - (or merlin-buffer-packages 'none) - (or merlin-buffer-flags 'none) - (or merlin-buffer-extensions 'none)) - messages) - (push (if dot_merlins - (concat "Loaded .merlin files: " (mapconcat 'identity dot_merlins ", ")) - "No .merlin loaded") - messages)) - (message "%s" (mapconcat 'identity messages "\n")))) - -(defun merlin-customize () - "Open the customize buffer for the group merlin." - (interactive) - (customize-group 'merlin)) - -(defun merlin-version () - "Print the version of the ocamlmerlin binary." - (interactive) - (with-demoted-errors "Error invoking merlin: %S" - (message "%s" (merlin--call-merlin "-version")))) - -(defun merlin--configuration () - (when (or merlin-configuration-function merlin-grouping-function) - (with-demoted-errors - "merlin-command: invalid configuration (%S)" - (funcall (or merlin-configuration-function merlin-grouping-function))))) - -(defun merlin-command () - "Return or update path of ocamlmerlin binary selected by configuration" - (when (or (not merlin-buffer-configuration) - (merlin-lookup 'do-not-cache-config merlin-buffer-configuration)) - (setq merlin-buffer-configuration (merlin--configuration))) - - (let ((command (merlin-lookup 'command merlin-buffer-configuration))) - (unless command - (setq - command - (cond - ((functionp merlin-command) (funcall merlin-command)) - ((stringp merlin-command) merlin-command) - ((equal merlin-command 'opam) - (with-temp-buffer - (if (eq (call-process-shell-command - "opam var bin" nil (current-buffer) nil) 0) - (let ((bin-path - (replace-regexp-in-string "\n$" "" (buffer-string)))) - ;; the opam bin dir needs to be on the path, so if merlin - ;; calls out to sub binaries (e.g. ocamlmerlin-reason), the - ;; correct version is used rather than the version that - ;; happens to be on the path - - ;; this was originally done via `opam exec' but that does not - ;; work for opam 1, and added a performance hit - (setq merlin-opam-bin-path (list (concat "PATH=" bin-path))) - (concat bin-path "/ocamlmerlin")) - - ;; best effort if opam is not available, lookup for the binary in - ;; the existing env - (progn - (message "merlin-command: opam var failed (%S)" - (buffer-string)) - "ocamlmerlin")))))) - - ;; cache command in merlin-buffer configuration to avoid having to shell - ;; out to `opam` each time. - (push (cons 'command command) merlin-buffer-configuration) - (when merlin-opam-bin-path - (push (cons 'env merlin-opam-bin-path) merlin-buffer-configuration))) - - command)) - -;;;;;;;;;;;;;;;; -;; MODE SETUP ;; -;;;;;;;;;;;;;;;; - -(defvar merlin-mode-map - (let ((merlin-map (make-sparse-keymap)) - (merlin-menu-map (make-sparse-keymap)) - (merlin-show-type-map (make-sparse-keymap))) - (define-key merlin-map (kbd "C-c C-x") #'merlin-error-next) - (define-key merlin-map (kbd "C-c C-l") #'merlin-locate) - (define-key merlin-map (kbd "C-c &" ) #'merlin-pop-stack) - (define-key merlin-map (kbd "C-c C-r") #'merlin-error-check) - (define-key merlin-map (kbd "C-c C-t") #'merlin-type-enclosing) - (define-key merlin-map (kbd "C-c C-d") #'merlin-destruct) - (define-key merlin-map (kbd "C-c C-n") #'merlin-phrase-next) - (define-key merlin-map (kbd "C-c C-p") #'merlin-phrase-prev) - (define-key merlin-menu-map [customize] - '("Customize merlin-mode" . merlin-customize)) - (define-key merlin-menu-map [separator] - '("-")) - (define-key merlin-show-type-map [point] - '(menu-item "around the cursor" merlin-type-enclosing - :help "Show the type of the smallest subexpression near cursor")) - (define-key merlin-show-type-map [exp] - '(menu-item "of an expression" merlin-type-expr - :help "Input an expression and show its type")) - (define-key merlin-menu-map [showtype] - (cons "Show type..." merlin-show-type-map)) - (define-key merlin-menu-map [use] - '(menu-item "Select packages" merlin-use - :help "Load findlib packages.")) - (define-key merlin-menu-map [error] - '(menu-item "Check for errors" merlin-error-check - :help "Check current buffer for any error.")) - (define-key merlin-menu-map [dot-merlin] - '(menu-item "Check configuration" merlin-configuration-check - :help "Display status of '.merlin'.")) - (define-key merlin-menu-map [setflags] - '(menu-item "Set compiler flags" merlin-flags - :help "Pass specific compiler flags for current buffer.")) - (define-key merlin-menu-map [extensions] - '(menu-item "Syntax extensions" merlin-extensions - :help "Enable support for some dialects of OCaml.")) - (define-key merlin-menu-map [restartmerlin] - '(menu-item "Shutdown merlin server" merlin-stop-server - :help "Stop merlin server.")) - (define-key merlin-menu-map [versionmerlin] - '(menu-item "Version" merlin-version - :help "Print version of the merlin binary.")) - (define-key merlin-map [menu-bar merlin] (cons "Merlin" merlin-menu-map)) - merlin-map)) - -(defun merlin-can-handle-buffer () - "Simple sanity check (used to avoid running merlin on, e.g., completion buffer)." - (cond ((equal (buffer-name) merlin-type-buffer-name) nil) - ((buffer-file-name (buffer-base-buffer)) t))) - -(defun merlin-lighter () - "Return the lighter for merlin which indicates the status of merlin process." - (let (messages - (num-errors (length merlin-erroneous-buffer))) - (when merlin-report-errors-in-lighter - (cond ((not merlin--project-cache) nil) - ((cdr-safe merlin--project-cache) - (push "check config!" messages)) - ((not (car-safe merlin--project-cache)) - (push "no .merlin" messages)))) - (unless (zerop num-errors) - (push (format "%d error%s" num-errors (if (> num-errors 1) "s" "")) - messages)) - (when (and merlin-show-instance-in-lighter - (merlin-lookup 'name merlin-buffer-configuration)) - (push (merlin-lookup 'name merlin-buffer-configuration) - messages)) - (if messages - (concat " Merlin (" (mapconcat 'identity messages ",") ")") - " Merlin"))) - -;;; DEPRECATED FUNCTIONS - -(define-obsolete-function-alias 'merlin-project-check 'merlin-configuration-check "v3.0.0") - -(define-obsolete-function-alias 'merlin--copy-enclosing 'merlin-copy-enclosing "v3.0.0") -(define-obsolete-function-alias 'merlin--destruct-enclosing 'merlin-destruct-enclosing "v3.0.0") - -(define-obsolete-function-alias 'merlin-restart-process 'merlin-stop-server "v3.0.0") - -;;;###autoload -(define-minor-mode merlin-mode - "Minor mode for interacting with a merlin process. -Runs a merlin process in the background and perform queries on it. - -Short cuts: -\\{merlin-mode-map}" - :init-value nil - :lighter (:eval (merlin-lighter)) - :keymap merlin-mode-map - (if merlin-mode - ;; When enabling merlin - (progn - (when (derived-mode-p 'tuareg-mode 'caml-mode 'reason-mode) - (setq merlin-guessed-favorite-caml-mode major-mode)) - (if (merlin-can-handle-buffer) - (progn - (let ((configuration (merlin--configuration))) - (when configuration (setq merlin-buffer-configuration configuration))) - (add-to-list 'after-change-functions 'merlin--on-edit) - (add-hook 'xref-backend-functions #'merlin-xref-backend nil t) - ;; TODO: Sanity check for selected merlin version - (unless merlin--idle-timer - (setq merlin--idle-timer - (run-with-idle-timer 0.5 t 'merlin-show-error-on-current-line)))) - (merlin-mode -1))) - ;; When disabling merlin - (progn - (when merlin-highlight-overlay - (delete-overlay merlin-highlight-overlay)) - (remove-overlays nil nil 'merlin-kind 'highlight) - (remove-overlays nil nil 'merlin-kind 'error) - (remove-hook 'xref-backend-functions #'merlin-xref-backend t)))) - -(provide 'merlin) - -;; Load these after (provide 'merlin) because they (require 'merlin) -(require 'merlin-cap) -(require 'merlin-xref) - -;;; merlin.el ends here diff --git a/ocaml-lsp-server/vendor/merlin/featuremap.tines b/ocaml-lsp-server/vendor/merlin/featuremap.tines deleted file mode 100644 index 5e47754c2..000000000 --- a/ocaml-lsp-server/vendor/merlin/featuremap.tines +++ /dev/null @@ -1,257 +0,0 @@ - - - - - - - - ]> - - -Configuration (OK) - OCaml settings - Goal is not to reproduce OCaml testsuite, just that settings are applied correctly and that the few Merlin specific behavior are affected. - include_dirs - no_std_include - check that it is possible to provide an alternative stdlib - - unsafe - check that merlin is subject to the same syntactic quirks as OCaml - - classic - write code that mixes different kind of arguments, check errors - - principal - write non-principal code, check errors - - threads - check that Thread/Mutex/Event libraries are found if the flag is specified - - recursive_types - write dubious code that wouldn't typecheck without it - - strict_sequence - check that 5; () fails - - applicative_functors - check that non-applicative functors are rejected, check quirks in Parser - - unsafe_string - check that environment is setup correctly with and without unsafe string - check that Bytes and String deprecation warning are reported appropriately - - nopervasives - figure wtf happens in this case ?! - - strict_formats - check it conforms to OCaml behavior, what is this expected to do? - - open_modules - check environment is initialized as it should - - ppx - check Ast is rewritten as it should - ensure graceful degradation if ppx is missing or broken - check composition of multiple ppx work as expected - - pp - check frontend/reader is affected as it should - - warnings - check that a few warnings are treated properly - - reals_paths / Short-path - - Findlib configuration - conf - check that it overrides location of findlib.conf - check behavior when file is missing or invalid (directory, wrong permission) - - path - check that it actually adds new path to the findlib package directories - - - Merlin settings - TODO: define command line flags for each of these settings - build_path / source_path / cmi_path / cmt_path - specify which behavior are affected by each path variable - check that each variable is considered for corresponding lookups - - extensions - check that corresponding extensions are enabled in lexer / parser / typer - - suffixes - specify which behavior should be affected by suffixes - check that .ml(i) and .re(i) are correctly handled by default - - stdlib - check that it is possible to use merlin with a different installation of OCaml - ensure graceful degradation if stdlib is incorrect - - reader - ensure this setting is not ignored - - dot_merlin - specify the format for good - ensure all features are parsed and affects configuration - ensure recursive resolution is working properly - - packages - ensure build path is updated correctly - ensure graceful degradation when loading unknown or invalid packages - ensure that ppxs specified by packages are loaded correctly - ppx path should be resolved relative to package directory - - - - Query settings - directory - ensure this setting takes precedence over process working directory - - filename - TODO: remove Msource.filename? - - terminal_width - check that pretty printer / error behavior take this into account :) - or completely remove it? - - verbosity - check that various verbosity sensitive queries are affected - - - -Queries (WIP) - Case analysis (destruct) - Completion - Normal - Candidate enumeration - Polymorphic variants - Values - Value constructors - Type constructors - Modules - Signature expansion affected by verbosity - - Module types - Record labels - - - Record fields - Normal - After module path - - Method completion - Sorting - By categories - Expression - Structure - Pattern - Module - Module types - Signature - Type - - By unification cost - By number of "arrows" - - Arguments - Type-directed - For infix operator - Labelled argument - Optional argument - - Expansion / spell checking - Path prefixes completion - Spell correction - - Global modules - Filtering - Hidden namespace '_' - Janestreet modules containing '__' - - - Document - check external doc comments are reported appropriately - check internal doc comments are reported appropriately - - Dump - parsetree - printast - env / fullenv - browse - tokens - flags - warnings - exn - paths - - Errors - Sources - Lexer - Parser - Typer - If a CMI is missing, only report this error (FIXME: these errors?) - Filter out type errors after a syntax error, they are likely to be noise - Top-level errors shouldn't escape - - - Sort by position - TODO: find a way to measure recovery quality - - Extensions - Meta OCaml - Lwt - - Findlib list - Check that custom findlib setups are supported - Fail gracefully if findlib not available? (JST) - - Jump - Locate - Occurrences - Look in the appropriate namespace, check correct behavior for each - Values - Constructors - Types - Modules - - What is the behavior when exiting/entering a module - Plain identifier when referred to from outside the module? - Qualified identifier when referred to from inside the module - - - Outline - Shape - Type enclosing - String argument (expro) is a bit redundant: only position should be provided. - - Type expression - Ensure expression is typed in the right environment - Explain how verbosity affects results - - Which (find source files) - With ext - Path - - -Reader (WIP) - check behaviors for builtin, -pp and external frontends - Lexer - Reconstruct identifiers - Decompose path components into tokens (TODO) - Check comments are reported appropriately - - Parser - check support for ML & MLI - - Pretty-printer - of parsetree (for destruct) - of outcometree (for completion & error report) - support for external readers - - - diff --git a/ocaml-lsp-server/vendor/merlin/featuremap.txt b/ocaml-lsp-server/vendor/merlin/featuremap.txt deleted file mode 100644 index 779045a9d..000000000 --- a/ocaml-lsp-server/vendor/merlin/featuremap.txt +++ /dev/null @@ -1,195 +0,0 @@ -Configuration (OK) - OCaml settings - Goal is not to reproduce OCaml testsuite, just that settings are applied correctly and that the few Merlin specific behavior are affected. - include_dirs - no_std_include - check that it is possible to provide an alternative stdlib - unsafe - check that merlin is subject to the same syntactic quirks as OCaml - classic - write code that mixes different kind of arguments, check errors - principal - write non-principal code, check errors - threads - check that Thread/Mutex/Event libraries are found if the flag is specified - recursive_types - write dubious code that wouldn't typecheck without it - strict_sequence - check that 5; () fails - applicative_functors - check that non-applicative functors are rejected, check quirks in Parser - unsafe_string - check that environment is setup correctly with and without unsafe string - check that Bytes and String deprecation warning are reported appropriately - nopervasives - figure wtf happens in this case ?! - strict_formats - check it conforms to OCaml behavior, what is this expected to do? - open_modules - check environment is initialized as it should - ppx - check Ast is rewritten as it should - ensure graceful degradation if ppx is missing or broken - check composition of multiple ppx work as expected - pp - check frontend/reader is affected as it should - warnings - check that a few warnings are treated properly - reals_paths / Short-path - Findlib configuration - conf - check that it overrides location of findlib.conf - check behavior when file is missing or invalid (directory, wrong permission) - path - check that it actually adds new path to the findlib package directories - Merlin settings - TODO: define command line flags for each of these settings - build_path / source_path / cmi_path / cmt_path - specify which behavior are affected by each path variable - check that each variable is considered for corresponding lookups - extensions - check that corresponding extensions are enabled in lexer / parser / typer - suffixes - specify which behavior should be affected by suffixes - check that .ml(i) and .re(i) are correctly handled by default - stdlib - check that it is possible to use merlin with a different installation of OCaml - ensure graceful degradation if stdlib is incorrect - reader - ensure this setting is not ignored - dot_merlin - specify the format for good - ensure all features are parsed and affects configuration - ensure recursive resolution is working properly - packages - ensure build path is updated correctly - ensure graceful degradation when loading unknown or invalid packages - ensure that ppxs specified by packages are loaded correctly - ppx path should be resolved relative to package directory - Query settings - directory - ensure this setting takes precedence over process working directory - filename - TODO: remove Msource.filename? - terminal_width - check that pretty printer / error behavior take this into account :) - or completely remove it? - verbosity - check that various verbosity sensitive queries are affected -Queries (WIP) - Case analysis (destruct) - On a pattern - If exhaustive - Try and split the thing under the cursor (works - on variables and wildcards) into subpatterns - If not-exhaustive - Make it exhaustive - On an expression [e] - If it is a module - expand into "let module ..." - If it is a variant or record type - replace by [match e with ] - Completion - Normal - Candidate enumeration - Polymorphic variants - Values - Value constructors - Type constructors - Modules - Signature expansion affected by verbosity - Module types - Record labels - Record fields - Normal - After module path - Method completion - Sorting - By categories - Expression - Structure - Pattern - Module - Module types - Signature - Type - By unification cost - By number of "arrows" - Arguments - Type-directed - For infix operator - Labelled argument - Optional argument - Expansion / spell checking - Path prefixes completion - Spell correction - Global modules - Filtering - Hidden namespace '_' - Janestreet modules containing '__' - Document - check external doc comments are reported appropriately - check internal doc comments are reported appropriately - Dump - parsetree - printast - env / fullenv - browse - tokens - flags - warnings - exn - paths - Errors - Sources - Lexer - Parser - Typer - If a CMI is missing, only report this error (FIXME: these errors?) - Filter out type errors after a syntax error, they are likely to be noise - Top-level errors shouldn't escape - Sort by position - TODO: find a way to measure recovery quality - Extensions - Meta OCaml - Lwt - Findlib list - Check that custom findlib setups are supported - Fail gracefully if findlib not available? (JST) - Jump - Locate - Occurrences - Look in the appropriate namespace, check correct behavior for each - Values - Constructors - Types - Modules - What is the behavior when exiting/entering a module - Plain identifier when referred to from outside the module? - Qualified identifier when referred to from inside the module - Outline - Shape - Type enclosing - String argument (expro) is a bit redundant: only position should be provided. - ↑ Wasn't that used to be able to do things like ":TypeOf FooBar.S"? - ↓ See below, the string argument is used to approximate where the cursor is - (in the middle of a path or even a path component), since locations are - only stored at the granularity of one path - Type expression - Ensure expression is typed in the right environment - Explain how verbosity affects results - Which (find source files) - With ext - Path -Reader (WIP) - check behaviors for builtin, -pp and external frontends - Lexer - Reconstruct identifiers - Decompose path components into tokens (TODO) - Check comments are reported appropriately - Parser - check support for ML & MLI - Pretty-printer - of parsetree (for destruct) - of outcometree (for completion & error report) - support for external readers diff --git a/ocaml-lsp-server/vendor/merlin/merlin-lib.opam b/ocaml-lsp-server/vendor/merlin/merlin-lib.opam deleted file mode 100644 index 1fce7f8e4..000000000 --- a/ocaml-lsp-server/vendor/merlin/merlin-lib.opam +++ /dev/null @@ -1,25 +0,0 @@ -opam-version: "2.0" -maintainer: "defree@gmail.com" -authors: "The Merlin team" -homepage: "https://github.com/ocaml/merlin" -bug-reports: "https://github.com/ocaml/merlin/issues" -dev-repo: "git+https://github.com/ocaml/merlin.git" -license: "MIT" -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] -] -depends: [ - "ocaml" {>= "4.14" & < "4.15"} - "dune" {>= "2.9.0"} - "csexp" {>= "1.5.1"} - "menhir" {dev} - "menhirLib" {dev} - "menhirSdk" {dev} -] -synopsis: - "Merlin's libraries" -description: - "These libraries provides access to low-level compiler interfaces and the - standard higher-level merlin protocol. The library is provided as-is, is not - thoroughly documented, and its public API might break with any new release." diff --git a/ocaml-lsp-server/vendor/merlin/merlin.opam b/ocaml-lsp-server/vendor/merlin/merlin.opam deleted file mode 100644 index 65f05c024..000000000 --- a/ocaml-lsp-server/vendor/merlin/merlin.opam +++ /dev/null @@ -1,68 +0,0 @@ -opam-version: "2.0" -maintainer: "defree@gmail.com" -authors: "The Merlin team" -homepage: "https://github.com/ocaml/merlin" -bug-reports: "https://github.com/ocaml/merlin/issues" -dev-repo: "git+https://github.com/ocaml/merlin.git" -license: "MIT" -build: [ - ["dune" "subst"] {dev} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "ocaml" {>= "4.14" & < "4.15"} - "dune" {>= "2.9.0"} - "merlin-lib" {= version} - "dot-merlin-reader" {>= "4.6"} - "yojson" {>= "2.0.0"} - "conf-jq" {with-test} -] -conflicts: [ - "seq" {!= "base"} - "base-effects" -] -synopsis: - "Editor helper, provides completion, typing and source browsing in Vim and Emacs" -description: - "Merlin is an assistant for editing OCaml code. It aims to provide the features available in modern IDEs: error reporting, auto completion, source browsing and much more." -post-messages: [ - "merlin installed. - -Quick setup for VIM -------------------- -Append this to your .vimrc to add merlin to vim's runtime-path: - let g:opamshare = substitute(system('opam var share'),'\\n$','','''') - execute \"set rtp+=\" . g:opamshare . \"/merlin/vim\" - -Also run the following line in vim to index the documentation: - :execute \"helptags \" . g:opamshare . \"/merlin/vim/doc\" - -Quick setup for EMACS -------------------- -Add opam emacs directory to your load-path by appending this to your .emacs: - (let ((opam-share (ignore-errors (car (process-lines \"opam\" \"var\" \"share\"))))) - (when (and opam-share (file-directory-p opam-share)) - ;; Register Merlin - (add-to-list 'load-path (expand-file-name \"emacs/site-lisp\" opam-share)) - (autoload 'merlin-mode \"merlin\" nil t nil) - ;; Automatically start it in OCaml buffers - (add-hook 'tuareg-mode-hook 'merlin-mode t) - (add-hook 'caml-mode-hook 'merlin-mode t) - ;; Use opam switch to lookup ocamlmerlin binary - (setq merlin-command 'opam))) - -Take a look at https://github.com/ocaml/merlin for more information - -Quick setup with opam-user-setup --------------------------------- - -Opam-user-setup support Merlin. - - $ opam user-setup install - -should take care of basic setup. -See https://github.com/OCamlPro/opam-user-setup -" - {success & !user-setup:installed} -] diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/browse_misc.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/browse_misc.ml deleted file mode 100644 index 3b81949b2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/browse_misc.ml +++ /dev/null @@ -1,151 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let dummy_type_scheme desc = - Types.create_expr desc ~level:0 ~id:0 ~scope:Btype.generic_level - -let print_constructor c = - let open Types in - match c.cstr_args with - | [] -> - Printtyp.tree_of_type_scheme - (dummy_type_scheme (get_desc c.cstr_res)) - | args -> - let desc = Tarrow (Ast_helper.no_label, - dummy_type_scheme (Ttuple args), - c.cstr_res, commu_ok) - in - Printtyp.tree_of_type_scheme (dummy_type_scheme desc) - -let summary_prev = function - | Env.Env_empty -> None - | Env.Env_open (s,_) | Env.Env_value (s,_,_) - | Env.Env_type (s,_,_) | Env.Env_extension (s,_,_) - | Env.Env_module (s,_,_,_) | Env.Env_modtype (s,_,_) - | Env.Env_class (s,_,_) | Env.Env_cltype (s,_,_) - | Env.Env_functor_arg (s,_) - | Env.Env_constraints (s,_) - | Env.Env_copy_types s - | Env.Env_persistent (s,_) - | Env.Env_value_unbound (s, _, _) | Env.Env_module_unbound (s, _, _) -> - Some s - -let signature_of_env ?(ignore_extensions=true) env = - let signature_of_summary = - let open Env in - let open Types in - (* FIXME: the use of [Exported] here is wrong... The compiler should export - that information. *) - function - | Env_value (_,i,v) -> Some (Sig_value (i,v,Exported)) - (* Trec_not == bluff, FIXME *) - | Env_type (_,i,t) -> Some (Sig_type (i,t,Trec_not,Exported)) - (* Texp_first == bluff, FIXME *) - | Env_extension (_,i,e) -> - begin match e.ext_type_path with - | Path.Pident id when Ident.name id = "exn" -> - Some (Sig_typext (i,e, Text_exception, Exported)) - | _ -> - Some (Sig_typext (i,e, Text_first, Exported)) - end - | Env_module (_,i,pr,m) -> Some (Sig_module (i,pr,m,Trec_not,Exported)) - | Env_modtype (_,i,m) -> Some (Sig_modtype (i,m,Exported)) - | Env_class (_,i,c) -> Some (Sig_class (i,c,Trec_not,Exported)) - | Env_cltype (_,i,c) -> Some (Sig_class_type (i,c,Trec_not,Exported)) - | Env_open _ | Env_empty | Env_functor_arg _ - | Env_constraints _ | Env_copy_types _ | Env_persistent _ - | Env_value_unbound _ | Env_module_unbound _ -> None - in - let summary_module_ident_opt = function - | Env.Env_module (_,i,_,_) -> Some i - | _ -> None - in - let sg = ref [] in - let append item = sg := item :: !sg in - let rec aux summary = - match summary_module_ident_opt summary with - | Some i when ignore_extensions && i = Extension.ident -> () - | _ -> - Option.iter ~f:append (signature_of_summary summary); - Option.iter ~f:aux (summary_prev summary) - in - aux (Env.summary env); - (* Since 4.08 one can't simply call [simplify]. *) - (* Typemod.simplify_signature *) (!sg) - -let dump_browse node = - let attr attr = - let ({Location . txt; loc},payload) = Ast_helper.Attr.as_tuple attr in - `Assoc [ - "start" , Lexing.json_of_position loc.Location.loc_start; - "end" , Lexing.json_of_position loc.Location.loc_end; - "name" , `String (txt ^ if payload = Parsetree.PStr [] then "" else " _") - ] - in - let rec append env node acc = - let loc = Mbrowse.node_loc node in - `Assoc [ - "filename" , `String loc.Location.loc_start.Lexing.pos_fname; - "start" , Lexing.json_of_position loc.Location.loc_start; - "end" , Lexing.json_of_position loc.Location.loc_end; - "ghost" , `Bool loc.Location.loc_ghost; - "attrs" , `List (List.map ~f:attr (Browse_raw.node_attributes node)); - "kind" , `String (Browse_raw.string_of_node node); - "children" , dump_list env node - ] :: acc - and dump_list env node = - `List (List.sort ~cmp:compare @@ - Mbrowse.fold_node append env node []) - in - `List (append Env.empty node []) - -let annotate_tail_calls (ts : Mbrowse.t) : - (Env.t * Browse_raw.node * Query_protocol.is_tail_position) list = - let is_one_of candidates node = List.mem node ~set:candidates in - let find_entry_points candidates (env, node) = - Tail_analysis.entry_points node, - (env, node, is_one_of candidates node) in - let _, entry_points = List.fold_n_map ts ~f:find_entry_points ~init:[] in - let propagate candidates (env, node, entry) = - let is_in_tail = entry || is_one_of candidates node in - (if is_in_tail - then Tail_analysis.tail_positions node - else []), - (env, node, is_in_tail) in - let _, tail_positions = List.fold_n_map entry_points ~f:propagate ~init:[] in - List.map ~f:(fun (env, node, tail) -> - env, node, - if not tail then - `No - else if Tail_analysis.is_call node then - `Tail_call - else - `Tail_position) - tail_positions diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/browse_tree.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/browse_tree.ml deleted file mode 100644 index 79afd4057..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/browse_tree.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let default_loc = Location.none -let default_env = Env.empty - -type t = { - t_node: Mbrowse.node; - t_loc : Location.t; - t_env : Env.t; - t_children: t list lazy_t; -} - -let of_node ?(env=default_env) node = - let rec one t_env t_node = - let t_loc = Mbrowse.node_loc t_node in - let rec t = {t_node; t_env; t_loc; t_children = lazy (aux t)} in - t - and aux t = - Mbrowse.fold_node (fun env node acc -> one env node :: acc) - t.t_env t.t_node [] - in - one (Browse_raw.node_update_env env node) node - -let of_browse b = - let env, node = Mbrowse.leaf_node b in - of_node ~env node - -let dummy = { - t_node = Browse_raw.Dummy; - t_loc = default_loc; - t_env = default_env; - t_children = lazy [] -} - -let rec normalize_type_expr env type_expr = - match Types.get_desc type_expr with - | Types.Tconstr (path,_,_) -> - normalize_type_decl env (Env.find_type path env) - | _ -> raise Not_found - -and normalize_type_decl env decl = match decl.Types.type_manifest with - | Some expr -> normalize_type_expr env expr - | None -> decl - -let id_of_constr_decl c = c.Types.cd_id - -let same_constructor env a b = - let name = function - | `Description d -> d.Types.cstr_name - | `Declaration d -> Ident.name d.Typedtree.cd_id - in - if name a <> name b then false - else begin - let get_decls = function - | `Description d -> - let ty = normalize_type_expr env d.Types.cstr_res in - begin match ty.Types.type_kind with - | Types.Type_variant (decls, _) -> - List.map decls ~f:id_of_constr_decl - | _ -> assert false - end - | `Declaration d -> - [d.Typedtree.cd_id] - in - let a = get_decls a in - let b = get_decls b in - List.exists a ~f:(fun id -> List.exists b ~f:(Ident.same id)) - end - -let all_occurrences path = - let rec aux acc t = - let acc = - let paths = Browse_raw.node_paths t.t_node in - let same l = Path.same path l.Location.txt in - match List.filter ~f:same paths with - | [] -> acc - | paths -> (t, paths) :: acc - in - List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children) - in - aux [] - -let all_constructor_occurrences ({t_env = env; _},d) t = - let rec aux acc t = - let acc = - match Browse_raw.node_is_constructor t.t_node with - | Some d' when ( - (* Don't try this at home kids. *) - try same_constructor env d d'.Location.txt - with Not_found -> same_constructor t.t_env d d'.Location.txt - ) -> - {d' with Location.txt = t} :: acc - | _ -> acc - in - List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children) - in - aux [] t - -let all_occurrences_of_prefix path node = - let rec path_prefix ~prefix path = - Path.same prefix path || - match path with - | Pdot (p,_) -> path_prefix ~prefix p - | _ -> false - in - let rec aux env node acc = - let acc = - let paths_and_lids = Browse_raw.node_paths_and_longident node in - let has_prefix ({Location. txt; _}, _) = - match txt with - | Path.Pdot (p, _) -> path_prefix ~prefix:path p - | _ -> false - in - List.fold_right paths_and_lids ~init:acc ~f:(fun elt acc -> - if has_prefix elt then elt :: acc else acc - ) - in - Browse_raw.fold_node aux env node acc - in - aux Env.empty node [] diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/browse_tree.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/browse_tree.mli deleted file mode 100644 index 24284e835..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/browse_tree.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -type t = { - t_node : Mbrowse.node; - t_loc : Location.t; - t_env : Env.t; - t_children : t list lazy_t; -} - -val default_loc : Location.t -val default_env : Env.t - -(** [of_node ?loc ?env node] produces a tree from [node], using [loc] and [env] - * as default annotation when nothing can be inferred from the [node]. - * If they are not specified, annotations from child are used for approximation. - *) -val of_node : ?env:Env.t -> Mbrowse.node -> t -val of_browse : Mbrowse.t -> t - -val dummy : t - -val all_occurrences : Path.t -> t -> (t * Path.t Location.loc list) list -val all_constructor_occurrences : - t * [ `Description of Types.constructor_description - | `Declaration of Typedtree.constructor_declaration ] - -> t -> t Location.loc list - -val all_occurrences_of_prefix : - Path.t -> Browse_raw.node -> (Path.t Location.loc * Longident.t) list diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/completion.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/completion.ml deleted file mode 100644 index 02c75a180..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/completion.ml +++ /dev/null @@ -1,806 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - Jeremie Dimino - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -open Browse_raw - -open Extend_protocol.Reader - -let {Logger. log} = Logger.for_section "Completion" - -type raw_info = - [ `Constructor of Types.constructor_description - | `Modtype of Types.module_type - | `Modtype_declaration of Ident.t * Types.modtype_declaration - | `None - | `String of string - | `Type_declaration of Ident.t * Types.type_declaration - | `Type_scheme of Types.type_expr - | `Variant of string * Types.type_expr option - ] - -let raw_info_printer : raw_info -> _ = function - | `Constructor c -> - `Print (Out_type (Browse_misc.print_constructor c)) - | `Modtype mt -> - `Print (Out_module_type (Printtyp.tree_of_modtype mt)) - | `Modtype_declaration (id, mtd) -> - `Print (Out_sig_item - (Printtyp.tree_of_modtype_declaration id mtd)) - | `None -> `String "" - | `String s -> `String s - | `Type_declaration (id, tdecl) -> - `Print (Out_sig_item - (Printtyp.tree_of_type_declaration id tdecl Types.Trec_first)) - | `Type_scheme te -> - `Print (Out_type (Printtyp.tree_of_type_scheme te)) - | `Variant (label, arg) -> - begin match arg with - | None -> `String label - | Some te -> - `Concat (label ^ " of ", - Out_type (Printtyp.tree_of_type_scheme te)) - end - -(* List methods of an object. - Code taken from [uTop](https://github.com/diml/utop - with permission from Jeremie Dimino. *) -let lookup_env f x env = - try Some (f x env) - with Not_found | Env.Error _ -> None - -let rec methods_of_type env ?(acc=[]) type_expr = - let open Types in - match get_desc type_expr with - | Tlink type_expr | Tobject (type_expr, _) | Tpoly (type_expr, _) -> - methods_of_type env ~acc type_expr - | Tfield (name, _, ty, rest) -> - methods_of_type env ~acc:((name,ty) :: acc) rest - | Tconstr (path, _, _) -> begin - match lookup_env Env.find_type path env with - | None | Some { type_manifest = None; _ } -> acc - | Some { type_manifest = Some type_expr; _ } -> - methods_of_type env ~acc type_expr - end - | _ -> acc - -let classify_node = function - | Dummy -> `Expression - | Pattern _ -> `Pattern - | Expression _ -> `Expression - | Case _ -> `Pattern - | Class_expr _ -> `Expression - | Class_structure _ -> `Expression - | Class_field _ -> `Expression - | Class_field_kind _ -> `Expression - | Module_expr _ -> `Module - | Module_type_constraint _ -> `Module_type - | Structure _ -> `Structure - | Structure_item _ -> `Structure - | Module_binding _ -> `Module - | Value_binding _ -> `Type - | Module_type _ -> `Module_type - | Signature _ -> `Signature - | Signature_item _ -> `Signature - | Module_declaration _ -> `Module - | Module_type_declaration _ -> `Module_type - | With_constraint _ -> `Type - | Core_type _ -> `Type - | Package_type _ -> `Module_type - | Row_field _ -> `Expression - | Value_description _ -> `Type - | Type_declaration _ -> `Type - | Type_kind _ -> `Type - | Type_extension _ -> `Type - | Extension_constructor _ -> `Type - | Label_declaration _ -> `Type - | Constructor_declaration _ -> `Type - | Class_type _ -> `Type - | Class_signature _ -> `Type - | Class_type_field _ -> `Type - | Class_declaration _ -> `Expression - | Class_description _ -> `Type - | Class_type_declaration _ -> `Type - | Method_call _ -> `Expression - | Record_field (`Expression _, _, _) -> `Expression - | Record_field (`Pattern _, _, _) -> `Pattern - | Module_binding_name _ -> `Module - | Module_declaration_name _ -> `Module - | Module_type_declaration_name _ -> `Module_type - | Open_description _ -> `Module - | Open_declaration _ -> `Module - | Include_declaration _ -> `Module - | Include_description _ -> `Module - -open Query_protocol.Compl - -let map_entry f entry = - {entry with desc = f entry.desc; info = f entry.info} - -let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = - let ident = match path with - | Some path -> - (* this is not correct: the ident is not persistent, the printing of some - polymorphic variant type could (perhaps) be incorrect because of this - (though I haven't tried to add a test). But it would be incorrect with - any ident with synthesize at this point anyway. - And create_persistent is the only function which is available on all - the versions of ocaml we support. *) - Ident.create_persistent (Path.last path) - | None -> Extension.ident - in - let kind, text = - match ty with - | `Value v -> - (`Value, `Type_scheme v.Types.val_type) - | `Cons c -> (`Constructor, `Constructor c) - | `Label label_descr -> - let desc = - Types.(Tarrow (Ast_helper.no_label, - label_descr.lbl_res, label_descr.lbl_arg, commu_ok)) - in - (`Label, `Type_scheme (Btype.newgenty desc)) - | `Label_decl (ty,label_decl) -> - let desc = - Types.(Tarrow (Ast_helper.no_label, - ty, label_decl.ld_type, commu_ok)) - in - (`Label, `Type_scheme (Btype.newgenty desc)) - | `Mod m -> - begin try - if not exact then raise Exit; - let verbosity = !Type_utils.verbosity in - if Type_utils.mod_smallerthan (1000 * verbosity) m = None then raise Exit; - (`Module, `Modtype m) - with Exit -> (`Module, `None) - end - | `ModType m -> - if exact then - (`Modtype, `Modtype_declaration (ident, (*verbose_sig env*) m)) - else - (`Modtype, `None) - | `Typ t -> - (`Type, `Type_declaration (ident, t)) - | `Variant (label,arg) -> - (`Variant, `Variant (label, arg)) - in - (* FIXME: When suggesting variants (and constructors) with parameters, - it could be nice to check precedence and add or not parenthesis. - let name = match ty with - | `Variant (_, Some _) -> "(" ^ name ^ " )" - | _ -> name - in*) - let name = - match prefix_path with - | None -> name - | Some _ -> Misc_utils.parenthesize_name name - in - let desc = - match kind with - | `Module | `Modtype -> `None - | _ -> text - in - let info = match Type_utils.read_doc_attributes attrs, get_doc, kind with - | Some (str, _), _, _ -> `String str - | None, _, (`Module | `Modtype) -> text - | None, None, _ -> `None - | None, Some get_doc, kind -> - match path, loc with - | Some p, Some loc -> - let namespace = (* FIXME: that's just terrible *) - match kind with - | `Value -> `Vals - | `Type -> `Type - | _ -> assert false - in - begin match get_doc (`Completion_entry (namespace, p, loc)) with - | `Found str -> `String str - | _ -> `None - | exception _ -> `None - end - | _, _ -> `None - in - let deprecated = Type_utils.is_deprecated attrs in - {name; kind; desc; info; deprecated} - -let item_for_global_module name = - {name; kind = `Module; desc = `None; info = `None; deprecated = false} - -let fold_variant_constructors ~env ~init ~f = - let rec aux acc t = - match Types.get_desc t with - | Types.Tvariant row -> - let row_fields = Types.row_fields row in - let row_more = Types.row_more row in - let acc = - let keep_if_present acc (lbl, row_field) = - let row_field = Types.row_field_repr row_field in - match row_field with - | Types.Rpresent arg when lbl <> "" -> f ("`" ^ lbl) arg acc - | Types.Reither (_, lst, _) when lbl <> "" -> - let arg = - match lst with - | [ well_typed ] -> Some well_typed - | _ -> None - in - f ("`" ^ lbl) arg acc - | _ -> acc - in - List.fold_left ~init:acc row_fields ~f:keep_if_present - in - aux acc row_more - | Types.Tconstr _ -> - let t' = try Ctype.full_expand env ~may_forget_scope:true t with _ -> t in - if Types.TransientTypeOps.equal - (Types.Transient_expr.repr t) - (Types.Transient_expr.repr t') - then - acc - else - aux acc t' - | _ -> acc - in - aux init - -let fold_sumtype_constructors ~env ~init ~f t = - let t = Types.Transient_expr.repr t in - match t.desc with - | Tconstr (path, _, _) -> - log ~title:"fold_sumtype_constructors" "node type: %s" - (Path.name path); - begin match Env.find_type_descrs path env with - | exception Not_found -> init - | Type_record _ | Type_abstract | Type_open -> init - | Type_variant (constrs, _) -> - List.fold_right constrs ~init ~f - end - | _ -> - init - -let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch = - let cstr_attributes c = c.Types.cstr_attributes in - let val_attributes v = v.Types.val_attributes in - let type_attributes t = t.Types.type_attributes in - let lbl_attributes l = l.Types.lbl_attributes in - let mtd_attributes t = t.Types.mtd_attributes in - let md_attributes t = t.Types.md_attributes in - let make_candidate ~attrs ~exact name ?loc ?path ty = - make_candidate ~get_doc ~prefix_path ~attrs ~exact name ?loc ?path ty in - let make_weighted_candidate ?(priority=0) ~attrs ~exact name ?loc ?path ty = - (* Just like [make_candidate] but associates some metadata to the candidate. - The candidates are later sorted using these metadata. - - The ordering works as follow: - - first we compare the priority of the candidates - - we compare the cost of unification for both (using Btype.total_changes) - - if they are equal, then we compare their "binding time": things - introduced more recently will come before older bindings (i.e. we - prioritize the local context) - - if these are also equal, then we just use classic string ordering on - the candidate name. *) - let time = - try Path.scope (Option.get path) - with _ -> 0 - in - let item = make_candidate ~attrs ~exact name ?loc ?path ty in - (- priority, - time, name), item - in - let is_internal name = name = "" || name.[0] = '_' in - let items = - let snap = Btype.snapshot () in - let rec arrow_arity n t = - match Types.get_desc t with - | Types.Tarrow (_,_,rhs,_) -> arrow_arity (n + 1) rhs - | _ -> n - in - let rec nth_arrow n t = - if n <= 0 then t else - match Types.get_desc t with - | Types.Tarrow (_,_,rhs,_) -> nth_arrow (n - 1) rhs - | _ -> t - in - let type_check = - (* Defines the priority of a candidate. - Priority is 1000 - cost - head_arrows, where: - - cost is the number unification variables instantiated to make the types unify - - head_arrows is 0 if types unified, or the number of arrows which - have been skipped to make them unify (i.e types would unify if the - user apply the function to head_arrows arguments). - Note that if no type is expected (context was not inferred), 0 will be - returned. *) - match target_type with - | None -> fun _ -> 0 - | Some ty -> - let arity = arrow_arity 0 ty in - fun scheme -> - let cost = - let c = Types.linked_variables in - try - let c' = c () in - Ctype.unify_var env ty (Ctype.instance scheme); - c () - c' - with _ -> - let arity = arrow_arity (-arity) scheme in - if arity > 0 then begin - let c' = c () in - Btype.backtrack snap; - let ty' = Ctype.instance scheme in - let ty' = nth_arrow arity ty' in - try Ctype.unify_var env ty ty'; arity + c () - c' - with _ -> 1000 - end - else 1000 - in - Btype.backtrack snap; - 1000 - cost - in - let of_kind = function - | `Keywords -> [] (* cannot happen after a dot. *) - | `Variants -> - let add_variant name param candidates = - if not @@ validate `Variant `Variant name then candidates else - make_weighted_candidate name ~exact:false ~priority:2 ~attrs:[] - (`Variant (name, param)) - :: candidates - in - let result = match target_type with - | None -> [] - | Some t -> fold_variant_constructors t ~init:[] ~f:add_variant ~env - in - let result = match branch with - | _ :: (_, Expression {Typedtree. exp_type = t; _}) :: _ - | (_, Expression {Typedtree. exp_type = t; _}) :: _ -> - fold_variant_constructors t ~init:result ~f:add_variant ~env - | _ -> result - in - result - | `Values -> - let type_check {Types. val_type; _} = type_check val_type in - Env.fold_values (fun name path v candidates -> - if not (validate `Lident `Value name) then candidates else - let priority = if is_internal name then 0 else type_check v in - make_weighted_candidate ~exact:(name = prefix) name ~priority ~path - ~attrs:(val_attributes v) - (`Value v) ~loc:v.Types.val_loc - :: candidates - ) prefix_path env [] - - | `Constructor -> - let type_check {Types. cstr_res; _} = type_check cstr_res in - let consider_constr constr candidates = - let name = constr.Types.cstr_name in - if not @@ validate `Lident `Cons name then candidates else - let priority = if is_internal name then 0 else type_check constr in - make_weighted_candidate ~exact:(name=prefix) name (`Cons constr) - ~priority ~attrs:(cstr_attributes constr) - :: candidates - in - let in_scope_candidates = - Env.fold_constructors consider_constr prefix_path env [] - in - begin match prefix_path, target_type with - | Some _, _ - | _, None -> in_scope_candidates - | None, Some ty -> - fold_sumtype_constructors ~env ~init:in_scope_candidates - ~f:consider_constr ty - end - - | `Types -> - Env.fold_types (fun name path decl candidates -> - if not @@ validate `Lident `Typ name then candidates else - make_weighted_candidate ~exact:(name = prefix) name ~path (`Typ decl) - ~loc:decl.Types.type_loc ~attrs:(type_attributes decl) - :: candidates - ) prefix_path env [] - - | `Modules -> - Env.fold_modules (fun name path v candidates -> - let attrs = md_attributes v in - let v = v.Types.md_type in - if not @@ validate `Uident `Mod name then candidates else - make_weighted_candidate ~exact:(name = prefix) name ~path (`Mod v) ~attrs - :: candidates - ) prefix_path env [] - - | `Modules_type -> - Env.fold_modtypes (fun name path v candidates -> - if not @@ validate `Uident `Mod name then candidates else - make_weighted_candidate ~exact:(name=prefix) name ~path (`ModType v) - ~attrs:(mtd_attributes v) - :: candidates - ) prefix_path env [] - - | `Labels -> - Env.fold_labels (fun ({Types.lbl_name = name; _} as l) candidates -> - if not (validate `Lident `Label name) then candidates else - make_weighted_candidate ~exact:(name = prefix) name (`Label l) - ~attrs:(lbl_attributes l) - :: candidates - ) prefix_path env [] - in - let of_kind_group = function - | #Query_protocol.Compl.kind as k -> of_kind k - | `Group kinds -> List.concat_map ~f:of_kind kinds - in - try of_kind_group kind - with exn -> - log ~title:"get_candidates/of_kind" - "Failed with exception: %a" Logger.exn exn; - [] - in - let items = List.sort items ~cmp:(fun (a,_) (b,_) -> compare a b) in - let items = List.rev_map ~f:snd items in - items - -let gen_values = `Group [`Values; `Constructor] - -let default_kinds = [`Variants; gen_values; `Types; `Modules; `Modules_type] - -let completion_order = function - | `Expression -> [`Variants; gen_values; `Types; `Modules; `Modules_type] - | `Structure -> [gen_values; `Types; `Modules; `Modules_type] - | `Pattern -> [`Variants; `Constructor; `Modules; `Labels; `Values; `Types; `Modules_type] - | `Module -> [`Modules; `Modules_type; `Types; gen_values] - | `Module_type -> [`Modules_type; `Modules; `Types; gen_values] - | `Signature -> [`Types; `Modules; `Modules_type; gen_values] - | `Type -> [`Types; `Modules; `Modules_type; gen_values] - -type kinds = [kind | `Group of kind list] list - -let complete_methods ~env ~prefix obj = - let t = obj.Typedtree.exp_type in - let has_prefix (name,_) = - String.is_prefixed ~by:prefix name && - (* Prevent identifiers introduced by type checker to leak *) - try ignore (String.index name ' ' : int); false - with Not_found -> true - in - let methods = List.filter ~f:has_prefix (methods_of_type env t) in - List.map methods ~f:(fun (name,ty) -> - let info = `None (* TODO: get documentation. *) in - { name; kind = `MethodCall; desc = `Type_scheme ty; info; deprecated = false } - ) - -type is_label = - [ `No | `Maybe - | `Description of Types.label_description list - | `Declaration of Types.type_expr * Types.label_declaration list - ] - -let complete_prefix ?get_doc ?target_type ?(kinds=[]) ~keywords ~prefix - ~is_label config (env,node) branch = - Env.with_cmis @@ fun () -> - let seen = Hashtbl.create 7 in - let uniq n = if Hashtbl.mem seen n - then false - else (Hashtbl.add seen n (); true) - in - let make_candidate ~attrs ~exact name ?loc ?path ty = - make_candidate ~get_doc ~attrs ~exact name ?loc ?path ty in - let find ?prefix_path ~is_label prefix = - let valid tag name = - let no_leak () = - (* Prevent identifiers introduced by type checker - and recovery to leak *) - List.for_all ~f:(fun by -> not (String.is_prefixed ~by name)) - ["self-"; "selfpat-"; "*type-"] - in - String.is_prefixed ~by:prefix name - && uniq (tag,name) - && no_leak () - in - (* Hack to prevent extensions namespace to leak - + another to hide the "Library_name__Module" present at Jane Street *) - let validate ident tag name = - (if ident = `Uident - then name <> "" && name.[0] <> '_' - && (String.no_double_underscore name || tag <> `Mod) - else name <> "_") - && valid tag name - in - let add_label_description ({Types.lbl_name = name; _} as l) candidates = - if not (valid `Label name) then candidates else - make_candidate ~prefix_path ~exact:(name = prefix) name - (`Label l) ~attrs:[] - :: candidates - in - let add_label_declaration ty ({Types.ld_id = name; _} as l) candidates = - let name = Ident.name name in - if not (valid `Label name) then candidates else - make_candidate ~prefix_path ~exact:(name = prefix) name - (`Label_decl (ty,l)) ~attrs:[] - :: candidates - in - let base_completion = match (is_label : is_label) with - | `No -> [] - | `Maybe -> - Env.fold_labels add_label_description prefix_path env [] - | `Description lbls -> - List.fold_right ~f:add_label_description lbls ~init:[] - | `Declaration (ty,decls) -> - List.fold_right ~f:(add_label_declaration ty) decls ~init:[] - in - if base_completion = [] then - let order = - if kinds = [] then - let kind = classify_node node in - completion_order kind - else - (kinds : kind list :> kinds) - in - let add_completions acc kind = - get_candidates - ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch - :: acc - in - List.fold_left ~f:add_completions order ~init:[] - |> List.concat - else base_completion - in - try - match prefix with - | Longident.Ldot (prefix_path, prefix) -> find ~prefix_path ~is_label prefix - | Longident.Lident prefix -> - (* Regular completion *) - let compl = find ~is_label prefix in - (* Keywords completion *) - let compl = - if not (List.mem `Keywords ~set:kinds) then - compl - else - List.fold_left keywords ~init:compl ~f:(fun candidates name -> - if String.is_prefixed ~by:prefix name then - { name; kind = `Keyword; desc = `None; info = `None - ; deprecated = false } - :: candidates - else - candidates - ) - in - (* Add modules on path but not loaded *) - List.fold_left (Mconfig.global_modules config) ~init:compl ~f:( - fun candidates name -> - if not (String.no_double_underscore name) then candidates else - let default = - { name; kind = `Module; desc = `None; info = `None; deprecated = false } in - if name = prefix && uniq (`Mod, name) then - try - let path, md, attrs = Type_utils.lookup_module (Longident.Lident name) env in - make_candidate ~prefix_path:(Some prefix) ~exact:true ~path name - (`Mod md) ~attrs - :: candidates - with Not_found -> - default :: candidates - else if String.is_prefixed ~by:prefix name && uniq (`Mod,name) then - default :: candidates - else - candidates - ) - | _ -> find ~is_label (String.concat ~sep:"." @@ Longident.flatten prefix) - with Not_found -> [] - -(* Propose completion from a particular node *) -let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix = - function - | [] -> [] - | (env, node) :: branch -> - match node with - | Method_call (obj,_,_) -> complete_methods ~env ~prefix obj - | Pattern { Typedtree.pat_desc = Typedtree.Tpat_record _ ; pat_type = t ; _ } - | Expression { Typedtree.exp_desc = Typedtree.Texp_record _ ; exp_type = t ; _ } -> - let is_label = - try match Types.get_desc t with - | Types.Tconstr (p, _, _) -> - (match (Env.find_type p env).Types.type_kind with - | Types.Type_record (labels, _) -> - `Declaration (t, labels) - | _ -> `Maybe) - | _ -> `Maybe - with _ -> `Maybe - in - let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in - complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label - buffer (env,node) branch - | Record_field (parent, lbl, _) -> - let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in - let snap = Btype.snapshot () in - let is_label = match lbl.Types.lbl_all with - | [||] -> - begin match - let ty = match parent with - | `Expression e -> e.Typedtree.exp_type - | `Pattern p -> p.Typedtree.pat_type - in - let decl = Ctype.extract_concrete_typedecl env ty in - (ty, decl) - with - | (ty, Typedecl (p, _, decl)) -> - begin try - let lbls = Datarepr.labels_of_type p decl in - let labels = List.map lbls ~f:(fun (_,lbl) -> - try - let _, lbl_arg, lbl_res = Ctype.instance_label false lbl in - begin try - Ctype.unify_var env ty lbl_res; - with _ -> () - end; - (* FIXME: the two subst can lose some sharing between types *) - let lbl_res = Subst.type_expr Subst.identity lbl_res in - let lbl_arg = Subst.type_expr Subst.identity lbl_arg in - {lbl with Types. lbl_res; lbl_arg} - with _ -> lbl - ) in - `Description labels - with _ -> - match decl.Types.type_kind with - | Types.Type_record (lbls, _) -> - `Declaration (ty, lbls) - | _ -> `Maybe - end - | _ | exception _ -> `Maybe - end - | lbls -> - `Description (Array.to_list lbls) - in - let result = - complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label - buffer (env, node) branch - in - Btype.backtrack snap; - result - | _ -> - let prefix, is_label = Longident.(keep_suffix @@ parse prefix) in - complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix buffer - ~is_label:(if is_label then `Maybe else `No) - (env, node) branch - -let expand_prefix ~global_modules ?(kinds=[]) env prefix = - Env.with_cmis @@ fun () -> - let lidents, last = - let ts = Expansion.explore ~global_modules env in - Expansion.get_lidents ts prefix - in - let validate' = - let last = Expansion.spell_index last in - fun s -> Expansion.spell_match last s - in - let validate _ _ s = validate' s in - let kinds = match kinds with - | [] -> default_kinds - | kinds -> (kinds : kind list :> kinds) - in - let process_prefix_path prefix_path = - let candidates = - let aux compl kind = - get_candidates ?prefix_path ~prefix:"" kind ~validate env [] :: compl in - List.fold_left ~f:aux kinds ~init:[] - in - match prefix_path with - | None -> - let f name = - if not (validate' name) then None else - Some (item_for_global_module name) - in - candidates @ [List.filter_map global_modules ~f] - |> List.flatten - | Some lident -> - let lident = Longident.flatten lident in - let lident = String.concat ~sep:"." lident ^ "." in - List.concat_map candidates ~f:(List.map ~f:(fun c -> - { c with name = lident ^ Misc_utils.parenthesize_name c.name })) - in - List.concat_map ~f:process_prefix_path lidents - -open Typedtree - -let labels_of_application ~prefix = function - | {exp_desc = Texp_apply (f, args); exp_env; _} -> - let rec labels t = - match Types.get_desc t with - | Types.Tarrow (label, lhs, rhs, _) -> - (label, lhs) :: labels rhs - | _ -> - let t' = Ctype.full_expand ~may_forget_scope:true exp_env t in - if Types.TransientTypeOps.equal - (Types.Transient_expr.repr t) - (Types.Transient_expr.repr t') - then - [] - else - labels t' - in - let labels = labels f.exp_type in - let is_application_of label (label',expr) = - match expr with - | Some {exp_loc = {Location. loc_ghost; loc_start; loc_end}; _} -> - label = label' - && (Btype.prefixed_label_name label <> prefix) - && not loc_ghost - && not (loc_start = loc_end) - | None -> false - in - List.filter_map ~f:(fun (label, ty) -> - match label with - | Asttypes.Nolabel -> None - | label when List.exists ~f:(is_application_of label) args -> None - | Asttypes.Labelled str -> Some ("~" ^ str, ty) - | Asttypes.Optional str -> - let ty = match Types.get_desc ty with - | Types.Tconstr (path, [ty], _) - when Path.same path Predef.path_option -> ty - | _ -> ty - in - Some ("?" ^ str, ty) - ) labels - | _ -> [] - - -let application_context ~prefix path = - let module Printtyp = Type_utils.Printtyp in - let target_type = ref ( - match snd (List.hd path) with - | Expression { exp_type = ty ; _ } - | Pattern { pat_type = ty ; _ } -> Some ty - | _ -> None - ) - in - let context = match path with - | (_, Expression earg) :: - (_, Expression ({ exp_desc = Texp_apply (efun, _); _ } as app)) :: _ - when earg != efun -> - (* Type variables shared across arguments should all be - printed with the same name. - [Printtyp.type_scheme] ensure that a name is unique within a given - type, but not across different invocations. - [reset] followed by calls to [mark_loops] and [type_sch] provide - that *) - Printtyp.reset (); - let pr t = - let ppf, to_string = Format.to_string () in - Printtyp.shared_type_scheme ppf t; - to_string () - in - (* Special case for optional arguments applied with ~, - get the argument wrapped inside Some _ *) - let earg = - match Mbrowse.optional_label_sugar earg.exp_desc with - | None -> earg - | Some earg -> - target_type := Some earg.exp_type; - earg - in - let labels = labels_of_application ~prefix app in - `Application { argument_type = pr earg.exp_type; - labels = List.map ~f:(fun (lbl,ty) -> lbl, pr ty) labels; - } - | _ -> `Unknown - in - !target_type, context diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/completion.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/completion.mli deleted file mode 100644 index 8cc348526..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/completion.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Query_protocol - -(* TODO: document all the following functions *) - -type raw_info = - [ `Constructor of Types.constructor_description - | `Modtype of Types.module_type - | `Modtype_declaration of Ident.t * Types.modtype_declaration - | `None - | `String of string - | `Type_declaration of Ident.t * Types.type_declaration - | `Type_scheme of Types.type_expr - | `Variant of string * Types.type_expr option - ] - -val raw_info_printer : raw_info -> - [ `String of string - | `Print of Extend_protocol.Reader.outcometree - | `Concat of string * Extend_protocol.Reader.outcometree - ] - -val map_entry : ('a -> 'b) -> - 'a Compl.raw_entry -> 'b Compl.raw_entry - -val branch_complete - : Mconfig.t - -> ?get_doc:([> `Completion_entry of Namespaced_path.Namespace.t - * Path.t * Location.t ] -> [> `Found of string ]) - -> ?target_type:Types.type_expr - -> ?kinds:Compl.kind list - -> keywords:string list - -> string - -> Mbrowse.t - -> raw_info Compl.raw_entry list - -val expand_prefix - : global_modules:string list - -> ?kinds:Compl.kind list - -> Env.t -> string - -> raw_info Compl.raw_entry list - -val application_context : prefix:Asttypes.label -> Mbrowse.t -> - Types.type_expr option * - [> `Application of Compl.application_context | `Unknown ] diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/construct.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/construct.ml deleted file mode 100644 index 740dd7d43..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/construct.ml +++ /dev/null @@ -1,549 +0,0 @@ -open Std -open Typedtree - -let {Logger. log} = Logger.for_section "construct" - -type values_scope = Null | Local -type what = Modtype | Mod - -exception Not_allowed of string -exception Not_a_hole -exception Modtype_not_found of what * string -exception No_constraint - -let () = - Location.register_error_of_exn (function - | Not_a_hole -> - Some (Location.error "Construct only works on holes.") - | Modtype_not_found (Modtype, s) -> - let txt = Format.sprintf "Module type not found: %s" s in - Some (Location.error txt) - | Modtype_not_found (Mod, s) -> - let txt = Format.sprintf "Module not found: %s" s in - Some (Location.error txt) - | No_constraint -> - Some (Location.error - "Could not find a module type to construct from. \ - Check that you used a correct constraint.") - | _ -> None - ) -module Util = struct - open Misc_utils.Path - open Types - - let predef_types = - let tbl = Hashtbl.create 14 in - let () = - let constant c = - Ast_helper.Exp.constant c - in - let construct s = - Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident s)) None - in - let ident s = - Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident s)) - in - List.iter ~f:(fun (k, v) -> Hashtbl.add tbl k v) - Parsetree.[ - Predef.path_int, constant (Pconst_integer("0", None)) ; - Predef.path_float, constant (Pconst_float("0.0", None)) ; - Predef.path_char, constant (Pconst_char 'c') ; - Predef.path_string, - constant (Pconst_string("", Location.none, None)) ; - Predef.path_bool, construct "true" ; - Predef.path_unit, construct "()" ; - Predef.path_exn, ident "exn" ; - Predef.path_array, Ast_helper.Exp.array [] ; - Predef.path_nativeint, constant (Pconst_integer("0", Some 'n')) ; - Predef.path_int32, constant (Pconst_integer("0", Some 'l')) ; - Predef.path_int64, constant (Pconst_integer("0", Some 'L')) ; - Predef.path_lazy_t, Ast_helper.Exp.lazy_ (construct "()") - ] - in - tbl - - let prefix env ~env_check path name = - to_shortest_lid ~env ~env_check ~name path - - let var_of_id id = Location.mknoloc @@ Ident.name id - - let type_to_string t = - Printtyp.type_expr (Format.str_formatter) t; - Format.flush_str_formatter () - - let unifiable env type_expr type_expected = - let snap = Btype.snapshot () in - try - Ctype.unify env type_expected type_expr |> ignore; - Some snap - with Ctype.Unify _ -> - (* Unification failure *) - Btype.backtrack snap; - None - - let is_in_stdlib path = - Path.head path |> Ident.name = "Stdlib" - - (** [find_values_for_type env typ] searches the environment [env] for - {i values} with a return type compatible with [typ] *) - let find_values_for_type env typ = - let aux name path value_description acc = - (* [check_type| checks return type compatibility and lists parameters *) - let rec check_type type_expr params = - let type_expr = Transient_expr.repr type_expr in - (* TODO is this test general enough ? *) - match unifiable env (Transient_expr.type_expr type_expr) typ with - | Some snap -> - (* This will be called multiple times so we need to backtrack - See c-simple, test 6.2b for an example *) - Btype.backtrack snap; - Some params - | None -> - begin match type_expr.desc with - | Tarrow (arg_label, _, te, _) -> check_type te (arg_label::params) - | _ -> None - end - in - (* TODO we should probably sort the results better *) - match is_in_stdlib path, check_type value_description.val_type [] with - | false, Some params -> - Path.Map.add path (name, value_description, params) acc - | _, _ -> acc - in - (* We look for values in the current scope and in local unonpend submodules. - We also exclude the Stdlib modules from the search. *) - let fold_values path acc = Env.fold_values aux path env acc in - let init = fold_values None Path.Map.empty in - Env.fold_modules (fun _name path _module_decl acc -> - if not (is_in_stdlib path) && not (is_opened env path) then - (* We ignore opened modules. That means that is a value of an opened - module has been shadowed we won't suggest the one in the opened - module. *) - fold_values (Some (Untypeast.lident_of_path path)) acc - else acc) None env init - - - (** The idents_table is used to keep track of already used names when - generating function arguments in the same expression *) - let idents_table ~keywords = - let table = Hashtbl.create 50 in - (* We add keywords to the table so they are always numbered *) - List.iter keywords ~f:(fun k -> Hashtbl.add table k (-1)); - table - - (* Given a list [l] of n elements which are lists of choices, - [combination l] is a list of all possible combinations of - these choices (cartesian product). For example: - - let l = [["a";"b"];["1";"2"]; ["x"]];; - combinations l;; - - : string list list = - [["a"; "1"; "x"]; ["b"; "1"; "x"]; - ["a"; "2"; "x"]; ["b"; "2"; "x"]] - - If the input is the empty list, the result is - the empty list singleton list. - *) - let combinations l = - List.fold_left l - ~init:[[]] - ~f:(fun acc_l choices_for_arg_i -> - List.fold_left choices_for_arg_i - ~init:[] - ~f:(fun acc choice_arg_i -> - let choices = List.map acc_l - ~f:(fun l -> List.rev (choice_arg_i :: l)) - in - List.rev_append acc choices)) - - (** [panache2 l1 l2] returns a new list containing an interleaving of the - values in [l1] and [l2] *) - let panache2 l1 l2 = - let rec aux acc l1 l2 = - match l1, l2 with - | [], [] -> List.rev acc - | tl, [] | [], tl -> List.rev_append acc tl - | a::tl1, b::tl2 -> aux (a::b::acc) tl1 tl2 - in aux [] l1 l2 - - (* Given a list [l] of n lists, [panache l] flattens the list - by starting with the first element of each, then the second one etc. *) - let panache l = - List.fold_left ~init:[] ~f:panache2 l -end - -module Gen = struct - open Types - - (* [make_value] generates the PAST repr of a value applied to holes *) - let make_value env (path, (name, _value_description, params)) = - let open Ast_helper in - let env_check = Env.find_value_by_name in - let lid = Location.mknoloc (Util.prefix env ~env_check path name) in - let params = List.map params - ~f:(fun label -> label, Exp.hole ()) - in - if List.length params > 0 then - Exp.(apply (ident lid) params) - else Exp.ident lid - - (* We never perform deep search when constructing modules *) - let rec module_ env = - let open Ast_helper in function - | Mty_ident path -> begin - try - let m = Env.find_modtype path env in - match m.mtd_type with - | Some t -> module_ env t - | None -> raise Not_found - with Not_found -> - let name = Ident.name (Path.head path) in - raise (Modtype_not_found (Modtype, name)) - end - | Mty_signature sig_items -> - let env = Env.add_signature sig_items env in - Mod.structure @@ structure env sig_items - | Mty_functor (param, out) -> - let param = match param with - | Unit -> Parsetree.Unit - | Named (id, in_) -> - Parsetree.Named ( - Location.mknoloc (Option.map ~f:Ident.name id), - Ptyp_of_type.module_type in_) - in - Mod.functor_ param @@ module_ env out - | Mty_alias path -> - begin try let m = Env.find_module path env in - module_ env m.md_type - with Not_found -> - let name = Ident.name (Path.head path) in - raise (Modtype_not_found (Mod, name)) - end - | Mty_for_hole -> Mod.mk Pmod_hole - and structure_item env = - let open Ast_helper in - function - | Sig_value (id, _vd, _visibility) -> - let vb = Vb.mk (Pat.var (Util.var_of_id id)) (Exp.hole ()) in - Str.value Nonrecursive [ vb ] - | Sig_type (id, type_declaration, rec_flag, _visibility) -> - let td = Ptyp_of_type.type_declaration id type_declaration in - let rec_flag = match rec_flag with - | Trec_first | Trec_next -> Asttypes.Recursive - | Trec_not -> Nonrecursive - in (* mutually recursive types are really handled by [structure] *) - Str.type_ rec_flag [td] - | Sig_modtype (id, { mtd_type; _ }, _visibility) -> - let mtd = Ast_helper.Mtd.mk - ?typ:(Option.map ~f:Ptyp_of_type.module_type mtd_type) - @@ Util.var_of_id id - in - Ast_helper.Str.modtype mtd - | Sig_module (id, _, mod_decl, _, _) -> - let module_binding = - Ast_helper.Mb.mk - (Location.mknoloc (Some (Ident.name id))) - @@ module_ env mod_decl.md_type - in - Str.module_ module_binding - | Sig_typext (id, ext_constructor, _, _) -> - let lid = - Untypeast.lident_of_path ext_constructor.ext_type_path - |> Location.mknoloc - in - Str.type_extension @@ Ast_helper.Te.mk - ~attrs:ext_constructor.ext_attributes - ~params:[] - ~priv:ext_constructor.ext_private - lid - [Ptyp_of_type.extension_constructor id ext_constructor] - | Sig_class_type (id, _class_type_decl, _, _) -> - let str = Format.asprintf "Construct does not handle class types yet. \ - Please replace this comment by [%s]'s definition." (Ident.name id) in - Str.text [ Docstrings.docstring str Location.none ] |> List.hd - | Sig_class (id, _class_decl, _, _) -> - let str = Format.asprintf "Construct does not handle classes yet. \ - Please replace this comment by [%s]'s definition." (Ident.name id) in - Str.text [ Docstrings.docstring str Location.none ] |> List.hd - and structure env (items : Types.signature_item list) = - List.map (Ptyp_of_type.group_items items) ~f:(function - | Ptyp_of_type.Item item -> structure_item env item - | Ptyp_of_type.Type (rec_flag, type_decls) -> - Ast_helper.Str.type_ rec_flag type_decls) - - (* [expression values_scope ~depth env ty] generates a list of PAST - expressions that could fill a hole of type [ty] in the environment [env]. - [depth] regulates the deep construction of recursive values. If - [values_scope] is set to [Local] the returned list will also contains - local values to choose from *) - let rec expression ~idents_table values_scope ~depth = - let exp_or_hole env typ = - if depth > 1 then - (* If max_depth has not been reached we recurse *) - expression ~idents_table values_scope ~depth:(depth - 1) env typ - else - (* else we return a hole *) - [ Ast_helper.Exp.hole () ] - in - let arrow_rhs env typ = - match (Transient_expr.repr typ).desc with - | Tarrow _ -> expression ~idents_table values_scope ~depth env typ - | _ -> exp_or_hole env typ - in - - (* [make_arg] tries to provide a nice default name for function args *) - let make_arg = - let make_i n i = - Hashtbl.replace idents_table n i; - Printf.sprintf "%s_%i" n i - in - let uniq_name env n = - let id = Ident.create_local n in - try - let i = Hashtbl.find idents_table n + 1 in - make_i n i - with Not_found -> - try - let _ = Env.find_value (Path.Pident id) env in - make_i n 0 - with Not_found -> Hashtbl.add idents_table n 0; n - in - fun env label ty -> - let open Asttypes in - match label with - | Labelled s | Optional s -> - (* Pun for labelled arguments *) - Ast_helper.Pat.var ( Location.mknoloc s), s - | Nolabel -> begin match get_desc ty with - | Tconstr (path, _, _) -> - let name = uniq_name env (Path.last path) in - Ast_helper.Pat.var (Location.mknoloc name), name - | _ -> Ast_helper.Pat.any (), "_" end - in - - let constructor env type_expr path constrs = - log ~title:"constructors" "[%s]" - (String.concat ~sep:"; " - (List.map constrs ~f:(fun c -> c.Types.cstr_name))); - (* [make_constr] builds the PAST repr of a type constructor applied - to holes *) - let make_constr env path type_expr cstr_descr = - let ty_args, ty_res, _ = Ctype.instance_constructor cstr_descr in - match Util.unifiable env type_expr ty_res with - | Some snap -> - let lid = - Util.prefix env ~env_check:Env.find_constructor_by_name - path cstr_descr.cstr_name - |> Location.mknoloc - in - let args = List.map ty_args ~f:(exp_or_hole env) in - let args_combinations = Util.combinations args in - let exps = List.map args_combinations - ~f:(function - | [] -> None - | [e] -> Some e - | l -> Some (Ast_helper.Exp.tuple l)) - in - Btype.backtrack snap; - List.filter_map exps - ~f:(fun exp -> - let exp = Ast_helper.Exp.construct lid exp in - (* For gadts not all combinations will be valid. - See Test 6.1b in c-simple.t for an example. - - We therefore check that constructed expressions - can be typed. *) - try - Typecore.type_expression env exp |> ignore; - Some exp - with _ -> None) - | None -> [] - in - List.map constrs ~f:(make_constr env path type_expr) - |> Util.panache - in - - let variant env _typ row_desc = - let fields = - List.filter - ~f:(fun (_lbl, row_field) -> match row_field_repr row_field with - | Rpresent _ - | Reither (true, [], _) - | Reither (false, [_], _) -> true - | _ -> false) - (row_fields row_desc) - in - match fields with - | [] -> raise (Not_allowed "empty variant type") - | row_descrs -> - List.map row_descrs ~f:(fun (lbl, row_field) -> - (match row_field_repr row_field with - | Reither (false, [ty], _) | Rpresent (Some ty) -> - List.map ~f:(fun s -> Some s) (exp_or_hole env ty) - | _ -> [None]) - |> List.map ~f:(fun e -> - Ast_helper.Exp.variant lbl e) - ) - |> List.flatten - in - - let record env typ path labels = - log ~title:"record labels" "[%s]" - (String.concat ~sep:"; " - (List.map labels ~f:(fun l -> l.Types.lbl_name))); - - let labels = List.map labels ~f:(fun ({ lbl_name; _ } as lbl) -> - let _, arg, res = Ctype.instance_label true lbl in - Ctype.unify env res typ ; - let lid = - Util.prefix env ~env_check:Env.find_label_by_name path lbl_name - |> Location.mknoloc - in - let exprs = exp_or_hole env arg in - lid, exprs) - in - - let lbl_lids, lbl_exprs = List.split labels in - Util.combinations lbl_exprs - |> List.map - ~f:(fun lbl_exprs -> - let labels = List.map2 lbl_lids lbl_exprs - ~f:(fun lid exp -> (lid, exp)) - in - Ast_helper.Exp.record labels None) - in - - (* Given a typed hole, there is two possible forms of constructions: - - Use the type's definition to propose the correct type constructors, - - Look for values in the environment with compatible return type. *) - fun env typ -> - log ~title:"construct expr" "Looking for expressions of type %s" - (Util.type_to_string typ); - let rtyp = - Ctype.full_expand ~may_forget_scope:true env typ - in - let constructed_from_type = match get_desc rtyp with - | Tlink _ | Tsubst _ -> - assert false - | Tpoly (texp, _) -> - (* We are not going "deeper" so we don't call [exp_or_hole] here *) - expression ~idents_table values_scope ~depth env texp - | Tunivar _ | Tvar _ -> - [ ] - | Tconstr (path, [texp], _) when path = Predef.path_lazy_t -> - (* Special case for lazy *) - let exps = exp_or_hole env texp in - List.map exps ~f:Ast_helper.Exp.lazy_ - | Tconstr (path, _params, _) -> - (* If this is a "basic" type we propose a default value *) - begin try - [ Hashtbl.find Util.predef_types path ] - with Not_found -> - let def = Env.find_type_descrs path env in - match def with - | Type_variant (constrs, _) -> constructor env rtyp path constrs - | Type_record (labels, _) -> record env rtyp path labels - | Type_abstract | Type_open -> [] - end - | Tarrow (label, tyleft, tyright, _) -> - let argument, name = make_arg env label tyleft in - let value_description = { - val_type = tyleft; - val_kind = Val_reg; - val_loc = Location.none; - val_attributes = []; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); - } - in - let env = Env.add_value (Ident.create_local name) value_description env in - let exps = arrow_rhs env tyright in - List.map exps ~f:(Ast_helper.Exp.fun_ label None argument) - | Ttuple types -> - let choices = List.map types ~f:(exp_or_hole env) - |> Util.combinations - in - List.map choices ~f:Ast_helper.Exp.tuple - | Tvariant row_desc -> variant env rtyp row_desc - | Tpackage (path, lids_args) -> begin - let open Ast_helper in - try - let ty = - Typemod.modtype_of_package env Location.none path lids_args - in - let ast = - Exp.constraint_ - (Exp.pack (module_ env ty)) - (Ptyp_of_type.core_type typ) - in - [ ast ] - with Typemod.Error _ -> - let name = Ident.name (Path.head path) in - raise (Modtype_not_found (Modtype, name)) end - | Tobject (fields, _) -> - let rec aux acc fields = - match get_desc fields with - | Tnil -> acc - | Tvar _ | Tunivar _ -> acc - | Tfield ("*dummy method*", _, _, fields) -> aux acc fields - | Tfield (name, _, type_expr, fields) -> - let exprs = exp_or_hole env type_expr - |> List.map ~f:(fun expr -> - let open Ast_helper in - Cf.method_ (Location.mknoloc name) Asttypes.Public - @@ Ast_helper.Cf.concrete Asttypes.Fresh expr) - in - aux (exprs :: acc) fields - | _ -> - failwith @@ Format.asprintf - "Unexpected type constructor in fields list: %a" - Printtyp.type_expr fields - in - let all_fields = aux [] fields |> Util.combinations in - List.map all_fields ~f:(fun fields -> - let open Ast_helper in - Exp.object_ @@ Ast_helper.Cstr.mk (Pat.any ()) fields) - | Tfield _ | Tnil -> failwith "Found a field type outside an object" - in - let matching_values = - if values_scope = Local then - Path.Map.bindings (Util.find_values_for_type env typ) - |> List.map ~f:(make_value env) - else [] - in - List.append constructed_from_type matching_values -end - -let needs_parentheses e = match e.Parsetree.pexp_desc with - | Pexp_fun _ - | Pexp_lazy _ - | Pexp_apply _ - | Pexp_variant (_, Some _) - | Pexp_construct (_, Some _) - -> true - | _ -> false - -let to_string_with_parentheses exp = - let f : _ format6 = - if needs_parentheses exp then "(%a)" - else "%a" - in - Format.asprintf f Pprintast.expression exp - -let node ?(depth = 1) ~keywords ~values_scope node = - match node with - | Browse_raw.Expression { exp_type; exp_env; _ } -> - let idents_table = Util.idents_table ~keywords in - Gen.expression ~idents_table values_scope ~depth exp_env exp_type - |> List.map ~f:to_string_with_parentheses - | Browse_raw.Module_expr - { mod_desc = Tmod_constraint _ ; mod_type; mod_env; _ } - | Browse_raw.Module_expr - { mod_desc = Tmod_apply _; mod_type; mod_env; _ } -> - let m = Gen.module_ mod_env mod_type in - [ Format.asprintf "%a" Pprintast.module_expr m ] - | Browse_raw.Module_expr _ - | Browse_raw.Module_binding _ -> - (* Constructible modules have an explicit constraint or are functor - applications. In other cases we do not know what to construct. *) - raise No_constraint - | _ -> raise Not_a_hole diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/construct.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/construct.mli deleted file mode 100644 index b0442f1a4..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/construct.mli +++ /dev/null @@ -1,11 +0,0 @@ -exception Not_allowed of string -exception Not_a_hole - -type values_scope = Null | Local - -val node - : ?depth : int - -> keywords : string list - -> values_scope : values_scope - -> Browse_raw.node - -> string list diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/context.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/context.ml deleted file mode 100644 index dcd625c7b..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/context.ml +++ /dev/null @@ -1,158 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let {Logger. log} = Logger.for_section "context" - -type t = - | Constructor of Types.constructor_description * Location.t - (* We attach the constructor description here so in the case of - disambiguated constructors we actually directly look for the type - path (cf. #486, #794). *) - | Expr - | Label of Types.label_description (* Similar to constructors. *) - | Module_path - | Module_type - | Patt - | Type - | Constant - | Unknown - -let to_string = function - | Constructor (cd, _) -> Printf.sprintf "constructor %s" cd.cstr_name - | Expr -> "expression" - | Label lbl -> Printf.sprintf "record field %s" lbl.lbl_name - | Module_path -> "module path" - | Module_type -> "module type" - | Patt -> "pattern" - | Constant -> "constant" - | Type -> "type" - | Unknown -> "unknown" - -(* Distinguish between "Mo[d]ule.something" and "Module.some[t]hing" *) -let cursor_on_longident_end - ~cursor:cursor_pos - ~lid_loc:{ Asttypes.loc; txt = lid } - name - = - match lid with - | Longident.Lident _ -> true - | _ -> - let end_offset = loc.loc_end.pos_cnum in - let cstr_name_size = String.length name in - let constr_pos = - { loc.loc_end - with pos_cnum = end_offset - cstr_name_size } - in - Lexing.compare_pos cursor_pos constr_pos >= 0 - -let inspect_pattern (type a) ~cursor ~lid (p : a Typedtree.general_pattern) = - log ~title:"inspect_context" "%a" Logger.fmt - (fun fmt -> Format.fprintf fmt "current pattern is: %a" - (Printtyped.pattern 0) p); - match p.pat_desc with - | Tpat_any when Longident.last lid = "_" -> None - | Tpat_var (_, str_loc) when (Longident.last lid) = str_loc.txt -> - None - | Tpat_alias (_, _, str_loc) - when (Longident.last lid) = str_loc.txt -> - (* Assumption: if [Browse.enclosing] stopped on this node and not on the - subpattern, then it must mean that the cursor is on the alias. *) - None - | Tpat_construct (lid_loc, cd, _, _) - when cursor_on_longident_end ~cursor ~lid_loc cd.cstr_name - && (Longident.last lid) = (Longident.last lid_loc.txt) -> - (* Assumption: if [Browse.enclosing] stopped on this node and not on the - subpattern, then it must mean that the cursor is on the constructor - itself. *) - Some (Constructor (cd, lid_loc.loc)) - | Tpat_construct _ -> Some Module_path - | _ -> - Some Patt - -let inspect_expression ~cursor ~lid e : t = - match e.Typedtree.exp_desc with - | Texp_construct (lid_loc, cd, _) -> - (* TODO: is this first test necessary ? *) - if (Longident.last lid) = (Longident.last lid_loc.txt) then - if cursor_on_longident_end ~cursor ~lid_loc cd.cstr_name then - Constructor (cd, lid_loc.loc) - else Module_path - else Module_path - | Texp_ident (p, lid_loc, _) -> - let name = Path.last p in - if name = "*type-error*" then - (* For type_enclosing: it is enough to return Module_path here. - - If the cursor was on the end of the lid typing should fail anyway - - If the cursor is on a segment of the path it should be typed ad a - Module_path - TODO: double check that this is correct-enough behavior for Locate *) - Module_path - else if cursor_on_longident_end ~cursor ~lid_loc name then - Expr - else - Module_path - | Texp_constant _ -> Constant - | _ -> - Expr - -let inspect_browse_tree ~cursor lid browse : t option = - log ~title:"inspect_context" "current node is: [%s]" - (String.concat ~sep:"|" ( - List.map ~f:(Mbrowse.print ()) browse - )); - match Mbrowse.enclosing cursor browse with - | [] -> - log ~title:"inspect_context" - "no enclosing around: %a" Lexing.print_position cursor; - Some Unknown - | enclosings -> - let open Browse_raw in - let node = Browse_tree.of_browse enclosings in - log ~title:"inspect_context" "current enclosing node is: %s" - (string_of_node node.Browse_tree.t_node); - match node.Browse_tree.t_node with - | Pattern p -> inspect_pattern ~cursor ~lid p - | Value_description _ - | Type_declaration _ - | Extension_constructor _ - | Module_binding_name _ - | Module_declaration_name _ -> - None - | Module_expr _ - | Open_description _ -> Some Module_path - | Module_type _ -> Some Module_type - | Core_type _ -> Some Type - | Record_field (_, lbl, _) when (Longident.last lid) = lbl.lbl_name -> - (* if we stopped here, then we're on the label itself, and whether or - not punning is happening is not important *) - Some (Label lbl) - | Expression e -> Some (inspect_expression ~cursor ~lid e) - | _ -> - Some Unknown diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/context.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/context.mli deleted file mode 100644 index 6884f8d32..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/context.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -type t = - | Constructor of Types.constructor_description * Location.t - (* We attach the constructor description here so in the case of - disambiguated constructors we actually directly look for the type - path (cf. #486, #794). *) - | Expr - | Label of Types.label_description (* Similar to constructors. *) - | Module_path - | Module_type - | Patt - | Type - | Constant - | Unknown - -val to_string : t -> string - -(** - [inspect_browse_tree lid ~cursor mbrowse] tries to provide contextual - information given the selected identifier, the position of the cursor and the - typed tree. It is used by Locate and Type_enclosing. - - The cursor position is used to distinguished whether a module path or an actual - constructor name is pointed at when the cursor is in the middle of a - longident, e.g. [Foo.B|ar.Constructor] (with | being the cursor). - - FIXME: when cursor at (M.|A 3), the enclosing node returned is const 3, thus - breaking the context inference. -*) -val inspect_browse_tree : - cursor:Std.Lexing.position -> Longident.t -> Mbrowse.t list -> t option diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/destruct.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/destruct.ml deleted file mode 100644 index 286f3f1c0..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/destruct.ml +++ /dev/null @@ -1,614 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Browse_raw - -exception Not_allowed of string -exception Useless_refine -exception Nothing_to_do -exception Ill_typed -exception Wrong_parent of string - -let {Logger. log} = Logger.for_section "destruct" - -let () = - Location.register_error_of_exn (function - | Not_allowed s -> Some (Location.error ("Destruct not allowed on " ^ s)) - | Useless_refine -> Some (Location.error "Cannot refine an useless branch") - | Nothing_to_do -> Some (Location.error "Nothing to do") - | Ill_typed -> Some ( - Location.error "The node on which destruct was called is ill-typed" - ) - | _ -> None - ) - -let mk_id s = Location.mknoloc (Longident.Lident s) -let mk_var s = Location.mknoloc s - -module Predef_types = struct - let char_ env ty = - let a = Tast_helper.Pat.constant env ty (Asttypes.Const_char 'a') in - let z = Patterns.omega in - [ a ; z ] - - let int_ env ty = - let zero = Tast_helper.Pat.constant env ty (Asttypes.Const_int 0) in - let n = Patterns.omega in - [ zero ; n ] - - let string_ env ty = - let empty = - Tast_helper.Pat.constant env ty ( - Asttypes.Const_string ("", Location.none, None) - ) - in - let s = Patterns.omega in - [ empty ; s ] - - let tbl = Hashtbl.create 3 - - let () = - List.iter ~f:(fun (k, v) -> Hashtbl.add tbl k v) [ - Predef.path_char, char_ ; - Predef.path_int, int_ ; - Predef.path_string, string_ ; - ] -end - -let placeholder = - Ast_helper.Exp.hole () - -let rec gen_patterns ?(recurse=true) env type_expr = - let open Types in - match get_desc type_expr with - | Tlink _ -> assert false (* impossible after [Btype.repr] *) - | Tvar _ -> raise (Not_allowed "non-immediate type") - | Tarrow _ -> raise (Not_allowed "arrow type") - | Tobject _ -> raise (Not_allowed "object type") - | Tpackage _ -> raise (Not_allowed "modules") - | Ttuple lst -> - let patterns = Patterns.omega_list lst in - [ Tast_helper.Pat.tuple env type_expr patterns ] - | Tconstr (path, _params, _) -> - begin match Env.find_type_descrs path env with - | Type_record (labels, _) -> - let lst = - List.map labels ~f:(fun lbl_descr -> - let lidloc = mk_id lbl_descr.lbl_name in - lidloc, lbl_descr, - Tast_helper.Pat.var env type_expr (mk_var lbl_descr.lbl_name) - ) - in - [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ] - | Type_variant (constructors, _) -> - let prefix = - let path = Printtyp.shorten_type_path env path in - fun name -> - let env_check = Env.find_constructor_by_name in - Misc_utils.Path.to_shortest_lid ~env ~name ~env_check path - in - let are_types_unifiable typ = - let snap = Btype.snapshot () in - let res = - try - ignore ( - Ctype.unify_gadt ~equations_level:0 - ~allow_recursive:true (* really? *) - (ref env) type_expr typ - ); - true - with Ctype.Unify _trace -> false - in - Btype.backtrack snap ; - res - in - List.filter_map constructors ~f:(fun cstr_descr -> - if cstr_descr.cstr_generalized && - not (are_types_unifiable cstr_descr.cstr_res) - then ( - log ~title:"gen_patterns" "%a" - Logger.fmt (fun fmt -> - Format.fprintf fmt - "Eliminating '%s' branch, its return type is not\ - \ compatible with the expected type (%a)" - cstr_descr.cstr_name Printtyp.type_expr type_expr); - None - ) else - let args = - if cstr_descr.cstr_arity <= 0 then [] else - Patterns.omegas cstr_descr.cstr_arity - in - let lidl = Location.mknoloc (prefix cstr_descr.cstr_name) in - Some ( - Tast_helper.Pat.construct env type_expr lidl cstr_descr args None) - ) - | _ -> - if recurse then from_type_decl env path type_expr else - raise (Not_allowed (sprintf "non-destructible type: %s" (Path.last path))) - end - | Tvariant row_desc -> - List.filter_map (row_fields row_desc) ~f:(fun (lbl, row_field) -> - match lbl, row_field_repr row_field with - | lbl, Rpresent param_opt -> - let popt = Option.map param_opt ~f:(fun _ -> Patterns.omega) in - Some (Tast_helper.Pat.variant env type_expr lbl popt (ref row_desc)) - | _, _ -> None - ) - | _ -> - let fmt, to_string = Format.to_string () in - Printtyp.type_expr fmt type_expr ; - raise (Not_allowed (to_string ())) - -and from_type_decl env path texpr = - let tdecl = Env.find_type path env in - match tdecl.Types.type_manifest with - | Some te -> gen_patterns ~recurse:false env te - | None -> - try Hashtbl.find Predef_types.tbl path env texpr - with Not_found -> - raise (Not_allowed (sprintf "non-destructible type: %s" (Path.last path))) - - -let rec needs_parentheses = function - | [] -> false - | t :: ts -> - match t with - | Structure _ - | Structure_item _ - | Value_binding _ -> false - | Expression e -> - begin match e.Typedtree.exp_desc with - | Texp_for _ - | Texp_while _ -> false - | Texp_let _ - (* We are after the "in" keyword, we need to look at the parent of the - binding. *) - | Texp_function {cases = [ _ ]; _ } - (* The assumption here is that we're not in a [function ... | ...] - situation but either in [fun param] or [let name param]. *) - -> - needs_parentheses ts - | _ -> true - end - | _ -> needs_parentheses ts - -let rec get_match = function -| [] -> assert false -| parent :: parents -> - match parent with - | Case _ - | Pattern _ -> - (* We are still in the same branch, going up. *) - get_match parents - | Expression m -> - (match m.Typedtree.exp_desc with - | Typedtree.Texp_match (e, _, _) -> m, e.exp_type - | Typedtree.Texp_function _ -> - let typ = m.exp_type in - (* Function must have arrow type. This arrow type - might be hidden behind type constructors *) - m, (match Types.get_desc typ with - | Tarrow (_, te, _, _) -> te - | Tconstr _ -> - (match - Ctype.full_expand ~may_forget_scope:true m.exp_env typ - |> Types.get_desc - with - | Tarrow (_, te, _, _) -> te - | _ -> assert false) - | _ -> assert false) - | _ -> - (* We were not in a match *) - let s = Mbrowse.print_node () parent in - raise (Not_allowed s)) - | _ -> - (* We were not in a match *) - let s = Mbrowse.print_node () parent in - raise (Not_allowed s) - -let rec get_every_pattern = function - | [] -> assert false - | parent :: parents -> - match parent with - | Case _ - | Pattern _ -> - (* We are still in the same branch, going up. *) - get_every_pattern parents - | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _) ; _} - when Ident.name id = "*type-error*" -> - raise (Ill_typed) - | Expression _ -> - (* We are on the right node *) - let patterns : Typedtree.pattern list = - Mbrowse.fold_node (fun env node acc -> - match node with - | Pattern _ -> (* Not expected here *) assert false - | Case _ -> - Mbrowse.fold_node (fun _env node acc -> - match node with - | Pattern p -> - let ill_typed_pred : Typedtree.pattern_predicate = - { f = fun p -> - List.memq Msupport.incorrect_attribute - ~set:p.pat_attributes } - in - if Typedtree.exists_general_pattern ill_typed_pred p then - raise Ill_typed; - begin match Typedtree.classify_pattern p with - | Value -> let p : Typedtree.pattern = p in p :: acc - | Computation -> let val_p, _ = Typedtree.split_pattern p in - (* We ignore computation patterns *) - begin match val_p with - | Some val_p -> val_p :: acc - | None -> acc - end - end - | _ -> acc - ) env node acc - | _ -> acc - ) Env.empty parent [] - in - let loc = - Mbrowse.fold_node (fun _ node acc -> - let open Location in - let loc = Mbrowse.node_loc node in - if Lexing.compare_pos loc.loc_end acc.loc_end > 0 then loc else acc - ) Env.empty parent Location.none - in - loc, patterns - | _ -> - (* We were not in a match *) - let s = Mbrowse.print_node () parent in - raise (Not_allowed s) - -let rec destructible patt = - let open Typedtree in - match patt.pat_desc with - | Tpat_any | Tpat_var _ -> true - | Tpat_alias (p, _, _) -> destructible p - | _ -> false - - -let is_package ty = - match ty.Types.desc with - | Types.Tpackage _ -> true - | _ -> false - -let filter_attr = - let default = Ast_mapper.default_mapper in - let keep attr = - let ({Location.txt;_},_) = Ast_helper.Attr.as_tuple attr in - not (String.is_prefixed ~by:"merlin." txt) - in - let attributes mapper attrs = - default.Ast_mapper.attributes mapper (List.filter ~f:keep attrs) - in - {default with Ast_mapper.attributes} - -let filter_expr_attr expr = - filter_attr.Ast_mapper.expr filter_attr expr - -let filter_pat_attr pat = - filter_attr.Ast_mapper.pat filter_attr pat - -let rec subst_patt initial ~by patt = - let f = subst_patt initial ~by in - if patt == initial then by else - let open Typedtree in - match patt.pat_desc with - | Tpat_any - | Tpat_var _ - | Tpat_constant _ -> patt - | Tpat_alias (p,x,y) -> - { patt with pat_desc = Tpat_alias (f p, x, y) } - | Tpat_tuple lst -> - { patt with pat_desc = Tpat_tuple (List.map lst ~f) } - | Tpat_construct (lid, cd, lst, lco) -> - { patt with pat_desc = Tpat_construct (lid, cd, List.map lst ~f, lco) } - | Tpat_variant (lbl, pat_opt, row_desc) -> - { patt with pat_desc = Tpat_variant (lbl, Option.map pat_opt ~f, row_desc) } - | Tpat_record (sub, flg) -> - let sub' = - List.map sub ~f:(fun (lid, lbl_descr, patt) -> lid, lbl_descr, f patt) - in - { patt with pat_desc = Tpat_record (sub', flg) } - | Tpat_array lst -> - { patt with pat_desc = Tpat_array (List.map lst ~f) } - | Tpat_or (p1, p2, row) -> - { patt with pat_desc = Tpat_or (f p1, f p2, row) } - | Tpat_lazy p -> - { patt with pat_desc = Tpat_lazy (f p) } - -let rec rm_sub patt sub = - let f p = rm_sub p sub in - let open Typedtree in - match patt.pat_desc with - | Tpat_any - | Tpat_var _ - | Tpat_constant _ -> patt - | Tpat_alias (p,x,y) -> - { patt with pat_desc = Tpat_alias (f p, x, y) } - | Tpat_tuple lst -> - { patt with pat_desc = Tpat_tuple (List.map lst ~f) } - | Tpat_construct (lid, cd, lst, lco) -> - { patt with pat_desc = Tpat_construct (lid, cd, List.map lst ~f, lco) } - | Tpat_variant (lbl, pat_opt, row_desc) -> - { patt with pat_desc = Tpat_variant (lbl, Option.map pat_opt ~f, row_desc) } - | Tpat_record (sub, flg) -> - let sub' = - List.map sub ~f:(fun (lid, lbl_descr, patt) -> lid, lbl_descr, f patt) - in - { patt with pat_desc = Tpat_record (sub', flg) } - | Tpat_array lst -> - { patt with pat_desc = Tpat_array (List.map lst ~f) } - | Tpat_or (p1, p2, row) -> - if p1 == sub then p2 else if p2 == sub then p1 else - { patt with pat_desc = Tpat_or (f p1, f p2, row) } - | Tpat_lazy p -> - { patt with pat_desc = Tpat_lazy (f p) } - -let rec qualify_constructors ~unmangling_tables f pat = - let open Typedtree in - let qualify_constructors = qualify_constructors ~unmangling_tables in - let pat_desc = - match pat.pat_desc with - | Tpat_alias (p, id, loc) -> Tpat_alias (qualify_constructors f p, id, loc) - | Tpat_tuple ps -> Tpat_tuple (List.map ps ~f:(qualify_constructors f)) - | Tpat_record (labels, closed) -> - let labels = - let open Longident in - List.map labels - ~f:(fun ((Location.{ txt ; _ } as lid), lbl_des, pat) -> - let lid_name = flatten txt |> String.concat ~sep:"." in - let pat = qualify_constructors f pat in - (* Un-mangle *) - match unmangling_tables with - | Some (_, labels) -> - (match Hashtbl.find_opt labels lid_name with - | Some lbl_des -> ( - { lid with txt = Lident lbl_des.Types.lbl_name }, - lbl_des, - pat - ) - | None -> (lid, lbl_des, pat)) - | None -> (lid, lbl_des, pat)) - in - let closed = - if List.length labels > 0 then - let _, lbl_des, _ = List.hd labels in - if List.length labels = Array.length lbl_des.Types.lbl_all then - Asttypes.Closed - else Asttypes.Open - else closed - in - Tpat_record (labels, closed) - | Tpat_construct (lid, cstr_desc, ps, lco) -> - let lid = - match lid.Asttypes.txt with - | Longident.Lident name -> - (* Un-mangle *) - let name = match unmangling_tables with - | Some (constrs, _) -> - (match Hashtbl.find_opt constrs name with - | Some cstr_des -> cstr_des.Types.cstr_name - | None -> name) - | None -> name - in - begin match Types.get_desc pat.pat_type with - | Types.Tconstr (path, _, _) -> - let path = f pat.pat_env path in - let env_check = Env.find_constructor_by_name in - let txt = Misc_utils.Path.to_shortest_lid - ~env:pat.pat_env ~name ~env_check path - in - { lid with Asttypes.txt } - | _ -> lid - end - | _ -> lid (* already qualified *) - in - Tpat_construct - (lid, cstr_desc, List.map ps ~f:(qualify_constructors f), lco) - | Tpat_array ps -> Tpat_array (List.map ps ~f:(qualify_constructors f)) - | Tpat_or (p1, p2, row_desc) -> - Tpat_or (qualify_constructors f p1, qualify_constructors f p2, row_desc) - | Tpat_lazy p -> Tpat_lazy (qualify_constructors f p) - | desc -> desc - in - { pat with pat_desc = pat_desc } - -let find_branch patterns sub = - let rec is_sub_patt patt ~sub = - if patt == sub then true else - let open Typedtree in - match patt.pat_desc with - | Tpat_any - | Tpat_var _ - | Tpat_constant _ - | Tpat_variant (_, None, _) -> false - | Tpat_alias (p,_,_) - | Tpat_variant (_, Some p, _) - | Tpat_lazy p -> - is_sub_patt p ~sub - | Tpat_tuple lst - | Tpat_construct (_, _, lst, _) - | Tpat_array lst -> - List.exists lst ~f:(is_sub_patt ~sub) - | Tpat_record (subs, _) -> - List.exists subs ~f:(fun (_, _, p) -> is_sub_patt p ~sub) - | Tpat_or (p1, p2, _) -> - is_sub_patt p1 ~sub || is_sub_patt p2 ~sub - in - let rec aux before = function - | [] -> raise Not_found - | p :: after when is_sub_patt p ~sub -> before, after, p - | p :: ps -> aux (p :: before) ps - in - aux [] patterns - -let rec node config source selected_node parents = - let open Extend_protocol.Reader in - let loc = Mbrowse.node_loc selected_node in - match selected_node with - | Record_field (`Expression _, _, _) -> - begin match parents with - | Expression { exp_desc = Texp_field _; _ } as parent :: rest -> - node config source parent rest - | Expression e :: rest -> - node config source (Expression e) rest - | _ -> - raise (Not_allowed (string_of_node selected_node)) - end - | Expression expr -> - let ty = expr.Typedtree.exp_type in - let pexp = filter_expr_attr (Untypeast.untype_expression expr) in - log ~title:"node_expression" "%a" - Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp); - let needs_parentheses, result = - if is_package (Types.Transient_expr.repr ty) then ( - let mode = Ast_helper.Mod.unpack pexp in - false, Ast_helper.Exp.letmodule_no_opt "M" mode placeholder - ) else ( - let ps = gen_patterns expr.Typedtree.exp_env ty in - let cases = - List.map ps ~f:(fun patt -> - let pc_lhs = filter_pat_attr (Untypeast.untype_pattern patt) in - { Parsetree. pc_lhs ; pc_guard = None ; pc_rhs = placeholder } - ) - in - needs_parentheses parents, Ast_helper.Exp.match_ pexp cases - ) - in - let str = Mreader.print_pretty - config source (Pretty_expression result) in - let str = if needs_parentheses then "(" ^ str ^ ")" else str in - loc, str - | Pattern patt -> - begin let last_case_loc, patterns = get_every_pattern parents in - (* Printf.eprintf "tot %d o%!"(List.length patterns); *) - List.iter patterns ~f:(fun p -> - let p = filter_pat_attr (Untypeast.untype_pattern p) in - log ~title:"EXISTING" "%t" - (fun () -> Mreader.print_pretty config source (Pretty_pattern p)) - ) ; - let pss = List.map patterns ~f:(fun x -> [ x ]) in - let m, e_typ = get_match parents in - let pred = Typecore.partial_pred - ~lev:Btype.generic_level - m.Typedtree.exp_env - e_typ - in - begin match Parmatch.complete_partial ~pred pss with - | _ :: _ as patterns -> - let cases = - List.map patterns ~f:(fun (pat, unmangling_tables) -> - (* Unmangling and prefixing *) - let pat = - qualify_constructors ~unmangling_tables - Printtyp.shorten_type_path pat - in - - (* Untyping and casing *) - let ppat = filter_pat_attr (Untypeast.untype_pattern pat) in - Ast_helper.Exp.case ppat placeholder - ) - in - let loc = - let open Location in - { last_case_loc with loc_start = last_case_loc.loc_end } - in - - (* Pretty printing *) - let str = Mreader.print_pretty config source (Pretty_case_list cases) in - loc, str - | [] -> - begin match Typedtree.classify_pattern patt with - | Computation -> raise (Not_allowed ("computation pattern")); - | Value -> - let _patt : Typedtree.value Typedtree.general_pattern = patt in - if not (destructible patt) then raise Nothing_to_do else - let ty = patt.Typedtree.pat_type in - (* Printf.eprintf "pouet cp \n%!" ; *) - begin match gen_patterns patt.Typedtree.pat_env ty with - | [] -> assert false (* we raise Not_allowed, but never return [] *) - | [ more_precise ] -> - (* Printf.eprintf "one cp \n%!" ; *) - (* If only one pattern is generated, then we're only refining the - current pattern, not generating new branches. *) - let ppat = filter_pat_attr (Untypeast.untype_pattern more_precise) in - let str = Mreader.print_pretty - config source (Pretty_pattern ppat) in - patt.Typedtree.pat_loc, str - | sub_patterns -> - let rev_before, after, top_patt = - find_branch patterns patt - in - let new_branches = - List.map sub_patterns ~f:(fun by -> - subst_patt patt ~by top_patt - ) - in - let patterns = - List.rev_append rev_before - (List.append new_branches after) - in - let unused = Parmatch.return_unused patterns in - let new_branches = - List.fold_left unused ~init:new_branches ~f:(fun branches u -> - match u with - | `Unused p -> List.remove ~phys:true p branches - | `Unused_subs (p, lst) -> - List.map branches ~f:(fun branch -> - if branch != p then branch else - List.fold_left lst ~init:branch ~f:rm_sub - ) - ) - in - (* List.iter ~f:(Format.eprintf "multi cp %a \n%!" (Printtyped.pattern 0)) new_branches ; *) - match new_branches with - | [] -> raise Useless_refine - | p :: ps -> - let p = - List.fold_left ps ~init:p ~f:(fun acc p -> - Tast_helper.Pat.pat_or top_patt.Typedtree.pat_env - top_patt.Typedtree.pat_type acc p - ) - in - (* Format.eprintf "por %a \n%!" (Printtyped.pattern 0) p; *) - let ppat = filter_pat_attr (Untypeast.untype_pattern p) in - (* Format.eprintf "ppor %a \n%!" (Pprintast.pattern) ppat; *) - let str = Mreader.print_pretty - config source (Pretty_pattern ppat) in - (* Format.eprintf "STR: %s \n %!" str; *) - top_patt.Typedtree.pat_loc, str - end - end - end - end - | node -> - raise (Not_allowed (string_of_node node)) diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/destruct.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/destruct.mli deleted file mode 100644 index c1958ffd3..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/destruct.mli +++ /dev/null @@ -1,85 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -(** Destruct at the moment works in two contexts: - - - an expression context: - It will replace the expression [e] under the cursor with - - {[ - match e with - | p1 -> _ - | ... - ]} - - This matching will be exhaustive. - - If [e] has a "package" type, it will be replaced by - [let module M = (val e) in _] - - - a pattern context: - Here two different behaviors can be observed: - + if your matching is not exhaustive, it will be made exhaustive. - + if your matching is exhaustive, it will refine the subpattern under - the cursor if possible (i.e. if your cursor is on a variable or _ ). - - - * * * - - - Final remarks: - - Destruct will refuse to work on expression (resp. patterns) with a - functional or polymorphic type. - - - Constructors of variant types will be prefixed by their path (if - necessary) but record labels will not. - The reason is that we don't control the way things are printed, we reuse - [Pprintast] which will print things like: - [{ Module.label1 = label1 ; Module.label2 = label2}] where one would - rather have [{ Module.label1 ; label2 }]. Since qualifying one label is - less annoying than rewriting the whole pattern, we decided to note - qualify labels (understanding that the code inserted by merlin in the - buffer will sometimes be wrong). - -*) - -(* TODO: document the following *) - -exception Not_allowed of string -exception Useless_refine -exception Nothing_to_do -exception Ill_typed -exception Wrong_parent of string - -val node : - Mconfig.t -> Msource.t -> Browse_raw.node -> - Browse_raw.node list -> Location.t * string -(** [node ~env parents current_node] returns a location indicating which - portion of the buffer must be replaced and the string to replace it with. *) - -val log : 'a Logger.printf diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/dune b/ocaml-lsp-server/vendor/merlin/src/analysis/dune deleted file mode 100644 index 1521f351e..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/dune +++ /dev/null @@ -1,24 +0,0 @@ -(library - (name merlin_analysis) - (public_name merlin-lib.analysis) - (flags - :standard - -open Ocaml_utils - -open Ocaml_parsing - -open Ocaml_preprocess - -open Ocaml_typing - -open Merlin_utils - -open Merlin_specific - -open Merlin_extend - -open Merlin_kernel) - (libraries - merlin_config - merlin_specific - merlin_extend - merlin_kernel - merlin_utils - ocaml_parsing - ocaml_preprocess - query_protocol - ocaml_typing - ocaml_utils)) diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/expansion.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/expansion.ml deleted file mode 100644 index 05b905676..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/expansion.ml +++ /dev/null @@ -1,136 +0,0 @@ -open Std - -type t = Trie of (string * Longident.t * t list lazy_t) - -let rec explore_node lident env = - let add_module name _ _ l = - let lident = Longident.Ldot (lident, name) in - Trie (name, lident, lazy (explore_node lident env)) :: l - in - Env.fold_modules add_module (Some lident) env [] - -let explore ?(global_modules=[]) env = - let seen = - let tbl = Hashtbl.create 7 in - fun name -> Hashtbl.mem tbl name || (Hashtbl.add tbl name (); false) - in - let add_module l name = - if seen name then l - else - let lident = Longident.Lident name in - Trie (name, lident, lazy (explore_node lident env)) :: l - in - let add_module' name _ _ l = add_module l name in - List.fold_left ~f:add_module global_modules - ~init:(Env.fold_modules add_module' None env []) - -(* This is a hacked up heuristic spell checking function. - It checks only the prefix of the key. - A proper damerau-levenshtein might be better but certainly not urgent. - - Implementation is a fork of - https://github.com/c-cube/spelll/blob/master/src/spelll.ml - Thanks companion-cube :) *) -let optimal_string_prefix_alignment key cutoff = - let equal_char : char -> char -> bool = (=) in - let min_int x y : int = if x < y then x else y in - if String.length key = 0 - then (fun str -> String.length str) - else - (* distance vectors (v0=previous, v1=current) *) - let v0 = Array.make (String.length key + 1) 0 in - let v1 = Array.make (String.length key + 1) 0 in - fun str -> - let l1 = min (String.length str) (String.length key) in - if l1 = 0 then - String.length key - else if str = key then - 0 - else - try - (* initialize v0: v0(i) = A(0)(i) = delete i chars from t *) - for i = 0 to String.length key do - v0.(i) <- i - done; - (* main loop for the bottom up dynamic algorithm *) - for i = 0 to l1 - 1 do - (* first edit distance is the deletion of i+1 elements from s *) - v1.(0) <- i+1; - - let min = ref (i+1) in - (* try add/delete/replace operations *) - for j = 0 to String.length key - 1 do - let cost = if equal_char str.[i] key.[j] then 0 else 1 in - v1.(j+1) <- min_int (v1.(j) + 1) (min_int (v0.(j+1) + 1) (v0.(j) + cost)); - if i > 0 && j > 0 && str.[i] = key.[j-1] && str.[i-1] = key.[j] then - v1.(j+1) <- min_int v1.(j+1) (v0.(j-1) + cost); - - min := min_int !min v1.(j+1) - done; - - if !min > cutoff then raise Exit; - - (* copy v1 into v0 for next iteration *) - Array.blit v1 0 v0 0 (String.length key + 1); - done; - let idx = String.length key in - min v1.(idx-1) v1.(idx) - with Exit -> cutoff + 1 - -let spell_index s1 = - let cutoff = match String.length s1 with - | 0 -> 0 - | 1 -> 0 - | 2 -> 0 - | 3 -> 1 - | _ -> 2 - in - let f = optimal_string_prefix_alignment s1 cutoff in - fun s2 -> (s1 = "" || s2 = "" || (s1.[0] = s2.[0] && (f s2 <= cutoff))) - -let spell_match index str = index str - -let filter path ts = - let path = List.map ~f:spell_index path in - let rec aux_ts ts = function - | [] -> [] - | p0 :: ps -> List.filter_map ~f:(aux_t p0 ps) ts - and aux_t p0 ps (Trie (name, ident, ts)) = - if spell_match p0 name then - Some (Trie (name, ident, lazy (aux_ts (Lazy.force ts) ps))) - else - None - in - aux_ts ts path - -let rec to_lidents len acc = function - | Trie (_, lident, _) :: ts when len = 0 -> - to_lidents len (lident :: acc) ts - | Trie (_, _, lazy ts') :: ts -> - to_lidents len (to_lidents (len - 1) acc ts') ts - | [] -> acc - -let to_lidents len ts = to_lidents len [] ts - -let get_lidents ts path = - let open Longident in - let lident = parse path in - let lident, last = match lident with - | Ldot (l, id) -> l, id - | Lident id -> Lident "", id - | Lapply _ -> assert false - in - let rec components acc = function - | Lident "" -> acc - | Lident id -> id :: acc - | Lapply _ -> assert false - | Ldot (l, id) -> components (id :: acc) l - in - let lidents = match components [] lident with - | [] -> [None] - | components -> - let ts = filter components ts in - let lidents = to_lidents (List.length components - 1) ts in - List.map ~f:(fun x -> Some x) lidents - in - lidents, last diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/expansion.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/expansion.mli deleted file mode 100644 index 330b84330..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/expansion.mli +++ /dev/null @@ -1,9 +0,0 @@ -type t - -val explore : ?global_modules:string list -> Env.t -> t list - -val get_lidents : t list -> string -> Longident.t option list * string - -val spell_index : string -> string -> bool - -val spell_match : (string -> bool) -> string -> bool diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/jump.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/jump.ml deleted file mode 100644 index 18063d0a3..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/jump.ml +++ /dev/null @@ -1,219 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - Tomasz Kołodziejski - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -open Typedtree -open Browse_raw - -let is_node_fun = function - | Expression { exp_desc = Texp_function _; _ } -> true - | _ -> false -;; - -let is_node_let = function - | Value_binding _ -> true - | _ -> false -;; - -let is_node_pattern = function - | Case _ -> true - | _ -> false -;; - -let fun_pred = fun all -> - (* For: - `let f x y z = ...` jump to f - For - `let f = fun x -> fun y -> fun z -> ...` jump to f - For - `List.map l ~f:(fun x -> ...)` jump to fun - - Every fun is immediately followed by pattern in the typed tree. - Invariant: head is a fun. - *) - let rec normalize_fun = function - (* fun pat fun something *) - | node1 :: node2 :: node3 :: tail when is_node_fun node3 -> - assert (is_node_fun node1); - assert (is_node_pattern node2); - normalize_fun (node3 :: tail) - (* fun let something *) - | node1 :: node2 :: _ when is_node_let node2 -> - assert (is_node_fun node1); - node2 - | node :: _ -> - assert (is_node_fun node); - node - | _ -> - assert false - in - match all with - | node :: _ when is_node_fun node -> Some (normalize_fun all) - | _ -> None -;; - -let let_pred = function - | node :: _ when is_node_let node -> Some node - | _ -> None -;; - -let module_pred = function - | (Module_binding _ as node) :: _ -> Some node - | _ -> None -;; - -let match_pred = function - | (Expression { exp_desc = Texp_match _ ; _ } as node) :: _ -> Some node - | _ -> None -;; - -let rec find_map ~f = function - | [] -> None - | head :: tail -> - match f head with - | Some v -> Some v - | None -> find_map tail ~f -;; - -exception No_matching_target -exception No_predicate of string - -(* Returns first node on the list matching a predicate *) -let rec find_node preds nodes = - match nodes with - | [] -> raise No_matching_target - | _ :: tail -> - match find_map preds ~f:(fun pred -> pred nodes) with - | Some node -> node - | None -> find_node preds tail -;; - -(* Skip all nodes that won't advance cursor's position *) -let rec skip_non_moving pos = function - | (node :: tail) as all -> - let node_loc = Browse_raw.node_real_loc Location.none node in - let loc_start = node_loc.Location.loc_start in - if pos.Lexing.pos_lnum = loc_start.Lexing.pos_lnum then - skip_non_moving pos tail - else - all - | [] -> [] -;; - -let get typed_tree pos target = - let roots = Mbrowse.of_typedtree typed_tree in - let enclosings = - match Mbrowse.enclosing pos [roots] with - | [] -> [] - | l -> List.map ~f:snd l - in - - let all_preds = [ - "fun", fun_pred; - "let", let_pred; - "module", module_pred; - "match", match_pred; - ] in - let targets = Str.split (Str.regexp "[, ]") target in - try - let preds = - List.map targets ~f:(fun target -> - match List.find_some all_preds ~f:(fun (name, _) -> name = target) with - | Some (_, f) -> f - | None -> raise (No_predicate target) - ) - in - if String.length target = 0 then - `Error "Specify target" - else begin - let nodes = skip_non_moving pos enclosings in - let node = find_node preds nodes in - let node_loc = Browse_raw.node_real_loc Location.none node in - `Found node_loc.Location.loc_start - end - with - | No_predicate target -> - `Error ("No predicate for " ^ target) - | No_matching_target -> - `Error "No matching target" - -let phrase typed_tree pos target = - let roots = Mbrowse.of_typedtree typed_tree in - (* Select nodes around cursor. - If the cursor is around a module expression, also search inside it. *) - let enclosing = match Mbrowse.enclosing pos [roots] with - | (env, (Browse_raw.Module_expr _ as node)) :: enclosing -> - Browse_raw.fold_node (fun env node enclosing -> (env,node) :: enclosing) - env node enclosing - | enclosing -> enclosing - in - (* Drop environment, they are of no use here *) - let enclosing = List.map ~f:snd enclosing in - let find_item x xs = match target with - | `Prev -> List.rev (List.take_while ~f:((!=)x) xs) - | `Next -> match List.drop_while ~f:((!=)x) xs with _::xs -> xs | [] -> [] - in - let find_pos prj xs = - match target with - | `Prev -> - let f x = Location_aux.compare_pos pos (prj x) > 0 in - List.rev (List.take_while ~f xs) - | `Next -> - let f x = Location_aux.compare_pos pos (prj x) >= 0 in - List.drop_while ~f xs - in - let rec seek_item = function - | [] -> None - | Browse_raw.Signature xs :: tail -> - begin match find_pos (fun x -> x.Typedtree.sig_loc) xs.Typedtree.sig_items with - | [] -> seek_item tail - | y :: _ -> Some y.Typedtree.sig_loc - end - | Browse_raw.Structure xs :: tail -> - begin match find_pos (fun x -> x.Typedtree.str_loc) xs.Typedtree.str_items with - | [] -> seek_item tail - | y :: _ -> Some y.Typedtree.str_loc - end - | Browse_raw.Signature_item (x,_) :: Browse_raw.Signature xs :: tail -> - begin match find_item x xs.Typedtree.sig_items with - | [] -> seek_item tail - | y :: _ -> Some y.Typedtree.sig_loc - end - | Browse_raw.Structure_item (x,_) :: Browse_raw.Structure xs :: tail -> - begin match find_item x xs.Typedtree.str_items with - | [] -> seek_item tail - | y :: _ -> Some y.Typedtree.str_loc - end - | _ :: xs -> seek_item xs - in - match seek_item enclosing, target with - | Some loc, _ -> `Logical (Lexing.split_pos loc.Location.loc_start) - | None, `Prev -> `Start - | None, `Next -> `End diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/jump.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/jump.mli deleted file mode 100644 index f42a950e9..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/jump.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - Tomasz Kołodziejski - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -val get : - Mtyper.typedtree -> - Std.Lexing.position -> - string -> [> `Error of string | `Found of Lexing.position ] - -val phrase : - Mtyper.typedtree -> - Std.Lexing.position -> - [< `Next | `Prev ] -> [> `End | `Logical of int * int | `Start ] diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/locate.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/locate.ml deleted file mode 100644 index cfe55ff1e..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/locate.ml +++ /dev/null @@ -1,1032 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let last_location = ref Location.none - -let {Logger. log} = Logger.for_section "locate" -module File : sig - type t = private - | ML of string - | MLL of string - | MLI of string - | CMT of string - | CMTI of string - - val ml : string -> t - val mli : string -> t - val cmt : string -> t - val cmti : string -> t - - val of_filename : string -> t option - - val alternate : t -> t - - val name : t -> string - - val with_ext : ?src_suffix_pair:(string * string) -> t -> string - - val explain_not_found : - ?doc_from:string -> string -> t -> [> `File_not_found of string ] -end = struct - type t = - | ML of string - | MLL of string - | MLI of string - | CMT of string - | CMTI of string - - let file_path_to_mod_name f = - Misc.unitname (Filename.basename f) - - let ml s = ML (file_path_to_mod_name s) - let mll s = MLL (file_path_to_mod_name s) - let mli s = MLI (file_path_to_mod_name s) - let cmt s = CMT (file_path_to_mod_name s) - let cmti s = CMTI (file_path_to_mod_name s) - - let of_filename fn = - match Misc.rev_string_split ~on:'.' fn with - | [] - | [ _ ] -> None - | ext :: _ -> - let ext = String.lowercase ext in - Some ( - match ext with - | "cmti" -> cmti fn - | "cmt" -> cmt fn - | "mll" -> mll fn - | _ -> if Filename.check_suffix ext "i" then mli fn else ml fn - ) - - let alternate = function - | ML s - | MLL s -> MLI s - | MLI s -> ML s - | CMT s -> CMTI s - | CMTI s -> CMT s - - let name = function - | ML name - | MLL name - | MLI name - | CMT name - | CMTI name -> name - - let ext src_suffix_pair = function - | ML _ -> fst src_suffix_pair - | MLI _ -> snd src_suffix_pair - | MLL _ -> ".mll" - | CMT _ -> ".cmt" - | CMTI _ -> ".cmti" - - let with_ext ?(src_suffix_pair=(".ml",".mli")) t = - name t ^ ext src_suffix_pair t - - let explain_not_found ?(doc_from="") str_ident path = - let msg = - match path with - | ML file -> - sprintf "'%s' seems to originate from '%s' whose ML file could not be \ - found" str_ident file - | MLL file -> - sprintf "'%s' seems to originate from '%s' whose MLL file could not be \ - found" str_ident file - | MLI file -> - sprintf "'%s' seems to originate from '%s' whose MLI file could not be \ - found" str_ident file - | CMT file -> - sprintf "Needed cmt file of module '%s' to locate '%s' but it is not \ - present" file str_ident - | CMTI file when file <> doc_from -> - sprintf "Needed cmti file of module '%s' to locate '%s' but it is not \ - present" file str_ident - | CMTI _ -> - sprintf "The documentation for '%s' originates in the current file, \ - but no cmt is available" str_ident - in - `File_not_found msg -end - -module Preferences : sig - val set : [ `ML | `MLI ] -> unit - - val src : string -> File.t - val build : string -> File.t - - val is_preferred : string -> bool -end = struct - let prioritize_impl = ref true - - let set choice = - prioritize_impl := - match choice with - | `ML -> true - | _ -> false - - let src file = if !prioritize_impl then File.ml file else File.mli file - let build file = if !prioritize_impl then File.cmt file else File.cmti file - - let is_preferred fn = - match File.of_filename fn with - | Some ML _ -> !prioritize_impl - | Some MLI _ -> not !prioritize_impl - | _ -> false -end - -module File_switching : sig - val reset : unit -> unit - - val move_to : digest:Digest.t -> string -> unit - - val where_am_i : unit -> string option - - val source_digest : unit -> Digest.t option -end = struct - type t = { - last_file_visited : string; - digest : Digest.t; - } - - let last_file_visited t = t.last_file_visited - let digest t = t.digest - - let state = ref None - - let reset () = state := None - - let move_to ~digest file = - log ~title:"File_switching.move_to" "%s" file; - state := Some { last_file_visited = file ; digest } - - let where_am_i () = Option.map !state ~f:last_file_visited - - let source_digest () = Option.map !state ~f:digest -end - - -module Utils = struct - let is_builtin_path = function - | Path.Pident id -> Ident.is_predef id - | _ -> false - - (* Reuse the code of [Misc.find_in_path_uncap] but returns all the files - matching, instead of the first one. This is only used when looking for ml - files, not cmts. Indeed for cmts we know that the load path will only ever - contain files with uniq names; this in not the case for the "source path" - however. We therefore get all matching files and use an heuristic at the - call site to choose the appropriate file. - - Note: We do not refine the load path for module path as we used too. *) - let find_all_in_path_uncap ?src_suffix_pair ~with_fallback path file = - let name = File.with_ext ?src_suffix_pair file in - let uname = String.uncapitalize name in - let fallback, ufallback = - let alt = File.alternate file in - let fallback = File.with_ext ?src_suffix_pair alt in - fallback, String.uncapitalize fallback - in - let try_file dirname basename acc = - if Misc.exact_file_exists ~dirname ~basename - then Misc.canonicalize_filename (Filename.concat dirname basename) :: acc - else acc - in - let try_dir acc dirname = - let acc = try_file dirname uname acc in - let acc = try_file dirname name acc in - let acc = - if with_fallback then - let acc = try_file dirname ufallback acc in - let acc = try_file dirname fallback acc in - acc - else - acc - in - acc - in - List.fold_left ~f:try_dir ~init:[] path - - let find_all_matches ~config ?(with_fallback=false) file = - let files = - List.concat_map ~f:(fun synonym_pair -> - find_all_in_path_uncap ~src_suffix_pair:synonym_pair ~with_fallback - (Mconfig.source_path config) file - ) Mconfig.(config.merlin.suffixes) - in - List.dedup_adjacent files ~cmp:String.compare - - let find_file_with_path ~config ?(with_fallback=false) file path = - if File.name file = Misc.unitname Mconfig.(config.query.filename) then - Some Mconfig.(config.query.filename) - else - let attempt_search src_suffix_pair = - let fallback = - if with_fallback then - Some (File.with_ext ~src_suffix_pair (File.alternate file)) - else - None - in - let fname = File.with_ext ~src_suffix_pair file in - try Some (Misc.find_in_path_uncap ?fallback path fname) - with Not_found -> None - in - try - Some (List.find_map Mconfig.(config.merlin.suffixes) ~f:attempt_search) - with Not_found -> - None -end - -let move_to filename cmt_infos = - let digest = - (* [None] only for packs, and we wouldn't have a trie if the cmt was for a - pack. *) - let sourcefile_in_builddir = - Filename.concat - (cmt_infos.Cmt_format.cmt_builddir) - (Option.get cmt_infos.cmt_sourcefile) - in - match sourcefile_in_builddir |> String.split_on_char ~sep:'.' |> List.rev with - | ext :: "pp" :: rev_path -> - (* If the source file was a post-processed file (.pp.mli?), use the - regular .mli? file for locate. *) - let sourcefile_in_builddir = - (ext :: rev_path) |> List.rev |> String.concat ~sep:"." - in - (match - Misc.exact_file_exists - ~dirname:(Filename.dirname sourcefile_in_builddir) - ~basename:(Filename.basename sourcefile_in_builddir) - with - | true -> Digest.file sourcefile_in_builddir - | false -> Option.get cmt_infos.cmt_source_digest) - | _ -> Option.get cmt_infos.cmt_source_digest - in - File_switching.move_to ~digest filename - - -let rec load_cmt comp_unit ml_or_mli = - let fn = - Preferences.set ml_or_mli; - Preferences.build comp_unit - in - match Load_path.find_uncap (File.with_ext fn) with - | filename -> - let cmt = (Cmt_cache.read filename).cmt_infos in - let pos_fname = cmt.cmt_sourcefile in - (* FIXME @ulysse: is the [Option.iter] still necessary with the new - implementation of [move_to]? *) - Option.iter cmt.cmt_source_digest - ~f:(fun _digest -> move_to filename cmt); - Ok (pos_fname, cmt) - | exception Not_found -> - if ml_or_mli = `MLI then begin - (* there might not have been an mli (so no cmti), so the decl comes from - the .ml, and the corresponding .cmt *) - log ~title:"load" "Failed to load cmti file, retrying with cmt"; - load_cmt comp_unit `ML - end else - Error () - -module Shape_reduce = - Shape.Make_reduce (struct - type env = Env.t - - let fuel = 10 - - let read_unit_shape ~unit_name = - let fn = File.(with_ext (cmt unit_name)) in - log ~title:"read_unit_shape" "inspecting %s" unit_name; - match Load_path.find_uncap fn with - | filename -> - let cmt_infos = (Cmt_cache.read filename).cmt_infos in - move_to filename cmt_infos; - log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; - cmt_infos.cmt_impl_shape - | exception Not_found -> - log ~title:"read_unit_shape" "failed to find %s" fn; - None - - let find_shape env id = Env.shape_of_path - ~namespace:Shape.Sig_component_kind.Module env (Pident id) - end) - -let uid_of_path ~env ~ml_or_mli ~decl_uid path ns = - match ml_or_mli with - | `MLI -> Some decl_uid - | `ML -> - let shape = Env.shape_of_path ~namespace:ns env path in - log ~title:"shape_of_path" "initial: %a" - Logger.fmt (fun fmt -> Shape.print fmt shape); - let r = Shape_reduce.weak_reduce env shape in - log ~title:"shape_of_path" "reduced: %a" - Logger.fmt (fun fmt -> Shape.print fmt r); - r.uid - -(** [module_aliasing] iterates on a typedtree to check if the provided uid - corresponds to a module alias. If it does the function returns the uid of the - aliased module. If not it returns None. - The intended use of this function is to traverse dune-generated aliases. *) -let module_aliasing ~(bin_annots : Cmt_format.binary_annots) uid = - let exception Found of Path.t * Env.t in - let iterator env = { Tast_iterator.default_iterator with - module_binding = (fun sub mb -> - begin match mb with - | { mb_id = Some id; mb_expr = { mod_desc = Tmod_ident (path, _); _ }; _ } - -> - let md = Env.find_module (Pident id) env in - if Shape.Uid.equal uid md.md_uid then - raise (Found (path, env)) - | _ -> () end; - Tast_iterator.default_iterator.module_binding sub mb) - } - in - try - begin match bin_annots with - | Interface s -> - let sig_final_env = Envaux.env_of_only_summary s.sig_final_env in - let iterator = iterator sig_final_env in - iterator.signature iterator { s with sig_final_env } - | Implementation str -> - let str_final_env = Envaux.env_of_only_summary str.str_final_env in - let iterator = iterator str_final_env in - iterator.structure iterator { str with str_final_env } - | _ -> () end; - None - with Found (path, env) -> - let namespace = Shape.Sig_component_kind.Module in - let shape = Env.shape_of_path ~namespace env path in - log ~title:"locate" "Uid %a corresponds to an alias of %a - which has the shape %a and the uid %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid) - Logger.fmt (fun fmt -> Path.print fmt path) - Logger.fmt (fun fmt -> Shape.print fmt shape) - Logger.fmt (fun fmt -> - Format.pp_print_option Shape.Uid.print fmt shape.uid); - Option.map ~f:(fun uid -> uid, path) shape.uid - -let from_uid ~ml_or_mli uid loc path = - let loc_of_comp_unit comp_unit = - match load_cmt comp_unit ml_or_mli with - | Ok (Some pos_fname, _cmt) -> - let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in - let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in - Some loc - | _ -> None - in - let title = "from_uid" in - match uid with - | Some (Shape.Uid.Item { comp_unit; _ } as uid)-> - let locopt = - if Env.get_unit_name () = comp_unit then begin - log ~title "We look for %a in the current compilation unit." - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - let tbl = Env.get_uid_to_loc_tbl () in - match Shape.Uid.Tbl.find_opt tbl uid with - | Some loc -> - log ~title "Found location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - Some (uid, loc) - | None -> - log ~title - "Uid not found.@.\ - Fallbacking to the node's location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - Some (uid, loc) - end else begin - log ~title "Loading the shapes for unit %S" comp_unit; - match load_cmt comp_unit ml_or_mli with - | Ok (Some _pos_fname, cmt) -> - log ~title "Shapes successfully loaded, looking for %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_loc uid with - | Some loc when - String.ends_with ~suffix:"ml-gen" loc.loc_start.pos_fname -> - log ~title "Found location in generated file: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - (* This notably happens when using Dune. In that case we - try to resolve the alias immediately. *) - begin match module_aliasing ~bin_annots:cmt.cmt_annots uid with - | Some (Shape.Uid.Compilation_unit comp_unit as uid, _path) -> - log ~title - "The alias points to another compilation unit %s" comp_unit; - loc_of_comp_unit comp_unit - |> Option.map ~f:(fun loc -> uid, loc) - | _ -> Some (uid, loc) - end - | Some loc -> - log ~title "Found location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - Some (uid, loc) - | None -> - log ~title "Uid not found in the loaded shape."; - None - end - | _ -> - log ~title "Failed to load the shapes"; - None - end - in - begin match locopt with - | Some (uid, loc) -> `Found (Some uid, loc) - | None -> `Not_found (Path.name path, None) - end - | Some (Compilation_unit comp_unit as uid) -> - begin - match loc_of_comp_unit comp_unit with - | Some loc -> `Found (Some uid, loc) - | _ -> log ~title "Failed to load the shapes"; - `Not_found (Path.name path, None) - end - | Some (Predef _ | Internal) -> assert false - | None -> log ~title "No UID found, fallbacking to lookup location."; - `Found (None, loc) - -let locate ~env ~ml_or_mli decl_uid loc path ns = - let uid = uid_of_path ~env ~ml_or_mli ~decl_uid path ns in - from_uid ~ml_or_mli uid loc path - -let path_and_loc_of_cstr desc _ = - let open Types in - match desc.cstr_tag with - | Cstr_extension (path, _) -> path, desc.cstr_loc - | _ -> - match get_desc desc.cstr_res with - | Tconstr (path, _, _) -> path, desc.cstr_loc - | _ -> assert false - -let path_and_loc_from_label desc env = - let open Types in - match get_desc desc.lbl_res with - | Tconstr (path, _, _) -> - let typ_decl = Env.find_type path env in - path, typ_decl.Types.type_loc - | _ -> assert false - -type find_source_result = - | Found of string - | Not_found of File.t - | Multiple_matches of string list - -let find_source ~config loc = - log ~title:"find_source" "attempt to find %S" - loc.Location.loc_start.Lexing.pos_fname ; - let fname = loc.Location.loc_start.Lexing.pos_fname in - let with_fallback = loc.Location.loc_ghost in - let file = - match File.of_filename fname with - | Some file -> file - | None -> - (* no extension? we have to decide. *) - Preferences.src fname - in - let filename = File.name file in - let initial_path = - match File_switching.where_am_i () with - | None -> fname - | Some s -> s - in - let dir = Filename.dirname initial_path in - let dir = - match Mconfig.(config.query.directory) with - | "" -> dir - | cwd -> Misc.canonicalize_filename ~cwd dir - in - match Utils.find_all_matches ~config ~with_fallback file with - | [] -> - log ~title:"find_source" "failed to find %S in source path (fallback = %b)" - filename with_fallback ; - log ~title:"find_source" "looking for %S in %S" (File.name file) dir ; - begin match Utils.find_file_with_path ~config ~with_fallback file [dir] with - | Some source -> Found source - | None -> - log ~title:"find_source" "Trying to find %S in %S directly" fname dir; - try Found (Misc.find_in_path [dir] fname) - with _ -> Not_found file - end - | [ x ] -> Found x - | files -> - log ~title:(sprintf "find_source(%s)" filename) - "multiple matches in the source path : %s" - (String.concat ~sep:" , " files); - try - match File_switching.source_digest () with - | None -> - log ~title:"find_source" - "... no source digest available to select the right one" ; - raise Not_found - | Some digest -> - log ~title:"find_source" - "... trying to use source digest to find the right one" ; - log ~title:"find_source" "Source digest: %s" (Digest.to_hex digest) ; - Found ( - List.find files ~f:(fun f -> - let fdigest = Digest.file f in - log ~title:"find_source" " %s (%s)" f (Digest.to_hex fdigest) ; - fdigest = digest - ) - ) - with Not_found -> - log ~title:"find_source" "... using heuristic to select the right one" ; - log ~title:"find_source" "we are looking for a file named %s in %s" fname dir ; - let rev = String.reverse (Misc.canonicalize_filename ~cwd:dir fname) in - let lst = - List.map files ~f:(fun path -> - let path' = String.reverse path in - let priority = (String.common_prefix_len rev path') * 2 + - if Preferences.is_preferred path - then 1 - else 0 - in - priority, path - ) - in - let lst = - (* TODO: remove duplicates in [source_path] instead of using - [sort_uniq] here. *) - List.sort_uniq ~cmp:(fun ((i:int),s) ((j:int),t) -> - let tmp = compare j i in - if tmp <> 0 then tmp else - match compare s t with - | 0 -> 0 - | n -> - (* Check if we are referring to the same files. - Especially useful on OSX case-insensitive FS. - FIXME: May be able handle symlinks and non-existing files, - CHECK *) - match File_id.get s, File_id.get t with - | s', t' when File_id.check s' t' -> - 0 - | _ -> n - ) lst - in - match lst with - | (i1, _) :: (i2, _) :: _ when i1 = i2 -> - Multiple_matches files - | (_, s) :: _ -> Found s - | _ -> assert false - -(* Well, that's just another hack. - [find_source] doesn't like the "-o" option of the compiler. This hack handles - Jane Street specific use case where "-o" is used to prefix a unit name by the - name of the library which contains it. *) -let find_source ~config loc path = - let result = - match find_source ~config loc with - | Found _ as result -> result - | failure -> - let fname = loc.Location.loc_start.Lexing.pos_fname in - match - let i = String.first_double_underscore_end fname in - let pos = i + 1 in - let fname = String.sub fname ~pos ~len:(String.length fname - pos) in - let loc = - let lstart = { loc.Location.loc_start with Lexing.pos_fname = fname } in - { loc with Location.loc_start = lstart } - in - find_source ~config loc - with - | Found _ as result -> result - | _ -> failure - | exception _ -> failure - in - match result with - | Found src -> `Found (Some src, loc.Location.loc_start) - | Not_found f -> File.explain_not_found path f - | Multiple_matches lst -> - let matches = String.concat lst ~sep:", " in - `File_not_found ( - sprintf "Several source files in your path have the same name, and \ - merlin doesn't know which is the right one: %s" - matches) - -module Namespace = struct - type under_type = [ `Constr | `Labels ] - - type t = (* TODO: share with [Namespaced_path.Namespace.t] *) - [ `Type | `Mod | `Modtype | `Vals | under_type ] - - type inferred = - [ t - | `This_label of Types.label_description - | `This_cstr of Types.constructor_description ] - - let from_context : Context.t -> inferred list = function - | Type -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ] - | Module_type -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ] - | Expr | Constant -> - [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ] - | Patt -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ] - | Unknown -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ] - | Label lbl -> [ `This_label lbl ] - | Module_path -> [ `Mod ] - | Constructor (c, _) -> [ `This_cstr c ] -end - -module Env_lookup : sig - - val loc - : Path.t - -> Namespaced_path.Namespace.t - -> Env.t - -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option - - val in_namespaces - : Namespace.inferred list - -> Longident.t - -> Env.t - -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) option - -end = struct - - let loc path (namespace : Namespaced_path.Namespace.t) env = - try - Some ( - match namespace with - | `Unknown - | `Apply - | `Vals -> - let vd = Env.find_value path env in - vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value - | `Constr - | `Labels - | `Type -> - let td = Env.find_type path env in - td.type_loc, td.type_uid, Shape.Sig_component_kind.Type - | `Functor - | `Mod -> - let md = Env.find_module path env in - md.md_loc, md.md_uid, Shape.Sig_component_kind.Module - | `Modtype -> - let mtd = Env.find_modtype path env in - mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type - ) - with - Not_found -> None - - exception Found of - (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) - - let in_namespaces (nss : Namespace.inferred list) ident env = - let open Shape.Sig_component_kind in - try - List.iter nss ~f:(fun namespace -> - try - match namespace with - | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) -> - log ~title:"lookup" - "got extension constructor"; - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Extension_constructor, cd.cstr_uid, loc)) - | `This_cstr cd -> - log ~title:"lookup" - "got constructor, fetching path and loc in type namespace"; - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Type, cd.cstr_uid,loc)) - | `Constr -> - log ~title:"lookup" "lookup in constructor namespace" ; - let cd = Env.find_constructor_by_name ident env in - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Type,cd.cstr_uid, loc)) - | `Mod -> - log ~title:"lookup" "lookup in module namespace" ; - let path, md = Env.find_module_by_name ident env in - raise (Found (path, Module, md.md_uid, md.Types.md_loc)) - | `Modtype -> - log ~title:"lookup" "lookup in module type namespace" ; - let path, mtd = Env.find_modtype_by_name ident env in - raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc)) - | `Type -> - log ~title:"lookup" "lookup in type namespace" ; - let path, typ_decl = Env.find_type_by_name ident env in - raise ( - Found (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc) - ) - | `Vals -> - log ~title:"lookup" "lookup in value namespace" ; - let path, val_desc = Env.find_value_by_name ident env in - raise ( - Found (path, Value, val_desc.val_uid, val_desc.Types.val_loc) - ) - | `This_label lbl -> - log ~title:"lookup" - "got label, fetching path and loc in type namespace"; - let path, loc = path_and_loc_from_label lbl env in - (* TODO: Use [`Labels] here instead of [`Type] *) - raise (Found (path, Type, lbl.lbl_uid, loc)) - | `Labels -> - log ~title:"lookup" "lookup in label namespace" ; - let lbl = Env.find_label_by_name ident env in - let path, loc = path_and_loc_from_label lbl env in - (* TODO: Use [`Labels] here instead of [`Type] *) - raise (Found (path, Type, lbl.lbl_uid, loc)) - with Not_found -> () - ) ; - log ~title:"lookup" " ... not in the environment" ; - None - with Found ((path, namespace, decl_uid, _loc) as x) -> - log ~title:"env_lookup" "found: '%a' in namespace %s with uid %a" - Logger.fmt (fun fmt -> Path.print fmt path) - (Shape.Sig_component_kind.to_string namespace) - Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - Some x -end - -let uid_from_longident ~env nss ml_or_mli ident = - let str_ident = String.concat ~sep:"." (Longident.flatten ident) in - match Env_lookup.in_namespaces nss ident env with - | None -> `Not_in_env str_ident - | Some (path, namespace, decl_uid, loc) -> - if Utils.is_builtin_path path then - `Builtin - else - let uid = uid_of_path ~env ~ml_or_mli ~decl_uid path namespace in - `Uid (uid, loc, path) - -let from_longident ~env nss ml_or_mli ident = - match uid_from_longident ~env nss ml_or_mli ident with - | `Uid (uid, loc, path) -> from_uid ~ml_or_mli uid loc path - | (`Builtin | `Not_in_env _) as v -> v - -let from_path ~config ~env ~namespace ml_or_mli path = - File_switching.reset (); - if Utils.is_builtin_path path then - `Builtin - else - match Env_lookup.loc path namespace env with - | None -> `Not_in_env (Path.name path) - | Some (loc, uid, namespace) -> - match locate ~env ~ml_or_mli uid loc path namespace with - | `Not_found _ - | `File_not_found _ as err -> err - | `Found (uid, loc) -> - match find_source ~config loc (Path.name path) with - | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise - -let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = - File_switching.reset (); - let browse = Mbrowse.of_typedtree local_defs in - let lid = Longident.parse path in - let ident, is_label = Longident.keep_suffix lid in - match - match namespaces with - | Some nss -> - if not is_label - then `Ok (nss :> Namespace.inferred list) - else if List.mem `Labels ~set:nss then ( - log ~title:"from_string" "restricting namespaces to labels"; - `Ok [ `Labels ] - ) else ( - log ~title:"from_string" - "input is clearly a label, but the given namespaces don't cover that"; - `Error `Missing_labels_namespace - ) - | None -> - match Context.inspect_browse_tree ~cursor:pos lid [browse], is_label with - | None, _ -> - log ~title:"from_string" "already at origin, doing nothing" ; - `Error `At_origin - | Some (Label _ as ctxt), true - | Some ctxt, false -> - log ~title:"from_string" - "inferred context: %s" (Context.to_string ctxt); - `Ok (Namespace.from_context ctxt) - | _, true -> - log ~title:"from_string" - "dropping inferred context, it is not precise enough"; - `Ok [ `Labels ] - with - | `Error e -> e - | `Ok nss -> - log ~title:"from_string" - "looking for the source of '%s' (prioritizing %s files)" - path (match switch with `ML -> ".ml" | `MLI -> ".mli"); - match from_longident ~env nss switch ident with - | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err - | `Builtin -> `Builtin path - | `Found (uid, loc) -> - match find_source ~config loc path with - | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise - -(** When we look for docstring in external compilation unit we can perform - a uid-based search and return the attached comment in the attributes. - This is a more sound way to get documentation than resorting on the - [Ocamldoc.associate_comment] heuristic *) -let doc_from_uid ~comp_unit uid = - let exception Found of Typedtree.attributes in - let test elt_uid attributes = - if Shape.Uid.equal uid elt_uid then raise (Found attributes) - in - let iterator = - let first_item = ref true in - let uid_is_comp_unit = match uid with - | Shape.Uid.Compilation_unit _ -> true - | _ -> false - in - fun env -> { Tast_iterator.default_iterator with - - (* Needed to return top-level module doc (when the uid is a compunit). - The module docstring must be the first signature or structure item *) - signature_item = (fun sub ({ sig_desc; _} as si) -> - begin match sig_desc, !first_item, uid_is_comp_unit with - | Tsig_attribute attr, true, true -> raise (Found [attr]) - | _, false, true -> raise Not_found - | _, _, _ -> first_item := false end; - Tast_iterator.default_iterator.signature_item sub si); - - structure_item = (fun sub ({ str_desc; _} as sti) -> - begin match str_desc, !first_item, uid_is_comp_unit with - | Tstr_attribute attr, true, true -> raise (Found [attr]) - | _, false, true -> raise Not_found - | _, _, _ -> first_item := false end; - Tast_iterator.default_iterator.structure_item sub sti); - - value_description = (fun sub ({ val_val; val_attributes; _ } as vd) -> - test val_val.val_uid val_attributes; - Tast_iterator.default_iterator.value_description sub vd); - - type_declaration = (fun sub ({ typ_type; typ_attributes; _ } as td) -> - test typ_type.type_uid typ_attributes; - Tast_iterator.default_iterator.type_declaration sub td); - - value_binding = (fun sub ({ vb_pat; vb_attributes; _ } as vb) -> - begin match vb_pat.pat_desc with - | Tpat_var (id, _) -> - begin try - let vd = Env.find_value (Pident id) env in - test vd.val_uid vb_attributes - with Not_found -> () end - | _ -> () end; - Tast_iterator.default_iterator.value_binding sub vb) - } - in - let parse_attributes attrs = - let open Parsetree in - try Some (List.find_map attrs ~f:(fun attr -> - if List.exists ["ocaml.doc"; "ocaml.text"] - ~f:(String.equal attr.attr_name.txt) - then Ast_helper.extract_str_payload attr.attr_payload - else None)) - with Not_found -> None - in - let typedtree = - log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; - match load_cmt comp_unit `MLI with - | Ok (_, cmt_infos) -> - log ~title:"doc_from_uid" "Cmt loaded, itering on the typedtree"; - begin match cmt_infos.cmt_annots with - | Interface s -> Some (`Interface { s with - sig_final_env = Envaux.env_of_only_summary s.sig_final_env}) - | Implementation str -> Some (`Implementation { str with - str_final_env = Envaux.env_of_only_summary str.str_final_env}) - | _ -> None - end - | Error _ -> None - in - try begin match typedtree with - | Some (`Interface s) -> - let iterator = iterator s.sig_final_env in - iterator.signature iterator s; - log ~title:"doc_from_uid" "uid not found in the signature" - | Some (`Implementation str) -> - let iterator = iterator str.str_final_env in - iterator.structure iterator str; - log ~title:"doc_from_uid" "uid not found in the implementation" - | _ -> () end; - `No_documentation - with - | Found attrs -> - log ~title:"doc_from_uid" "Found attributes for this uid"; - begin match parse_attributes attrs with - | Some (doc, _) -> `Found (doc |> String.trim) - | None -> `No_documentation end - | Not_found -> `No_documentation - -let get_doc ~config ~env ~local_defs ~comments ~pos = - File_switching.reset (); - let browse = Mbrowse.of_typedtree local_defs in - let from_uid ~loc uid = - begin match uid with - | Some (Shape.Uid.Item { comp_unit; _ } as uid) - | Some (Shape.Uid.Compilation_unit comp_unit as uid) - when Env.get_unit_name () <> comp_unit -> - log ~title:"get_doc" "the doc (%a) you're looking for is in another - compilation unit (%s)" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid) comp_unit; - (match doc_from_uid ~comp_unit uid with - | `Found doc -> `Found_doc doc - | `No_documentation -> - (* We fallback on the legacy heuristic to handle some unproper - doc placement. See test [unattached-comment.t] *) - `Found loc) - | _ -> - (* Uid based search doesn't works in the current CU since Merlin's parser - does not attach doc comments to the typedtree *) - `Found loc - end - in - fun path -> - let_ref last_location Location.none @@ fun () -> - match - match path with - | `Completion_entry (namespace, path, _loc) -> - log ~title:"get_doc" "completion: looking for the doc of '%a'" - Logger.fmt (fun fmt -> Path.print fmt path) ; - let from_path = from_path ~config ~env ~namespace `MLI path in - begin match from_path with - | `Found (uid, _, pos) -> - let loc : Location.t = - { loc_start = pos; loc_end = pos; loc_ghost = true } - in - from_uid ~loc uid - | (`Builtin |`Not_in_env _|`File_not_found _|`Not_found _) - as otherwise -> otherwise - end - | `User_input path -> - log ~title:"get_doc" "looking for the doc of '%s'" path; - let lid = Longident.parse path in - begin match Context.inspect_browse_tree ~cursor:pos lid [browse] with - | None -> - `Found { Location. loc_start=pos; loc_end=pos ; loc_ghost=true } - | Some _ -> - (* FIXME @ulysse: Why are we looking at the context if we're not using - the information? *) - begin match from_string ~config ~env ~local_defs ~pos `MLI path with - | `Found (uid, _, pos) -> - let loc : Location.t = - { loc_start = pos; loc_end = pos; loc_ghost = true } - in - from_uid ~loc uid - | `At_origin | `Missing_labels_namespace -> `No_documentation - | `Builtin _ -> `Builtin - | (`Not_in_env _ | `Not_found _ |`File_not_found _ ) - as otherwise -> otherwise - end - end - with - | `Found_doc doc -> `Found doc - | `Found loc -> - (* When the doc we look for is in the current buffer or if search by uid - has failed we use an alternative heuristic since Merlin's pure parser - does not poulates doc attributes in the typedtree. *) - let comments = - match File_switching.where_am_i () with - | None -> comments - | Some cmt_path -> - log ~title:"get_doc" "File switching: actually in %s" cmt_path; - let {Cmt_cache. cmt_infos; _ } = Cmt_cache.read cmt_path in - cmt_infos.Cmt_format.cmt_comments - in - log ~title:"get_doc" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt "looking around %a inside: [\n" - Location.print_loc !last_location; - List.iter comments ~f:(fun (c, l) -> - Format.fprintf fmt " (%S, %a);\n" c - Location.print_loc l); - Format.fprintf fmt "]\n" - ); - begin match - Ocamldoc.associate_comment comments loc !last_location - with - | None, _ -> `No_documentation - | Some doc, _ -> `Found doc - end - | `Builtin -> - begin match path with - | `User_input path -> `Builtin path - | `Completion_entry (_, path, _) -> `Builtin (Path.name path) - end - | `File_not_found _ - | `Not_found _ - | `No_documentation - | `Not_in_env _ as otherwise -> otherwise diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/locate.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/locate.mli deleted file mode 100644 index 581d75c29..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/locate.mli +++ /dev/null @@ -1,77 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -val log : 'a Logger.printf - -module Namespace : sig - type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ] -end - -val from_path - : config:Mconfig.t - -> env:Env.t - -> namespace:Namespaced_path.Namespace.t - -> [ `ML | `MLI ] - -> Path.t - -> [> `File_not_found of string - | `Found of Shape.Uid.t option * string option * Lexing.position - | `Builtin - | `Not_in_env of string - | `Not_found of string * string option ] - -val from_string - : config:Mconfig.t - -> env:Env.t - -> local_defs:Mtyper.typedtree - -> pos:Lexing.position - -> ?namespaces:Namespace.t list - -> [ `ML | `MLI ] - -> string - -> [> `File_not_found of string - | `Found of Shape.Uid.t option * string option * Lexing.position - | `Builtin of string - | `Missing_labels_namespace - | `Not_found of string * string option - | `Not_in_env of string - | `At_origin ] - -val get_doc - : config:Mconfig.t - -> env:Env.t - -> local_defs:Mtyper.typedtree - -> comments:(string * Location.t) list - -> pos:Lexing.position - -> [ `User_input of string - | `Completion_entry of - Namespaced_path.Namespace.t * Path.t * Location.t ] - -> [> `File_not_found of string - | `Found of string - | `Builtin of string - | `Not_found of string * string option - | `Not_in_env of string - | `No_documentation ] diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/misc_utils.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/misc_utils.ml deleted file mode 100644 index b5ac18ded..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/misc_utils.ml +++ /dev/null @@ -1,59 +0,0 @@ -open Std - -module Path : sig - val is_opened : Env.t -> Path.t -> bool - - val to_shortest_lid : - env:Env.t -> - ?name:string -> - env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t -end = struct - let opens env = - let rec aux acc = function - | Env.Env_open (s, path) -> aux (path::acc) s - | s -> - Option.map ~f:(aux acc) (Browse_misc.summary_prev s) - |> Option.value ~default:acc - in - aux [] env - - let is_opened env path = List.mem path ~set:(opens (Env.summary env)) - - let rec to_shortest_lid ~(opens : Path.t list) = function - | Path.Pdot (path, name) when List.exists ~f:(Path.same path) opens -> - Longident.Lident name - | Path.Pdot (path, name) -> Ldot (to_shortest_lid ~opens path, name) - | Pident ident -> Lident (Ident.name ident) - | _ -> assert false - - let maybe_replace_name ?name lid = - let open Longident in - Option.value_map name - ~default:lid - ~f:(fun name -> match lid with - | Lident _ -> Lident name - | Ldot (lid, _) -> Ldot (lid, name) - | _ -> assert false) - - let to_shortest_lid ~env ?name ~env_check path = - let opens = opens (Env.summary env) in - let lid = - to_shortest_lid ~opens path - |> maybe_replace_name ?name - in - try - env_check lid env |> ignore; - lid - with Not_found -> - maybe_replace_name ?name (Untypeast.lident_of_path path) -end - - -let parenthesize_name name = - (* Qualified operators need parentheses *) - if name = "" || not (Oprint.parenthesized_ident name) then name else ( - if name.[0] = '*' || name.[String.length name - 1] = '*' then - "( " ^ name ^ " )" - else - "(" ^ name ^ ")" - ) diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/misc_utils.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/misc_utils.mli deleted file mode 100644 index 06a02a5db..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/misc_utils.mli +++ /dev/null @@ -1,24 +0,0 @@ -module Path : sig - (** [to_shortest_lid ~env ~env_check path] will make a [Longident.t] from the - provided [Path.t] and attempt to use the shortest prefix possible given the - currently opened modules. The result is checked by looking it up in the - environment using the [env_check : Longident.t -> Env.t -> 'a] function. - - The check is needed because shadowing can cause subtle issues. A typical check - function would be [Env.find_constructor_by_name]. WHen the check fails the - function will return [Untypeast.lident_of_path path] instead of clever - prefix-less constructions. - - Optionally a [name] can be provided that will be used as the last ident of the - path. *) - val to_shortest_lid : - env:Env.t -> - ?name:string -> - env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t - - (* Return whether the given path is opened in the given environment *) - val is_opened : Env.t -> Path.t -> bool -end - -(* Add parenthesis to qualified operators *) -val parenthesize_name : string -> string diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/namespaced_path.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/namespaced_path.ml deleted file mode 100644 index 2ade36f4c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/namespaced_path.ml +++ /dev/null @@ -1,133 +0,0 @@ -open Std - -module Namespace = struct - type t = [ - | `Vals - | `Type - | `Constr - | `Mod - | `Modtype - | `Functor - | `Labels - | `Unknown - | `Apply - ] - - let to_tag_string = function - | `Mod -> "" - | `Functor -> "[functor]" - | `Labels -> "[label]" - | `Constr -> "[cstr]" - | `Type -> "[type]" - | `Vals -> "[val]" - | `Modtype -> "[Mty]" - | `Unknown -> "[?]" - | `Apply -> "[functor application]" - - let to_string = function - | `Mod -> "(module) " - | `Functor -> "(functor)" - | `Labels -> "(label) " - | `Constr -> "(constructor) " - | `Type -> "(type) " - | `Vals -> "(value) " - | `Modtype -> "(module type) " - | `Unknown -> "(unknown)" - | `Apply -> "(functor application)" -end - -module Id = struct - type t = - | Id of Ident.t - | String of string - - let name = function - | Id id -> Ident.name id - | String s -> s - - let unique_name = function - | Id id -> Ident.unique_toplevel_name id - | String s -> s - - let equal mi1 mi2 = - match mi1, mi2 with - | Id i1, Id i2 -> Ident.equal i1 i2 - | Id i, String s - | String s, Id i -> (Ident.name i) = s - | String s1, String s2 -> s1 = s2 -end - -type t = elt list -and elt = - | Ident of Id.t * Namespace.t - | Applied_to of t - -let rec to_string ~name = function - | [] - | Applied_to _ :: _ -> invalid_arg "Namespaced_path.to_string" - | Ident (id, ns) :: rest -> - List.fold_left rest ~init:(name id ^ Namespace.to_tag_string ns) ~f:( - fun acc elt -> - match elt with - | Ident (id, ns) -> - Printf.sprintf "%s.%s%s" acc (name id) (Namespace.to_tag_string ns) - | Applied_to arg -> - Printf.sprintf "%s(%s)" acc (to_string ~name arg) - ) - -let to_unique_string l = to_string ~name:Id.unique_name l -let to_string l = to_string ~name:Id.name l - -let of_path ~namespace p = - let rec aux namespace acc p = - let open Path in - match p with - | Pident id -> Ident (Id.Id id, namespace) :: acc - | Pdot (p, s) -> aux `Mod (Ident (Id.String s, namespace) :: acc) p - | Papply (p1, p2) -> - let acc = - Applied_to (aux `Mod [] p2) :: acc - in - aux `Mod acc p1 - in - aux namespace [] p - -let head_exn = function - | [] -> invalid_arg "head" - | x :: _ -> x - -let head x = - try Some (head_exn x) - with Invalid_argument _ -> None - -let peal_head_exn = function - | [] -> invalid_arg "peal_head_exn" - | _head :: rest -> rest - -let peal_head p = - try Some (peal_head_exn p) - with Invalid_argument _ -> None - -let rec equal p1 p2 = List.equal ~eq:equal_elt p1 p2 -and equal_elt elt1 elt2 = - match elt1, elt2 with - | Ident (i1, ns1), Ident (i2, ns2) -> Id.equal i1 i2 && ns1 = ns2 - | Applied_to p1, Applied_to p2 -> equal p1 p2 - | _, _ -> false - -let rewrite_head ~new_prefix p = new_prefix @ p - -let strip_stamps = - List.map ~f:(function - | Ident (Id i, ns) -> Ident (String (Ident.name i), ns) - | elt -> elt - ) - -let empty = [] - -let rec subst_prefix ~old_prefix ~new_prefix p = - match old_prefix, p with - | [], _ -> Some (new_prefix @ p) - | op1 :: ops, elt1 :: p when equal_elt op1 elt1 -> - subst_prefix ~old_prefix:ops ~new_prefix p - | _ -> None diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/namespaced_path.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/namespaced_path.mli deleted file mode 100644 index 4e4a75cec..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/namespaced_path.mli +++ /dev/null @@ -1,49 +0,0 @@ -module Namespace : sig - type t = [ - | `Vals - | `Type - | `Constr - | `Mod - | `Modtype - | `Functor - | `Labels - | `Unknown - | `Apply - ] - - val to_string : t -> string -end - -module Id : sig - type t = private - | Id of Ident.t - | String of string - - val name : t -> string -end - -type t (* = private elt list *) -and elt = private - | Ident of Id.t * Namespace.t - | Applied_to of t - -val to_string : t -> string -val to_unique_string : t -> string - -val head : t -> elt option -val head_exn : t -> elt - -val peal_head : t -> t option -val peal_head_exn : t -> t - -val equal : t -> t -> bool - -val rewrite_head : new_prefix:t -> t -> t - -val strip_stamps : t -> t - -val of_path : namespace:Namespace.t -> Path.t -> t - -val empty : t - -val subst_prefix : old_prefix:t -> new_prefix:t -> t -> t option diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/ocamldoc.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/ocamldoc.ml deleted file mode 100644 index 15949f853..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/ocamldoc.ml +++ /dev/null @@ -1,61 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright 2013 OCamlPro *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the Lesser GNU Public License version 3.0. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) -(* Lesser GNU General Public License for more details. *) -(* *) -(**************************************************************************) - -(** Pops comments from a list of comments (string * loc) to find the ones that - are associated to a given location. Also returns the remaining comments after - the location. *) -let associate_comment ?(after_only=false) comments loc nextloc = - let lstart = loc.Location.loc_start.Lexing.pos_lnum - and lend = loc.Location.loc_end.Lexing.pos_lnum in - let isnext c = - nextloc <> Location.none && - nextloc.Location.loc_start.Lexing.pos_cnum < - c.Location.loc_end.Lexing.pos_cnum - in - let rec aux = function - | [] -> None, [] - | (comment, cloc)::comments -> - let cstart = cloc.Location.loc_start.Lexing.pos_lnum - and cend = cloc.Location.loc_end.Lexing.pos_lnum - in - let processed = - (* It seems 4.02.3 remove ** from doc comment string, but not from - * locations. We can recognize doc comment by checking how the two - * differ. *) - (cloc.Location.loc_end.Lexing.pos_cnum - - cloc.Location.loc_start.Lexing.pos_cnum) = - String.length comment + 5 - in - if cend < lstart - 1 || cstart < lend && after_only then - aux comments - else if cstart > lend + 1 || - isnext cloc || - cstart > lstart && cend < lend (* keep inner comments *) - then - None, (comment, cloc)::comments - else if String.length comment < 2 || - (not processed && (comment.[0] <> '*' || comment.[1] = '*')) - then - aux comments - else - let comment = - if processed then comment else - String.sub comment 1 (String.length comment - 1) - in - let comment = String.trim comment in - match aux comments with - | None, comments -> Some comment, comments - | Some c, comments -> Some (String.concat "\n" [comment; c]), comments - in - aux comments diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/outline.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/outline.ml deleted file mode 100644 index c7628bdc5..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/outline.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Option.Infix - -(* Réglisse la police *) -open Typedtree - -open Browse_raw -open Browse_tree - -let id_of_patt = function - | { pat_desc = Tpat_var (id, _) ; _ } -> Some id - | _ -> None - -let mk ?(children=[]) ~location ~deprecated outline_kind outline_type id = - { Query_protocol. outline_kind; outline_type; location; children; - outline_name = Ident.name id ; deprecated } - -let get_class_field_desc_infos = function - | Typedtree.Tcf_val (str_loc,_,_,_,_) -> Some (str_loc, `Value) - | Typedtree.Tcf_method (str_loc,_,_) -> Some (str_loc, `Method) - | _ -> None - -let outline_type ~env typ = - let ppf, to_string = Format.to_string () in - Printtyp.wrap_printing_env env (fun () -> - Type_utils.print_type_with_decl ~verbosity:0 env ppf typ); - Some (to_string ()) - -let rec summarize node = - let location = node.t_loc in - match node.t_node with - | Value_binding vb -> - let deprecated = Type_utils.is_deprecated vb.vb_attributes in - begin match id_of_patt vb.vb_pat with - | None -> None - | Some ident -> - let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in - Some (mk ~location ~deprecated `Value typ ident) - end - | Value_description vd -> - let deprecated = Type_utils.is_deprecated vd.val_attributes in - let typ = outline_type ~env:node.t_env vd.val_val.val_type in - Some (mk ~location ~deprecated `Value typ vd.val_id) - - | Module_declaration md -> - let children = get_mod_children node in - begin match md.md_id with - | None -> None - | Some id -> - let deprecated = Type_utils.is_deprecated md.md_attributes in - Some (mk ~children ~location ~deprecated `Module None id) - end - - | Module_binding mb -> - let children = get_mod_children node in - begin match mb.mb_id with - | None -> None - | Some id -> - let deprecated = Type_utils.is_deprecated mb.mb_attributes in - Some (mk ~children ~location ~deprecated `Module None id) - end - - | Module_type_declaration mtd -> - let children = get_mod_children node in - let deprecated = Type_utils.is_deprecated mtd.mtd_attributes in - Some (mk ~deprecated ~children ~location `Modtype None mtd.mtd_id) - - | Type_declaration td -> - let children = - List.concat_map (Lazy.force node.t_children) ~f:(fun child -> - match child.t_node with - | Type_kind _ -> - List.map (Lazy.force child.t_children) ~f:(fun x -> - match x.t_node with - | Constructor_declaration c -> - let deprecated = Type_utils.is_deprecated c.cd_attributes in - mk `Constructor None c.cd_id ~deprecated ~location:c.cd_loc - | Label_declaration ld -> - let deprecated = Type_utils.is_deprecated ld.ld_attributes in - mk `Label None ld.ld_id ~deprecated ~location:ld.ld_loc - | _ -> assert false (* ! *) - ) - | _ -> [] - ) - in - let deprecated = Type_utils.is_deprecated td.typ_attributes in - Some (mk ~children ~location ~deprecated `Type None td.typ_id) - - | Type_extension te -> - let name = Path.name te.tyext_path in - let children = - List.filter_map (Lazy.force node.t_children) ~f:(fun x -> - summarize x >>| fun x -> { x with Query_protocol.outline_kind = `Constructor } - ) - in - let deprecated = Type_utils.is_deprecated te.tyext_attributes in - Some { Query_protocol. outline_name = name; outline_kind = `Type - ; outline_type = None; location; children; deprecated } - - | Extension_constructor ec -> - let deprecated = Type_utils.is_deprecated ec.ext_attributes in - Some (mk ~location `Exn None ec.ext_id ~deprecated) - - | Class_declaration cd -> - let children = - List.concat_map (Lazy.force node.t_children) ~f:get_class_elements - in - let deprecated = Type_utils.is_deprecated cd.ci_attributes in - Some (mk ~children ~location `Class None cd.ci_id_class_type ~deprecated) - - | _ -> None - -and get_class_elements node = - match node.t_node with - | Class_expr _ -> - List.concat_map (Lazy.force node.t_children) ~f:get_class_elements - | Class_structure _ -> - List.filter_map (Lazy.force node.t_children) ~f:(fun child -> - match child.t_node with - | Class_field cf -> - begin match get_class_field_desc_infos cf.cf_desc with - | Some (str_loc, outline_kind) -> - let deprecated = Type_utils.is_deprecated cf.cf_attributes in - Some { Query_protocol. - outline_name = str_loc.Location.txt; - outline_kind; - outline_type = None; - location = str_loc.Location.loc; - children = []; - deprecated - } - | None -> None - end - | _ -> None - ) - | _ -> [] - -and get_mod_children node = - List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir - -and remove_mod_indir node = - match node.t_node with - | Module_expr _ - | Module_type _ -> - List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir - | _ -> remove_top_indir node - -and remove_top_indir t = - match t.t_node with - | Structure _ - | Signature _ -> List.concat_map ~f:remove_top_indir (Lazy.force t.t_children) - | Signature_item _ - | Structure_item _ -> List.filter_map (Lazy.force t.t_children) ~f:summarize - | _ -> [] - -let get browses = List.concat @@ List.rev_map ~f:remove_top_indir browses - -let shape cursor nodes = - let rec aux node = - (* A node is selected if: - - part of the module language - - or under the cursor *) - let selected = match node.t_node with - | Module_expr _ - | Module_type_constraint _ - | Structure _ - | Structure_item _ - | Module_binding _ - | Module_type _ - | Signature _ - | Signature_item _ - | Module_declaration _ - | Module_type_declaration _ - | Module_binding_name _ - | Module_declaration_name _ - | Module_type_declaration_name _ -> not node.t_loc.Location.loc_ghost - | _ -> Location_aux.compare_pos cursor node.t_loc = 0 && - Lexing.compare_pos node.t_loc.Location.loc_start cursor <> 0 && - Lexing.compare_pos node.t_loc.Location.loc_end cursor <> 0 - in - if selected then [{ - Query_protocol. - shape_loc = node.t_loc; - shape_sub = List.concat_map ~f:aux (Lazy.force node.t_children) - }] - else [] - in - List.concat_map ~f:aux nodes diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/outline.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/outline.mli deleted file mode 100644 index 20ae50e53..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/outline.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -val get : Browse_tree.t list -> Query_protocol.outline -val shape : Lexing.position -> Browse_tree.t list -> Query_protocol.shape list diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/polarity_search.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/polarity_search.ml deleted file mode 100644 index ee224c12d..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/polarity_search.ml +++ /dev/null @@ -1,138 +0,0 @@ -open Std - -type t = Trie of (string * Longident.t * t list lazy_t) - -module PathSet = Set.Make(Path) - -type query = { - positive: PathSet.t; - pos_fun: int; - - negative: PathSet.t; - neg_fun: int; -} - -let remove cost set path = - if PathSet.mem path !set then ( - decr cost; - set := PathSet.remove path !set - ) - -let rec normalize_path env path = - match Env.find_type path env with - | exception Not_found -> path - | decl -> - match decl.Types.type_manifest with - | Some body when decl.Types.type_private = Asttypes.Public - || decl.Types.type_kind <> Types.Type_abstract -> - begin match Types.get_desc body with - | Types.Tconstr (path, _, _) -> normalize_path env path - | _ -> path - end - | _ -> path - -let match_query env query t = - let cost = ref 0 in - let rec traverse neg neg_fun pos pos_fun t = - incr cost; - incr cost; - match Types.get_desc t with - | Types.Tconstr (path, params, _) -> - remove cost pos (normalize_path env path); - begin match Env.find_type path env with - | exception Not_found -> () - | { Types.type_variance; _ } -> - List.iter2 type_variance params ~f:(fun var arg -> - if Types.Variance.mem Types.Variance.Inj var then ( - if Types.Variance.mem Types.Variance.Pos var then - traverse neg neg_fun pos pos_fun arg; - if Types.Variance.mem Types.Variance.Neg var then - traverse pos pos_fun neg neg_fun arg - ) - ) - end - - | Types.Tarrow (_, t1, t2, _) -> - decr pos_fun; - traverse neg neg_fun pos pos_fun t2; - traverse pos pos_fun neg neg_fun t1 - - | Types.Ttuple ts -> - List.iter ~f:(traverse neg neg_fun pos pos_fun) ts - - | Types.Tvar _ | Types.Tunivar _ -> - decr cost (* Favor polymorphic defs *) - - | _ -> () - in - let neg = ref query.negative and pos = ref query.positive in - let neg_fun = ref query.neg_fun and pos_fun = ref query.pos_fun in - traverse neg neg_fun pos pos_fun t; - if PathSet.is_empty !pos - && PathSet.is_empty !neg - && !neg_fun <= 0 - && !pos_fun <= 0 - then - Some !cost - else - None - -let build_query ~positive ~negative env = - let prepare r l = - if l = Longident.Lident "fun" then (incr r; None) else - let set, _ = Env.find_type_by_name l env in - Some (normalize_path env set) - in - let pos_fun = ref 0 and neg_fun = ref 0 in - let positive = List.filter_map positive ~f:(prepare pos_fun) in - let negative = List.filter_map negative ~f:(prepare neg_fun) in - { - positive = PathSet.of_list positive; - negative = PathSet.of_list negative; - neg_fun = !neg_fun; pos_fun = !pos_fun; - } - -let directories ~global_modules env = - let rec explore lident env = - let add_module name _ md l = - match md.Types.md_type with - | Types.Mty_alias _ -> l - | _ -> - let lident = Longident.Ldot (lident, name) in - Trie (name, lident, lazy (explore lident env)) :: l - in - Env.fold_modules add_module (Some lident) env [] - in - List.fold_left ~f:(fun l name -> - let lident = Longident.Lident name in - match Env.find_module_by_name lident env with - | exception _ -> l - | _ -> Trie (name, lident, lazy (explore lident env)) :: l - ) ~init:[] global_modules - (*Env.fold_modules (fun name _ _ l -> - ignore (seen name); - let lident = Longident.Lident name in - Trie (name, lident, lazy (explore lident env)) :: l - ) None env []*) - -let execute_query query env dirs = - let direct dir acc = - Env.fold_values (fun _ path desc acc -> - match match_query env query desc.Types.val_type with - | Some cost -> (cost, path, desc) :: acc - | None -> acc - ) dir env acc - in - let rec recurse acc (Trie (_, dir, children)) = - match - ignore (Env.find_module_by_name dir env); - Lazy.force children - with - | children -> - List.fold_left ~f:recurse ~init:(direct (Some dir) acc) children - | exception Not_found -> - Logger.notify ~section:"polarity-search" "%S not found" - (String.concat ~sep:"." (Longident.flatten dir)); - acc - in - List.fold_left dirs ~init:(direct None []) ~f:recurse diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/ptyp_of_type.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/ptyp_of_type.ml deleted file mode 100644 index 3f76d4c70..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/ptyp_of_type.ml +++ /dev/null @@ -1,238 +0,0 @@ -open Std -open Typedtree -open Types - -let var_of_id id = Location.mknoloc @@ Ident.name id - -type signature_elt = - | Item of Types.signature_item - | Type of Asttypes.rec_flag * Parsetree.type_declaration list - -let rec module_type = - let open Ast_helper in function - | Mty_for_hole -> failwith "Holes are not allowed in module types" - | Mty_signature signature_items -> - Mty.signature @@ signature signature_items - | Mty_ident path -> - Ast_helper.Mty.ident (Location.mknoloc (Untypeast.lident_of_path path)) - | Mty_alias path -> - Ast_helper.Mty.alias (Location.mknoloc (Untypeast.lident_of_path path)) - | Mty_functor (param, type_out) -> - let param = match param with - | Unit -> Parsetree.Unit - | Named (id, type_in) -> - Parsetree.Named ( - Location.mknoloc (Option.map ~f:Ident.name id), - module_type type_in) - in - let out = module_type type_out in - Mty.functor_ param out -and core_type type_expr = - let open Ast_helper in - match Types.get_desc type_expr with - | Tvar None | Tunivar None -> Typ.any () - | Tvar (Some s) | Tunivar (Some s) -> Typ.var s - | Tarrow (label, type_expr, type_expr_out, _commutable) -> - Typ.arrow label - (core_type type_expr) - (core_type type_expr_out) - | Ttuple type_exprs -> Typ.tuple @@ List.map ~f:core_type type_exprs - | Tconstr (path, type_exprs, _abbrev) -> - let loc = Untypeast.lident_of_path path |> Location.mknoloc in - Typ.constr loc @@ List.map ~f:core_type type_exprs - | Tobject (type_expr, _class_) -> - let rec aux acc type_expr = match get_desc type_expr with - | Tnil -> acc, Asttypes.Closed - | Tvar None | Tunivar None -> acc, Asttypes.Open - | Tfield ("*dummy method*", _, _, fields) -> aux acc fields - | Tfield (name, _, type_expr, fields) -> - let open Ast_helper in - let core_type = core_type type_expr in - let core_type = Of.tag (Location.mknoloc name) core_type in - - aux (core_type :: acc) fields - | _ -> - failwith @@ Format.asprintf - "Unexpected type constructor in fields list: %a" - Printtyp.type_expr type_expr - in - let fields, closed = aux [] type_expr in - Typ.object_ fields closed - | Tfield _ -> failwith "Found object field outside of object." - | Tnil -> Typ.object_ [] Closed - | Tlink type_expr | Tsubst (type_expr, _) -> core_type type_expr - | Tvariant row -> - let row_fields = row_fields row in - let row_closed = row_closed row in - let field (label, row_field) = - let label = Location.mknoloc label in - match row_field_repr row_field with - | Rpresent None | Reither (true, _, _) -> - Rf.tag label true [] - | Rpresent (Some type_expr) -> - let core_type = core_type type_expr in - Rf.tag label false [ core_type ] - | Reither (false, type_exprs, _) -> - Rf.tag label false @@ List.map ~f:core_type type_exprs - | Rabsent -> assert false - in - let closed = if row_closed then Asttypes.Closed else Asttypes.Open in - let fields = List.map ~f:field row_fields in - (* TODO NOT ALWAYS NONE *) - Typ.variant fields closed None - | Tpoly (type_expr, type_exprs) -> - let names = List.map ~f:(fun v -> match get_desc v with - | Tunivar (Some name) | Tvar (Some name) -> mknoloc name - | _ -> failwith "poly: not a var") - type_exprs - in - Typ.poly names @@ core_type type_expr - | Tpackage (path, lids_type_exprs) -> - let loc = mknoloc (Untypeast.lident_of_path path) in - let args = List.map lids_type_exprs - ~f:(fun (id, t) -> mknoloc id, core_type t) - in - Typ.package loc args -and modtype_declaration id { mtd_type; mtd_attributes; _ } = - Ast_helper.Mtd.mk - ~attrs:mtd_attributes - ?typ:(Option.map ~f:module_type mtd_type) - (var_of_id id) -and module_declaration id { md_type; md_attributes; _ } = - let name = Location.mknoloc (Some (Ident.name id)) in - Ast_helper.Md.mk - ~attrs:md_attributes - name - @@ module_type md_type -and extension_constructor id { - ext_args; - ext_ret_type; - ext_attributes; - _ -} = - Ast_helper.Te.decl - ~attrs:ext_attributes - ~args:(constructor_arguments ext_args) - ?res:(Option.map ~f:core_type ext_ret_type) - (var_of_id id) -and value_description id { val_type; val_kind=_; val_loc; val_attributes; _ } = - let type_ = core_type val_type in - { - Parsetree.pval_name = var_of_id id; - pval_type = type_; - pval_prim = []; - pval_attributes = val_attributes; - pval_loc = val_loc - } -and label_declaration { ld_id; ld_mutable; ld_type; ld_attributes; _ } = - Ast_helper.Type.field - ~attrs:ld_attributes - ~mut:ld_mutable - (var_of_id ld_id) - (core_type ld_type) -and constructor_arguments = function - | Cstr_tuple type_exprs -> - Parsetree.Pcstr_tuple (List.map ~f:core_type type_exprs) - | Cstr_record label_decls -> - Parsetree.Pcstr_record (List.map ~f:label_declaration label_decls) -and constructor_declaration { cd_id; cd_args; cd_res; cd_attributes; _} = - Ast_helper.Type.constructor - ~attrs:cd_attributes - ~args:(constructor_arguments cd_args) - ?res:(Option.map ~f:core_type cd_res) - @@ var_of_id cd_id -and type_declaration id { - type_params; - type_variance; - type_manifest; - type_kind; - type_attributes; - type_private; - _ } - = - let params = List.map2 type_params type_variance ~f:(fun type_ variance -> - let core_type = core_type type_ in - let pos, neg, _inv, inj = Types.Variance.get_lower variance in - let v = if pos then Asttypes.Covariant - else (if neg then Contravariant - else NoVariance) - in - let i = if inj then Asttypes.Injective else NoInjectivity in - core_type, (v, i)) - in - let kind = match type_kind with - | Type_abstract -> Parsetree.Ptype_abstract - | Type_open -> Ptype_open - | Type_variant (constrs, _) -> - Ptype_variant (List.map ~f:constructor_declaration constrs) - | Type_record (labels, _repr) -> - Ptype_record (List.map ~f:label_declaration labels) - in - let manifest = Option.map ~f:core_type type_manifest in - Ast_helper.Type.mk - ~attrs:type_attributes - ~params - ~kind - ~priv:type_private - ?manifest - (var_of_id id) -and signature_item (str_item : Types.signature_item) = - let open Ast_helper in - match str_item with - | Sig_value (id, vd, _visibility) -> - let vd = value_description id vd in - Sig.value vd - | Sig_type (id, type_decl, rec_flag, _visibility) -> - let rec_flag = match rec_flag with - | Trec_first -> Asttypes.Recursive - | Trec_next -> Asttypes.Recursive - | Trec_not -> Nonrecursive - in (* mutually recursive types are really handled by [signature] *) - Sig.type_ rec_flag [type_declaration id type_decl] - | Sig_modtype (id, modtype_decl, _visibility) -> - Sig.modtype @@ modtype_declaration id modtype_decl - | Sig_module (id, _, mod_decl, _, _) -> - Sig.module_ @@ module_declaration id mod_decl - | Sig_typext (id, ext_constructor, _, _) -> - let ext = Te.mk - (Location.mknoloc @@ Longident.Lident (Ident.name id)) - [ extension_constructor id ext_constructor] - in - Sig.type_extension ext - | Sig_class_type (id, _, _, _) -> - let str = Format.asprintf "Construct does not handle class types yet. \ - Please replace this comment by [%s]'s definition." (Ident.name id) in - Sig.text [ Docstrings.docstring str Location.none ] |> List.hd - | Sig_class (id, _, _, _) -> - let str = Format.asprintf "Construct does not handle classes yet. \ - Please replace this comment by [%s]'s definition." (Ident.name id) in - Sig.text [ Docstrings.docstring str Location.none ] |> List.hd -and signature (items : Types.signature_item list) = - List.map (group_items items) - ~f:(function - | Item item -> signature_item item - | Type (rec_flag, type_decls) -> Ast_helper.Sig.type_ rec_flag type_decls) -and group_items (items : Types.signature_item list) = - let rec read_type type_acc items = - match items with - | Sig_type (id, type_decl, Trec_next, _) :: rest -> - let td = type_declaration id type_decl in - read_type (td :: type_acc) rest - | _ -> List.rev type_acc, items - in - let rec group acc items = - match items with - | Sig_type (id, type_decl, Trec_first, _) :: rest -> - let type_, rest = read_type [type_declaration id type_decl] rest in - group (Type (Asttypes.Recursive, type_) :: acc) rest - | Sig_type (id, type_decl, Trec_not, _) :: rest -> - let type_, rest = read_type [type_declaration id type_decl] rest in - group (Type (Asttypes.Nonrecursive, type_) :: acc) rest - | Sig_class _ as item :: _ :: _ :: _ :: rest -> - group (Item item :: acc) rest - | Sig_class_type _ as item :: _ :: _ :: rest -> - group (Item item :: acc) rest - | item :: rest -> group (Item item :: acc) rest - | [] -> List.rev acc - in - group [] items diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/ptyp_of_type.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/ptyp_of_type.mli deleted file mode 100644 index 26fb46eb8..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/ptyp_of_type.mli +++ /dev/null @@ -1,41 +0,0 @@ -type signature_elt = -| Item of Types.signature_item -| Type of Asttypes.rec_flag * Parsetree.type_declaration list - -val module_type : Types.module_type -> Parsetree.module_type - -val core_type : Types.type_expr -> Parsetree.core_type - -val modtype_declaration : - Ident.t -> - Types.modtype_declaration -> - Parsetree.module_type_declaration - -val module_declaration : - Ident.t -> Types.module_declaration -> Parsetree.module_declaration - -val signature_item : Types.signature_item -> Parsetree.signature_item - -val extension_constructor : - Ident.t -> Types.extension_constructor -> Parsetree.extension_constructor - -val value_description : - Ident.t -> Types.value_description -> Parsetree.value_description - -val label_declaration : Types.label_declaration -> Parsetree.label_declaration - -val constructor_arguments : - Types.constructor_arguments -> Parsetree.constructor_arguments - -val constructor_declaration : - Types.constructor_declaration -> Parsetree.constructor_declaration - -val type_declaration : - Ident.t -> Types.type_declaration -> Parsetree.type_declaration - -val signature : Types.signature -> Parsetree.signature - -(** [group_items sig_items] groups items from a signature in a more meaningful - way: type declaration of the same recursive type are group together and items - following a class or class_type items are discarded *) -val group_items : Types.signature_item list -> signature_elt list diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/refactor_open.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/refactor_open.ml deleted file mode 100644 index 8d9afc78a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/refactor_open.ml +++ /dev/null @@ -1,52 +0,0 @@ -open Std - -(** [qual_or_unqual_path mode ~open_lident ~open_path node_path node_lid] - if mode is - `Unqualify - returns [node_lid] or [node_lid] with prefix [open_lident] cut off, - whichever is shorter - - `Qualify - returns [node_path] with its prefix equal to [open_lident] - - Returns [None] if [node_lid] doesn't need changes. - - Note: by "prefix" we mean the leftmost consecutive part of a longident or a path. *) -let qual_or_unqual_path mode ~open_lident ~open_path node_path node_lid = - let open_lid_head = Longident.head open_lident in - let node_lid_head = Longident.head node_lid in - let rec make_new_node_lid acc (p : Path.t) = - match p with - | Pident ident -> - Ident.name ident :: acc - | Pdot (path', s) when - mode = `Unqualify && - (Path.same open_path path' - || String.equal s node_lid_head (* unqualify shouldn't enlarge lident *)) - -> - s :: acc - | Pdot (_, s) when mode = `Qualify && s = open_lid_head -> - s :: acc - | Pdot (path', s) -> - make_new_node_lid (s :: acc) path' - | _ -> raise Not_found - in - let same_longident node_lid_head new_node_lid = - (* this works because [make_new_node_lid] changes only prefix of a longident *) - String.equal node_lid_head (List.hd new_node_lid) - in - match make_new_node_lid [] node_path with - | new_node_lid when not (same_longident node_lid_head new_node_lid) -> - Some (String.concat ~sep:"." new_node_lid) - | _ | exception Not_found -> None - -let get_rewrites ~mode typer pos = - match Mbrowse.select_open_node (Mtyper.node_at typer pos) with - | None | Some (_, _, []) -> [] - | Some (open_path, open_lident, ((_, node) :: _)) -> - let paths_and_lids = Browse_tree.all_occurrences_of_prefix open_path node in - List.filter_map paths_and_lids ~f:(fun ({Location. txt = path; loc}, lid) -> - if loc.Location.loc_ghost || Location_aux.compare_pos pos loc > 0 then - None - else - qual_or_unqual_path mode ~open_lident ~open_path path lid - |> Option.map ~f:(fun new_lid -> (new_lid, loc))) - |> List.sort_uniq ~cmp:(fun (_,l1) (_,l2) -> Location_aux.compare l1 l2) diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/refactor_open.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/refactor_open.mli deleted file mode 100644 index 9a4f2cb43..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/refactor_open.mli +++ /dev/null @@ -1,6 +0,0 @@ - -val get_rewrites - : mode:[> `Qualify | `Unqualify ] - -> Mtyper.result - -> Lexing.position - -> (string * Location.t) list diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/signature_help.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/signature_help.ml deleted file mode 100644 index e9f2a7039..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/signature_help.ml +++ /dev/null @@ -1,160 +0,0 @@ -open Std - -open Browse_raw - -type parameter_info = - { label : Asttypes.arg_label - ; param_start : int - ; param_end : int - ; argument : Typedtree.expression option - } - -type application_signature = - { function_name : string option - ; function_position : Msource.position - ; signature : string - ; parameters : parameter_info list - ; active_param : int option - } - -(* extract a properly properly parenthesized identifier - from (expression_desc (Texp_ident (Longident))) *) -let extract_ident (exp_desc : Typedtree.expression_desc) = - let rec longident ppf : Longident.t -> unit = function - | Lident s -> fprintf ppf "%s" (Misc_utils.parenthesize_name s) - | Ldot (p, s) -> fprintf ppf "%a.%s" longident p (Misc_utils.parenthesize_name s) - | Lapply (p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 - in - match exp_desc with - | Texp_ident (_, { txt = li; _ }, _) -> - let ppf, to_string = Format.to_string () in - longident ppf li; - Some (to_string ()) - | _ -> None - -(* Type variables shared across arguments should all be - printed with the same name. - [Printtyp.type_scheme] ensure that a name is unique within a given - type, but not across different invocations. - [reset] followed by calls to [mark_loops] and [type_sch] provide - that *) -let pp_type env ppf ty = - let module Printtyp = Type_utils.Printtyp in - Printtyp.wrap_printing_env env ~verbosity:0 (fun () -> - Printtyp.shared_type_scheme ppf ty) - -(* surround function types in parentheses *) -let pp_parameter_type env ppf ty = - match Types.get_desc ty with - | Tarrow _ -> Format.fprintf ppf "(%a)" (pp_type env) ty - | _ -> pp_type env ppf ty - -(* print parameter labels and types *) -let pp_parameter env label ppf ty = - match label with - | Asttypes.Nolabel -> - pp_parameter_type env ppf ty - | Asttypes.Labelled l -> - Format.fprintf ppf "%s:%a" l (pp_parameter_type env) ty - | Asttypes.Optional l -> - (* unwrap option for optional labels the same way as - [Raw_compat.labels_of_application] *) - let unwrap_option ty = match Types.get_desc ty with - | Types.Tconstr (path, [ty], _) - when Path.same path Predef.path_option -> ty - | _ -> ty - in - Format.fprintf ppf "?%s:%a" l (pp_parameter_type env) (unwrap_option ty) - -(* record buffer offsets to be able to underline parameter types *) -let print_parameter_offset ?arg:argument ppf buffer env label ty = - let param_start = Buffer.length buffer in - Format.fprintf ppf "%a%!" (pp_parameter env label) ty; - let param_end = Buffer.length buffer in - Format.pp_print_string ppf " -> "; - Format.pp_print_flush ppf (); - { label; param_start; param_end; argument } - -let separate_function_signature ~args (e : Typedtree.expression) = - Type_utils.Printtyp.reset (); - let buffer = Buffer.create 16 in - let ppf = Format.formatter_of_buffer buffer in - let rec separate ?(i=0) ?(parameters=[]) args ty = - match (args, Types.get_desc ty) with - | (_, arg)::args, Tarrow (label, ty1, ty2, _) -> - let parameter = print_parameter_offset ppf buffer e.exp_env label ty1 ?arg in - separate args ty2 ~i:(succ i) ~parameters:(parameter::parameters) - - | [], Tarrow (label, ty1, ty2, _) -> - let parameter = print_parameter_offset ppf buffer e.exp_env label ty1 in - separate args ty2 ~i:(succ i) ~parameters:(parameter::parameters) - - (* end of function type, print remaining type without recording offsets *) - | _ -> - Format.fprintf ppf - "%a%!" (pp_type e.exp_env) ty; - { function_name = extract_ident e.exp_desc - ; function_position = `Offset e.exp_loc.loc_end.pos_cnum - ; signature = Buffer.contents buffer - ; parameters = List.rev parameters - ; active_param = None - } - in - separate args e.exp_type - -let active_parameter_by_arg ~arg params = - let find_by_arg = function - | { argument = Some a; _ } when a == arg -> true - | _ -> false - in - try Some (List.index params ~f:find_by_arg) - with Not_found -> None - -let active_parameter_by_prefix ~prefix params = - let common = function - | Asttypes.Nolabel -> Some 0 - | l when String.is_prefixed ~by:"~" prefix - || String.is_prefixed ~by:"?" prefix -> - Some (String.common_prefix_len (Btype.prefixed_label_name l) prefix) - | _ -> None - in - - let rec find_by_prefix ?(i=0) ?longest_len ?longest_i = function - | [] -> longest_i - | p :: ps -> - match common p.label, longest_len with - | Some common_len, Some longest_len when common_len > longest_len -> - find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i - | Some common_len, None -> - find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i - | _ -> - find_by_prefix ps ~i:(succ i) ?longest_len ?longest_i - in - find_by_prefix params - -let is_arrow t = match Types.get_desc t with - | Tarrow _ -> true - | _ -> false - -let application_signature ~prefix = function - (* provide signature information for applied functions *) - | (_, Expression arg) :: (_, Expression { exp_desc = - Texp_apply ({ exp_type; _ } as e, args); _}) :: _ - when is_arrow exp_type -> - let result = separate_function_signature e ~args in - let active_param = active_parameter_by_arg ~arg result.parameters in - let active_param = match active_param with - | Some _ as ap -> ap - | None -> active_parameter_by_prefix ~prefix result.parameters - in - Some { result with active_param } - - (* provide signature information directly after an unapplied function-type - value *) - | (_, Expression ({ exp_type; _ } as e)) :: _ - when is_arrow exp_type -> - let result = separate_function_signature e ~args:[] in - let active_param = active_parameter_by_prefix ~prefix result.parameters in - Some { result with active_param } - - | _ -> None diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/signature_help.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/signature_help.mli deleted file mode 100644 index d445ca5ad..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/signature_help.mli +++ /dev/null @@ -1,19 +0,0 @@ -type parameter_info = - { label : Asttypes.arg_label - ; param_start : int - ; param_end : int - ; argument : Typedtree.expression option - } - -type application_signature = - { function_name : string option - ; function_position : Msource.position - ; signature : string - ; parameters : parameter_info list - ; active_param : int option - } - -val application_signature : - prefix:string - -> Mbrowse.t - -> application_signature option diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/tail_analysis.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/tail_analysis.ml deleted file mode 100644 index 3e75a758d..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/tail_analysis.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Browse_raw -open Typedtree - -let tail_operator = function - | {exp_desc = Texp_ident - (_,_, {Types.val_kind = - Types.Val_prim - {Primitive.prim_name = "%sequand"|"%sequor"; _ } - ; _ }) - ; _ } - -> true - | _ -> false - -let expr_tail_positions = function - | Texp_apply (callee, args) when tail_operator callee -> - begin match List.last args with - | None | Some (_, None)-> [] - | Some (_, Some expr) -> [Expression expr] - end - | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ | Texp_assert _ - | Texp_lazy _ | Texp_object _ | Texp_pack _ - | Texp_function _ | Texp_apply _ | Texp_tuple _ - | Texp_ident _ | Texp_constant _ - | Texp_construct _ | Texp_variant _ | Texp_record _ - | Texp_field _ | Texp_setfield _ | Texp_array _ - | Texp_while _ | Texp_for _ | Texp_send _ | Texp_new _ - | Texp_unreachable | Texp_extension_constructor _ | Texp_letop _ | Texp_hole - -> [] - | Texp_match (_,cs,_) - -> List.map cs ~f:(fun c -> Case c) - | Texp_try (_,cs) - -> List.map cs ~f:(fun c -> Case c) - | Texp_letmodule (_,_,_,_,e) | Texp_letexception (_,e) | Texp_let (_,_,e) - | Texp_sequence (_,e) | Texp_ifthenelse (_,e,None) | Texp_open (_, e) - -> [Expression e] - | Texp_ifthenelse (_,e1,Some e2) - -> [Expression e1; Expression e2] - - -let tail_positions = function - | Expression expr -> expr_tail_positions expr.exp_desc - | Case case -> [Expression case.c_rhs] - | _ -> [] - -(* If the expression is a function, return all of its entry-points (which are - in tail-positions). Returns an empty list otherwise *) -let expr_entry_points = function - | Texp_function {cases; _} -> List.map cases ~f:(fun c -> Case c) - | _ -> [] - -let entry_points = function - | Expression expr -> expr_entry_points expr.exp_desc - | _ -> [] - -(* FIXME: what about method call? It should be translated to a Texp_apply, - but I am not sure *) -let is_call = function - | Expression {exp_desc = Texp_apply _; _} -> true - | _ -> false diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/tail_analysis.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/tail_analysis.mli deleted file mode 100644 index 6e29c3808..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/tail_analysis.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -(* Assuming an expression (or other constructs occurring inside expressions, - like cases of a match statement) is in tail-position, returns all - sub-expression that will be evaluated in tail-position too *) -val tail_positions: Browse_raw.node -> Browse_raw.node list - -(* If the node is a function, return all of its entry-points -- those are in - tail-position. Returns an empty list otherwise *) -val entry_points: Browse_raw.node -> Browse_raw.node list - -val is_call: Browse_raw.node -> bool diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/type_enclosing.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/type_enclosing.ml deleted file mode 100644 index a228241cd..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/type_enclosing.ml +++ /dev/null @@ -1,133 +0,0 @@ -open Std - -let log_section = "type-enclosing" -let {Logger.log} = Logger.for_section log_section - -type type_info = - | Modtype of Env.t * Types.module_type - | Type of Env.t * Types.type_expr - | Type_decl of Env.t * Ident.t * Types.type_declaration - | String of string - -type typed_enclosings = - (Location.t * type_info * Query_protocol.is_tail_position) list - -let from_nodes ~path = - let aux (env, node, tail) = - let open Browse_raw in - let ret x = Some (Mbrowse.node_loc node, x, tail) in - match[@ocaml.warning "-9"] node with - | Expression {exp_type = t} - | Pattern {pat_type = t} - | Core_type {ctyp_type = t} - | Value_description { val_desc = { ctyp_type = t } } -> - ret (Type (env, t)) - | Type_declaration { typ_id = id; typ_type = t} -> - ret (Type_decl (env, id, t)) - | Module_expr {mod_type = Types.Mty_for_hole} -> None - | Module_expr {mod_type = m} - | Module_type {mty_type = m} - | Module_binding {mb_expr = {mod_type = m}} - | Module_declaration {md_type = {mty_type = m}} - | Module_type_declaration {mtd_type = Some {mty_type = m}} - | Module_binding_name {mb_expr = {mod_type = m}} - | Module_declaration_name {md_type = {mty_type = m}} - | Module_type_declaration_name {mtd_type = Some {mty_type = m}} -> - ret (Modtype (env, m)) - | Class_field - { cf_desc = - Tcf_method - (_, _, - Tcfk_concrete - (_, {exp_type})) } -> - begin match Types.get_desc exp_type with - | Tarrow (_, _, t, _) -> ret (Type (env, t)) - | _ -> None - end - | Class_field - { cf_desc = - Tcf_val (_, _, _, Tcfk_concrete (_, {exp_type = t }), _) } -> - ret (Type (env, t)) - | Class_field { cf_desc = - Tcf_method (_, _, Tcfk_virtual {ctyp_type = t }) } -> - ret (Type (env, t)) - | Class_field { cf_desc = - Tcf_val (_, _, _, Tcfk_virtual {ctyp_type = t }, _) } -> - ret (Type (env, t)) - | _ -> None - in - List.filter_map ~f:aux path - -let from_reconstructed ~nodes ~cursor ~verbosity exprs = - let open Browse_raw in - let env, node = Mbrowse.leaf_node nodes in - log ~title:"from_reconstructed" "node = %s\nexprs = [%s]" - (Browse_raw.string_of_node node) - (String.concat ~sep:";" (List.map exprs ~f:(fun l -> - l.Location.txt)) - ); - let include_lident = match node with - | Pattern _ -> false - | _ -> true - in - let include_uident = match node with - | Module_binding _ - | Module_binding_name _ - | Module_declaration _ - | Module_declaration_name _ - | Module_type_declaration _ - | Module_type_declaration_name _ - -> false - | _ -> true - in - - let get_context lident = - Context.inspect_browse_tree - ~cursor - (Longident.parse lident) - [nodes] - in - - let f = - fun {Location. txt = source; loc} -> - let context = get_context source in - Option.iter context ~f:(fun ctx -> - log ~title:"from_reconstructed" "source = %s; context = %s" - source (Context.to_string ctx)); - match context with - (* Retrieve the type from the AST when it is possible *) - | Some (Context.Constructor (cd, loc)) -> - log ~title:"from_reconstructed" "ctx: constructor %s" - cd.cstr_name; - let ppf, to_string = Format.to_string () in - Type_utils.print_constr ~verbosity env ppf cd; - Some (loc, String (to_string ()), `No) - | Some Context.Constant -> None - | _ -> - let context = Option.value ~default:Context.Expr context in - (* Else use the reconstructed identifier *) - match source with - | "" -> - log ~title:"from_reconstructed" "no reconstructed identifier"; - None - | source when not include_lident && Char.is_lowercase source.[0] -> - log ~title:"from_reconstructed" "skipping lident"; - None - | source when not include_uident && Char.is_uppercase source.[0] -> - log ~title:"from_reconstructed" "skipping uident"; - None - | source -> - try - let ppf, to_string = Format.to_string () in - if Type_utils.type_in_env ~verbosity ~context env ppf source then ( - log ~title:"from_reconstructed" "typed %s" source; - Some (loc, String (to_string ()), `No) - ) - else ( - log ~title:"from_reconstructed" "FAILED to type %s" source; - None - ) - with _ -> - None - in - List.filter_map exprs ~f diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/type_enclosing.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/type_enclosing.mli deleted file mode 100644 index 8ffec0e21..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/type_enclosing.mli +++ /dev/null @@ -1,55 +0,0 @@ -(** Provides type information around the cursor. - - The information comes from two sources: - 1. enclosing AST nodes: we just retrieve the types in the typedtree - 2. if the cursor is on an identifier, by typing it in the current - environment - - (2) is primarily useful in the following situations: - - when the identifier is polymorphic in the environment, but monomorphic in - the AST because it's been instantiated. - - when there is a syntax or type error in that area, and we don't have a - precise enough AST node for the position (i.e. we got a "recovered" node, of - type ['a]). - - Furthermore, (2) has a finer granularity than (1): when the cursor is in the - middle of a longident, e.g. [Foo.B|ar.Baz.lol] (with | being the cursor), - then we'll have one AST node covering the whole ident. - But what we reconstruct gives us: [Foo.Bar], [Foo.Bar.Baz], - [Foo.Bar.Baz.lol]; and we return the type for each of them. - These are what we call "small enclosings". - - There are however some issues with the small enclosings: - - one has to be careful of the context (obviously that information won't be - available in case of parse errors); because a given identifier could exist - in different namespaces, for instance: - {[ - type t - module type t = sig val t : t end - let t (t : t) : (module t) = (module struct let t = t end) - ]} - - - the information might be redundant with the one we get from the AST. -*) - -val log_section : string - -type type_info = - | Modtype of Env.t * Types.module_type - | Type of Env.t * Types.type_expr - | Type_decl of Env.t * Ident.t * Types.type_declaration - | String of string - -type typed_enclosings = - (Location.t * type_info * Query_protocol.is_tail_position) list - -val from_nodes : - path:(Env.t * Browse_raw.node * Query_protocol.is_tail_position) list -> - typed_enclosings - -val from_reconstructed : - nodes:(Env.t * Browse_raw.node) list -> - cursor:Lexing.position -> - verbosity:int -> - string Location.loc list -> - typed_enclosings diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/type_utils.ml b/ocaml-lsp-server/vendor/merlin/src/analysis/type_utils.ml deleted file mode 100644 index 2837d7c89..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/type_utils.ml +++ /dev/null @@ -1,335 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let parse_expr ?(keywords=Lexer_raw.keywords []) expr = - let lexbuf = Lexing.from_string expr in - let state = Lexer_raw.make keywords in - let rec lexer = function - | Lexer_raw.Fail (e,l) -> raise (Lexer_raw.Error (e,l)) - | Lexer_raw.Return token -> token - | Lexer_raw.Refill k -> lexer (k ()) - in - let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in - Parser_raw.parse_expression lexer lexbuf - -let lookup_module name env = - let path, md = Env.find_module_by_name name env in - path, md.Types.md_type, md.Types.md_attributes - -let verbosity = ref 0 - -module Printtyp = struct - include Printtyp - - let expand_type env ty = - Env.with_cmis @@ fun () -> (* ?? Not sure *) - if !verbosity = 0 then ty - else - (* Fresh copy of the type to mutilate *) - let ty = Subst.type_expr Subst.identity ty in - let marks = Hashtbl.create 7 in - let mark ty = - if Hashtbl.mem marks (Types.get_id ty) then false - else (Hashtbl.add marks (Types.get_id ty) (); true) - in - let rec iter d ty0 = - if mark ty0 then - let open Types in - let ty' = Ctype.full_expand ~may_forget_scope:true env ty0 in - if get_desc ty' == get_desc ty0 then - Btype.iter_type_expr (iter d) ty0 - else begin - let desc = match get_desc ty' with - | Tvariant row -> - Tvariant (set_row_name row None) - | Tobject (ty, _) -> - Tobject (ty, ref None) - | desc -> desc - in - Types.Transient_expr.(set_desc (repr ty0) desc); - if d > 0 then - Btype.iter_type_expr (iter (pred d)) ty0 - end - in - iter !verbosity ty; - ty - - let expand_type_decl env ty = - match ty.Types.type_manifest with - | Some m -> {ty with Types.type_manifest = Some (expand_type env m)} - | None -> ty - - let expand_sig env mty = - Env.with_cmis @@ fun () -> - Env.scrape_alias env mty - - let verbose_type_scheme env ppf t = - Printtyp.type_scheme ppf (expand_type env t) - - let verbose_type_declaration env id ppf t = - Printtyp.type_declaration id ppf (expand_type_decl env t) - - let verbose_modtype env ppf t = - Printtyp.modtype ppf (expand_sig env t) - - let select_verbose a b env = - (if !verbosity = 0 then a else b env) - - let type_scheme env ppf ty = - select_verbose type_scheme verbose_type_scheme env ppf ty - - let type_declaration env id ppf = - select_verbose type_declaration verbose_type_declaration env id ppf - - let modtype env ppf mty = - select_verbose modtype verbose_modtype env ppf mty - - let wrap_printing_env env ~verbosity:v f = - let_ref verbosity v (fun () -> wrap_printing_env env f) -end - -let si_modtype_opt = function - | Types.Sig_modtype (_, m, _) -> m.mtd_type - | Types.Sig_module (_, _, m, _, _) -> Some m.md_type - | _ -> None - -(* Check if module is smaller (= has less definition, counting nested ones) - * than a particular threshold. Return (Some n) if module has size n, or None - * otherwise (module is bigger than threshold). - * Used to skip printing big modules in completion. *) -let rec mod_smallerthan n m = - if n < 0 then None - else - let open Types in - match m with - | Mty_ident _ -> Some 1 - | Mty_signature s -> - begin match List.length_lessthan n s with - | None -> None - | Some _ -> - List.fold_left s ~init:(Some 0) - ~f:begin fun acc item -> - let sub n1 m = match mod_smallerthan (n - n1) m with - | Some n2 -> Some (n1 + n2) - | None -> None - in - match acc, si_modtype_opt item with - | None, _ -> None - | Some n', _ when n' > n -> None - | Some n1, Some mty -> sub n1 mty - | Some n', _ -> Some (succ n') - end - end - | Mty_functor _ -> - let (m1,m2) = unpack_functor m in - begin - match mod_smallerthan n m2, m1 with - | None, _ -> None - | result, Unit -> result - | Some n1, Named (_, mt) -> - match mod_smallerthan (n - n1) mt with - | None -> None - | Some n2 -> Some (n1 + n2) - end - | _ -> Some 1 - -let print_short_modtype verbosity env ppf md = - match mod_smallerthan 1000 md with - | None when verbosity = 0 -> - Format.pp_print_string ppf - "(* large signature, repeat to confirm *)"; - | _ -> - Printtyp.modtype env ppf md - -let print_type_with_decl ~verbosity env ppf typ = - if verbosity > 0 then - match Types.get_desc typ with - | Types.Tconstr (path, params, _) -> - let decl = - Env.with_cmis @@ fun () -> - Env.find_type path env - in - let is_abstract = - match decl.Types.type_kind with - | Types.Type_abstract -> true - | _ -> false - in - (* Print expression only if it is parameterized or abstract *) - let print_expr = is_abstract || params <> [] in - if print_expr then - Printtyp.type_scheme env ppf typ; - (* If not abstract, also print the declaration *) - if not is_abstract then - begin - (* Separator if expression was printed *) - if print_expr then - begin - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf (); - end; - let ident = match path with - | Path.Papply _ -> assert false - | Path.Pdot _ -> Ident.create_persistent (Path.last path) - | Path.Pident ident -> ident - in - Printtyp.type_declaration env ident ppf decl - end - | _ -> Printtyp.type_scheme env ppf typ - else - Printtyp.type_scheme env ppf typ - -let print_exn ppf exn = - match Location.error_of_exn exn with - | None | Some `Already_displayed -> - Format.pp_print_string ppf (Printexc.to_string exn) - | Some (`Ok report) -> Location.print_main ppf report - -let print_type ppf env lid = - let p, t = Env.find_type_by_name lid.Asttypes.txt env in - Printtyp.type_declaration env - (Ident.create_persistent (* Incorrect, but doesn't matter. *) - (Path.last p)) - ppf t - -let print_modtype ppf verbosity env lid = - let _p, mtd = Env.find_modtype_by_name lid.Asttypes.txt env in - match mtd.mtd_type with - | Some mt -> print_short_modtype verbosity env ppf mt - | None -> Format.pp_print_string ppf "(* abstract module *)" - -let print_modpath ppf verbosity env lid = - let _path, md = - Env.find_module_by_name lid.Asttypes.txt env - in - print_short_modtype verbosity env ppf (md.md_type) - -let print_cstr_desc ppf cstr_desc = - !Oprint.out_type ppf (Browse_misc.print_constructor cstr_desc) - -let print_constr ppf env lid = - let cstr_desc = - Env.find_constructor_by_name lid.Asttypes.txt env - in - (* FIXME: support Reader printer *) - print_cstr_desc ppf cstr_desc - -exception Fallback -let type_in_env ?(verbosity=0) ?keywords ~context env ppf expr = - let print_expr expression = - let (str, _sg, _shape, _) = - Env.with_cmis @@ fun () -> - Typemod.type_toplevel_phrase env - [Ast_helper.Str.eval expression] - in - let open Typedtree in - match str.str_items with - | [ { str_desc = Tstr_eval (exp,_); _ }] -> - print_type_with_decl ~verbosity env ppf exp.exp_type - | _ -> failwith "unhandled expression" - in - Printtyp.wrap_printing_env env ~verbosity @@ fun () -> - Msupport.uncatch_errors @@ fun () -> - match parse_expr ?keywords expr with - | exception exn -> print_exn ppf exn; false - - | e -> - let extract_specific_parsing_info e = - match e.Parsetree.pexp_desc with - | Parsetree.Pexp_ident longident -> `Ident longident - | Parsetree.Pexp_construct (longident, _) -> `Constr longident - | _ -> `Other - in - let open Context in - match extract_specific_parsing_info e with - | `Ident longident | `Constr longident -> - begin try - begin match context with - | Label lbl_des -> - (* We use information from the context because `Env.find_label_by_name` - can fail *) - Printtyp.type_expr ppf lbl_des.lbl_arg; - | Type -> - print_type ppf env longident - (* TODO: special processing for module aliases ? *) - | Module_type -> - print_modtype ppf verbosity env longident - | Module_path -> - print_modpath ppf verbosity env longident - | Constructor _ -> - print_constr ppf env longident - | _ -> raise Fallback - end; - true - with _ -> - (* Fallback to contextless typing attempts *) - try - print_expr e; - true - with exn -> try - print_modpath ppf verbosity env longident; - true - with _ -> try - (* TODO: useless according to test suite *) - print_modtype ppf verbosity env longident; - true - with _ -> try - (* TODO: useless according to test suite *) - print_constr ppf env longident; - true - with _ -> print_exn ppf exn; false - end - - | `Other -> - try print_expr e; true - with exn -> print_exn ppf exn; false - -let print_constr ~verbosity env ppf cd = - Printtyp.wrap_printing_env env ~verbosity @@ fun () -> - print_cstr_desc ppf cd - -(* From doc-ock - https://github.com/lpw25/doc-ock/blob/master/src/docOckAttrs.ml *) -let read_doc_attributes attrs = - let rec loop = function - | ({Location.txt = - ("doc" | "ocaml.doc"); loc = _}, payload) :: _ -> - Ast_helper.extract_str_payload payload - | _ :: rest -> loop rest - | [] -> None - in - loop (List.map ~f:Ast_helper.Attr.as_tuple attrs) - -let is_deprecated = - List.exists ~f:(fun (attr : Parsetree.attribute) -> - match Ast_helper.Attr.as_tuple attr with - | {Location.txt = - ("deprecated" | "ocaml.deprecated"); loc = _}, _ -> - true - | _ -> false) diff --git a/ocaml-lsp-server/vendor/merlin/src/analysis/type_utils.mli b/ocaml-lsp-server/vendor/merlin/src/analysis/type_utils.mli deleted file mode 100644 index ac997ba06..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/analysis/type_utils.mli +++ /dev/null @@ -1,74 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -val verbosity : int ref - -module Printtyp : sig - include module type of struct include Printtyp end - - val type_declaration : - Env.t -> Ident.t -> Format.formatter -> Types.type_declaration -> unit - - val type_scheme : Env.t -> Format.formatter -> Types.type_expr -> unit - - val modtype : Env.t -> Format.formatter -> Types.module_type -> unit - - val wrap_printing_env : Env.t -> verbosity:int -> (unit -> 'a) -> 'a -end - -val mod_smallerthan : int -> Types.module_type -> int option -(** Check if module is smaller (= has less definition, counting nested ones) - than a particular threshold. Return (Some n) if module has size n, or None - otherwise (module is bigger than threshold). - Used to skip printing big modules in completion. *) - -val type_in_env : ?verbosity:int -> ?keywords:Lexer_raw.keywords -> - context: Context.t -> Env.t -> Format.formatter -> string -> bool -(** [type_in_env env ppf input] parses [input] and prints its type on [ppf]. - Returning true if it printed a type, false otherwise. *) - -val print_type_with_decl : verbosity:int -> - Env.t -> Format.formatter -> Types.type_expr -> unit -(** [print_type_or_decl] behaves like [Printtyp.type_scheme], it prints the - type expression, except if it is a type constructor and verbosity is set then - it also prints the type declaration. *) - -val lookup_module : Longident.t -> - Env.t -> Path.t * Types.module_type * Parsetree.attributes -(** [lookup_module] is a fancier version of [Env.lookup_module] that also - returns the module type. *) - -val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option -(** [read_doc_attributes] looks for a docstring in an attribute list. *) - -val is_deprecated : Parsetree.attributes -> bool - -val print_constr : verbosity:int -> Env.t -> Format.formatter -> - Types.constructor_description -> unit diff --git a/ocaml-lsp-server/vendor/merlin/src/config/dune b/ocaml-lsp-server/vendor/merlin/src/config/dune deleted file mode 100644 index 2b5b6477f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/config/dune +++ /dev/null @@ -1,10 +0,0 @@ -(rule - (targets merlin_config.ml) - (deps gen_config.ml) - (action (with-stdout-to %{targets} - (run %{ocaml} gen_config.ml %{ocaml_version})))) - -(library - (name merlin_config) - (public_name merlin-lib.config) - (modules merlin_config)) diff --git a/ocaml-lsp-server/vendor/merlin/src/config/gen_config.ml b/ocaml-lsp-server/vendor/merlin/src/config/gen_config.ml deleted file mode 100644 index 9919271aa..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/config/gen_config.ml +++ /dev/null @@ -1,21 +0,0 @@ -let ocaml_version_val = - match - Scanf.sscanf Sys.argv.(1) "%s@.%s@.%d" (fun maj min p -> maj, min, p) - with - | "4", "02", _ -> - "`OCaml_4_02_3" - | "4", "07", p -> - Printf.sprintf "`OCaml_4_07_%d" p - | maj, min, _ -> - Printf.sprintf "`OCaml_%s_%s_0" maj min - -let () = - Printf.printf {| -let version = "%%VERSION%%" -let ocamlversion : - [ `OCaml_4_02_0 | `OCaml_4_02_1 | `OCaml_4_02_2 | `OCaml_4_02_3 - | `OCaml_4_03_0 | `OCaml_4_04_0 | `OCaml_4_05_0 | `OCaml_4_06_0 - | `OCaml_4_07_0 | `OCaml_4_07_1 | `OCaml_4_08_0 | `OCaml_4_09_0 - | `OCaml_4_10_0 | `OCaml_4_11_0 | `OCaml_4_12_0 | `OCaml_4_13_0 - | `OCaml_4_14_0 ] = %s -|} ocaml_version_val diff --git a/ocaml-lsp-server/vendor/merlin/src/dot-merlin/dot_merlin_reader.ml b/ocaml-lsp-server/vendor/merlin/src/dot-merlin/dot_merlin_reader.ml deleted file mode 100644 index ccb5d5426..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/dot-merlin/dot_merlin_reader.ml +++ /dev/null @@ -1,488 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2019 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Merlin_utils -open Misc -open Std -open Std.Result - -let findlib_ok = - try - Ok (Findlib.init ()) - with exn -> - let message = match exn with - | Failure message -> message - | exn -> Printexc.to_string exn - in - (* This is a quick and dirty workaround to get Merlin to work even when - findlib directory has been removed. *) - begin match Sys.getenv "OCAMLFIND_CONF" with - | exception Not_found -> - Unix.putenv "OCAMLFIND_CONF" "/dev/null" - | _ -> () - end; - Error ("Error during findlib initialization: " ^ message) - -let {Logger. log} = Logger.for_section "Mconfig_dot" - -type file = { - recurse : bool; - includes : string list; - path : string; - directives : Merlin_dot_protocol.Directive.Raw.t list; -} - -module Cache = File_cache.Make (struct - type t = file - let read path = - let ic = open_in path in - let acc = ref [] in - let recurse = ref false in - let includes = ref [] in - let tell l = acc := l :: !acc in - try - let rec aux () = - let line = String.trim (input_line ic) in - if line = "" then () - - else if String.is_prefixed ~by:"B " line then - tell (`B (String.drop 2 line)) - else if String.is_prefixed ~by:"S " line then - tell (`S (String.drop 2 line)) - else if String.is_prefixed ~by:"SRC " line then - tell (`S (String.drop 4 line)) - else if String.is_prefixed ~by:"CMI " line then - tell (`CMI (String.drop 4 line)) - else if String.is_prefixed ~by:"CMT " line then - tell (`CMT (String.drop 4 line)) - else if String.is_prefixed ~by:"PKG " line then - tell (`PKG (rev_split_words (String.drop 4 line))) - else if String.is_prefixed ~by:"EXT " line then - tell (`EXT (rev_split_words (String.drop 4 line))) - else if String.is_prefixed ~by:"FLG " line then - tell (`FLG (Shell.split_command (String.drop 4 line))) - else if String.is_prefixed ~by:"REC" line then - recurse := true - else if String.is_prefixed ~by:". " line then - includes := String.trim (String.drop 2 line) :: !includes - else if String.is_prefixed ~by:"STDLIB " line then - tell (`STDLIB (String.drop 7 line)) - else if String.is_prefixed ~by:"FINDLIB " line then - tell (`FINDLIB (String.drop 8 line)) - else if String.is_prefixed ~by:"SUFFIX " line then - tell (`SUFFIX (String.drop 7 line)) - else if String.is_prefixed ~by:"READER " line then - tell (`READER (List.rev (rev_split_words (String.drop 7 line)))) - else if String.is_prefixed ~by:"FINDLIB_PATH " line then - tell (`FINDLIB_PATH (String.drop 13 line)) - else if String.is_prefixed ~by:"FINDLIB_TOOLCHAIN " line then - tell (`FINDLIB_TOOLCHAIN (String.drop 18 line)) - else if String.is_prefixed ~by:"EXCLUDE_QUERY_DIR" line then - tell `EXCLUDE_QUERY_DIR - else if String.is_prefixed ~by:"#" line then - () - else - tell (`UNKNOWN_TAG (String.split_on_char ~sep:' ' line |> List.hd)); - aux () - in - aux () - with - | End_of_file -> - close_in_noerr ic; - let recurse = !recurse and includes = !includes in - {recurse; includes; path; directives = List.rev !acc} - | exn -> - close_in_noerr ic; - raise exn - - let cache_name = "Mconfig_dot" - end) - -let find fname = - if Sys.file_exists fname && not (Sys.is_directory fname) then - Some fname - else - let rec loop dir = - let fname = Filename.concat dir ".merlin" in - if Sys.file_exists fname && not (Sys.is_directory fname) - then Some fname - else - let parent = Filename.dirname dir in - if parent <> dir - then loop parent - else None - in - loop fname - -let directives_of_files filenames = - let marked = Hashtbl.create 7 in - let rec process acc = function - | x :: rest when Hashtbl.mem marked x -> - process acc rest - | x :: rest -> - Hashtbl.add marked x (); - let file = Cache.read x in - let dir = Filename.dirname file.path in - let rest = - List.map ~f:(canonicalize_filename ~cwd:dir) file.includes @ rest - in - let rest = - if file.recurse then ( - let dir = - if Filename.basename file.path <> ".merlin" - then dir else Filename.dirname dir - in - if dir <> file.path then - match find dir with - | Some fname -> fname :: rest - | None -> rest - else rest - ) else rest - in - process (file :: acc) rest - | [] -> List.rev acc - in - process [] filenames - -let ppx_of_package ?(predicates=[]) setup pkg = - let d = Findlib.package_directory pkg in - (* Determine the 'ppx' property: *) - let in_words ~comma s = - (* splits s in words separated by commas and/or whitespace *) - let l = String.length s in - let rec split i j = - if j < l then - match s.[j] with - | (' '|'\t'|'\n'|'\r'|',' as c) when c <> ',' || comma -> - if i - split i (j+1) - else - if i None - and ppxopts = - try - List.map ~f:(fun opt -> - match in_words ~comma:true opt with - | pkg :: opts -> - pkg, List.map ~f:resolve_path opts - | _ -> assert false - ) (in_words ~comma:false - (Findlib.package_property predicates pkg "ppxopt")) - with Not_found -> [] - in - begin match ppx with - | None -> () - | Some ppx -> log ~title:"ppx" "%s" ppx - end; - begin match ppxopts with - | [] -> () - | lst -> - log ~title:"ppx options" "%a" Logger.json @@ fun () -> - let f (ppx,opts) = - `List [`String ppx; `List (List.map ~f:(fun s -> `String s) opts)] - in - `List (List.map ~f lst) - end; - let setup = match ppx with - | None -> setup - | Some ppx -> Ppxsetup.add_ppx ppx setup - in - List.fold_left ppxopts ~init:setup - ~f:(fun setup (ppx,opts) -> Ppxsetup.add_ppxopts ppx opts setup) - -let path_separator = - match Sys.os_type with - | "Cygwin" - | "Win32" -> ";" - | _ -> ":" - -let set_findlib_path = - let findlib_cache = ref ("",[],"") in - fun ?(conf="") ?(path=[]) ?(toolchain="") () -> - let key = (conf,path,toolchain) in - if key <> !findlib_cache then begin - let env_ocamlpath = match path with - | [] -> None - | path -> Some (String.concat ~sep:path_separator path) - and config = match conf with - | "" -> None - | s -> Some s - and toolchain = match toolchain with - | "" -> None - | s -> Some s - in - log ~title:"set_findlib_path" "findlib_conf = %s; findlib_path = %s\n" - conf (String.concat ~sep:path_separator path); - Findlib.init ?env_ocamlpath ?config ?toolchain (); - findlib_cache := key - end - -let standard_library = - set_findlib_path (); - Findlib.ocaml_stdlib () - -let is_package_optional name = - let last = String.length name - 1 in - last >= 0 && name.[last] = '?' - -let remove_option name = - let last = String.length name - 1 in - if last >= 0 && name.[last] = '?' then - String.sub name ~pos:0 ~len:last - else - name - -let path_of_packages ?conf ?path ?toolchain packages = - set_findlib_path ?conf ?path ?toolchain (); - let recorded_packages, invalid_packages = - List.partition packages - ~f:(fun name -> - match Findlib.package_directory (remove_option name) with - | _ -> true - | exception _ -> false) - in - let failures = - match - List.filter_map invalid_packages ~f:(fun pkg -> - if is_package_optional pkg then ( - log ~title:"path_of_packages" "Uninstalled package %S" pkg; - None - ) else - Some pkg - ) - with - | [] -> [] - | xs -> ["Failed to load packages: " ^ String.concat ~sep:"," xs] - in - let recorded_packages = List.map ~f:remove_option recorded_packages in - let packages, failures = - match Findlib.package_deep_ancestors [] recorded_packages with - | packages -> packages, failures - | exception exn -> - [], (sprintf "Findlib failure: %S" (Printexc.to_string exn) :: failures) - in - let packages = List.filter_dup packages in - let path = List.map ~f:Findlib.package_directory packages in - let ppxs = List.fold_left ~f:ppx_of_package packages ~init:Ppxsetup.empty in - path, ppxs, failures - -type config = { - pass_forward : Merlin_dot_protocol.Directive.no_processing_required list; - to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list; - stdlib : string option; - packages_to_load : string list; - findlib : string option; - findlib_path : string list; - findlib_toolchain : string option; -} - -let empty_config = { - pass_forward = []; - to_canonicalize = []; - stdlib = None; - packages_to_load = []; - findlib = None; - findlib_path = []; - findlib_toolchain = None; -} - -let prepend_config ~cwd ~cfg = - List.fold_left ~init:cfg ~f:(fun cfg (d : Merlin_dot_protocol.Directive.Raw.t) -> - match d with - | `B _ | `S _ | `CMI _ | `CMT _ as directive -> - { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } - | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ - | (`EXCLUDE_QUERY_DIR | `UNKNOWN_TAG _) as directive -> - { cfg with pass_forward = directive :: cfg.pass_forward } - | `PKG ps -> - { cfg with packages_to_load = ps @ cfg.packages_to_load } - | `STDLIB path -> - let canon_path = canonicalize_filename ~cwd path in - begin match cfg.stdlib with - | None -> () - | Some p -> - log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path - end; - { cfg with stdlib = Some canon_path } - | `FINDLIB path -> - let canon_path = canonicalize_filename ~cwd path in - begin match cfg.stdlib with - | None -> () - | Some p -> - log ~title:"conflicting paths for findlib" "%s\n%s" p canon_path - end; - { cfg with findlib = Some canon_path} - | `FINDLIB_PATH path -> - let canon_path = canonicalize_filename ~cwd path in - { cfg with findlib_path = canon_path :: cfg.findlib_path } - | `FINDLIB_TOOLCHAIN path -> - begin match cfg.stdlib with - | None -> () - | Some p -> - log ~title:"conflicting paths for findlib toolchain" "%s\n%s" p path - end; - { cfg with findlib_toolchain = Some path} - ) - -let process_one ~cfg {path;directives; _ } = - let cwd = Filename.dirname path in - prepend_config ~cwd ~cfg (List.rev directives) - -let expand = - let filter path = - let name = Filename.basename path in - name <> "" && name.[0] <> '.' && - try Sys.is_directory path - with _ -> false - in - fun ~stdlib dir path -> - let path = expand_directory stdlib path in - let path = canonicalize_filename ~cwd:dir path in - expand_glob ~filter path [] - -module Import_from_dune = struct - let escape_only c s = - let open String in - let n = ref 0 in - let len = length s in - for i = 0 to len - 1 do - if unsafe_get s i = c then incr n - done; - if !n = 0 then - s - else - let b = Bytes.create (len + !n) in - n := 0; - for i = 0 to len - 1 do - if unsafe_get s i = c then ( - Bytes.unsafe_set b !n '\\'; - incr n - ); - Bytes.unsafe_set b !n (unsafe_get s i); - incr n - done; - Bytes.unsafe_to_string b - - let need_quoting s = - let len = String.length s in - len = 0 - || - let rec loop i = - if i = len then - false - else - match s.[i] with - | ' ' - | '\"' - | '(' - | ')' - | '{' - | '}' - | ';' - | '#' -> - true - | _ -> loop (i + 1) - in - loop 0 - - let quote s = - let s = - if Sys.win32 then - (* We need this hack because merlin unescapes backslashes (except when - protected by single quotes). It is only a problem on windows because - Filename.quote is using double quotes. *) - escape_only '\\' s - else - s - in - if need_quoting s then - Filename.quote s - else - s -end - -let postprocess cfg = - let stdlib = Option.value ~default:standard_library cfg.stdlib in - let pkg_paths, ppxsetup, failures = path_of_packages cfg.packages_to_load in - let ppx = - match Ppxsetup.command_line ppxsetup with - | [] -> [] - | lst -> - let cmd = List.concat_map lst ~f:(fun pp -> ["-ppx"; pp]) - in - [ `FLG cmd] - in - List.concat - [ List.concat_map cfg.to_canonicalize ~f:(fun (dir, directive) -> - let dirs = - match directive with - | `B path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `B p) - | `S path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `S p) - | `CMI path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMI p) - | `CMT path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMT p) - in - (dirs :> Merlin_dot_protocol.directive list) - ) - ; (cfg.pass_forward :> Merlin_dot_protocol.directive list) - ; List.concat_map pkg_paths ~f:(fun p -> [ `B p; `S p ]) - ; ppx - ; List.map failures ~f:(fun s -> `ERROR_MSG s) - ] - -let load dot_merlin_file = - let directives = directives_of_files [ dot_merlin_file ] in - let cfg = - List.fold_left directives ~init:empty_config - ~f:(fun cfg file -> process_one ~cfg file) - in - let directives = postprocess cfg in - match cfg.packages_to_load, findlib_ok with - | [], _ | _, Ok _ -> directives - | _, Error msg -> (`ERROR_MSG msg) :: directives - -let dot_merlin_file = Filename.concat (Sys.getcwd ()) ".merlin" - -let rec main () = - match Merlin_dot_protocol.Commands.read_input stdin with - | Halt -> exit 0 - | File _path -> - let directives = load dot_merlin_file in - Merlin_dot_protocol.write ~out_channel:stdout directives; - flush stdout; - main () - | Unknown -> main () - -let () = main () diff --git a/ocaml-lsp-server/vendor/merlin/src/dot-merlin/dune b/ocaml-lsp-server/vendor/merlin/src/dot-merlin/dune deleted file mode 100644 index 992e3041c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/dot-merlin/dune +++ /dev/null @@ -1,5 +0,0 @@ -(executable - (package dot-merlin-reader) - (name dot_merlin_reader) - (public_name dot-merlin-reader) - (libraries findlib merlin-lib.utils merlin-lib.dot_protocol str unix)) diff --git a/ocaml-lsp-server/vendor/merlin/src/dot-protocol/dune b/ocaml-lsp-server/vendor/merlin/src/dot-protocol/dune deleted file mode 100644 index c40ec9e41..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/dot-protocol/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name merlin_dot_protocol) - (public_name merlin-lib.dot_protocol) - (libraries merlin_utils csexp)) diff --git a/ocaml-lsp-server/vendor/merlin/src/dot-protocol/merlin_dot_protocol.ml b/ocaml-lsp-server/vendor/merlin/src/dot-protocol/merlin_dot_protocol.ml deleted file mode 100644 index e14abe3f8..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/dot-protocol/merlin_dot_protocol.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2019 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Merlin_utils.Std -open Merlin_utils.Std.Result - -module Directive = struct - type include_path = - [ `B of string | `S of string | `CMI of string | `CMT of string ] - - type no_processing_required = - [ `EXT of string list - | `FLG of string list - | `STDLIB of string - | `SUFFIX of string - | `READER of string list - | `EXCLUDE_QUERY_DIR - | `UNKNOWN_TAG of string ] - - module Processed = struct - type acceptable_in_input = [ include_path | no_processing_required ] - - type t = - [ acceptable_in_input - | `ERROR_MSG of string ] - end - - module Raw = struct - type t = - [ Processed.acceptable_in_input - | `PKG of string list - | `FINDLIB of string - | `FINDLIB_PATH of string - | `FINDLIB_TOOLCHAIN of string ] - end -end - -type directive = Directive.Processed.t - -module Sexp = struct - type t = Csexp.t = Atom of string | List of t list - - let atoms_of_strings = List.map ~f:(fun s -> Atom s) - - let strings_of_atoms = - List.filter_map ~f:(function Atom s -> Some s | _ -> None) - - let rec to_string = function - | Atom s -> s - | List l -> String.concat ~sep:" " - ( List.concat [["("]; List.map ~f:to_string l;[")"]]) - - let to_directive sexp = - match sexp with - | List [ Atom tag; Atom value ] -> - begin match tag with - | "S" -> `S value - | "B" -> `B value - | "CMI" -> `CMI value - | "CMT" -> `CMT value - | "STDLIB" -> `STDLIB value - | "SUFFIX" -> `SUFFIX value - | "ERROR" -> `ERROR_MSG value - | "FLG" -> - (* This means merlin asked dune 2.6 for configuration. - But the protocole evolved, only dune 2.8 should be used *) - `ERROR_MSG "No .merlin file found. Try building the project." - | tag -> `UNKNOWN_TAG tag - end - | List [ Atom tag; List l ] -> - let value = strings_of_atoms l in - begin match tag with - | "EXT" -> `EXT value - | "FLG" -> `FLG value - | "READER" -> `READER value - | tag -> `UNKNOWN_TAG tag - end - | List [ Atom "EXCLUDE_QUERY_DIR" ] -> `EXCLUDE_QUERY_DIR - | _ -> `ERROR_MSG "Unexpected output from external config reader" - - let from_directives (directives : Directive.Processed.t list) = - let f t = - let tag, body = - let single s = [ Atom s ] in - match t with - | `B s -> ("B", single s) - | `S s -> ("S", single s) - | `CMI s -> ("CMI", single s) - | `CMT s -> ("CMT", single s) - | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ]) - | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ]) - | `STDLIB s -> ("STDLIB", single s) - | `SUFFIX s -> ("SUFFIX", single s) - | `READER ss -> ("READER", [ List (atoms_of_strings ss) ]) - | `EXCLUDE_QUERY_DIR -> ("EXCLUDE_QUERY_DIR", []) - | `UNKNOWN_TAG tag -> ("ERROR", single @@ - Printf.sprintf "Unknown tag in .merlin: %s" tag) - | `ERROR_MSG s -> ("ERROR", single s) - in - List (Atom tag :: body) - in - List (List.map ~f directives) -end - -module Commands = struct - type t = File of string | Halt | Unknown - - let read_input in_channel = - let open Sexp in - match Csexp.input in_channel with - | Ok (List [Atom "File"; Atom path]) -> File path - | Ok (Atom "Halt") -> Halt - | Ok _ -> Unknown - | Error _msg -> Halt - - let send_file ~out_channel path = - Sexp.(List [Atom "File"; Atom path]) - |> Csexp.to_channel out_channel -end - -type read_error = - | Unexpected_output of string - | Csexp_parse_error of string - -let read ~in_channel = - match Csexp.input in_channel with - | Ok (Sexp.List directives) -> - Ok (List.map directives ~f:Sexp.to_directive) - | Ok sexp -> - let msg = Printf.sprintf - "A list of directives was expected, instead got: \"%s\"" - (Sexp.to_string sexp) - in - Error (Unexpected_output msg) - | Error msg -> Error (Csexp_parse_error msg) - -let write ~out_channel (directives : directive list) = - directives |> Sexp.from_directives |> Csexp.to_channel out_channel - -module Make (IO : sig - type 'a t - - module O : sig - val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t - end -end) (Chan : sig - type t - - val read : t -> Csexp.t option IO.t - - val write : t -> Csexp.t -> unit IO.t -end) = struct - let read chan = - let open IO.O in - let+ res = Chan.read chan in - match res with - | None -> - Error (Unexpected_output "Eof") - | Some (Sexp.List directives) -> - Ok (List.map directives ~f:Sexp.to_directive) - | Some sexp -> - let msg = Printf.sprintf - "A list of directives was expected, instead got: \"%s\"" - (Sexp.to_string sexp) - in - Error (Unexpected_output msg) - - module Commands = struct - let send_file chan path = - Chan.write chan Sexp.(List [Atom "File"; Atom path]) - - let halt chan = - Chan.write chan (Sexp.Atom "Halt") - end -end diff --git a/ocaml-lsp-server/vendor/merlin/src/dot-protocol/merlin_dot_protocol.mli b/ocaml-lsp-server/vendor/merlin/src/dot-protocol/merlin_dot_protocol.mli deleted file mode 100644 index e66dcf3f2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/dot-protocol/merlin_dot_protocol.mli +++ /dev/null @@ -1,114 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2019 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -(* EXCLUDE_QUERY_DIR - -If you're building with dune, all your build artifacts will be in -_build, any .cmi (or .cmt) that will be found next to the source file -is likely to be a source of conflicts. -With this directive, .merlin files generated by dune can instruct merlin -to disregard local build artifacts. - -This is especially useful when working on the compiler where two build -system coexist: dune (used for development, which will generate the -.merlin) and make, used for the actual build and testing of the compiler. -Build artifacts generated by the makefile build will be at a different -version than the one produced by dune, and understood by merlin. We -really do not want to load them. *) - -module Directive : sig - type include_path = - [ `B of string | `S of string | `CMI of string | `CMT of string ] - - type no_processing_required = - [ `EXT of string list - | `FLG of string list - | `STDLIB of string - | `SUFFIX of string - | `READER of string list - | `EXCLUDE_QUERY_DIR - | `UNKNOWN_TAG of string ] - - module Processed : sig - type acceptable_in_input = [ include_path | no_processing_required ] - - type t = - [ acceptable_in_input - | `ERROR_MSG of string ] - end - - module Raw : sig - type t = - [ Processed.acceptable_in_input - | `PKG of string list - | `FINDLIB of string - | `FINDLIB_PATH of string - | `FINDLIB_TOOLCHAIN of string ] - end -end - -type directive = Directive.Processed.t - -module Commands : sig - type t = File of string | Halt | Unknown - - val read_input : in_channel -> t - val send_file : out_channel:out_channel -> string -> unit -end - -type read_error = - | Unexpected_output of string - | Csexp_parse_error of string - -(** [read inc] reads one csexp from the channel [inc] and returns the list of - directives it represents *) -val read : in_channel:in_channel -> (directive list, read_error) Merlin_utils.Std.Result.t - -val write : out_channel:out_channel -> directive list -> unit - -module Make (IO : sig - type 'a t - - module O : sig - val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t - end -end) (Chan : sig - type t - - val read : t -> Csexp.t option IO.t - - val write : t -> Csexp.t -> unit IO.t -end) : sig - val read : Chan.t -> (directive list, read_error) Merlin_utils.Std.Result.t IO.t - - module Commands : sig - val send_file : Chan.t -> string -> unit IO.t - - val halt : Chan.t -> unit IO.t - end -end diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/.gitignore b/ocaml-lsp-server/vendor/merlin/src/extend/.gitignore deleted file mode 100644 index f7817ae5c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -*.annot -*.cmo -*.cma -*.cmi -*.a -*.o -*.cmx -*.cmxs -*.cmxa - -# ocamlbuild working directory -_build/ - -# ocamlbuild targets -*.byte -*.native - -# oasis generated files -setup.data -setup.log diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/dune b/ocaml-lsp-server/vendor/merlin/src/extend/dune deleted file mode 100644 index 8d5b797a2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name merlin_extend) - (public_name merlin-lib.extend) - (modules (:standard \ extend_helper)) - (flags :standard -open Ocaml_utils -open Ocaml_parsing -open Ocaml_typing) - (libraries ocaml_parsing ocaml_typing unix ocaml_utils)) diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_driver.ml b/ocaml-lsp-server/vendor/merlin/src/extend/extend_driver.ml deleted file mode 100644 index 076621a41..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_driver.ml +++ /dev/null @@ -1,66 +0,0 @@ -module P = Extend_protocol - -(** Helper for the driver (Merlin) *) - -type t = { - name: string; - capabilities: P.capabilities; - stdin: out_channel; - stdout: in_channel; - mutable pid: int; - - notify: string -> unit; - debug: string -> unit; -} - -exception Extension of string * string * string - -let run ?(notify=ignore) ?(debug=ignore) name = - let pstdin, stdin = Unix.pipe () in - let stdout, pstdout = Unix.pipe () in - Unix.set_close_on_exec pstdin; - Unix.set_close_on_exec stdin; - Unix.set_close_on_exec pstdout; - Unix.set_close_on_exec stdout; - let pid = - Unix.create_process - ("ocamlmerlin-" ^ name) [||] - pstdin pstdout Unix.stderr - in - Unix.close pstdout; - Unix.close pstdin; - let stdin = Unix.out_channel_of_descr stdin in - let stdout = Unix.in_channel_of_descr stdout in - match Extend_main.Handshake.negotiate_driver name stdout stdin with - | capabilities -> {name; capabilities; stdin; stdout; pid; notify; debug} - | exception exn -> - close_out_noerr stdin; - close_in_noerr stdout; - raise exn - -let stop t = - close_out_noerr t.stdin; - close_in_noerr t.stdout; - if t.pid <> -1 then ( - let _, _ = Unix.waitpid [] t.pid in - t.pid <- -1; - ) - -let capabilities t = t.capabilities - -let reader t request = - if t.pid = -1 then - invalid_arg "Extend_main.Driver.reader: extension is closed"; - output_value t.stdin (P.Reader_request request); - flush t.stdin; - let rec aux () = - match input_value t.stdout with - | P.Notify str -> t.notify str; aux () - | P.Debug str -> t.debug str; aux () - | P.Exception (kind, msg) -> - stop t; - raise (Extension (t.name, kind, msg)) - | P.Reader_response response -> - response - in - aux () diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_driver.mli b/ocaml-lsp-server/vendor/merlin/src/extend/extend_driver.mli deleted file mode 100644 index baf7f6ed4..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_driver.mli +++ /dev/null @@ -1,16 +0,0 @@ -(** Helper for the driver (Merlin) *) -open Extend_protocol - -type t - -exception Extension of string * string * string - -val run : ?notify:(string -> unit) -> ?debug:(string -> unit) -> string -> t - -val stop : t -> unit - -val capabilities : t -> capabilities - -val reader : t -> - Reader.request -> - Reader.response diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_helper.ml b/ocaml-lsp-server/vendor/merlin/src/extend/extend_helper.ml deleted file mode 100644 index 8aedb35cd..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_helper.ml +++ /dev/null @@ -1,102 +0,0 @@ -open Parsetree - -(** Generate an extension node that will be reported as a syntax error by - Merlin. *) -let syntax_error msg loc : extension = - let str = Location.mkloc "merlin.syntax-error" loc in - let payload = PStr [{ - pstr_loc = Location.none; - pstr_desc = Pstr_eval ( - Ast_helper.(Exp.constant (const_string msg)), [] - ); - }] - in - (str, payload) -;; - - -(** Physical locations might be too precise for some features. - - For instance in: - let x = f in y - ^1 ^2 - - Merlin cannot distinguish position ^1 from ^2 in the normal AST, - because IN doesn't appear in abstract syntax. This is a problem when - completing, because a different environment should be selected for both - positions. - - One can add relaxed_location attributes to make some locations closer to - the concrete syntax. - - Here is the same line annotated with physical and relaxed locations: - let x = f in y - [ ] [ ] -- physical locations for f and y nodes - [ ][ ] -- relaxed locations for f and y nodes -*) -let relaxed_location loc : attribute = - let str = Location.mkloc "merlin.relaxed-location" loc in - Ast_helper.Attr.mk str (PStr []) -;; - - -(** If some code should be ignored by merlin when reporting information to - the user, put a hide_node attribute. - - This is useful for generated/desugared code which doesn't correspond to - anything in concrete syntax (example use-case: encoding of some - js_of_ocaml constructs). -*) -let hide_node : attribute = - Ast_helper.Attr.mk (Location.mknoloc "merlin.hide") (PStr []) - -(** The converse: when merlin should focus on a specific node of the AST. - The main use case is also for js_of_ocaml. - - Assuming is translated to: - - let module M = struct - let prolog = ... (* boilerplate *) - - let code = - - let epilog = ... (* boilerplate *) - end - in M.boilerplate - - To make merlin focus on [M.code] and ignore the boilerplate ([M.prolog] - and [M.epilog]), add a [focus_node] attribute to the [M.code] item. -*) -let focus_node : attribute = - Ast_helper.Attr.mk (Location.mknoloc "merlin.focus") (PStr []) - -(* Projections for merlin attributes and extensions *) - -let classify_extension (id, _ : extension) : [`Other | `Syntax_error] = - match id.Location.txt with - | "merlin.syntax-error" -> `Syntax_error - | _ -> `Other - -let classify_attribute attr : [`Other | `Relaxed_location | `Hide | `Focus] = - let id, _ = Ast_helper.Attr.as_tuple attr in - match id.Location.txt with - | "merlin.relaxed-location" -> `Relaxed_location - | "merlin.hide" -> `Hide - | "merlin.focus" -> `Focus - | _ -> `Other - -let extract_syntax_error (id, payload : extension) : string * Location.t = - if id.Location.txt <> "merlin.syntax-error" then - invalid_arg "Merlin_extend.Reader_helper.extract_syntax_error"; - let invalid_msg = - "Warning: extension produced an incorrect syntax-error node" in - let msg = match Ast_helper.extract_str_payload payload with - | Some (msg, _loc) -> msg - | None -> invalid_msg - in - msg, id.Location.loc - -let extract_relaxed_location attr : Location.t = - match Ast_helper.Attr.as_tuple attr with - | ({Location. txt = "merlin.relaxed-location"; loc} , _) -> loc - | _ -> invalid_arg "Merlin_extend.Reader_helper.extract_relaxed_location" diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_helper.mli b/ocaml-lsp-server/vendor/merlin/src/extend/extend_helper.mli deleted file mode 100644 index 3488b4f58..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_helper.mli +++ /dev/null @@ -1,66 +0,0 @@ -open Parsetree - -(** Generate an extension node that will be reported as a syntax error by - Merlin. *) -val syntax_error : string -> Location.t -> extension - -(** Physical locations might be too precise for some features. - - For instance in: - let x = f in y - ^1 ^2 - - Merlin cannot distinguish position ^1 from ^2 in the normal AST, - because IN doesn't appear in abstract syntax. This is a problem when - completing, because a different environment should be selected for both - positions. - - One can add relaxed_location attributes to make some locations closer to - the concrete syntax. - - Here is the same line annotated with physical and relaxed locations: - let x = f in y - [ ] [ ] -- physical locations for f and y nodes - [ ][ ] -- relaxed locations for f and y nodes -*) -val relaxed_location : Location.t -> attribute - -(** If some code should be ignored by merlin when reporting information to - the user, put a hide_node attribute. - - This is useful for generated/desugared code which doesn't correspond to - anything in concrete syntax (example use-case: encoding of some - js_of_ocaml constructs). -*) -val hide_node : attribute - -(** The converse: when merlin should focus on a specific node of the AST. - The main use case is also for js_of_ocaml. - - Assuming is translated to: - - let module M = struct - let prolog = ... (* boilerplate *) - - let code = - - let epilog = ... (* boilerplate *) - end - in M.boilerplate - - To make merlin focus on [M.code] and ignore the boilerplate ([M.prolog] - and [M.epilog]), add a [focus_node] attribute to the [M.code] item. -*) -val focus_node : attribute - -(* Projections for merlin attributes and extensions *) - -val classify_extension : extension -> - [`Other | `Syntax_error] - -val extract_syntax_error : extension -> string * Location.t - -val classify_attribute : attribute -> - [`Other | `Relaxed_location | `Hide | `Focus] - -val extract_relaxed_location : attribute -> Location.t diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_main.ml b/ocaml-lsp-server/vendor/merlin/src/extend/extend_main.ml deleted file mode 100644 index d7363d674..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_main.ml +++ /dev/null @@ -1,186 +0,0 @@ -module P = Extend_protocol -module R = P.Reader - -module Description = struct - type t = P.description - - let make_v0 ~name ~version = { P. name; version } -end - -module Reader = struct - type t = (module R.V0) - let make_v0 (x : (module R.V0)) : t = x - - module Make (V : R.V0) = struct - - open P.Reader - - let buffer = ref None - - let get_buffer () = - match !buffer with - | None -> invalid_arg "No buffer loaded" - | Some buffer -> buffer - - let exec = function - | Req_load buf -> - buffer := Some (V.load buf); - Res_loaded - | Req_parse -> - Res_parse (V.parse (get_buffer ())) - | Req_parse_line (pos, str) -> - Res_parse (V.parse_line (get_buffer ()) pos str) - | Req_parse_for_completion pos -> - let info, tree = V.for_completion (get_buffer ()) pos in - Res_parse_for_completion (info, tree) - | Req_get_ident_at pos -> - Res_get_ident_at (V.ident_at (get_buffer ()) pos) - | Req_print_outcome trees -> - let print t = - V.print_outcome Format.str_formatter t; - Format.flush_str_formatter () - in - let trees = List.rev_map print trees in - Res_print_outcome (List.rev trees) - | Req_pretty_print p -> - V.pretty_print Format.str_formatter p; - Res_pretty_print (Format.flush_str_formatter ()) - - end -end - -module Utils = struct - - (* Postpone messages until ready *) - let send, set_ready = - let is_ready = ref false in - let postponed = ref [] in - let really_send msg = output_value stdout msg in - let set_ready () = - is_ready := true; - let postponed' = List.rev !postponed in - postponed := []; - List.iter really_send postponed' - in - let send msg = - if !is_ready then - really_send msg - else - postponed := msg :: !postponed - in - send, set_ready - - let notify msg = send (P.Notify msg) - let debug msg = send (P.Debug msg) -end - -module Handshake = struct - let magic_number : string = "MERLINEXTEND002" - - type versions = { - ast_impl_magic_number : string; - ast_intf_magic_number : string; - cmi_magic_number : string; - cmt_magic_number : string; - } - - let versions = Config.({ - ast_impl_magic_number; - ast_intf_magic_number; - cmi_magic_number; - cmt_magic_number; - }) - - let negotiate (capabilities : P.capabilities) = - output_string stdout magic_number; - output_value stdout versions; - output_value stdout capabilities; - flush stdout; - Utils.set_ready (); - match input_value stdin with - | exception End_of_file -> exit 0 - | P.Start_communication -> () - | _ -> - prerr_endline "Unexpected value after handshake."; - exit 1 - - exception Error of string - - let () = - Printexc.register_printer (function - | Error msg -> - Some (Printf.sprintf "Extend_main.Handshake.Error %S" msg) - | _ -> None - ) - - let negotiate_driver ext_name i o = - let magic' = really_input_string i (String.length magic_number) in - if magic' <> magic_number then ( - let msg = Printf.sprintf - "Extension %s has incompatible protocol version %S (expected %S)" - ext_name magic' magic_number - in - raise (Error msg) - ); - let versions' : versions = input_value i in - let check_v prj name = - if prj versions <> prj versions' then - let msg = Printf.sprintf - "Extension %s %s has incompatible version %S (expected %S)" - ext_name name (prj versions') (prj versions) - in - raise (Error msg) - in - check_v (fun x -> x.ast_impl_magic_number) "implementation AST"; - check_v (fun x -> x.ast_intf_magic_number) "interface AST"; - check_v (fun x -> x.cmi_magic_number) "compiled interface (CMI)"; - check_v (fun x -> x.cmt_magic_number) "typedtree (CMT)"; - output_value o P.Start_communication; - flush o; - let capabilities : P.capabilities = - input_value i - in - capabilities -end - -(** The main entry point of an extension. *) -let extension_main ?reader desc = - (* Check if invoked from Merlin *) - begin match Sys.getenv "__MERLIN_MASTER_PID" with - | exception Not_found -> - Printf.eprintf "This is %s merlin extension, version %s.\n\ - This binary should be invoked from merlin and \ - cannot be used directly.\n%!" - desc.P.name - desc.P.version; - exit 1; - | _ -> () - end; - (* Communication happens on stdin/stdout. *) - Handshake.negotiate {P. reader = reader <> None}; - let reader = match reader with - | None -> (fun _ -> failwith "No reader") - | Some (module R : R.V0) -> - let module M = Reader.Make(R) in - M.exec - in - let respond f = - match f () with - | (r : P.response) -> Utils.send r - | exception exn -> - let name = Printexc.exn_slot_name exn in - let desc = Printexc.to_string exn in - Utils.send (P.Exception (name, desc)) - in - let rec loop () = - flush stdout; - match input_value stdin with - | exception End_of_file -> exit 0 - | P.Start_communication -> - prerr_endline "Unexpected message."; - exit 2 - | P.Reader_request request -> - respond (fun () -> P.Reader_response (reader request)); - loop () - in - loop () diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_main.mli b/ocaml-lsp-server/vendor/merlin/src/extend/extend_main.mli deleted file mode 100644 index 05020198c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_main.mli +++ /dev/null @@ -1,36 +0,0 @@ -open Extend_protocol - -module Description : sig - type t - val make_v0 : name:string -> version:string -> t -end - -module Utils : sig - val notify : string -> unit - val debug : string -> unit -end - -module Reader : sig - type t - val make_v0 : (module Reader.V0) -> t -end - -module Handshake : sig - val magic_number : string - - type versions = { - ast_impl_magic_number : string; - ast_intf_magic_number : string; - cmi_magic_number : string; - cmt_magic_number : string; - } - - exception Error of string - - val versions : versions - - val negotiate_driver : string -> in_channel -> out_channel -> capabilities -end - -(** The main entry point of an extension. *) -val extension_main : ?reader:Reader.t -> Description.t -> 'a diff --git a/ocaml-lsp-server/vendor/merlin/src/extend/extend_protocol.ml b/ocaml-lsp-server/vendor/merlin/src/extend/extend_protocol.ml deleted file mode 100644 index b7c522dc3..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/extend/extend_protocol.ml +++ /dev/null @@ -1,152 +0,0 @@ -module Reader = struct - - (** Description of a buffer managed by Merlin *) - type buffer = { - - path : string; - (** Path of the buffer in the editor. - The path is absolute if it is backed by a file, although it might not yet - have been saved in the editor. - The path is relative if it is a temporary buffer. *) - - flags : string list; - (** Any flag that has been passed to the reader in .merlin file *) - - text : string; - (** Content of the buffer *) - } - - (** ASTs exchanged with Merlin *) - type parsetree = - - | Structure of Parsetree.structure - (** An implementation, usually coming from a .ml file *) - - | Signature of Parsetree.signature - (** An interface, usually coming from a .mli file *) - - (** Printing in error messages or completion items *) - type outcometree = - | Out_value of Outcometree.out_value - | Out_type of Outcometree.out_type - | Out_class_type of Outcometree.out_class_type - | Out_module_type of Outcometree.out_module_type - | Out_sig_item of Outcometree.out_sig_item - | Out_signature of Outcometree.out_sig_item list - | Out_type_extension of Outcometree.out_type_extension - | Out_phrase of Outcometree.out_phrase - - (** Printing in case destruction *) - type pretty_parsetree = - | Pretty_toplevel_phrase of Parsetree.toplevel_phrase - | Pretty_expression of Parsetree.expression - | Pretty_core_type of Parsetree.core_type - | Pretty_pattern of Parsetree.pattern - | Pretty_signature of Parsetree.signature - | Pretty_structure of Parsetree.structure - | Pretty_case_list of Parsetree.case list - - (** Additional information useful for guiding completion *) - type complete_info = { - complete_labels : bool; - (** True if it is appropriate to suggest labels for this completion. *) - } - - module type V0 = sig - (** Internal representation of a buffer for the extension. - Extension should avoid global state, cached information should be stored - in values of this type. *) - type t - - (** Turns a merlin-buffer into an internal buffer. - - This function should be total, an exception at this point is a - fatal-error. - - Simplest implementation is identity, with type t = buffer. - *) - val load : buffer -> t - - (** Get the main parsetree from the buffer. - This should return the AST corresponding to [buffer.source]. - *) - val parse : t -> parsetree - - (** Give the opportunity to optimize the parsetree when completing from a - specific position. - - The simplest implementation is: - - let for_completion t _ = ({complete_labels = true}, (tree t)) - - But it might be worthwhile to specialize the parsetree for a better - completion. - *) - val for_completion : t -> Lexing.position -> complete_info * parsetree - - (** Parse a separate user-input in the context of this buffer. - Used when the user manually enters an expression and ask for its type or location. - *) - val parse_line : t -> Lexing.position -> string -> parsetree - - (** Given a buffer and a position, return the components of the identifier - (actually the qualified path) under the cursor. - - This should return the raw identifier names -- operators should not be - surrounded by parentheses. - - An empty list is a valid result if no identifiers are under the cursor. - *) - val ident_at : t -> Lexing.position -> string Location.loc list - - (** Opposite direction: pretty-print a tree. - This works on outcometree and is used for displaying answers to queries. - (type errors, signatures of modules in environment, completion candidates, etc). - *) - val print_outcome : Format.formatter -> outcometree -> unit - - (* This one works on parsetree and is used for case destruction - (merlin-destruct) *) - val pretty_print : Format.formatter -> pretty_parsetree -> unit - end - - type request = - | Req_load of buffer - | Req_parse - | Req_parse_line of Lexing.position * string - | Req_parse_for_completion of Lexing.position - | Req_get_ident_at of Lexing.position - | Req_print_outcome of outcometree list - | Req_pretty_print of pretty_parsetree - - type response = - | Res_loaded - | Res_parse of parsetree - | Res_parse_for_completion of complete_info * parsetree - | Res_get_ident_at of string Location.loc list - | Res_print_outcome of string list - | Res_pretty_print of string - -end - -(* Name of the extension *) -type description = { - name : string; - version : string; -} - -(* Services an extension can provide *) -type capabilities = { - reader: bool; -} - -(* Main protocol *) -type request = - | Start_communication - | Reader_request of Reader.request - -type response = - | Notify of string - | Debug of string - | Exception of string * string - | Reader_response of Reader.response diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/dune b/ocaml-lsp-server/vendor/merlin/src/frontend/dune deleted file mode 100644 index 92776fa4f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/dune +++ /dev/null @@ -1,32 +0,0 @@ -(library - (name query_protocol) - (public_name merlin-lib.query_protocol) - (modules query_protocol) - (flags :standard -open Merlin_utils -open Merlin_kernel -open Ocaml_parsing -open Merlin_kernel) - (libraries merlin_kernel merlin_utils ocaml_parsing)) - -(library - (name query_commands) - (public_name merlin-lib.query_commands) - (modules query_commands) - (flags - :standard - -open Ocaml_utils - -open Ocaml_parsing - -open Ocaml_typing - -open Merlin_kernel - -open Merlin_specific - -open Merlin_utils - -open Merlin_specific - -open Merlin_analysis - -open Merlin_kernel) - (libraries - merlin_utils - merlin_kernel - ocaml_utils - ocaml_parsing - ocaml_typing - merlin_specific - merlin_config - merlin_analysis - query_protocol)) diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/dune b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/dune deleted file mode 100644 index e8ab3eccd..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/dune +++ /dev/null @@ -1,40 +0,0 @@ -(include_subdirs unqualified) - -(executable - (name ocamlmerlin_server) - (package merlin) - (public_name ocamlmerlin-server) - (flags - :standard - -open Ocaml_utils - -open Ocaml_parsing - -open Ocaml_typing - -open Merlin_kernel - -open Merlin_utils - -open Merlin_analysis - -open Merlin_kernel) - (modules (:standard \ gen_ccflags)) - (libraries merlin-lib.config yojson merlin-lib.analysis merlin-lib.kernel - merlin-lib.utils merlin-lib.os_ipc merlin-lib.ocaml_parsing - merlin-lib.query_protocol merlin-lib.query_commands - merlin-lib.ocaml_typing merlin-lib.ocaml_utils)) - -(executable - (name gen_ccflags) - (modules gen_ccflags) - (libraries str)) - -(rule - (targets pre-flags post-flags) - (deps gen_ccflags.exe) - (action (run %{deps} "%{ocaml-config:ccomp_type}" %{targets}))) - -(rule - (targets ocamlmerlin.exe) - (deps (:c ocamlmerlin.c) pre-flags post-flags) - (action (run %{cc} "%{read-lines:pre-flags}%{targets}" %{c} %{read-lines:post-flags}))) - -(install - (package merlin) - (section bin) - (files (ocamlmerlin.exe as ocamlmerlin))) diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/gen_ccflags.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/gen_ccflags.ml deleted file mode 100644 index 509525840..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/gen_ccflags.ml +++ /dev/null @@ -1,18 +0,0 @@ -let ccomp_type = Sys.argv.(1) -let pre_flags_f = Sys.argv.(2) -let post_flags_f = Sys.argv.(3) - -let pre_flags, post_flags = - if Str.string_match (Str.regexp "msvc") ccomp_type 0 then - "/Fe", "advapi32.lib" - else - "-o", "" - -let write_lines f s = - let oc = open_out f in - output_string oc s; - close_out oc - -let () = - write_lines pre_flags_f pre_flags; - write_lines post_flags_f post_flags diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/log_info.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/log_info.ml deleted file mode 100644 index 94e5923b2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/log_info.ml +++ /dev/null @@ -1,8 +0,0 @@ -let get () = - let log_file, sections = - match String.split_on_char ',' (Sys.getenv "MERLIN_LOG") with - | (value :: sections) -> (Some value, sections) - | [] -> (None, []) - | exception Not_found -> (None, []) - in - `Log_file_path log_file, `Log_sections sections \ No newline at end of file diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/log_info.mli b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/log_info.mli deleted file mode 100644 index c74beb922..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/log_info.mli +++ /dev/null @@ -1,2 +0,0 @@ -val get : - unit -> [`Log_file_path of string option] * [`Log_sections of string list] diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_commands.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_commands.ml deleted file mode 100644 index cbf234302..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_commands.ml +++ /dev/null @@ -1,668 +0,0 @@ -open Std - -type command = -Command : string * Marg.docstring * - ([`Mandatory|`Optional|`Many] * 'args Marg.spec) list * 'args * - (Mpipeline.t -> 'args -> json) -> command - -let command name ?(doc="") ~spec ~default f = - Command (name, doc, spec, default, f) - -let arg ?(kind=`Mandatory) name doc action = (kind, (name, doc, action)) -let optional x = arg ~kind:`Optional x -let many x = arg ~kind:`Many x - -let marg_position f = Marg.param "position" - (function - | "start" -> f `Start - | "end" -> f `End - | str -> match int_of_string str with - | n -> f (`Offset n) - | exception _ -> - match - let offset = String.index str ':' in - let line = String.sub str ~pos:0 ~len:offset in - let col = String.sub str ~pos:(offset+1) - ~len:(String.length str - offset - 1) in - `Logical (int_of_string line, int_of_string col) - with - | pos -> f pos - | exception _ -> - failwithf "expecting position, got %S. \ - position can be start|end||:, \ - where offset, line and col are numbers, \ - lines are indexed from 1." - str - ) - -let marg_completion_kind f = Marg.param "completion-kind" - (function - | "t" | "type" | "types" -> f `Types - | "v" | "val" | "value" | "values" -> f `Values - | "variant" | "variants" | "var" -> f `Variants - | "c" | "constr" | "constructor" -> f `Constructor - | "l" | "label" | "labels" -> f `Labels - | "m" | "mod" | "module" -> f `Modules - | "mt" | "modtype" | "module-type" -> f `Modules_type - | "k" | "kw" | "keyword" -> f `Keywords - | str -> - failwithf "expecting completion kind, got %S. \ - kind can be value, variant, constructor, \ - label, module or module-type" - str - ) - -let rec find_command name = function - | [] -> raise Not_found - | (Command (name', _, _, _, _) as command) :: xs -> - if name = name' then - command - else find_command name xs - -let run pipeline query = - Logger.log ~section:"New_commands" ~title:"run(query)" - "%a" Logger.json (fun () -> Query_json.dump query); - let result = Query_commands.dispatch pipeline query in - let json = Query_json.json_of_response query result in - json - -let all_commands = [ - - command "case-analysis" - ~spec: [ - arg "-start" " Where analysis starts" - (marg_position (fun startp (_startp,endp) -> (startp,endp))); - arg "-end" " Where analysis ends" - (marg_position (fun endp (startp,_endp) -> (startp,endp))); - ] -~doc:"When the range determined by (-start, -end) positions is an expression, -this command replaces it with [match expr with _] expression where a branch \ -is introduced for each immediate value constructor of the type that was \ -determined for expr. -When it is a variable pattern, it is further expanded and new branches are \ -introduced for each possible immediate constructor of this variable. -The return value has the shape \ -`[{'start': position, 'end': position}, content]`, where content is string. -" - ~default:(`Offset (-1), `Offset (-1)) - begin fun buffer -> function - | (`Offset (-1), _) -> failwith "-start is mandatory" - | (_, `Offset (-1)) -> failwith "-end is mandatory" - | (startp, endp) -> - run buffer (Query_protocol.Case_analysis (startp,endp)) - end - ; - - command "holes" - ~spec:[] - ~doc:"Returns the list of the positions of all the holes in the file." - ~default:() - begin fun buffer () -> - run buffer (Query_protocol.Holes) - end - ; - - command "construct" - ~spec: [ - arg "-position" " Position where construct should happen" - (marg_position (fun pos (_pos, with_values, depth) -> - (pos, with_values, depth))); - optional "-with-values" " Use values from the environment" - (Marg.param "" - (fun with_values (pos, _with_values, depth) -> - match with_values with - | "none" -> (pos, None, depth) - | "local" -> (pos, Some `Local, depth) - | _ -> failwith "-with-values should be one of none or local" - )); - optional "-depth" " Depth for the search (defaults to 1)" - (Marg.param "int" (fun depth (pos, with_values,_depth) -> - match int_of_string depth with - | depth -> - if depth >= 1 then (pos, with_values, Some depth) - else failwith "depth should be a positive integer" - | exception _ -> - failwith "depth should be a positive integer" - )); - ] -~doc:"The construct command returns a list of expressions that could fill a -hole at '-position' given its inferred type. The '-depth' parameter allows to -recursively construct terms. Note that when '-depth' > 1 partial results of -inferior depth will not be returned." - ~default:(`Offset (-1), None, None) - begin fun buffer (pos, with_values, max_depth) -> - match pos with - | `Offset (-1) -> failwith "-position is mandatory" - | pos -> run buffer (Query_protocol.Construct (pos, with_values, max_depth)) - end - ; - - command "complete-prefix" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (txt,_pos,kinds,doc,typ) -> (txt,pos,kinds,doc,typ))); - optional "-doc" " Add docstring to entries (default is false)" - (Marg.bool (fun doc (txt,pos,kinds,_doc,typ) -> (txt,pos,kinds,doc,typ))); - arg "-prefix" " Prefix to complete" - (Marg.param "string" (fun txt (_,pos,kinds,doc,typ) -> (txt,pos,kinds,doc,typ))); - optional "-types" " Report type information (default is true)" - (Marg.bool (fun typ (txt,pos,kinds,doc,_typ) -> (txt,pos,kinds,doc,typ))); - optional "-kind" " Namespace to complete (value, constructor, type, variant, label, module, module-type). Default is decided by cursor context" - (marg_completion_kind (fun kind (txt,pos,kinds,doc,typ) -> (txt,pos,kind::kinds,doc,typ))); - ] -~doc:"This functions completes an identifier that the user started to type. -It returns a list of possible completions. -With '-types y' (default), each completion comes with type information. -With '-doc y' it tries to lookup OCamldoc, which is slightly more time consuming. - -The result has the form: -```javascript -{ - 'context': (null | ['application',{'argument_type': string, 'labels': [{'name':string,'type':string}]}]), - 'entries': [{'name':string,'kind':string,'desc':string,'info':string}] -} -``` - -Context describe where completion is occurring. Only application is distinguished now: that's when one is completing the arguments to a function call. In this case, one gets the type expected at the cursor as well as the other labels. - -Entries is the list of possible completion. Each entry is made of: -- a name, the text that should be put in the buffer if selected -- a kind, one of `'value'`, `'variant'`, `'constructor'`, `'label'`, `'module'`, `'signature'`, `'type'`, `'method'`, `'#'` (for method calls), `'exn'`, `'class'` -- a description, most of the time a type or a definition line, to be put next to the name in completion box -- optional information which might not fit in the completion box, like signatures for modules or documentation string." - ~default:("",`None,[],false,true) - begin fun buffer (txt,pos,kinds,doc,typ) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Complete_prefix (txt,pos,List.rev kinds,doc,typ)) - end - ; - - command "document" -~doc:"Returns OCamldoc documentation as a string. -If `-identifier ident` is specified, documentation for this ident is looked \ -up from environment at `-position`. -Otherwise, Merlin looks for the documentation for the entity under the cursor (at `-position`)." - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (ident,_pos) -> (ident,pos))); - optional "-identifier" " Identifier" - (Marg.param "string" (fun ident (_ident,pos) -> (Some ident,pos))); - ] - ~default:(None,`None) - begin fun buffer (ident,pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Document (ident, pos)) - end - ; - - command "enclosing" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos _pos -> pos)); - ] -~doc:"Returns a list of locations `{'start': position, 'end': position}` in \ -increasing size of all entities surrounding the position. -(In a lisp, this would be the locations of all s-exps that contain the cursor.)" - ~default:`None - begin fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Enclosing pos) - end - ; - - command "errors" - ~spec:[ - arg "-lexing" " Whether to report lexing errors or not" - (Marg.bool (fun l (_,p,t) -> (l,p,t))); - arg "-parsing" " Whether to report parsing errors or not" - (Marg.bool (fun p (l,_,t) -> (l,p,t))); - arg "-typing" " Whether to report typing errors or not" - (Marg.bool (fun t (l,p,_) -> (l,p,t))); - ] - ~doc:"Returns a list of errors in current buffer. -The value is a list where each item as the shape: - -```javascript -{ -'start' : position, -'end' : position, -'valid' : bool, -'message' : string, -'type' : ('type'|'parser'|'env'|'warning'|'unkown') -} -``` - -`start` and `end` are omitted if error has no location \ -(e.g. wrong file format), otherwise the editor should probably highlight / \ -mark this range. -`type` is an attempt to classify the error. -`valid` is here mostly for informative purpose. \ -It reflects whether Merlin was expecting such an error to be possible or not, \ -and is useful for debugging purposes. -`message` is the error description to be shown to the user." - ~default:(true, true, true) - begin fun buffer (lexing, parsing, typing) -> - run buffer (Query_protocol.Errors { lexing; parsing; typing }) - end - ; - - command "expand-prefix" -~doc:" -The function behaves like `complete-prefix`, but it also handles partial, \ -incorrect, or wrongly spelled prefixes (as determined by some heuristic). -For instance, `L.ma` can get expanded to `List.map`. This function is a \ -useful fallback if normal completion gave no results. -Be careful that it always return fully qualified paths, whereas normal \ -completion only completes an identifier (last part of a module path)." - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (txt,_pos,kinds,typ) -> (txt,pos,kinds,typ))); - arg "-prefix" " Prefix to complete" - (Marg.param "string" (fun txt (_prefix,pos,kinds,typ) -> (txt,pos,kinds,typ))); - optional "-types" " Report type information (default is false)" - (Marg.bool (fun typ (txt,pos,kinds,_typ) -> (txt,pos,kinds,typ))); - optional "-kind" - " Namespace to complete (value, constructor, type, variant, label, module, module-type). Default is decided by cursor context" - (marg_completion_kind (fun kind (txt,pos,kinds,typ) -> (txt,pos,kind::kinds,typ))); - ] - ~default:("",`None,[],false) - begin fun buffer (txt,pos,kinds,typ) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Expand_prefix (txt,pos,List.rev kinds,typ)) - end - ; - - command "extension-list" - ~spec: [ - optional "-status" " Filter extensions" - (Marg.param "" - (fun status _status -> match status with - | "all" -> `All - | "enabled" -> `Enabled - | "disabled" -> `Disabled - | _ -> failwith "-status should be one of all, disabled or enabled" - )); - ] - ~doc:"List all known / currently enabled / currently disabled extensions \ - as a list of strings." - ~default:`All - begin fun buffer status -> - run buffer (Query_protocol.Extension_list status) - end - ; - - command "findlib-list" - ~doc:"Returns all known findlib packages as a list of string." - ~spec:[] - ~default:() - begin fun buffer () -> - run buffer (Query_protocol.Findlib_list) - end - ; - - command "flags-list" - ~spec:[] -~doc:"Returns supported compiler flags.\ -The purpose of this command is to implement interactive completion of \ -compiler settings in an IDE." - ~default:() - begin fun _ () -> - `List (List.map ~f:Json.string (Mconfig.flags_for_completion ())) - end - ; - - command "jump" - ~spec: [ - arg "-target" " Entity to jump to" - (Marg.param "string" (fun target (_,pos) -> (target,pos))); - arg "-position" " Position to complete" - (marg_position (fun pos (target,_pos) -> (target,pos))); - ] -~doc:"This command can be used to assist navigation in a source code buffer. -Target is a string that can contain one or more of the 'fun', 'let', 'module' \ -and 'match' words. -It returns the starting position of the function, let definition, module or \ -match expression that contains the cursor -" - ~default:("",`None) - begin fun buffer (target,pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Jump (target,pos)) - end - ; - - command "phrase" - ~spec: [ - arg "-target" " Entity to jump to" - (Marg.param "string" (fun target (_,pos) -> - match target with - | "next" -> (`Next,pos) - | "prev" -> (`Prev,pos) - | _ -> failwith "-target should be one of 'next' or 'prev'" - )); - arg "-position" " Position to complete" - (marg_position (fun pos (target,_pos) -> (target,pos))); - ] - ~doc:"Returns the position of the next or previous phrase \ - (top-level definition or module definition)." - ~default:(`Next,`None) - begin fun buffer (target,pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Phrase (target,pos)) - end - ; - - command "list-modules" - ~spec:[ - many "-ext" " file extensions to look for" - (Marg.param "extension" (fun ext exts -> ext :: exts)); - ] -~doc:"Looks into project source paths for files with an extension \ -matching and prints the corresponding module name." - ~default:[] - - begin fun buffer extensions -> - run buffer (Query_protocol.List_modules (List.rev extensions)) - end - ; - - command "locate" - ~spec: [ - optional "-prefix" " Prefix to complete" - (Marg.param "string" (fun txt (_,pos,kind) -> (Some txt,pos,kind))); - arg "-position" " Position to complete" - (marg_position (fun pos (prefix,_pos,kind) -> (prefix,pos,kind))); - optional "-look-for" " Prefer opening interface or implementation" - (Marg.param "" - (fun kind (prefix,pos,_) -> match kind with - | "mli" | "interface" -> (prefix,pos,`MLI) - | "ml" | "implementation" -> (prefix,pos,`ML) - | str -> - failwithf "expecting interface or implementation, got %S." str)); - ] -~doc:"Finds the declaration of entity at the specified position, \ -Or referred to by specified string. -Returns either: -- if location failed, a `string` describing the reason to the user, -- `{'pos': position}` if the location is in the current buffer, -- `{'file': string, 'pos': position}` if definition is located in a \ -different file." - ~default:(None,`None,`MLI) - begin fun buffer (prefix,pos,lookfor) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Locate (prefix,lookfor,pos)) - end - ; - - command "locate-type" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos _ -> pos)); - ] - ~doc: "Locate the declaration of the type of the expression" - ~default:`None - begin fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Locate_type pos) - end - ; - - command "occurrences" - ~spec: [ - arg "-identifier-at" " Position to complete" - (marg_position (fun pos _pos -> (`Ident_at pos))); - ] -~doc:"Returns a list of locations `{'start': position, 'end': position}` \ -of all occurrences in current buffer of the entity at the specified position." - ~default:`None - begin fun buffer -> function - | `None -> failwith "-identifier-at is mandatory" - | `Ident_at pos -> - run buffer (Query_protocol.Occurrences (`Ident_at pos)) - end - ; - - command "outline" - ~spec:[] -~doc:"Returns a tree of objects `{'start': position, 'end': position, \ -'name': string, 'kind': string, 'children': subnodes}` describing the content \ -of the buffer." - ~default:() - begin fun buffer () -> - run buffer (Query_protocol.Outline) - end - ; - - command "path-of-source" - ~doc:"Looks for first file with a matching name in the project source \ - and build paths" - ~spec: [ - arg "-file" " filename to look for in project paths" - (Marg.param "filename" (fun file files -> file :: files)); - ] - ~default:[] - - begin fun buffer filenames -> - run buffer (Query_protocol.Path_of_source (List.rev filenames)) - end - ; - - command "refactor-open" - ~doc:"refactor-open -position pos -action \n\t\ - TODO" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (action,_pos) -> (action,pos))); - arg "-action" " Direction of rewriting" - (Marg.param "" (fun action (_action,pos) -> - match action with - | "qualify" -> (Some `Qualify,pos) - | "unqualify" -> (Some `Unqualify,pos) - | _ -> failwith "invalid -action" - ) - ); - ] - ~default:(None,`None) - begin fun buffer -> function - | (None, _) -> failwith "-action is mandatory" - | (_, `None) -> failwith "-position is mandatory" - | (Some action, (#Msource.position as pos)) -> - run buffer (Query_protocol.Refactor_open (action,pos)) - end - ; - - command "search-by-polarity" - ~doc:"search-by-polarity -position pos -query ident\n\t\ - TODO" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (query,_pos) -> (query,pos))); - arg "-query" " Query of the form TODO" - (Marg.param "string" (fun query (_prefix,pos) -> (query,pos))); - ] - ~default:("",`None) - begin fun buffer (query,pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Polarity_search (query,pos)) - end - ; - - command "shape" -~doc:"This command can be used to assist navigation in a source code buffer. -It returns a tree of all relevant locations around the cursor. -It is similar to outline without telling any information about the entity \ -at a given location. -```javascript -shape = -{ - 'start' : position, - 'end' : position, - 'children' : [shape] -} -``` -" - ~spec: [ - arg "-position" " Position " - (marg_position (fun pos _pos -> pos)); - ] - ~default:`None - begin fun buffer -> function - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Shape pos) - end - ; - - command "type-enclosing" -~doc:"Returns a list of type information for all expressions at given \ -position, sorted by increasing size. -That is asking for type enlosing around `2` in `string_of_int 2` will return \ -the types of `2 : int` and `string_of_int 2 : string`. - -If `-expression` and `-cursor` are specified, the first result will be the type -relevant to the prefix ending at the `cursor` offset. - -`-index` can be used to print only one type information. This is useful to -query the types lazily: normally, Merlin would return the signature of all -enclosing modules, which can be very expensive. - -The result is returned as a list of: -```javascript -{ - 'start': position, - 'end': position, - 'type': string, - // is this expression not in tail position, in tail position, \ -or even a tail call? - 'tail': ('no' | 'position' | 'call') -} -```" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (expr,cursor,_pos,index) -> (expr,cursor,pos,index))); - optional "-expression" " Expression to type" - (Marg.param "string" (fun expr (_expr,cursor,pos,index) -> (expr,cursor,pos,index))); - optional "-cursor" " Position of the cursor inside expression" - (Marg.param "int" (fun cursor (expr,_cursor,pos,index) -> - match int_of_string cursor with - | cursor -> (expr,cursor,pos,index) - | exception _ -> - failwith "cursor should be an integer" - )); - optional "-index" " Only print type of 'th result" - (Marg.param "int" (fun index (expr,cursor,pos,_index) -> - match int_of_string index with - | index -> (expr,cursor,pos,Some index) - | exception _ -> - failwith "index should be an integer" - )); - ] - ~default:("",-1,`None,None) - begin fun buffer (expr,cursor,pos,index) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - let expr = - if expr = "" then None - else - let cursor = if cursor = -1 then String.length expr else cursor in - Some (expr, cursor) - in - run buffer (Query_protocol.Type_enclosing (expr,pos,index)) - end - ; - - command "type-expression" -~doc:"Returns the type of the expression when typechecked in the environment \ -around the specified position." - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos (expr,_pos) -> (expr,pos))); - arg "-expression" " Expression to type" - (Marg.param "string" (fun expr (_expr,pos) -> (expr,pos))); - ] - ~default:("",`None) - begin fun buffer (expr,pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Type_expr (expr,pos)) - end - ; - - (* Implemented without support from Query_protocol. This command might be - refactored if it proves useful for old protocol too. *) - command "check-configuration" - ~spec:[] -~doc:"This command checks that merlin project and options are correct. -The return value has the shape: -```javascript -{ - 'dot_merlins': [path], // a list of string - 'failures': [message] // a list of string -} -```" - ~default:() - begin fun pipeline () -> - let config = Mpipeline.final_config pipeline in - `Assoc [ - (* TODO Remove support for multiple configuration files - The protocol could be changed to: - 'config_file': path_to_dot_merlin_or_dune - - For now, if the configurator is dune, the field 'dot_merlins' - will contain the path to the dune file (or jbuild, or dune-project) - *) - - "dot_merlins", `List - (match Mconfig.(config.merlin.config_path) with - | Some path -> [Json.string path] - | None -> []); - "failures", `List (List.map ~f:Json.string - Mconfig.(config.merlin.failures)); - ] - end - ; - - (* Used only for testing *) - command "dump" - ~spec:[ - arg "-what" " \ - Information to dump ()" - (Marg.param "string" (fun what _ -> what)); - ] - ~default:"" - ~doc:"Not for the casual user, used for debugging merlin" - begin fun pipeline what -> - run pipeline (Query_protocol.Dump [`String what]) - end - ; - - (* Used only for testing *) - command "dump-configuration" ~spec:[] ~default:() - ~doc:"Not for the casual user, used for merlin tests" - begin fun pipeline () -> - Mconfig.dump (Mpipeline.final_config pipeline) - end - ; - -] diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_commands.mli b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_commands.mli deleted file mode 100644 index 2c6498aa2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_commands.mli +++ /dev/null @@ -1,9 +0,0 @@ -open Std - -type command = - Command : string * Marg.docstring * ([`Mandatory|`Optional|`Many] * 'args Marg.spec) list * 'args * - (Mpipeline.t -> 'args -> json) -> command - -val all_commands : command list - -val find_command : string -> command list -> command diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_merlin.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_merlin.ml deleted file mode 100644 index 8770a39f2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/new/new_merlin.ml +++ /dev/null @@ -1,167 +0,0 @@ -(** {1 Prepare command-line arguments} *) - -let {Logger. log} = Logger.for_section "New_merlin" - -let usage () = - prerr_endline - "Usage: ocamlmerlin command [options] -- [compiler flags]\n\ - Help commands are:\n\ - \ -version Print version and exit\n\ - \ -vnum Print version number and exit\n\ - \ -warn-help Show description of warning numbers\n\ - \ -flags-help Show description of accepted compiler flags\n\ - \ -commands-help Describe all accepted commands\n" - -let commands_help () = - print_endline "Query commands are:"; - List.iter (fun (New_commands.Command (name, doc, args, _, _)) -> - print_newline (); - let args = List.map (fun (kind, (key0,desc,_)) -> - let key1, desc = - let len = String.length desc in - match String.index desc ' ' with - | 0 -> key0, String.sub desc 1 (len - 1) - | idx -> key0 ^ " " ^ String.sub desc 0 idx, - String.sub desc (idx + 1) (len - idx - 1) - | exception Not_found -> key0, desc - in - let key = match kind with - | `Mandatory -> key1 - | `Optional -> "[ " ^ key1 ^ " ]" - | `Many -> "[ " ^ key1 ^ " " ^ key0 ^ " ... ]" - in - key, (key1, desc) - ) args in - let args, descs = List.split args in - print_endline ("### `" ^ String.concat " " (name :: args) ^ "`"); - print_newline (); - let print_desc (k,d) = print_endline (Printf.sprintf "%24s %s" k d) in - List.iter print_desc descs; - print_newline (); - print_endline doc - ) New_commands.all_commands - -let run = function - | [] -> - usage (); - 1 - | "-version" :: _ -> - Printf.printf "The Merlin toolkit version %s, for Ocaml %s\n" - Merlin_config.version Sys.ocaml_version; - 0 - | "-vnum" :: _ -> - Printf.printf "%s\n" Merlin_config.version; - 0 - | "-warn-help" :: _ -> - Warnings.help_warnings (); - 0 - | "-flags-help" :: _ -> - Mconfig.document_arguments stdout; - 0 - | "-commands-help" :: _ -> - commands_help (); - 0 - | query :: raw_args -> - match New_commands.find_command query New_commands.all_commands with - | exception Not_found -> - prerr_endline ("Unknown command " ^ query ^ ".\n"); - usage (); - 1 - | New_commands.Command (_name, _doc, spec, command_args, command_action) -> - (* Setup notifications *) - let notifications = ref [] in - Logger.with_notifications notifications @@ fun () -> - (* Parse commandline *) - match begin - let start_cpu = Misc.time_spent () in - let start_clock = Unix.gettimeofday () *. 1000. in - let config, command_args = - let fails = ref [] in - let config, command_args = - Mconfig.parse_arguments - ~wd:(Sys.getcwd ()) ~warning:(fun w -> fails := w :: !fails) - (List.map snd spec) raw_args Mconfig.initial command_args - in - let config = - let failures = !fails @ config.merlin.failures in - Mconfig.({config with merlin = {config.merlin with failures}}) - in - config, command_args - in - (* Start processing query *) - Logger.with_log_file Mconfig.(config.merlin.log_file) - ~sections:Mconfig.(config.merlin.log_sections) @@ fun () -> - File_id.with_cache @@ fun () -> - let source = Msource.make (Misc.string_of_file stdin) in - let pipeline = Mpipeline.make config source in - let json = - let class_, message = - Printexc.record_backtrace true; - match - Mpipeline.with_pipeline pipeline @@ fun () -> - command_action pipeline command_args - with - | result -> - ("return", result) - | exception (Failure str) -> - let trace = Printexc.get_backtrace () in - log ~title:"run" "Command error backtrace: %s" trace; - ("failure", `String str) - | exception exn -> - let trace = Printexc.get_backtrace () in - log ~title:"run" "Command error backtrace: %s" trace; - match Location.error_of_exn exn with - | None | Some `Already_displayed -> - ("exception", `String (Printexc.to_string exn ^ "\n" ^ trace)) - | Some (`Ok err) -> - Location.print_main Format.str_formatter err; - ("error", `String (Format.flush_str_formatter ())) - in - let cpu_time = Misc.time_spent () -. start_cpu in - let clock_time = Unix.gettimeofday () *. 1000. -. start_clock in - let timing = Mpipeline.timing_information pipeline in - let pipeline_time = - List.fold_left (fun acc (_, k) -> k +. acc) 0.0 timing in - let timing = ("clock", clock_time) :: - ("cpu", cpu_time) :: - ("query", (cpu_time -. pipeline_time)) :: timing in - let notify { Logger.section; msg } = - `String (Printf.sprintf "%s: %s" section msg) - in - let format_timing (k,v) = (k, `Int (int_of_float (0.5 +. v))) in - `Assoc [ - "class", `String class_; "value", message; - "notifications", `List (List.rev_map notify !notifications); - "timing", `Assoc (List.map format_timing timing) - ] - in - log ~title:"run(result)" "%a" Logger.json (fun () -> json); - begin match Mconfig.(config.merlin.protocol) with - | `Sexp -> Sexp.tell_sexp print_string (Sexp.of_json json) - | `Json -> Yojson.Basic.to_channel stdout json - end; - print_newline () - end with - | () -> 0 - | exception exn -> - prerr_endline ("Exception: " ^ Printexc.to_string exn); - 1 - -let run ~new_env wd args = - begin match new_env with - | Some env -> - Os_ipc.merlin_set_environ env; - Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ())) - | None -> () end; - let wd_msg = match wd with - | None -> "No working directory specified" - | Some wd -> - try Sys.chdir wd; Printf.sprintf "changed directory to %S" wd - with _ -> Printf.sprintf "cannot change working directory to %S" wd - in - let `Log_file_path log_file, `Log_sections sections = - Log_info.get () - in - Logger.with_log_file log_file ~sections @@ fun () -> - log ~title:"run" "%s" wd_msg; - run args diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/ocamlmerlin.c b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/ocamlmerlin.c deleted file mode 100644 index 6e7ce9a2d..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/ocamlmerlin.c +++ /dev/null @@ -1,710 +0,0 @@ -#include -#include -#include -#include -#ifdef _WIN32 -/* GetNamedPipeServerProcessId requires Windows Vista+ */ -#undef _WIN32_WINNT -#define _WIN32_WINNT 0x600 -#include -#include -#include -#include // ConvertSidToStringSid -#ifndef STDIN_FILENO -#define STDIN_FILENO 0 -#endif -#ifndef STDOUT_FILENO -#define STDOUT_FILENO 1 -#endif -#ifndef STDERR_FILENO -#define STDERR_FILENO 2 -#endif -#ifdef _MSC_VER -typedef SSIZE_T ssize_t; -#define PATH_MAX MAX_PATH -#ifndef _UCRT -#define snprintf _snprintf -#endif -#endif -#else -#include -#include -#include -#include -#include -#include -#endif -#include -#include -#include -#include -#include - -#if defined(__linux) -#include -#elif defined(__APPLE__) -#include -#elif defined(__OpenBSD__) -#include -#endif - -/** Portability information **/ - -/* Determine OS, http://stackoverflow.com/questions/6649936 - __linux__ Defined on Linux - __sun Defined on Solaris - __FreeBSD__ Defined on FreeBSD - __NetBSD__ Defined on NetBSD - __OpenBSD__ Defined on OpenBSD - __APPLE__ Defined on Mac OS X - __hpux Defined on HP-UX - __osf__ Defined on Tru64 UNIX (formerly DEC OSF1) - __sgi Defined on Irix - _AIX Defined on AIX -*/ - -/* Compute executable path, http://stackoverflow.com/questions/1023306 - Mac OS X _NSGetExecutablePath() (man 3 dyld) - Linux readlink /proc/self/exe - Solaris getexecname() - FreeBSD sysctl CTL_KERN KERN_PROC KERN_PROC_PATHNAME -1 - NetBSD readlink /proc/curproc/exe - DragonFly BSD readlink /proc/curproc/file - Windows GetModuleFileName() with hModule = NULL -*/ - -#define NO_EINTR(var, command) \ - do { (var) = command; } while ((var) == -1 && errno == EINTR) - -static void dumpinfo(void); - -static void failwith_perror(const char *msg) -{ - perror(msg); - dumpinfo(); - exit(EXIT_FAILURE); -} - -static void failwith(const char *msg) -{ - fprintf(stderr, "%s\n", msg); - dumpinfo(); - exit(EXIT_FAILURE); -} - -#define PATHSZ (PATH_MAX+1) - -#define BEGIN_PROTECTCWD \ - { char previous_cwd[PATHSZ]; \ - if (!getcwd(previous_cwd, PATHSZ)) previous_cwd[0] = '\0'; - -/* Return from chdir is ignored */ -#define END_PROTECTCWD \ - if (previous_cwd[0] != '\0') if (chdir(previous_cwd)) {} } - -static const char *path_socketdir(void) -{ - static const char *tmpdir = NULL; - if (tmpdir == NULL) - tmpdir = getenv("TMPDIR"); - if (tmpdir == NULL) - tmpdir = "/tmp"; - return tmpdir; -} - -#ifdef _WIN32 -/** Deal with Windows IPC **/ - -static void ipc_send(HANDLE hPipe, unsigned char *buffer, size_t len, HANDLE fds[3]) -{ - DWORD dwNumberOfBytesWritten; - if (!WriteFile(hPipe, fds, 3 * sizeof(HANDLE), &dwNumberOfBytesWritten, NULL) || dwNumberOfBytesWritten != 3 * sizeof(HANDLE)) - failwith_perror("sendmsg"); - if (!WriteFile(hPipe, buffer, len, &dwNumberOfBytesWritten, NULL) || dwNumberOfBytesWritten != len) - failwith_perror("send"); -} - -#else -/** Deal with UNIX IPC **/ - -static void ipc_send(int fd, unsigned char *buffer, size_t len, int fds[3]) -{ - char msg_control[CMSG_SPACE(3 * sizeof(int))]; - struct iovec iov = { .iov_base = buffer, .iov_len = len }; - struct msghdr msg = { - .msg_iov = &iov, .msg_iovlen = 1, - .msg_controllen = CMSG_SPACE(3 * sizeof(int)), - }; - msg.msg_control = &msg_control; - memset(msg.msg_control, 0, msg.msg_controllen); - - struct cmsghdr *cm = CMSG_FIRSTHDR(&msg); - cm->cmsg_level = SOL_SOCKET; - cm->cmsg_type = SCM_RIGHTS; - cm->cmsg_len = CMSG_LEN(3 * sizeof(int)); - - int *fds0 = (int*)CMSG_DATA(cm); - fds0[0] = fds[0]; - fds0[1] = fds[1]; - fds0[2] = fds[2]; - - ssize_t sent; - NO_EINTR(sent, sendmsg(fd, &msg, 0)); - - if (sent == -1) - failwith_perror("sendmsg"); - - while (sent < len) - { - ssize_t sent_; - NO_EINTR(sent_, send(fd, buffer + sent, len - sent, 0)); - - if (sent_ == -1) - failwith_perror("sent"); - - sent += sent_; - } -} -#endif - -/* Serialize arguments */ - -#define byte(x,n) ((unsigned)((x) >> (n * 8)) & 0xFF) - -static void append_argument(unsigned char *buffer, size_t len, ssize_t *pos, const char *p) -{ - ssize_t j = *pos; - while (*p && j < len) - { - buffer[j] = *p; - j += 1; - p += 1; - } - - if (j >= len) - failwith("maximum number of arguments exceeded"); - - buffer[j] = 0; - j += 1; - *pos = j; -} - -#ifdef _MSC_VER -extern __declspec(dllimport) char **environ; -#else -extern char **environ; -#endif - -static ssize_t prepare_args(unsigned char *buffer, size_t len, int argc, char **argv) -{ - int i = 0; - ssize_t j = 4; - - /* First put the current working directory */ - - char cwd[PATHSZ]; - if (!getcwd(cwd, PATHSZ)) cwd[0] = '\0'; - append_argument(buffer, len, &j, cwd); - - /* Then append environ */ - for (i = 0; environ[i] != NULL; ++i) - { - const char *v = environ[i]; - if (v[0] == '\0') continue; - - append_argument(buffer, len, &j, environ[i]); - } - - /* Env var delimiter */ - append_argument(buffer, len, &j, ""); - - /* Append arguments */ - for (i = 0; i < argc && j < len; ++i) - { - append_argument(buffer, len, &j, argv[i]); - } - - /* Put size at the beginning */ - buffer[0] = byte(j,0); - buffer[1] = byte(j,1); - buffer[2] = byte(j,2); - buffer[3] = byte(j,3); - return j; -} - -#ifdef _WIN32 -#define IPC_SOCKET_TYPE HANDLE -static HANDLE connect_socket(const char *socketname, int fail) -{ - HANDLE hPipe; - hPipe = CreateFile(socketname, GENERIC_READ | GENERIC_WRITE, 0, NULL, OPEN_EXISTING, 0, 0); - if (hPipe == INVALID_HANDLE_VALUE) - if (fail) failwith_perror("connect"); - return hPipe; -} -#else -#define IPC_SOCKET_TYPE int -#define INVALID_HANDLE_VALUE -1 -static int connect_socket(const char *socketname, int fail) -{ - int sock = socket(PF_UNIX, SOCK_STREAM, 0); - if (sock == -1) failwith_perror("socket"); - - int err; - - BEGIN_PROTECTCWD - struct sockaddr_un address; - int address_len; - - /* Return from chdir is ignored */ - err = chdir(path_socketdir()); - address.sun_family = AF_UNIX; - snprintf(address.sun_path, 104, "./%s", socketname); - address_len = strlen(address.sun_path) + sizeof(address.sun_family) + 1; - - NO_EINTR(err, connect(sock, (struct sockaddr*)&address, address_len)); - END_PROTECTCWD - - if (err == -1) - { - if (fail) failwith_perror("connect"); - close(sock); - return -1; - } - - return sock; -} -#endif - -#ifdef _WIN32 -static void start_server(const char *socketname, const char* eventname, const char *exec_path) -{ - char buf[PATHSZ]; - PROCESS_INFORMATION pi; - STARTUPINFO si; - HANDLE hEvent = CreateEvent(NULL, FALSE, FALSE, eventname); - DWORD dwResult; - sprintf(buf, "%s server %s %s", exec_path, socketname, eventname); - ZeroMemory(&si, sizeof(si)); - si.cb = sizeof(si); - ZeroMemory(&pi, sizeof(pi)); - /* Note that DETACHED_PROCESS means that the process does not appear in Task Manager - but the server can still be stopped with ocamlmerlin server stop-server */ - if (!CreateProcess(exec_path, buf, NULL, NULL, FALSE, DETACHED_PROCESS, NULL, NULL, &si, &pi)) - failwith_perror("fork"); - CloseHandle(pi.hProcess); - CloseHandle(pi.hThread); - if (WaitForSingleObject(hEvent, 5000) != WAIT_OBJECT_0) - failwith_perror("execlp"); -} -#else -static void make_daemon(int sock) -{ - /* On success: The child process becomes session leader */ - if (setsid() < 0) - failwith_perror("setsid"); - - /* Close all open file descriptors */ - close(0); - if (open("/dev/null", O_RDWR, 0) != 0) - failwith_perror("open"); - dup2(0,1); - dup2(0,2); - - /* Change directory to root, so that process still works if directory - * is delete. */ - if (chdir("/") != 0) - failwith_perror("chdir"); - - //int x; - //for (x = sysconf(_SC_OPEN_MAX); x>2; x--) - //{ - // if (x != sock) - // close(x); - //} - - pid_t child = fork(); - signal(SIGHUP, SIG_IGN); - - /* An error occurred */ - if (child < 0) - failwith_perror("fork"); - - /* Success: Let the parent terminate */ - if (child > 0) - exit(EXIT_SUCCESS); -} - -static void start_server(const char *socketname, const char* ignored, const char *exec_path) -{ - int sock = socket(PF_UNIX, SOCK_STREAM, 0); - if (sock == -1) - failwith_perror("socket"); - - int err; - - BEGIN_PROTECTCWD - struct sockaddr_un address; - int address_len; - - /* Return from chdir is ignored */ - err = chdir(path_socketdir()); - address.sun_family = AF_UNIX; - snprintf(address.sun_path, 104, "./%s", socketname); - address_len = strlen(address.sun_path) + sizeof(address.sun_family) + 1; - unlink(address.sun_path); - - NO_EINTR(err, bind(sock, (struct sockaddr*)&address, address_len)); - END_PROTECTCWD - - if (err == -1) - failwith_perror("bind"); - - if (listen(sock, 5) == -1) - failwith_perror("listen"); - - pid_t child = fork(); - - if (child == -1) - failwith_perror("fork"); - - if (child == 0) - { - make_daemon(sock); - - char socket_fd[50], socket_path[PATHSZ]; - sprintf(socket_fd, "%d", sock); - snprintf(socket_path, PATHSZ, "%s/%s", path_socketdir(), socketname); - //execlp("nohup", "nohup", exec_path, "server", socket_path, socket_fd, NULL); - execlp(exec_path, exec_path, "server", socket_path, socket_fd, NULL); - failwith_perror("execlp"); - } - - close(sock); - wait(NULL); -} -#endif - -static IPC_SOCKET_TYPE connect_and_serve(const char *socket_path, const char* event_path, const char *exec_path) -{ - IPC_SOCKET_TYPE sock = connect_socket(socket_path, 0); - - if (sock == INVALID_HANDLE_VALUE) - { - start_server(socket_path, event_path, exec_path); - sock = connect_socket(socket_path, 1); - } - - if (sock == INVALID_HANDLE_VALUE) - abort(); - - return sock; -} - -/* OCaml merlin path */ - -static const char *search_in_path(const char *PATH, const char *argv0, char *merlin_path) -{ - static char binary_path[PATHSZ]; -#ifdef _WIN32 - char *result = NULL; - DWORD dwResult; -#endif - - if (PATH == NULL || argv0 == NULL) return NULL; - - while (*PATH) - { - int i = 0; - // Copy one path from PATH - while (i < PATHSZ-1 && *PATH && *PATH != ':') - { - binary_path[i] = *PATH; - i += 1; - PATH += 1; - } - - // Append filename - { - const char *file = argv0; - binary_path[i] = '/'; - i += 1; - - while (i < PATHSZ-1 && *file) - { - binary_path[i] = *file; - i += 1; - file += 1; - } - - binary_path[i] = 0; - } - - // Check path -#ifdef _WIN32 - dwResult = GetFullPathName(binary_path, PATHSZ, merlin_path, NULL); - if (dwResult && dwResult < PATHSZ) - if (GetLongPathName(binary_path, NULL, 0)) - result = binary_path; -#else - char *result = realpath(binary_path, merlin_path); -#endif - if (result != NULL) - return result; - - // Seek next path in PATH - while (*PATH && *PATH != ':') - PATH += 1; - - while (*PATH == ':') - PATH += 1; - } - - return NULL; -} - -static void prune_binary_name(char * buffer) { - size_t strsz = strlen(buffer); - while (strsz > 0 && buffer[strsz-1] != '/' && buffer[strsz-1] != '\\') - strsz -= 1; - buffer[strsz] = 0; -} - -#ifdef _WIN32 -static char ocamlmerlin_server[] = "ocamlmerlin-server.exe"; -#else -static char ocamlmerlin_server[] = "ocamlmerlin-server"; -#endif - -static void compute_merlinpath(char merlin_path[PATHSZ], const char *argv0, struct stat *st) -{ - char argv0_dirname[PATHSZ]; - size_t strsz; - - strcpy(argv0_dirname, argv0); - prune_binary_name(argv0_dirname); - - // Check if we were called with a path or not - if (strlen(argv0_dirname) == 0) { - if (search_in_path(getenv("PATH"), argv0, merlin_path) == NULL) - failwith("cannot resolve path to ocamlmerlin"); - } else { -#ifdef _WIN32 - // GetFullPathName does not resolve symbolic links, which realpath does. - // @@DRA GetLongPathName ensures that the file exists (better way?!). - // Not sure if this matters. - DWORD dwResult = GetFullPathName(argv0, PATHSZ, merlin_path, NULL); - if (!dwResult || dwResult >= PATHSZ || !GetLongPathName(merlin_path, NULL, 0)) -#else - if (realpath(argv0, merlin_path) == NULL) -#endif - failwith("argv0 does not point to a valid file"); - } - - prune_binary_name(merlin_path); - strsz = strlen(merlin_path); - - // Append ocamlmerlin-server - if (strsz + sizeof(ocamlmerlin_server) + 8 > PATHSZ) - failwith("path is too long"); - - strcpy(merlin_path + strsz, ocamlmerlin_server); - - if (stat(merlin_path, st) != 0) - { - strcpy(merlin_path + strsz, "ocamlmerlin_server.exe"); - if (stat(merlin_path, st) != 0) - { - strcpy(merlin_path + strsz, ocamlmerlin_server); - failwith_perror("stat(ocamlmerlin-server, also tried ocamlmerlin_server.exe)"); - } - } -} - -#ifdef _WIN32 - -/* May return NULL */ -LPSTR retrieve_user_sid_string() -{ - LPSTR usidstr; - HANDLE process_token; - if ( ! OpenProcessToken( GetCurrentProcess(), TOKEN_QUERY, &process_token ) ) - return NULL; - - DWORD sid_buffer_size; - if ( ! GetTokenInformation(process_token, TokenUser, NULL, 0, &sid_buffer_size ) && - ( GetLastError() != ERROR_INSUFFICIENT_BUFFER ) ) - { - CloseHandle(process_token); - return NULL; - } - - TOKEN_USER * token_user_ptr = (PTOKEN_USER) malloc(sid_buffer_size); - if ( ! token_user_ptr ) - { - CloseHandle( process_token); - return NULL; - } - - if ( ! GetTokenInformation(process_token, TokenUser, token_user_ptr, - sid_buffer_size, &sid_buffer_size)) - { - free(token_user_ptr); - CloseHandle(process_token); - return NULL; - } - - if (! ConvertSidToStringSid(token_user_ptr->User.Sid, &usidstr)) - usidstr = NULL; - - free(token_user_ptr); - CloseHandle(process_token); - - return usidstr; -} - -static void compute_socketname(char socketname[PATHSZ], char eventname[PATHSZ], const char merlin_path[PATHSZ]) -#else -static void compute_socketname(char socketname[PATHSZ], struct stat *st) -#endif -{ -#ifdef _WIN32 - BY_HANDLE_FILE_INFORMATION info; - LPSTR user_sid_string; - HANDLE hFile = CreateFile(merlin_path, FILE_READ_ATTRIBUTES, FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); - if (hFile == INVALID_HANDLE_VALUE || !GetFileInformationByHandle(hFile, &info)) - failwith_perror("stat (cannot find ocamlmerlin binary)"); - CloseHandle(hFile); - - user_sid_string = retrieve_user_sid_string() ; - if (! user_sid_string) - user_sid_string = LocalAlloc(LPTR, 1); - - // @@DRA Need to use Windows API functions to get meaningful values for st_dev and st_ino - snprintf(eventname, PATHSZ, - "ocamlmerlin_%s_%lx_%llx", - user_sid_string, - info.dwVolumeSerialNumber, - ((__int64)info.nFileIndexHigh) << 32 | ((__int64)info.nFileIndexLow)); - snprintf(socketname, PATHSZ, - "\\\\.\\pipe\\%s", eventname); - - LocalFree(user_sid_string); -#else - snprintf(socketname, PATHSZ, - "ocamlmerlin_%llu_%llu_%llu.socket", - (unsigned long long)getuid(), - (unsigned long long)st->st_dev, - (unsigned long long)st->st_ino); -#endif -} - -/* Main */ - -static char - merlin_path[PATHSZ] = "", - socketname[PATHSZ] = "", - eventname[PATHSZ] = ""; -static unsigned char argbuffer[262144]; - -static void dumpinfo(void) -{ - fprintf(stderr, - "merlin path: %s\nsocket path: %s/%s\n", merlin_path, path_socketdir(), socketname); -} - -static void unexpected_termination(int argc, char **argv) -{ - int sexp = 0; - int i; - - for (i = 1; i < argc - 1; ++i) - { - if (strcmp(argv[i], "-protocol") == 0 && - strcmp(argv[i+1], "sexp") == 0) - sexp = 1; - } - - puts(sexp - ? "((assoc) (class . \"failure\") (value . \"abnormal termination\") (notifications))" - : "{\"class\": \"failure\", \"value\": \"abnormal termination\", \"notifications\": [] }" - ); - failwith("abnormal termination"); -} - -int main(int argc, char **argv) -{ - char result = 0; - int err = 0; - struct stat st; -#ifdef _WIN32 - HANDLE fds[3]; - ULONG pid; - HANDLE hProcess, hServerProcess; - DWORD dwNumberOfBytesRead; - CHAR argv0[PATHSZ]; - GetModuleFileName(NULL, argv0, PATHSZ); - compute_merlinpath(merlin_path, argv0, &st); -#else - compute_merlinpath(merlin_path, argv[0], &st); -#endif - if (argc >= 2 && strcmp(argv[1], "server") == 0) - { - IPC_SOCKET_TYPE sock; - ssize_t len; -#ifdef _WIN32 - compute_socketname(socketname, eventname, merlin_path); -#else - compute_socketname(socketname, &st); -#endif - - sock = connect_and_serve(socketname, eventname, merlin_path); - len = prepare_args(argbuffer, sizeof(argbuffer), argc-2, argv+2); -#ifdef _WIN32 - hProcess = GetCurrentProcess(); - if (!GetNamedPipeServerProcessId(sock, &pid)) - failwith_perror("GetNamedPipeServerProcessId"); - hServerProcess = OpenProcess(PROCESS_DUP_HANDLE, FALSE, pid); - if (hServerProcess == INVALID_HANDLE_VALUE) - failwith_perror("OpenProcess"); - if (!DuplicateHandle(hProcess, GetStdHandle(STD_INPUT_HANDLE), hServerProcess, &fds[0], 0, FALSE, DUPLICATE_SAME_ACCESS)) - failwith_perror("DuplicateHandle(stdin)"); - if (!DuplicateHandle(hProcess, GetStdHandle(STD_OUTPUT_HANDLE), hServerProcess, &fds[1], 0, FALSE, DUPLICATE_SAME_ACCESS)) - failwith_perror("DuplicateHandle(stdout)"); - CloseHandle(GetStdHandle(STD_OUTPUT_HANDLE)); - if (!DuplicateHandle(hProcess, GetStdHandle(STD_ERROR_HANDLE), hServerProcess, &fds[2], 0, FALSE, DUPLICATE_SAME_ACCESS)) - failwith_perror("DuplicateHandle(stderr)"); -#else - int fds[3] = { STDIN_FILENO, STDOUT_FILENO, STDERR_FILENO }; -#endif - ipc_send(sock, argbuffer, len, fds); - -#ifdef _WIN32 - if (ReadFile(sock, &result, 1, &dwNumberOfBytesRead, NULL) && dwNumberOfBytesRead == 1) - err = 1; -#else - NO_EINTR(err, read(sock, &result, 1)); -#endif - if (err == 1) - exit(result); - - unexpected_termination(argc, argv); - } - else - { - argv[0] = ocamlmerlin_server; -#ifdef _WIN32 - int err = _spawnvp(_P_WAIT, merlin_path, (const char *const *)argv); - if (err < 0) - failwith_perror("spawnvp(ocamlmerlin-server)"); - else - exit(err); -#else - execvp(merlin_path, argv); - failwith_perror("execvp(ocamlmerlin-server)"); -#endif - } - - /* This is never reached */ - return 0; -} diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/ocamlmerlin_server.ml deleted file mode 100644 index 2c840dfc9..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ /dev/null @@ -1,99 +0,0 @@ -let merlin_timeout = - try float_of_string (Sys.getenv "MERLIN_TIMEOUT") - with _ -> 600.0 - -module Server = struct - - let rec protect_eintr f = - match f () with - | exception (Unix.Unix_error(Unix.EINTR, _, _)) -> protect_eintr f - | result -> result - - let process_request {Os_ipc. wd; environ; argv; context = _} = - match Array.to_list argv with - | "stop-server" :: _ -> raise Exit - | args -> New_merlin.run ~new_env:(Some environ) (Some wd) args - - let process_client client = - let context = client.Os_ipc.context in - Os_ipc.context_setup context; - let close_with return_code = - flush_all (); - Os_ipc.context_close context ~return_code - in - match process_request client with - | code -> close_with code - | exception Exit -> - close_with (-1); - raise Exit - | exception exn -> - Logger.log ~section:"server" ~title:"process failed" "%a" - Logger.exn exn; - close_with (-1) - - let server_accept merlinid server = - let rec loop total = - Mocaml.flush_caches ~older_than:300.0 (); - let merlinid' = File_id.get Sys.executable_name in - if total > merlin_timeout || - not (File_id.check merlinid merlinid') then - None - else - let timeout = max 10.0 (min 60.0 (merlin_timeout -. total)) in - match Os_ipc.server_accept server ~timeout with - | Some _ as result -> result - | None -> loop (total +. timeout) - in - match Os_ipc.server_accept server ~timeout:1.0 with - | Some _ as result -> result - | None -> loop 1.0 - - let rec loop merlinid server = - match server_accept merlinid server with - | None -> (* Timeout *) - () - | Some client -> - let continue = - match process_client client with - | exception Exit -> false - | () -> true - in - if continue then loop merlinid server - - let start socket_path socket_fd = - match Os_ipc.server_setup socket_path socket_fd with - | None -> - Logger.log ~section:"server" ~title:"cannot setup listener" "" - | Some server -> - loop (File_id.get Sys.executable_name) server; - Os_ipc.server_close server -end - -let main () = - (* Setup env for extensions *) - Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ())); - match List.tl (Array.to_list Sys.argv) with - | "single" :: args -> exit (New_merlin.run ~new_env:None None args) - | "old-protocol" :: args -> Old_merlin.run args - | ["server"; socket_path; socket_fd] -> Server.start socket_path socket_fd - | ("-help" | "--help" | "-h" | "server") :: _ -> - Printf.eprintf - "Usage: %s \n\ - Select the merlin frontend to execute. Valid values are:\n\ - \n- 'old-protocol' executes the merlin frontend from previous version.\n\ - \ It is a top level reading and writing commands in a JSON form.\n\ - \n- 'single' is a simpler frontend that reads input from stdin,\n\ - \ processes a single query and outputs result on stdout.\n\ - \n- 'server' works like 'single', but uses a background process to\n\ - \ speedup processing.\n\ - If no frontend is specified, it defaults to 'old-protocol' for\n\ - compatibility with existing editors.\n" - Sys.argv.(0) - | args -> Old_merlin.run args - -let () = - Std.Json.pretty_to_string := Yojson.Basic.pretty_to_string; - let `Log_file_path log_file, `Log_sections sections = - Log_info.get () - in - Logger.with_log_file log_file ~sections main diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_IO.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_IO.ml deleted file mode 100644 index f9494a30a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_IO.ml +++ /dev/null @@ -1,365 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let latest_version : Old_protocol.protocol_version = `V3 -let current_version = ref `V2 - -let default_context = - {Old_protocol.Context. - document = None; printer_width = None; printer_verbosity = None} - -let invalid_arguments () = failwith "invalid arguments" - -open Query_protocol -open Old_protocol - -let pos_of_json = function - | `String "start" -> `Start - | `String "end" -> `End - | `Int offset -> `Offset offset - | `Assoc props -> - begin try match List.assoc "line" props, List.assoc "col" props with - | `Int line, `Int col -> `Logical (line,col) - | _ -> failwith "Incorrect position" - with Not_found -> failwith "Incorrect position" - end - | _ -> failwith "Incorrect position" - -let mandatory_position = function - | [`String "at"; jpos] -> pos_of_json jpos - | _ -> invalid_arguments () - -let optional_string = function - | [`String name] -> Some name - | [] -> None - | _ -> invalid_arguments () - -let string_list l = - List.map ~f:(function `String s -> s | _ -> invalid_arguments ()) l - -let source_or_build = function - | "source" -> `Source - | "build" -> `Build - | _ -> invalid_arguments () - -let ml_or_mli = function - | "ml" -> `ML - | "mli" -> `MLI - | _ -> invalid_arguments () - -let auto_ml_or_mli = function - | "auto" -> `Auto - | x -> ml_or_mli x - -let add_or_remove = function - | "add" -> `Add - | "remove" -> `Rem - | _ -> invalid_arguments () - -let with_failures failures assoc = match failures with - | `Ok -> assoc - | `Failures failures -> - let flags, extensions = - List.fold_left failures ~init:([],[]) ~f:( - fun (flgs, exts) (str,exn) -> - match exn with - | Arg.Bad _ -> str :: flgs, exts - | Extension.Unknown -> flgs, str :: exts - | _ -> assert false - ) - in - let flags = - match flags with - | [] -> [] - | failures -> - let str = String.concat ~sep:", " failures in - [ `String ("Unknown flags " ^ str) ] - in - let extensions = - match extensions with - | [] -> [] - | failures -> - let str = String.concat ~sep:", " failures in - [ `String ("Unknown extensions " ^ str) ] - in - ("failures", `List (flags @ extensions)) :: assoc - -let document_of_json = - let make kind path dot_merlins = - {Context.dot_merlins; - kind = auto_ml_or_mli kind; - path = optional_string path; - } - in function - | (`String "dot_merlin" :: `List dot_merlins :: `String kind :: opt_name) -> - make kind opt_name (Some (string_list dot_merlins)) - | (`String kind :: opt_name) -> - make kind opt_name None - | _ -> invalid_arguments () - -let request_of_json context = - let request x = Request (context, x) in function - | (`String "type" :: `String "expression" :: `String expr :: opt_pos) -> - request (Query (Type_expr (expr, mandatory_position opt_pos))) - | [`String "type"; `String "enclosing"; - `Assoc [ "expr", `String expr ; "offset", `Int offset] ; jpos] -> - request (Query (Type_enclosing (Some (expr, offset), pos_of_json jpos, None))) - | [`String "type"; `String "enclosing"; `String "at"; jpos] -> - request (Query (Type_enclosing (None, pos_of_json jpos, None))) - | [ `String "case"; `String "analysis"; `String "from"; x; `String "to"; y ] -> - request (Query (Case_analysis (pos_of_json x, pos_of_json y))) - | [`String "enclosing"; jpos] -> - request (Query (Enclosing (pos_of_json jpos))) - | [`String "complete"; `String "prefix"; `String prefix; `String "at"; jpos] -> - request (Query (Complete_prefix (prefix, pos_of_json jpos, [], false, true))) - | [`String "complete"; `String "prefix"; `String prefix; `String "at"; jpos; - `String "with"; `String "doc"] -> - request (Query (Complete_prefix (prefix, pos_of_json jpos, [], true, true))) - | [`String "expand"; `String "prefix"; `String prefix; `String "at"; jpos] -> - request (Query (Expand_prefix (prefix, pos_of_json jpos, [], true))) - | [`String "search"; `String "polarity"; `String query; `String "at"; jpos] -> - request (Query (Polarity_search (query, pos_of_json jpos))) - | (`String "document" :: (`String "" | `Null) :: pos) -> - request (Query (Document (None, mandatory_position pos))) - | (`String "document" :: `String path :: pos) -> - request (Query (Document (Some path, mandatory_position pos))) - | (`String "locate" :: (`String "" | `Null) :: `String choice :: pos) -> - request (Query (Locate (None, ml_or_mli choice, mandatory_position pos))) - | (`String "locate" :: `String path :: `String choice :: pos) -> - request (Query (Locate (Some path, ml_or_mli choice, mandatory_position pos))) - | (`String "jump" :: `String target :: pos) -> - request (Query (Jump (target, mandatory_position pos))) - | [`String "outline"] -> - request (Query Outline) - | [`String "shape"; pos] -> - request (Query (Shape (pos_of_json pos))) - | [`String "occurrences"; `String "ident"; `String "at"; jpos] -> - request (Query (Occurrences (`Ident_at (pos_of_json jpos)))) - | (`String ("reset"|"checkout") :: document) -> - request (Sync (Checkout (document_of_json document))) - | [`String "refresh"] -> - request (Sync Refresh) - | [`String "errors"] -> - request (Query (Errors { lexing = true; parsing = true; typing = true })) - | (`String "dump" :: args) -> - request (Query (Dump args)) - | [`String "which"; `String "path"; `String name] -> - request (Query (Path_of_source [name])) - | [`String "which"; `String "path"; `List names] -> - request (Query (Path_of_source (string_list names))) - | [`String "which"; `String "with_ext"; `String ext] -> - request (Query (List_modules [ext])) - | [`String "which"; `String "with_ext"; `List exts] -> - request (Query (List_modules (string_list exts))) - | [`String "flags" ; `String "set" ; `List flags ] -> - request (Sync (Flags_set (string_list flags))) - | [`String "flags" ; `String "get" ] -> - request (Sync (Flags_get)) - | [`String "find"; `String "use"; `List packages] - | (`String "find" :: `String "use" :: packages) -> - request (Sync (Findlib_use (string_list packages))) - | [`String "find"; `String "list"] -> - request (Query Findlib_list) - | [`String "extension"; `String "enable"; `List extensions] -> - request (Sync (Extension_set (`Enabled,string_list extensions))) - | [`String "extension"; `String "disable"; `List extensions] -> - request (Sync (Extension_set (`Disabled,string_list extensions))) - | [`String "extension"; `String "list"] -> - request (Query (Extension_list `All)) - | [`String "extension"; `String "list"; `String "enabled"] -> - request (Query (Extension_list `Enabled)) - | [`String "extension"; `String "list"; `String "disabled"] -> - request (Query (Extension_list `Disabled)) - | [`String "path"; `String "list"; - `String ("source"|"build" as var)] -> - request (Query (Path_list (source_or_build var))) - | [`String "path"; `String "reset"] -> - request (Sync Path_reset) - | (`String "path" :: `String ("add"|"remove" as action) :: - `String ("source"|"build" as var) :: ((`List pathes :: []) | pathes)) -> - request (Sync (Path (source_or_build var, add_or_remove action, string_list pathes))) - | [`String "tell"; pos_start; pos_end; `String content] -> - request (Sync (Tell (pos_of_json pos_start, pos_of_json pos_end, content))) - | [`String "project"; `String "get"] -> - request (Sync Project_get) - | [`String "version"] -> - request (Query Version) - | [`String "protocol"; `String "version"] -> - request (Sync (Protocol_version None)) - | [`String "protocol"; `String "version"; `Int n] -> - request (Sync (Protocol_version (Some n))) - | _ -> invalid_arguments () - -let json_of_protocol_version : Old_protocol.protocol_version -> _ = function - | `V2 -> `Int 2 - | `V3 -> `Int 3 - -let json_of_sync_command (type a) (command : a sync_command) (response : a) : json = - match command, response with - | Tell _, () -> `Bool true - | Checkout _, () -> `Bool true - | Refresh, () -> `Bool true - | Flags_get, flags -> - `List (List.map ~f:Json.string flags) - | Flags_set _, failures -> - `Assoc (with_failures failures ["result", `Bool true]) - | Findlib_use _, failures -> - `Assoc (with_failures failures ["result", `Bool true]) - | Extension_set _, failures -> - `Assoc (with_failures failures ["result", `Bool true]) - | Path _, () -> `Bool true - | Path_reset, () -> `Bool true - | Protocol_version _, (`Selected v, `Latest vm, version) -> - `Assoc ["selected", json_of_protocol_version v; - "latest", json_of_protocol_version vm; - "merlin", `String version - ] - | Project_get, (strs, fails) -> - let failures = match fails with - | `Failures ((_::_) as fails) -> - ["failures", `List (List.map ~f:Json.string fails)] - | _ -> [] - in - `Assoc (("result", `List (List.map ~f:Json.string strs))::failures) - | Idle_job, b -> `Bool b - -let classify_response = function - | Failure s | Exception (Failure s) -> ("failure", `String s) - | Error error -> ("error", error) - | Exception exn -> - begin match Location.error_of_exn exn with - | Some (`Ok error) -> ("error", Query_json.json_of_error error) - | None | Some `Already_displayed -> - ("exception", `String (Printexc.to_string exn)) - end - | Return (Query cmd, response) -> - ("return", Query_json.json_of_response cmd response) - | Return (Sync cmd, response) -> - ("return", json_of_sync_command cmd response) - -let json_of_response_v2 response = - let class_, value = classify_response response in - `List [`String class_; value] - -let json_of_response_v3 ~notifications response = - let class_, value = classify_response response in - `Assoc [ - "class", `String class_; - "value", value; - "notifications", - `List (List.map ~f:(fun { Logger.section; msg } -> - `Assoc ["section", `String section; "message", `String msg]) - notifications); - ] - -let json_of_response notifications response = - match !current_version with - | `V2 -> json_of_response_v2 response - | `V3 -> json_of_response_v3 ~notifications response - -let request_of_json = function - | `Assoc _ as json -> - let open Yojson.Basic.Util in - let document = - let value = member "document" json in - let value = - if value = `Null then - member "context" json - else value - in - if value = `Null then - None - else Some (to_list value |> document_of_json) - in - let printer_width = member "printer_width" json |> to_int_option in - let printer_verbosity = member "printer_verbosity" json |> to_int_option in - let context = {Context. document; printer_verbosity; printer_width} in - let query = member "query" json |> to_list in - request_of_json context query - | `List jsons -> request_of_json default_context jsons - | _ -> invalid_arguments () - -let make_json ?(on_read=ignore) ~input ~output () = - let rec read buf len = - on_read input; - try Unix.read input buf 0 len - with Unix.Unix_error (Unix.EINTR,_,_) -> - read buf len - in - let lexbuf = Lexing.from_function read in - let input = Seq.to_dispenser (Yojson.Basic.(seq_from_lexbuf (init_lexer ()) lexbuf)) in - let output = Unix.out_channel_of_descr output in - let output' = Yojson.Basic.to_channel output in - let output json = - output' json; - output_char output '\n'; - flush output - in - input, output - -let make_sexp ?on_read ~input ~output () = - (* Fix for emacs: emacs start-process doesn't distinguish between stdout and - stderr. So we redirect stderr to /dev/null with sexp frontend. *) - begin match - begin - try Some (Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o600) - with - | Unix.Unix_error _ -> - if Sys.os_type = "Win32" then - try Some (Unix.openfile "NUL" [Unix.O_WRONLY] 0o600) - with Unix.Unix_error _ -> None - else None - end - with - | None -> () - | Some fd -> - Unix.dup2 fd Unix.stderr; - Unix.close fd - end; - let input' = Sexp.of_file_descr ?on_read input in - let input' () = Option.map ~f:Sexp.to_json (input' ()) in - let buf = Buffer.create 8192 in - let output json = - let sexp = Sexp.of_json json in - Sexp.to_buf sexp buf; - Buffer.add_char buf '\n'; - let contents = Buffer.to_bytes buf in - let rec write_contents n l = - if l > 0 then - let l' = Unix.write output contents n l in - if l' > 0 then - write_contents (n + l') (l - l') - in - write_contents 0 (Bytes.length contents); - if Buffer.length buf > 100_000 - then Buffer.reset buf - else Buffer.clear buf - in - input', output diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_IO.mli b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_IO.mli deleted file mode 100644 index dbf9cf38b..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_IO.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -val latest_version : Old_protocol.protocol_version -val current_version : Old_protocol.protocol_version ref - -(* Misc *) -val default_context : Old_protocol.Context.t - -val request_of_json : Json.t -> Old_protocol.request -val json_of_response : Logger.notification list -> - Old_protocol.response -> Json.t - -val make_json : ?on_read:(Unix.file_descr -> unit) -> - input:Unix.file_descr -> - output:Unix.file_descr -> - unit -> (unit -> Json.t option) * (Json.t -> unit) - -val make_sexp : ?on_read:(Unix.file_descr -> unit) -> - input:Unix.file_descr -> - output:Unix.file_descr -> - unit -> (unit -> Json.t option) * (Json.t -> unit) diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_command.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_command.ml deleted file mode 100644 index 5946d65ed..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_command.ml +++ /dev/null @@ -1,252 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Old_protocol -module Printtyp = Type_utils.Printtyp - -type customization = [ - | `Ext of [`Enabled | `Disabled] * string - | `Flags of string list - | `Use of string list - | `Path of [`Build | `Source] * [`Add | `Rem] * string list -] - -let customize config = - let open Mconfig in - function - | `Ext (`Enabled, ext) -> - let extensions = ext :: config.merlin.extensions in - {config with merlin = {config.merlin with extensions}}; - | `Ext (`Disabled, ext) -> - let extensions = List.remove_all ext config.merlin.extensions in - {config with merlin = {config.merlin with extensions}}; - | `Flags flags -> - let flags_to_apply = [{workdir = config.query.directory; workval = flags}] in - {config with merlin = {config.merlin with flags_to_apply}} - | `Use _pkgs -> - config - | `Path (var, action, paths) -> - let f l = match action with - | `Add -> List.filter_dup (paths @ l) - | `Rem -> List.filter l ~f:(fun x -> not (List.mem x ~set:paths)) - in - let merlin = config.merlin in - let merlin = - match var with - | `Build -> {merlin with build_path = f merlin.build_path} - | `Source -> {merlin with source_path = f merlin.source_path} - in - {config with merlin} - - -type buffer = { - path: string option; - dot_merlins: string list option; - mutable customization : customization list; - mutable source : Msource.t; -} - -type state = { - mutable buffer : buffer; -} - -let normalize_document doc = - doc.Context.path, doc.Context.dot_merlins - -let new_buffer (path, dot_merlins) = - { path; dot_merlins; customization = []; - source = Msource.make "" } - -let default_config = ref Mconfig.initial - -let configure (state : buffer) = - let config = !default_config in - let config = {config with Mconfig.query = match state.path with - | None -> config.Mconfig.query - | Some path -> { - config.Mconfig.query with - Mconfig. - filename = Filename.basename path; - directory = Misc.canonicalize_filename (Filename.dirname path); - } - } in - let config = - match state.dot_merlins with - | Some (first :: _) -> (* ignore anything but the first one... *) - Mconfig.get_external_config first config - | None | Some [] -> - match state.path with - | None -> config - | Some p -> Mconfig.get_external_config p config - in - List.fold_left ~f:customize ~init:config state.customization - -let new_state document = - { buffer = new_buffer document } - -let checkout_buffer_cache = ref [] -let checkout_buffer = - let cache_size = 8 in - fun document -> - let document = normalize_document document in - try List.assoc document !checkout_buffer_cache - with Not_found -> - let buffer = new_buffer document in - begin match document with - | Some _, _ -> - checkout_buffer_cache := - (document, buffer) :: List.take_n cache_size !checkout_buffer_cache - | None, _ -> () - end; - buffer - -let make_pipeline config buffer = - Mpipeline.make config buffer.source - -let dispatch_sync config state (type a) : a sync_command -> a = function - | Idle_job -> false - - | Tell (pos_start, pos_end, text) -> - let source = Msource.substitute state.source pos_start pos_end text in - state.source <- source - - | Refresh -> - checkout_buffer_cache := []; - Cmi_cache.flush () - - | Flags_set flags -> - state.customization <- - (`Flags flags) :: - List.filter ~f:(function `Flags _ -> false | _ -> true) - state.customization; - `Ok - - | Findlib_use packages -> - state.customization <- - (`Use packages) :: - List.filter ~f:(function `Use _ -> false | _ -> true) - state.customization; - `Ok - - | Extension_set (action,exts) -> - state.customization <- - List.map ~f:(fun ext -> `Ext (action, ext)) exts @ - List.filter ~f:(function - | `Ext (_, ext) when List.mem ext ~set:exts -> false - | _ -> true - ) state.customization; - `Ok - - | Path (var,_,paths) -> - state.customization <- - List.filter_map ~f:(function - | `Path (var', action', paths') when var = var' -> - let paths' = List.filter paths' - ~f:(fun path -> not (List.mem path ~set:paths)) - in - if paths' = [] then None else Some (`Path (var', action', paths')) - | x -> Some x - ) state.customization - - | Path_reset -> - state.customization <- - List.filter ~f:(function | `Path _ -> false - | _ -> true - ) state.customization; - - | Protocol_version version -> - begin match version with - | None -> () - | Some 2 -> Old_IO.current_version := `V2 - | Some 3 -> Old_IO.current_version := `V3 - | Some _ -> () - end; - (`Selected !Old_IO.current_version, - `Latest Old_IO.latest_version, - Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" - Merlin_config.version Sys.ocaml_version) - - | Flags_get -> - let pipeline = make_pipeline config state in - let config = Mpipeline.final_config pipeline in - List.concat_map ~f:(fun f -> f.workval) - Mconfig.(config.merlin.flags_to_apply) - - | Project_get -> - let failures = match Mconfig.(config.merlin.failures) with - | [] -> `Ok - | failures -> `Failures failures in - - (Option.cons Mconfig.(config.merlin.config_path) [], failures) - - | Checkout _ -> failwith "invalid arguments" - -let default_state = lazy (new_state (None, None)) - -let document_states - : (string option * string list option, state) Hashtbl.t - = Hashtbl.create 7 - -let dispatch (type a) (context : Context.t) (cmd : a command) : a = - let open Context in - (* Document selection *) - let state = match context.document with - | None -> Lazy.force default_state - | Some document -> - let document = normalize_document document in - try Hashtbl.find document_states document - with Not_found -> - let state = new_state document in - Hashtbl.add document_states document state; - state - in - let config = configure state.buffer in - (* Printer verbosity *) - let config = match context.printer_verbosity with - | None -> config - | Some verbosity -> - Mconfig.({config with query = {config.query with verbosity}}) - in - let config = match context.printer_width with - | None -> config - | Some printer_width -> - Mconfig.({config with query = {config.query with printer_width}}) - in - (* Printer width *) - Format.default_width := Option.value ~default:0 context.printer_width; - (* Actual dispatch *) - match cmd with - | Query q -> - let pipeline = make_pipeline config state.buffer in - Mpipeline.with_pipeline pipeline @@ fun () -> - Query_commands.dispatch pipeline q - | Sync (Checkout context) when state == Lazy.force default_state -> - let buffer = checkout_buffer context in - state.buffer <- buffer - | Sync s -> dispatch_sync config state.buffer s diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_command.mli b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_command.mli deleted file mode 100644 index d478106cf..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_command.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -val default_config : Mconfig.t ref - -val dispatch : Old_protocol.Context.t -> 'a Old_protocol.command -> 'a diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_merlin.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_merlin.ml deleted file mode 100644 index 621168802..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_merlin.ml +++ /dev/null @@ -1,146 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let version_spec = - Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s" - Merlin_config.version Sys.ocaml_version - -let ocamlmerlin_args = [ - ( - "-ignore-sigint", - " Ignore SIGINT, useful when invoked from editor", - Marg.unit (fun acc -> - (try ignore (Sys.(signal sigint Signal_ignore)) - with Invalid_argument _ -> ()); - acc - ) - ); - ( - "-version", - " Print version and exit", - Marg.unit (fun _ -> - print_endline version_spec; - exit 0 - ) - ); - ( - "-vnum", - " Print version number and exit", - Marg.unit (fun _ -> - Printf.printf "%s\n" Merlin_config.version; - exit 0 - ) - ); - ( - "-warn-help", - " Show description of warning numbers", - Marg.unit (fun _ -> - Warnings.help_warnings (); - exit 0 - ) - ); - ( - "-protocol", - " Select frontend protocol ('json' or 'sexp')", - Marg.param "protocol" (fun arg _ -> - match arg with - | "json" -> `Json - | "sexp" -> `Sexp - | _ -> - prerr_endline "Valid protocols are 'json' and 'sexp'"; - exit 1 - ) - ); -] - -let signal sg behavior = - try ignore (Sys.signal sg behavior) - with Invalid_argument _ (*Sys.signal: unavailable signal*) -> () - -let rec merlin_loop input output = - let notifications = ref [] in - Logger.with_notifications notifications @@ fun () -> - match - match input () with - | Some (Old_protocol.Request (context, request)) -> - let answer = Old_command.dispatch context request in - output ~notifications:(List.rev !notifications) - (Old_protocol.Return (request, answer)); - true - | None -> false - with - | exception exn -> - let trace = - { Logger.section = "backtrace"; msg = Printexc.get_backtrace () } - in - output ~notifications:(trace :: List.rev !notifications) - (Old_protocol.Exception exn); - merlin_loop input output - | true -> merlin_loop input output - | false -> () - -let setup_system () = - (* Setup signals, unix is a disaster *) - signal Sys.sigusr1 Sys.Signal_ignore; - signal Sys.sigpipe Sys.Signal_ignore; - signal Sys.sighup Sys.Signal_ignore - -let setup_merlin args = - let config, protocol = - Mconfig.parse_arguments - ~wd:(Sys.getcwd ()) ~warning:prerr_endline ocamlmerlin_args args - Mconfig.initial `Json - in - Old_command.default_config := config; - let protocol = match protocol with - | `Json -> Old_IO.make_json - | `Sexp -> Old_IO.make_sexp - in - let input, output = protocol ~input:Unix.stdin ~output:Unix.stdout () in - let input () = match input () with - | None -> None - | Some json -> - Logger.log ~section:"frontend" ~title:"input" "%a" - Logger.json (fun () -> json); - Some (Old_IO.request_of_json json) - in - let output ~notifications x = - let json = Old_IO.json_of_response notifications x in - Logger.log ~section:"frontend" ~title:"output" "%a" - Logger.json (fun () -> json); - output json - in - (input, output) - -let run args = - setup_system (); - let input, output = setup_merlin args in - merlin_loop input output; - exit 0 diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_merlin.mli b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_merlin.mli deleted file mode 100644 index 805b85b5d..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_merlin.mli +++ /dev/null @@ -1 +0,0 @@ -val run : string list -> 'a diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_protocol.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_protocol.ml deleted file mode 100644 index 1ed34ee39..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/old/old_protocol.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -type protocol_version = - [ `V2 (* First version to support versioning ! *) - | `V3 (* Responses are now assoc {class:string, value:..., notifications:string list} *) - ] - -module Context = -struct - type document = { - kind: [`ML | `MLI | `Auto ]; - path: string option; - dot_merlins: string list option; - } - - type t = { - document: document option; - printer_width: int option; - printer_verbosity: int option; - } -end - -type _ sync_command = - | Tell - : Msource.position * Msource.position * string - -> unit sync_command - | Refresh - : unit sync_command - | Flags_set - : string list - -> [ `Ok | `Failures of (string * exn) list ] sync_command - | Findlib_use - : string list - -> [`Ok | `Failures of (string * exn) list] sync_command - | Extension_set - : [`Enabled|`Disabled] * string list - -> [`Ok | `Failures of (string * exn) list] sync_command - | Path - : [`Build|`Source] - * [`Add|`Rem] - * string list - -> unit sync_command - | Path_reset - : unit sync_command - | Protocol_version - : int option - -> ([`Selected of protocol_version] * - [`Latest of protocol_version] * - string) sync_command - | Checkout - : Context.document - -> unit sync_command - | Idle_job - : bool sync_command - | Flags_get - : string list sync_command - | Project_get - : (string list * [`Ok | `Failures of string list]) sync_command - -type 'a command = - | Query of 'a Query_protocol.t - | Sync of 'a sync_command - -type request = Request : Context.t * 'a command -> request - -type response = - | Return : 'a command * 'a -> response - | Failure : string -> response - | Error : Json.t -> response - | Exception : exn -> response diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/query_json.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/query_json.ml deleted file mode 100644 index 81a1c699c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/ocamlmerlin/query_json.ml +++ /dev/null @@ -1,420 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Query_protocol - -let dump (type a) : a t -> json = - let mk command args = - `Assoc ( - ("command", `String command) :: - args - ) in - let mk_position = function - | `Start -> `String "start" - | `End -> `String "end" - | `Offset n -> - `Assoc ["offset", `Int n] - | `Logical (line,col) -> - `Assoc ["line", `Int line; "column", `Int col] - in - let kinds_to_json kind = - `List (List.map ~f:(function - | `Constructor -> `String "constructor" - | `Keywords -> `String "keywords" - | `Labels -> `String "label" - | `Modules -> `String "module" - | `Modules_type -> `String "module-type" - | `Types -> `String "type" - | `Values -> `String "value" - | `Variants -> `String "variant" - ) kind) - in - function - | Type_expr (expr, pos) -> - mk "type-expression" [ - "expression", `String expr; - "position", mk_position pos; - ] - - | Type_enclosing (opt_cursor, pos, index) -> - mk "type-enclosing" [ - "cursor", (match opt_cursor with - | None -> `Null - | Some (text, offset) -> `Assoc [ - "text", `String text; - "offset", `Int offset; - ] - ); - "index", (match index with - | None -> `String "all" - | Some n -> `Int n - ); - "position", mk_position pos; - ] - - | Locate_type pos -> - mk "locate-type" [ - "position", mk_position pos - ] - - | Enclosing pos -> - mk "enclosing" [ - "position", mk_position pos; - ] - - | Complete_prefix (prefix, pos, kind, doc, typ) -> - mk "complete-prefix" [ - "prefix", `String prefix; - "position", mk_position pos; - "with-doc", `Bool doc; - "with-types", `Bool typ; - "kind", kinds_to_json kind; - ] - - | Expand_prefix (prefix, pos, kind, typ) -> - mk "expand-prefix" [ - "prefix", `String prefix; - "position", mk_position pos; - "with-types", `Bool typ; - "kind", kinds_to_json kind; - ] - | Document (identifier, pos) -> - mk "document" [ - "identifier", (match identifier with - | None -> `Null - | Some ident -> `String ident - ); - "position", mk_position pos; - ] - | Locate (prefix, look_for, pos) -> - mk "locate" [ - "prefix", (match prefix with - | None -> `Null - | Some prefix -> `String prefix - ); - "look-for", (match look_for with - | `ML -> `String "implementation" - | `MLI -> `String "interface" - ); - "position", mk_position pos; - ] - | Jump (target, pos) -> - mk "jump" [ - "target", `String target; - "position", mk_position pos; - ] - | Phrase (target, pos) -> - mk "phrase" [ - "target", `String (match target with `Next -> "next" | `Prev -> "prev"); - "position", mk_position pos; - ] - | Case_analysis (pos_start,pos_end) -> - mk "case-analysis" [ - "start", mk_position pos_start; - "end", mk_position pos_end; - ] - | Holes -> mk "holes" [] - | Construct (pos, with_values, depth) -> - let depth = Option.value ~default:1 depth in - mk "construct" [ - "position", mk_position pos; - "with_values", (match with_values with - | Some `None | None -> `String "none" - | Some `Local -> `String "local" - ); - "depth", `Int depth - ] - | Outline -> mk "outline" [] - | Errors { lexing; parsing; typing } -> - let args = - if lexing && parsing && typing - then [] - else [ - "lexing", `Bool lexing; - "parsing", `Bool parsing; - "typing", `Bool typing; - ] - in - mk "errors" args - | Shape pos -> - mk "shape" [ - "position", mk_position pos; - ] - | Dump args -> - mk "dump" [ - "args", `List args - ] - | Path_of_source paths -> - mk "path-of-source" [ - "paths", `List (List.map ~f:Json.string paths) - ] - | List_modules exts -> - mk "list-modules" [ - "extensions", `List (List.map ~f:Json.string exts) - ] - | Findlib_list -> mk "findlib-list" [] - | Extension_list status -> - mk "extension-list" [ - "filter", (match status with - | `All -> `String "all" - | `Enabled -> `String "enabled" - | `Disabled -> `String "disabled" - ); - ] - | Path_list var -> - mk "path-list" [ - "variable", (match var with - | `Build -> `String "build" - | `Source -> `String "source" - ); - ] - | Polarity_search (query, pos) -> - mk "polarity-search" [ - "query", `String query; - "position", mk_position pos; - ] - | Occurrences (`Ident_at pos) -> - mk "occurrences" [ - "kind", `String "identifiers"; - "position", mk_position pos; - ] - | Refactor_open (action, pos) -> - mk "refactor-open" [ - "action", `String (match action with `Qualify -> "qualify" - | `Unqualify -> "unqualify"); - "position", mk_position pos; - ] - | Version -> mk "version" [] - -let string_of_completion_kind = function - | `Value -> "Value" - | `Variant -> "Variant" - | `Constructor -> "Constructor" - | `Label -> "Label" - | `Module -> "Module" - | `Modtype -> "Signature" - | `Type -> "Type" - | `Method -> "Method" - | `MethodCall -> "#" - | `Exn -> "Exn" - | `Class -> "Class" - | `Keyword -> "Keyword" - -let with_location ?(skip_none=false) loc assoc = - if skip_none && loc = Location.none then - `Assoc assoc - else - `Assoc (("start", Lexing.json_of_position loc.Location.loc_start) :: - ("end", Lexing.json_of_position loc.Location.loc_end) :: - assoc) - -let json_of_type_loc (loc,desc,tail) = - with_location loc [ - "type", (match desc with - | `String _ as str -> str - | `Index n -> `Int n); - "tail", `String (match tail with - | `No -> "no" - | `Tail_position -> "position" - | `Tail_call -> "call") - ] - -let json_of_error (error : Location.error) = - let of_sub loc sub = - let msg = - Location.print_sub_msg Format.str_formatter sub; - String.trim (Format.flush_str_formatter ()) - in - with_location ~skip_none:true loc ["message", `String msg] - in - let loc = Location.loc_of_report error in - let msg = - Format.asprintf "@[%a@]" Location.print_main error |> String.trim - in - let typ = - match error.source with - | Location.Lexer -> "lexer" - | Location.Parser -> "parser" - | Location.Typer -> "typer" - | Location.Warning -> - if String.is_prefixed ~by:"Error" msg then - "typer" (* Handle warn-error (since 4.08) *) - else - "warning" - | Location.Unknown -> "unknown" - | Location.Env -> "env" - | Location.Config -> "config" - in - let content = [ - "type" , `String typ; - "sub" , `List (List.map ~f:(of_sub loc) error.sub); - "valid" , `Bool true; - "message" , `String msg; - ] in - with_location ~skip_none:true loc content - -let json_of_completion {Compl. name; kind; desc; info; deprecated} = - `Assoc ["name", `String name; - "kind", `String (string_of_completion_kind kind); - "desc", `String desc; - "info", `String info; - "deprecated", `Bool deprecated] - -let json_of_completions {Compl. entries; context } = - `Assoc [ - "entries", `List (List.map ~f:json_of_completion entries); - "context", (match context with - | `Unknown -> `Null - | `Application {Compl. argument_type; labels} -> - let label (name,ty) = `Assoc ["name", `String name; - "type", `String ty] in - let a = `Assoc ["argument_type", `String argument_type; - "labels", `List (List.map ~f:label labels)] in - `List [`String "application"; a]) - ] - -let rec json_of_outline outline = - let json_of_item { outline_name ; outline_kind ; outline_type; location ; children ; deprecated } = - with_location location [ - "name", `String outline_name; - "kind", `String (string_of_completion_kind outline_kind); - "type", (match outline_type with - | None -> `Null - | Some typ -> `String typ); - "children", `List (json_of_outline children); - "deprecated", `Bool deprecated - ] - in - List.map ~f:json_of_item outline - -let rec json_of_shape { shape_loc; shape_sub } = - with_location shape_loc [ - "children", `List (List.map ~f:json_of_shape shape_sub); - ] - -let json_of_locate resp = - match resp with - | `At_origin -> `String "Already at definition point" - | `Builtin s -> - `String (sprintf "%S is a builtin, and it is therefore impossible \ - to jump to its definition" s) - | `Invalid_context -> `String "Not a valid identifier" - | `Not_found (id, None) -> `String ("didn't manage to find " ^ id) - | `Not_found (i, Some f) -> - `String - (sprintf "%s was supposed to be in %s but could not be found" i f) - | `Not_in_env str -> - `String (Printf.sprintf "Not in environment '%s'" str) - | `File_not_found msg -> - `String msg - | `Found (None,pos) -> - `Assoc ["pos", Lexing.json_of_position pos] - | `Found (Some file,pos) -> - `Assoc ["file",`String file; "pos", Lexing.json_of_position pos] - -let json_of_response (type a) (query : a t) (response : a) : json = - match query, response with - | Type_expr _, str -> `String str - | Type_enclosing _, results -> - `List (List.map ~f:json_of_type_loc results) - | Enclosing _, results -> - `List (List.map ~f:(fun loc -> with_location loc []) results) - | Complete_prefix _, compl -> - json_of_completions compl - | Expand_prefix _, compl -> - json_of_completions compl - | Polarity_search _, compl -> - json_of_completions compl - | Refactor_open _, locations -> - `List (List.map locations ~f:(fun (name,loc) -> - with_location loc ["content",`String name])) - | Document _, resp -> - begin match resp with - | `No_documentation -> `String "No documentation available" - | `Invalid_context -> `String "Not a valid identifier" - | `Builtin s -> - `String (sprintf "%S is a builtin, no documentation is available" s) - | `Not_found (id, None) -> `String ("didn't manage to find " ^ id) - | `Not_found (i, Some f) -> - `String - (sprintf "%s was supposed to be in %s but could not be found" i f) - | `Not_in_env str -> - `String (Printf.sprintf "Not in environment '%s'" str) - | `File_not_found msg -> - `String msg - | `Found doc -> - `String doc - end - | Locate_type _, resp -> json_of_locate resp - | Locate _, resp -> json_of_locate resp - | Jump _, resp -> - begin match resp with - | `Error str -> - `String str - | `Found pos -> - `Assoc ["pos", Lexing.json_of_position pos] - end - | Phrase _, pos -> - `Assoc ["pos", Lexing.json_of_position pos] - | Case_analysis _, ({ Location. loc_start ; loc_end; _ }, str) -> - let assoc = - `Assoc [ - "start", Lexing.json_of_position loc_start ; - "end", Lexing.json_of_position loc_end ; - ] - in - `List [ assoc ; `String str ] - | Holes, locations -> - `List (List.map locations - ~f:(fun (loc, typ) -> with_location loc ["type", `String typ])) - | Construct _, ({ Location. loc_start ; loc_end; _ }, strs) -> - let assoc = - `Assoc [ - "start", Lexing.json_of_position loc_start ; - "end", Lexing.json_of_position loc_end ; - ] - in - `List [ assoc ; `List (List.map ~f:Json.string strs) ] - | Outline, outlines -> - `List (json_of_outline outlines) - | Shape _, shapes -> - `List (List.map ~f:json_of_shape shapes) - | Errors _, errors -> - `List (List.map ~f:json_of_error errors) - | Dump _, json -> json - | Path_of_source _, str -> `String str - | List_modules _, strs -> `List (List.map ~f:Json.string strs) - | Findlib_list, strs -> `List (List.map ~f:Json.string strs) - | Extension_list _, strs -> `List (List.map ~f:Json.string strs) - | Path_list _, strs -> `List (List.map ~f:Json.string strs) - | Occurrences _, locations -> - `List (List.map locations - ~f:(fun loc -> with_location loc [])) - | Version, version -> - `String version diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/query_commands.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/query_commands.ml deleted file mode 100644 index b7011d569..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/query_commands.ml +++ /dev/null @@ -1,840 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Misc -open Std -open Query_protocol -module Printtyp = Type_utils.Printtyp - -exception No_nodes - -let print_completion_entries ~with_types config source entries = - if with_types then - let input_ref = ref [] and output_ref = ref [] in - let preprocess entry = - match Completion.raw_info_printer entry with - | `String s -> `String s - | `Print t -> - let r = ref "" in - input_ref := t :: !input_ref; - output_ref := r :: !output_ref; - `Print r - | `Concat (s,t) -> - let r = ref "" in - input_ref := t :: !input_ref; - output_ref := r :: !output_ref; - `Concat (s,r) - in - let entries = List.rev_map ~f:(Completion.map_entry preprocess) entries in - let entries = List.rev entries in - let outcomes = Mreader.print_batch_outcome config source !input_ref in - List.iter2 ~f:(:=) !output_ref outcomes; - let postprocess = function - | `String s -> s - | `Print r -> !r - | `Concat (s,r) -> s ^ !r - in - List.rev_map ~f:(Completion.map_entry postprocess) entries - else List.rev_map ~f:(Completion.map_entry (fun _ -> "")) entries - -let for_completion pipeline position = - let pipeline = Mpipeline.for_completion position pipeline in - let typer = Mpipeline.typer_result pipeline in - (pipeline, typer) - -let verbosity pipeline = - Mconfig.((Mpipeline.final_config pipeline).query.verbosity) - -let dump pipeline = function - | [`String "ppxed-source"] -> - let ppf, to_string = Format.to_string () in - begin match Mpipeline.ppx_parsetree pipeline with - | `Interface s -> Pprintast.signature ppf s - | `Implementation s -> Pprintast.structure ppf s - end; - Format.pp_print_newline ppf (); - Format.pp_force_newline ppf (); - `String (to_string ()) - - | [`String "source"] -> - let ppf, to_string = Format.to_string () in - begin match Mpipeline.reader_parsetree pipeline with - | `Interface s -> Pprintast.signature ppf s - | `Implementation s -> Pprintast.structure ppf s - end; - Format.pp_print_newline ppf (); - Format.pp_force_newline ppf (); - `String (to_string ()) - - | [`String "parsetree"] -> - let ppf, to_string = Format.to_string () in - begin match Mpipeline.reader_parsetree pipeline with - | `Interface s -> Printast.interface ppf s - | `Implementation s -> Printast.implementation ppf s - end; - Format.pp_print_newline ppf (); - Format.pp_force_newline ppf (); - `String (to_string ()) - - | [`String "ppxed-parsetree"] -> - let ppf, to_string = Format.to_string () in - begin match Mpipeline.ppx_parsetree pipeline with - | `Interface s -> Printast.interface ppf s - | `Implementation s -> Printast.implementation ppf s - end; - Format.pp_print_newline ppf (); - Format.pp_force_newline ppf (); - `String (to_string ()) - - | (`String ("env" | "fullenv" as kind) :: opt_pos) -> - let typer = Mpipeline.typer_result pipeline in - let kind = if kind = "env" then `Normal else `Full in - let pos = - match opt_pos with - | [`String "at"; jpos] -> - Some (match jpos with - | `String "start" -> `Start - | `String "end" -> `End - | `Int offset -> `Offset offset - | `Assoc props -> - begin match List.assoc "line" props, List.assoc "col" props with - | `Int line, `Int col -> `Logical (line,col) - | _ -> failwith "Incorrect position" - | exception Not_found -> failwith "Incorrect position" - end - | _ -> failwith "Incorrect position" - ) - | [] -> None - | _ -> failwith "incorrect position" - in - let env = match pos with - | None -> Mtyper.get_env typer - | Some pos -> - let pos = Mpipeline.get_lexing_pos pipeline pos in - fst (Mbrowse.leaf_node (Mtyper.node_at typer pos)) - in - let sg = Browse_misc.signature_of_env ~ignore_extensions:(kind = `Normal) env in - let aux item = - let ppf, to_string = Format.to_string () in - Printtyp.signature ppf [item]; - `String (to_string ()) - in - `List (List.map ~f:aux sg) - - | [`String "browse"] -> - let typer = Mpipeline.typer_result pipeline in - let structure = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - Browse_misc.dump_browse (snd (Mbrowse.leaf_node structure)) - - | [`String "current-level"] -> - let _typer = Mpipeline.typer_result pipeline in - `Int (Ctype.get_current_level ()) - - | [`String "tokens"] -> - failwith "TODO" - - | [`String "flags"] -> - let prepare_flags flags = - Json.list Json.string (List.concat_map flags ~f:(fun f -> f.workval)) in - let user = prepare_flags - Mconfig.((Mpipeline.input_config pipeline).merlin.flags_to_apply) in - let applied = prepare_flags - Mconfig.((Mpipeline.final_config pipeline).merlin.flags_applied) in - `Assoc [ "user", user; "applied", applied ] - - | [`String "warnings"] -> - let _typer = Mpipeline.typer_result pipeline in - Warnings.dump () (*TODO*) - - | [`String "exn"] -> - let exns = - Mpipeline.reader_lexer_errors pipeline @ - Mpipeline.reader_parser_errors pipeline @ - Mpipeline.typer_errors pipeline - in - `List (List.map ~f:(fun x -> `String (Printexc.to_string x)) exns) - - | [`String "paths"] -> - let paths = Mconfig.build_path (Mpipeline.final_config pipeline) in - `List (List.map paths ~f:(fun s -> `String s)) - - | [`String "typedtree"] -> - let tree = - Mpipeline.typer_result pipeline - |> Mtyper.get_typedtree - in - let ppf, to_string = Format.to_string () in - begin match tree with - | `Interface s -> Printtyped.interface ppf s - | `Implementation s -> Printtyped.implementation ppf s - end; - Format.pp_print_newline ppf (); - Format.pp_force_newline ppf (); - `String (to_string ()) - - | _ -> failwith "known dump commands: \ - paths, exn, warnings, flags, tokens, browse, source, \ - parsetree, ppxed-source, ppxed-parsetree, typedtree, \ - env/fullenv (at {col:, line:})" - -let reconstruct_identifier pipeline pos = function - | None -> - let path = Mreader.reconstruct_identifier - (Mpipeline.input_config pipeline) - (Mpipeline.raw_source pipeline) - pos - in - let path = Mreader_lexer.identifier_suffix path in - Logger.log - ~section:Type_enclosing.log_section - ~title:"reconstruct-identifier" - "paths: [%s]" - (String.concat ~sep:";" (List.map path - ~f:(fun l -> l.Location.txt))); - let reify dot = - if dot = "" || - (dot.[0] >= 'a' && dot.[0] <= 'z') || - (dot.[0] >= 'A' && dot.[0] <= 'Z') - then dot - else "(" ^ dot ^ ")" - in - begin match path with - | [] -> [] - | base :: tail -> - let f {Location. txt=base; loc=bl} {Location. txt=dot; loc=dl} = - let loc = Location_aux.union bl dl in - let txt = base ^ "." ^ reify dot in - Location.mkloc txt loc - in - [ List.fold_left tail ~init:base ~f ] - end - | Some (expr, offset) -> - let loc_start = - let l, c = Lexing.split_pos pos in - Lexing.make_pos (l, c - offset) - in - let shift loc int = - let l, c = Lexing.split_pos loc in - Lexing.make_pos (l, c + int) - in - let add_loc source = - let loc = - { Location. - loc_start ; - loc_end = shift loc_start (String.length source) ; - loc_ghost = false ; - } in - Location.mkloc source loc - in - let len = String.length expr in - let rec aux acc i = - if i >= len then - List.rev_map ~f:add_loc (expr :: acc) - else if expr.[i] = '.' then - aux (String.sub expr ~pos:0 ~len:i :: acc) (succ i) - else - aux acc (succ i) in - aux [] offset - -let dispatch pipeline (type a) : a Query_protocol.t -> a = - function - | Type_expr (source, pos) -> - let typer = Mpipeline.typer_result pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in - let ppf, to_string = Format.to_string () in - let verbosity = verbosity pipeline in - let context = Context.Expr in - ignore (Type_utils.type_in_env ~verbosity ~context env ppf source : bool); - to_string () - - | Type_enclosing (expro, pos, index) -> - let typer = Mpipeline.typer_result pipeline in - let verbosity = verbosity pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let structures = Mbrowse.enclosing pos - [Mbrowse.of_typedtree (Mtyper.get_typedtree typer)] in - let path = match structures with - | [] -> [] - | browse -> Browse_misc.annotate_tail_calls browse - in - - let result = Type_enclosing.from_nodes ~path in - - (* enclosings of cursor in given expression *) - let exprs = reconstruct_identifier pipeline pos expro in - let () = - Logger.log ~section:Type_enclosing.log_section - ~title:"reconstruct identifier" "%a" - Logger.json (fun () -> - let lst = - List.map exprs ~f:(fun { Location.loc; txt } -> - `Assoc [ "start", Lexing.json_of_position loc.Location.loc_start - ; "end", Lexing.json_of_position loc.Location.loc_end - ; "identifier", `String txt] - ) - in - `List lst - ) - in - let small_enclosings = - Type_enclosing.from_reconstructed exprs - ~nodes:structures ~cursor:pos ~verbosity - in - Logger.log ~section:Type_enclosing.log_section ~title:"small enclosing" "%a" - Logger.fmt (fun fmt -> - Format.fprintf fmt "result = [ %a ]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun fmt (loc, _, _) -> Location.print_loc fmt loc)) - small_enclosings - ); - - let ppf = Format.str_formatter in - let all_results = List.mapi (small_enclosings @ result) - ~f:(fun i (loc,text,tail) -> - let print = match index with None -> true | Some index -> index = i in - let ret x = (loc, x, tail) in - match text with - | Type_enclosing.String str -> ret (`String str) - | Type_enclosing.Type (env, t) when print -> - Printtyp.wrap_printing_env env ~verbosity - (fun () -> Type_utils.print_type_with_decl ~verbosity env ppf t); - ret (`String (Format.flush_str_formatter ())) - | Type_enclosing.Type_decl (env, id, t) when print -> - Printtyp.wrap_printing_env env ~verbosity - (fun () -> Printtyp.type_declaration env id ppf t); - ret (`String (Format.flush_str_formatter ())) - | Type_enclosing.Modtype (env, m) when print -> - Printtyp.wrap_printing_env env ~verbosity - (fun () -> Printtyp.modtype env ppf m); - ret (`String (Format.flush_str_formatter ())) - | _ -> ret (`Index i) - ) - in - let normalize ({Location. loc_start; loc_end; _}, text, _tail) = - Lexing.split_pos loc_start, Lexing.split_pos loc_end, text - in - (* We remove duplicates from the list. Duplicates can appear when the type - from the reconstructed identifier is the same as the one stored in the - typedtree *) - List.merge_cons - ~f:(fun a b -> - if compare (normalize a) (normalize b) = 0 then Some b else None) - all_results - - | Enclosing pos -> - let typer = Mpipeline.typer_result pipeline in - let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let path = match Mbrowse.enclosing pos [structures] with - | [] -> [] - | path -> List.map ~f:snd path - in - List.map ~f:Mbrowse.node_loc path - - | Locate_type pos -> - let typer = Mpipeline.typer_result pipeline in - let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let node = - match Mbrowse.enclosing pos [structures] with - | path :: _ -> Some path - | [] -> None - in - let path = - Option.bind node ~f:(fun (env, node) -> - Locate.log ~title:"query_commands Locate_type" - "inspecting node: %s" (Browse_raw.string_of_node node); - match node with - | Browse_raw.Expression {exp_type = ty; _} - | Pattern {pat_type = ty; _} - | Core_type {ctyp_type = ty; _} - | Value_description { val_desc = { ctyp_type = ty; _ }; _ } -> - begin match Types.get_desc ty with - | Tconstr (path, _, _) -> Some (env, path) - | _ -> None - end - | _ -> None) - in - begin match path with - | None -> `Invalid_context - | Some (env, path) -> - Locate.log ~title:"debug" "found type: %s" (Path.name path); - match Locate.from_path - ~env - ~config:(Mpipeline.final_config pipeline) - ~namespace:`Type `MLI - path with - | `Builtin -> `Builtin (Path.name path) - | `Not_in_env _ as s -> s - | `Not_found _ as s -> s - | `Found (_uid, file, pos) -> `Found (file, pos) - | `File_not_found _ as s -> s - end - - | Complete_prefix (prefix, pos, kinds, with_doc, with_types) -> - let pipeline, typer = for_completion pipeline pos in - let config = Mpipeline.final_config pipeline in - let verbosity = Mconfig.(config.query.verbosity) in - let no_labels = Mpipeline.reader_no_labels_for_completion pipeline in - let source = Mpipeline.input_source pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let branch = Mtyper.node_at ~skip_recovered:true typer pos in - let env, _ = Mbrowse.leaf_node branch in - let target_type, context = - Completion.application_context ~prefix branch in - let get_doc = - if not with_doc then None else - let local_defs = Mtyper.get_typedtree typer in - Some (Locate.get_doc ~config ~env ~local_defs - ~comments:(Mpipeline.reader_comments pipeline) ~pos) - in - let keywords = Mpipeline.reader_lexer_keywords pipeline in - let entries = - Printtyp.wrap_printing_env env ~verbosity @@ fun () -> - Completion.branch_complete config ~kinds ?get_doc ?target_type ~keywords - prefix branch - |> print_completion_entries ~with_types config source - and context = match context with - | `Application context when no_labels -> - `Application {context with Compl.labels = []} - | context -> context - in - {Compl. entries; context } - - | Expand_prefix (prefix, pos, kinds, with_types) -> - let pipeline, typer = for_completion pipeline pos in - let source = Mpipeline.input_source pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in - let config = Mpipeline.final_config pipeline in - let global_modules = Mconfig.global_modules config in - let entries = - Completion.expand_prefix env ~global_modules ~kinds prefix |> - print_completion_entries ~with_types config source - in - { Compl. entries ; context = `Unknown } - - | Polarity_search (query, pos) -> - let typer = Mpipeline.typer_result pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in - let query = - let re = Str.regexp "[ |\t]+" in - let pos,neg = Str.split re query |> List.partition ~f:(fun s->s.[0]<>'-') in - let prepare s = - Longident.parse @@ - if s.[0] = '-' || s.[0] = '+' - then String.sub s ~pos:1 ~len:(String.length s - 1) - else s - in - Polarity_search.build_query env - ~positive:(List.map pos ~f:prepare) - ~negative:(List.map neg ~f:prepare) - in - let config = Mpipeline.final_config pipeline in - let global_modules = Mconfig.global_modules config in - let dirs = Polarity_search.directories ~global_modules env in - ignore (Format.flush_str_formatter ()); - let entries = - Polarity_search.execute_query query env dirs |> - List.sort ~cmp:compare |> - Printtyp.wrap_printing_env env ~verbosity:(verbosity pipeline) @@ fun () -> - List.map ~f:(fun (_, path, v) -> - Printtyp.path Format.str_formatter path; - let name = Format.flush_str_formatter () in - Printtyp.type_scheme env Format.str_formatter v.Types.val_type; - let desc = Format.flush_str_formatter () in - {Compl. name; kind = `Value; desc; info = ""; deprecated = false } - ) - in - { Compl. entries ; context = `Unknown } - - | Refactor_open (mode, pos) -> - let typer = Mpipeline.typer_result pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - Refactor_open.get_rewrites ~mode typer pos - - | Document (patho, pos) -> - let typer = Mpipeline.typer_result pipeline in - let local_defs = Mtyper.get_typedtree typer in - let config = Mpipeline.final_config pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let comments = Mpipeline.reader_comments pipeline in - let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in - let path = - match patho with - | Some p -> p - | None -> - let path = reconstruct_identifier pipeline pos None in - let path = Mreader_lexer.identifier_suffix path in - let path = List.map ~f:(fun {Location. txt; _} -> txt) path in - String.concat ~sep:"." path - in - if path = "" then `Invalid_context else - Locate.get_doc ~config - ~env ~local_defs ~comments ~pos (`User_input path) - - | Locate (patho, ml_or_mli, pos) -> - let typer = Mpipeline.typer_result pipeline in - let local_defs = Mtyper.get_typedtree typer in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in - let path = - match patho with - | Some p -> p - | None -> - let path = reconstruct_identifier pipeline pos None in - let path = Mreader_lexer.identifier_suffix path in - let path = List.map ~f:(fun {Location. txt; _} -> txt) path in - let path = String.concat ~sep:"." path in - Locate.log ~title:"reconstructed identifier" "%s" path; - path - in - if path = "" then `Invalid_context else - begin match - Locate.from_string - ~config:(Mpipeline.final_config pipeline) - ~env ~local_defs ~pos ml_or_mli path - with - | `Found (_, file, pos) -> - Locate.log ~title:"result" - "found: %s" (Option.value ~default:"" file); - `Found (file, pos) - | `Missing_labels_namespace -> - (* Can't happen because we haven't passed a namespace as input. *) - assert false - | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _|`Builtin _) as - otherwise -> - Locate.log ~title:"result" "not found"; - otherwise - end - - | Jump (target, pos) -> - let typer = Mpipeline.typer_result pipeline in - let typedtree = Mtyper.get_typedtree typer in - let pos = Mpipeline.get_lexing_pos pipeline pos in - Jump.get typedtree pos target - - | Phrase (target, pos) -> - let typer = Mpipeline.typer_result pipeline in - let typedtree = Mtyper.get_typedtree typer in - let pos = Mpipeline.get_lexing_pos pipeline pos in - Mpipeline.get_lexing_pos pipeline (Jump.phrase typedtree pos target) - - | Case_analysis (pos_start, pos_end) -> - let typer = Mpipeline.typer_result pipeline in - let pos_start = Mpipeline.get_lexing_pos pipeline pos_start in - let pos_end = Mpipeline.get_lexing_pos pipeline pos_end in - let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - let nodes = Mbrowse.enclosing pos_start [browse] in - let dump_node (_,node) = - let {Location. loc_start; loc_end; _} = - Mbrowse.node_loc node in - let l1,c1 = Lexing.split_pos loc_start in - let l2,c2 = Lexing.split_pos loc_end in - `List [ - `String (Browse_raw.string_of_node node); - `Int l1; `Int c1; - `Int l2; `Int c2; - ] - in - Destruct.log ~title:"nodes before" "%a" - Logger.json (fun () -> `List (List.map nodes ~f:dump_node)); - let nodes = - (* Drop nodes that: - - start inside the user's selection - - finish inside the user's selection - *) - List.drop_while nodes - ~f:(fun (_,t) -> - let {Location. loc_start; loc_end; _} = Mbrowse.node_loc t in - Lexing.compare_pos loc_start pos_start > 0 || Lexing.compare_pos loc_end pos_end < 0) - in - Destruct.log ~title:"nodes after" "%a" - Logger.json (fun () -> `List (List.map nodes ~f:dump_node)); - begin match nodes with - | [] -> raise Destruct.Nothing_to_do - | (env,node) :: parents -> - let source = Mpipeline.input_source pipeline in - let config = Mpipeline.final_config pipeline in - let verbosity = verbosity pipeline in - Printtyp.wrap_printing_env env ~verbosity @@ fun () -> - Destruct.node config source node (List.map ~f:snd parents) - end - - | Holes -> - let typer = Mpipeline.typer_result pipeline in - let verbosity = verbosity pipeline in - let nodes = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - let ppf = Format.str_formatter in - let print ~nodes loc env type_ () = - match type_ with - | `Exp type_expr -> - Type_utils.print_type_with_decl ~verbosity env ppf type_expr - | `Mod module_type -> - (* For module_expr holes we need the type of the next enclosing - to get a useful result *) - match Mbrowse.enclosing (loc.Location.loc_start) [nodes] with - | _ :: (_, Browse_raw.Module_expr { mod_type; _}) :: _ -> - Printtyp.modtype env ppf mod_type - | _ -> - Printtyp.modtype env ppf module_type - in - let loc_and_types_of_holes node = - List.map (Browse_raw.all_holes node) ~f:( - fun (loc, env, type_) -> - Printtyp.wrap_printing_env env ~verbosity - (print ~nodes loc env type_); - (loc, Format.flush_str_formatter ())) - in - List.concat_map ~f:loc_and_types_of_holes nodes - - | Construct (pos, with_values, depth) -> - let values_scope = match with_values with - | Some `None | None -> Construct.Null - | Some `Local -> Construct.Local - in - let keywords = Mpipeline.reader_lexer_keywords pipeline in - let typer = Mpipeline.typer_result pipeline in - let typedtree = Mtyper.get_typedtree typer in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let structures = Mbrowse.enclosing pos - [Mbrowse.of_typedtree typedtree] in - begin match structures with - | (_, (Browse_raw.Module_expr { mod_desc = Tmod_hole; _ } as node_for_loc)) - :: (_, node) :: _parents -> - let loc = Mbrowse.node_loc node_for_loc in - (loc, Construct.node ~keywords ?depth ~values_scope node) - | (_, (Browse_raw.Expression { exp_desc = Texp_hole; _ } as node)) - :: _parents -> - let loc = Mbrowse.node_loc node in - (loc, Construct.node ~keywords ?depth ~values_scope node) - | _ :: _ -> raise Construct.Not_a_hole - | [] -> raise No_nodes - end - - | Outline -> - let typer = Mpipeline.typer_result pipeline in - let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - Outline.get [Browse_tree.of_browse browse] - - | Shape pos -> - let typer = Mpipeline.typer_result pipeline in - let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - let pos = Mpipeline.get_lexing_pos pipeline pos in - Outline.shape pos [Browse_tree.of_browse browse] - - | Errors { lexing; parsing; typing }-> - let typer = Mpipeline.typer_result pipeline in - let verbosity = verbosity pipeline in - Printtyp.wrap_printing_env (Mtyper.get_env typer) ~verbosity @@ fun () -> - let lexer_errors = Mpipeline.reader_lexer_errors pipeline in - let parser_errors = Mpipeline.reader_parser_errors pipeline in - let typer_errors = Mpipeline.typer_errors pipeline in - (* When there is a cmi error, we will have a lot of meaningless errors, - there is no need to report them. *) - let typer_errors = - let cmi_error = function Magic_numbers.Cmi.Error _ -> true | _ -> false in - match List.find typer_errors ~f:cmi_error with - | e -> [e] - | exception Not_found -> typer_errors - in - let error_start e = (Location.loc_of_report e).Location.loc_start in - let error_end e = (Location.loc_of_report e).Location.loc_end in - (* Turn into Location.error, ignore ghost warnings *) - let filter_error exn = - match Location.error_of_exn exn with - | None | Some `Already_displayed -> None - | Some (`Ok (err : Location.error)) -> - if (Location.loc_of_report err).loc_ghost && - (match exn with Msupport.Warning _ -> true | _ -> false) - then None - else Some err - in - let lexer_errors = List.filter_map ~f:filter_error lexer_errors in - (* Ast can contain syntax error *) - let first_syntax_error = ref Lexing.dummy_pos in - let filter_typer_error exn = - let result = filter_error exn in - begin match result with - | Some ({Location. source = Location.Parser; _} as err) - when !first_syntax_error = Lexing.dummy_pos || - Lexing.compare_pos !first_syntax_error (error_start err) > 0 -> - first_syntax_error := error_start err; - | _ -> () - end; - result - in - let typer_errors = List.filter_map ~f:filter_typer_error typer_errors in - (* Track first parsing error *) - let filter_parser_error = function - | Msupport.Warning _ as exn -> filter_error exn - | exn -> - let result = filter_error exn in - begin match result with - | None -> () - | Some err -> - if !first_syntax_error = Lexing.dummy_pos || - Lexing.compare_pos !first_syntax_error (error_start err) > 0 - then first_syntax_error := error_start err; - end; - result - in - let parser_errors = List.filter_map ~f:filter_parser_error parser_errors in - (* Sort errors *) - let cmp e1 e2 = - let n = Lexing.compare_pos (error_start e1) (error_start e2) in - if n <> 0 then n else - Lexing.compare_pos (error_end e1) (error_end e2) - in - let errors = - List.sort_uniq ~cmp - ((if lexing then lexer_errors else []) @ - (if parsing then parser_errors else []) @ - (if typing then typer_errors else [])) - in - (* Add configuration errors *) - let errors = - let cfg = Mpipeline.final_config pipeline in - let failures = - List.map ~f:(Location.error ~source:Location.Config) cfg.merlin.failures - in - failures @ errors - in - (* Filter anything after first parse error *) - let limit = !first_syntax_error in - if limit = Lexing.dummy_pos then errors else ( - List.take_while errors - ~f:(fun err -> Lexing.compare_pos (error_start err) limit <= 0) - ) - - | Dump args -> dump pipeline args - - | Path_of_source xs -> - let config = Mpipeline.final_config pipeline in - let rec aux = function - | [] -> raise Not_found - | x :: xs -> - try - find_in_path_uncap (Mconfig.source_path config) x - with Not_found -> try - find_in_path_uncap (Mconfig.build_path config) x - with Not_found -> - aux xs - in - aux xs - - | List_modules exts -> - let config = Mpipeline.final_config pipeline in - let with_ext ext = modules_in_path ~ext - Mconfig.(config.merlin.source_path) in - List.concat_map ~f:with_ext exts - - | Findlib_list -> - [] - - | Extension_list kind -> - let config = Mpipeline.final_config pipeline in - let enabled = Mconfig.(config.merlin.extensions) in - begin match kind with - | `All -> Extension.all - | `Enabled -> enabled - | `Disabled -> - List.fold_left ~f:(fun exts ext -> List.remove ext exts) - ~init:Extension.all enabled - end - - | Path_list `Build -> - let config = Mpipeline.final_config pipeline in - Mconfig.(config.merlin.build_path) - - | Path_list `Source -> - let config = Mpipeline.final_config pipeline in - Mconfig.(config.merlin.source_path) - - | Occurrences (`Ident_at pos) -> - let typer = Mpipeline.typer_result pipeline in - let str = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let enclosing = Mbrowse.enclosing pos [str] in - let curr_node = - let is_wildcard_pat = function - | Browse_raw.Pattern {pat_desc = Typedtree.Tpat_any; _} -> true - | _ -> false - in - List.find_some enclosing ~f:(fun (_, node) -> - (* it doesn't make sense to find occurrences of a wildcard pattern *) - not (is_wildcard_pat node)) - |> Option.map ~f:(fun (env, node) -> Browse_tree.of_node ~env node) - |> Option.value ~default:Browse_tree.dummy - in - let str = Browse_tree.of_browse str in - let get_loc {Location.txt = _; loc} = loc in - let ident_occurrence () = - let paths = Browse_raw.node_paths curr_node.Browse_tree.t_node in - let under_cursor p = Location_aux.compare_pos pos (get_loc p) = 0 in - Logger.log ~section:"occurrences" ~title:"Occurrences paths" "%a" - Logger.json (fun () -> - let dump_path ({Location.txt; loc} as p) = - let ppf, to_string = Format.to_string () in - Printtyp.path ppf txt; - `Assoc [ - "start", Lexing.json_of_position loc.Location.loc_start; - "end", Lexing.json_of_position loc.Location.loc_end; - "under_cursor", `Bool (under_cursor p); - "path", `String (to_string ()) - ] - in - `List (List.map ~f:dump_path paths)); - match List.filter paths ~f:under_cursor with - | [] -> [] - | (path :: _) -> - let path = path.Location.txt in - let ts = Browse_tree.all_occurrences path str in - let loc (_t,paths) = List.map ~f:get_loc paths in - List.concat_map ~f:loc ts - - in - let constructor_occurrence d = - let ts = Browse_tree.all_constructor_occurrences (curr_node,d) str in - List.map ~f:get_loc ts - - in - let locs = - match Browse_raw.node_is_constructor curr_node.Browse_tree.t_node with - | Some d -> constructor_occurrence d.Location.txt - | None -> ident_occurrence () - in - let loc_start l = l.Location.loc_start in - let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in - List.sort ~cmp locs - - | Version -> - Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" - Merlin_config.version Sys.ocaml_version; diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/query_commands.mli b/ocaml-lsp-server/vendor/merlin/src/frontend/query_commands.mli deleted file mode 100644 index 7663d00ed..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/query_commands.mli +++ /dev/null @@ -1,32 +0,0 @@ - -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -exception No_nodes - -val dispatch : Mpipeline.t -> 'a Query_protocol.t -> 'a diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/query_protocol.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/query_protocol.ml deleted file mode 100644 index 1322bc15c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/query_protocol.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -module Compl = -struct - type 'desc raw_entry = { - name: string; - kind: [`Value|`Constructor|`Variant|`Label| - `Module|`Modtype|`Type|`MethodCall|`Keyword]; - desc: 'desc; - info: 'desc; - deprecated: bool; - } - - type entry = string raw_entry - - type application_context = { - argument_type: string; - labels : (string * string) list; - } - - type t = { - entries: entry list; - context: [ `Unknown - | `Application of application_context - ] - } - - type kind = [ - | `Constructor - | `Labels - | `Modules - | `Modules_type - | `Types - | `Values - | `Variants - | `Keywords - ] -end - -type completions = Compl.t - -type outline = item list -and item = { - outline_name : string ; - outline_kind : [ - | `Value - | `Constructor - | `Label - | `Module - | `Modtype - | `Type - | `Exn - | `Class - | `Method - ]; - outline_type : string option ; - deprecated : bool ; - location : Location_aux.t ; - children : outline ; -} - -type shape = { - shape_loc : Location_aux.t; - shape_sub : shape list; -} - -type error_filter = { - lexing : bool; - parsing : bool; - typing : bool; -} - -type is_tail_position = [`No | `Tail_position | `Tail_call] - -type _ _bool = bool - -type _ t = - | Type_expr(* *) - : string * Msource.position - -> string t - | Type_enclosing(* *) - : (string * int) option * Msource.position * int option - -> (Location.t * [`String of string | `Index of int] * is_tail_position) list t - | Enclosing(* *) - : Msource.position - -> Location.t list t - | Complete_prefix(* *) - : string * Msource.position * Compl.kind list * - [`with_documentation] _bool * [`with_types] _bool - -> completions t - | Expand_prefix(* *) - : string * Msource.position * Compl.kind list * [`with_types] _bool - -> completions t - | Polarity_search - : string * Msource.position - -> completions t - | Refactor_open - : [`Qualify | `Unqualify] * Msource.position - -> (string * Location.t) list t - | Document(* *) - : string option * Msource.position - -> [ `Found of string - | `Invalid_context - | `Builtin of string - | `Not_in_env of string - | `File_not_found of string - | `Not_found of string * string option - | `No_documentation - ] t - | Locate_type - : Msource.position - -> [ `Found of string option * Lexing.position - | `Invalid_context - | `Builtin of string - | `Not_in_env of string - | `File_not_found of string - | `Not_found of string * string option - | `At_origin - ] t - | Locate(* *) - : string option * [ `ML | `MLI ] * Msource.position - -> [ `Found of string option * Lexing.position - | `Invalid_context - | `Builtin of string - | `Not_in_env of string - | `File_not_found of string - | `Not_found of string * string option - | `At_origin - ] t - | Jump(* *) - : string * Msource.position - -> [ `Found of Lexing.position - | `Error of string - ] t - | Phrase(* *) - : [`Next | `Prev] * Msource.position - -> Lexing.position t - | Case_analysis(* *) - : Msource.position * Msource.position -> (Location.t * string) t - | Holes(* *) - : (Location.t * string) list t - | Construct - : Msource.position * [`None | `Local] option * int option - -> (Location.t * string list) t - | Outline(* *) - : outline t - | Shape(* *) - : Msource.position - -> shape list t - | Errors(* *) - : error_filter - -> Location.error list t - | Dump - : Std.json list - -> Std.json t - | Path_of_source(* *) - : string list - -> string t - | List_modules(* *) - : string list - -> string list t - | Findlib_list - : string list t - | Extension_list - : [`All|`Enabled|`Disabled] - -> string list t - | Path_list - : [`Build|`Source] - -> string list t - | Occurrences(* *) - : [`Ident_at of Msource.position] - -> Location.t list t - | Version - : string t diff --git a/ocaml-lsp-server/vendor/merlin/src/frontend/test/ocamlmerlin_test.ml b/ocaml-lsp-server/vendor/merlin/src/frontend/test/ocamlmerlin_test.ml deleted file mode 100644 index f458058cb..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/frontend/test/ocamlmerlin_test.ml +++ /dev/null @@ -1,214 +0,0 @@ -open Std - -(* Poor man's test framework *) -type name = string - -type test = - | Single of name * (unit -> unit) - | Group of name * test list - -let test name f = Single (name, f) - -let group name tests = Group (name, tests) - -exception Detail of exn * string -let () = Printexc.register_printer (function - | (Detail (exn, msg)) -> - Some (Printexc.to_string exn ^ "\nAdditional information:\n" ^ msg) - | _ -> None - ) - -let str_match ~re str = - Str.string_match (Str.regexp (re ^ "$")) str 0 - -(* Setting up merlin *) -module M = Mpipeline - -let process ?(with_config=fun x -> x) ?for_completion filename text = - let config = with_config Mconfig.initial in - let config = Mconfig.({config with query = {config.query with filename}}) in - let source = Msource.make Trace.null config text in - let pipeline = M.make Trace.null config source in - match for_completion with - | None -> pipeline - | Some pos -> M.for_completion pos pipeline - -(* All tests *) - -let assert_errors ?with_config - filename ?(lexer=0) ?(parser=0) ?(typer=0) ?(config=0) source = - test filename (fun () -> - let m = process ?with_config filename source in - let lexer_errors = M.reader_lexer_errors m in - let parser_errors = M.reader_parser_errors m in - let failures, typer_errors = - Mtyper.with_typer (M.typer_result m) @@ fun () -> - Mconfig.((M.final_config m).merlin.failures), - M.typer_errors m - in - let fmt_msg exn = - match Location.error_of_exn exn with - | None | Some `Already_displayed -> Printexc.to_string exn - | Some (`Ok err) -> err.Location.msg - in - let expect ~count str errors = - let count' = List.length errors in - if count <> count' then failwith ( - "expecting " ^ string_of_int count ^ " " ^ str ^ " but got " ^ - string_of_int count' ^ " errors\n" ^ - String.concat "\n- " ("Errors: " :: List.map_end fmt_msg - (lexer_errors @ parser_errors @ typer_errors) - failures) - ) - in - expect ~count:lexer "lexer errors" lexer_errors; - expect ~count:parser "parser errors" parser_errors; - expect ~count:typer "typer errors" typer_errors; - expect ~count:config "configuration failures" failures; - ) - -let assertf b fmt = - if b then - Printf.ikfprintf ignore () fmt - else - Printf.ksprintf failwith fmt - -let validate_output ?with_config filename source query pred = - test filename (fun () -> - let pipeline = process ?with_config filename source in - let result = Query_commands.dispatch pipeline query in - try pred result - with exn -> - let info = `Assoc [ - "query", Query_json.dump query; - "result", Query_json.json_of_response query result; - ] in - raise (Detail (exn, Json.pretty_to_string info)) - ) - -(* FIXME: this sucks. improve. *) -let validate_failure ?with_config filename source query pred = - test filename (fun () -> - let pipeline = process ?with_config filename source in - let for_info, wrapped = - match Query_commands.dispatch pipeline query with - | exception e -> ("failure", `String (Printexc.to_string e)), `Error e - | res -> ("result", Query_json.json_of_response query res), `Ok res - in - try pred wrapped - with exn -> - let info = `Assoc [ "query", Query_json.dump query; for_info ] in - raise (Detail (exn, Json.pretty_to_string info)) - ) - -let tests = [ - - group "misc" ( - [ - assert_errors "relaxed_external.ml" - "external test : unit = \"bs\""; - - validate_output "occurrences.ml" - "let foo _ = ()\nlet () = foo 4\n" - (Query_protocol.Occurrences (`Ident_at (`Offset 5))) - (fun locations -> - assertf (List.length locations = 2) "expected two locations"); - ] - ); - - group "std" [ - - group "glob" ( - let glob_match ~pattern str = - Glob.match_pattern (Glob.compile_pattern pattern) str in - let should_match name ~pattern str = - test name (fun () -> assertf (glob_match ~pattern str) - "pattern %S should match %S" pattern str) - and shouldn't_match name ~pattern str = - test name (fun () -> assertf (not (glob_match ~pattern str)) - "pattern %S shouldn't match %S" pattern str) - in - [ - should_match "empty" ~pattern:"" ""; - shouldn't_match "not-empty" ~pattern:"" "x"; - should_match "litteral" ~pattern:"x" "x"; - shouldn't_match "not-litteral" ~pattern:"x" "y"; - should_match "skip" ~pattern:"x?z" "xyz"; - shouldn't_match "not-skip" ~pattern:"x?yz" "xyz"; - should_match "joker1" ~pattern:"x*" "xyz"; - shouldn't_match "not-joker1" ~pattern:"y*" "xyz"; - should_match "joker2" ~pattern:"xy*xy*" "xyzxyz"; - shouldn't_match "not-joker2" ~pattern:"xy*yz*" "xyzyxz"; - should_match "joker3" ~pattern:"*bar*" "foobarbaz"; - ] - ); - - group "shell" ( - let string_list = function - | [] -> "[]" - | comps -> - let comps = List.map ~f:String.escaped comps in - "[\"" ^ String.concat ~sep:"\";\"" comps ^ "\"]" - in - let assert_split i (str, expected) = - test ("split_command-" ^ string_of_int i) @@ fun () -> - let result = Shell.split_command str in - assertf (result = expected) - "Shell.split_command %S = %s, expecting %s" - str (string_list result) (string_list expected) - in - List.mapi ~f:assert_split [ - "a b c" , ["a";"b";"c"]; - "a'b'c" , ["abc"]; - "a 'b c'" , ["a"; "b c"]; - "a\"b'c\"" , ["ab'c"]; - "a\\\"b'c'" , ["a\"bc"]; - ] - ); - ]; -] - -(* Driver *) - -let passed = ref 0 -let failed = ref 0 - -let rec run_tests indent = function - | [] -> () - | x :: xs -> - run_test indent x; - run_tests indent xs - -and run_test indent = function - | Single (name, f) -> - Printf.printf "%s%s:\t%!" indent name; - begin match f () with - | () -> - incr passed; - Printf.printf "OK\n%!" - | exception exn -> - let bt = Printexc.get_backtrace () in - incr failed; - Printf.printf "KO\n%!"; - Printf.eprintf "%sTest %s failed with exception:\n%s%s\n%!" - indent name - indent - (match exn with - | Failure str -> str - | exn -> Printexc.to_string exn); - begin match Location.error_of_exn exn with - | None | Some `Already_displayed -> () - | Some (`Ok {Location. msg; loc}) -> - Printf.eprintf "%sError message:\n%s\n%!" indent msg - end; - Printf.eprintf "%sBacktrace:\n%s\n%!" indent bt - end - | Group (name, tests) -> - Printf.printf "%s-> %s\n" indent name; - run_tests (indent ^ " ") tests - -let () = - Printexc.record_backtrace true; - run_tests " " tests; - Printf.printf "Passed %d, failed %d\n" !passed !failed; - if !failed > 0 then exit 1 diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/dune b/ocaml-lsp-server/vendor/merlin/src/kernel/dune deleted file mode 100644 index aaba3f232..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/dune +++ /dev/null @@ -1,22 +0,0 @@ -(rule (copy# ../ocaml/driver/pparse.ml pparse.ml )) -(rule (copy# ../ocaml/driver/pparse.mli pparse.mli)) - -(library - (name merlin_kernel) - (public_name merlin-lib.kernel) - (flags - :standard - -open Ocaml_utils - -open Merlin_utils - -open Ocaml_parsing - -open Ocaml_preprocess - -open Ocaml_typing - -open Merlin_specific - -open Merlin_extend) - (libraries merlin_config os_ipc ocaml_parsing ocaml_preprocess ocaml_typing ocaml_utils - merlin_extend merlin_specific merlin_utils merlin_dot_protocol spawn)) - -(rule - (targets standard_library.ml) - (action - (write-file %{targets} "let path = {|%{ocaml-config:standard_library}|}"))) diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/extension.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/extension.ml deleted file mode 100644 index 91a08cdd5..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/extension.ml +++ /dev/null @@ -1,194 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Parser_raw - -exception Unknown - -type t = { - name : string; - private_def : string list; - public_def : string list; - packages : string list; - keywords : (string * Parser_raw.token) list; -} - -type set = string list - -(* Private definitions are put in a fake module named "_" with the following - * ident. Use it to test or find private definitions. *) -let ident = Ident.create_persistent "_" - -(** Definition of each extension *) -let ext_lwt = { - name = "lwt"; - private_def = [ - "module Lwt : sig - val un_lwt : 'a Lwt.t -> 'a - val in_lwt : 'a Lwt.t -> 'a Lwt.t - val to_lwt : 'a -> 'a Lwt.t - val finally' : 'a Lwt.t -> unit Lwt.t -> 'a Lwt.t - val un_stream : 'a Lwt_stream.t -> 'a - val unit_lwt : unit Lwt.t -> unit Lwt.t - end" - ]; - public_def = [ - "val (>>) : unit Lwt.t -> 'a Lwt.t -> 'a Lwt.t - val raise_lwt : exn -> 'a Lwt.t - val assert_lwt : bool -> unit Lwt.t" - ]; - keywords = [ - "lwt", LET_LWT; - "try_lwt", TRY_LWT; - "match_lwt", MATCH_LWT; - "finally", FINALLY_LWT; - "for_lwt", FOR_LWT; - "while_lwt", WHILE_LWT; - ]; - packages = ["lwt.syntax"]; -} - -let ext_nonrec = { - name = "nonrec"; - private_def = []; - public_def = []; - keywords = [ - "nonrec", NONREC; - ]; - packages = []; -} - -let ext_meta = { - name = "meta"; - private_def = [ - "module Meta : sig - val code : 'a -> 'a code - val uncode : 'a code -> 'a - end" - ]; - public_def = []; - keywords = [ - ">.", GREATERDOT; - ]; - packages = []; -} - -(* Known extensions *) -let registry = [ext_lwt;ext_meta] -let registry = - List.fold_left registry ~init:String.Map.empty - ~f:(fun map ext -> String.Map.add map ~key:ext.name ~data:ext) - -let all = String.Map.keys registry - -let lookup s = - try Some (String.Map.find s registry) - with Not_found -> None - -let empty = [] - -(* Compute set of extensions from package names (used to enable support for - "lwt" if "lwt.syntax" is loaded by user. *) -let from ~extensions ~packages = - String.Map.fold registry ~init:[] ~f:(fun ~key:name ~data:ext set -> - if List.mem name ~set:extensions || - List.exists ~f:(List.mem ~set:ext.packages) packages - then name :: set - else set - ) - -(* Merlin expects a few extensions to be always enabled, otherwise error - recovery may fail arbitrarily *) -let default = match Merlin_config.ocamlversion with - | `OCaml_4_02_2 | `OCaml_4_03_0 -> [ext_nonrec] - | _ -> [] - -let default_kw = List.concat_map ~f:(fun ext -> ext.keywords) default - -(* Lexer keywords needed by extensions *) -let keywords set = - let add_kw kws ext = - match lookup ext with - | None -> kws - | Some def -> def.keywords @ kws - in - let all = List.fold_left set ~init:default_kw ~f:add_kw in - Lexer_raw.keywords all - -(* Register extensions in typing environment *) -let parse_sig = - let keywords = Lexer_raw.keywords [] in fun str -> - let lexbuf = Lexing.from_string str in - let state = Lexer_raw.make keywords in - let rec lexer = function - | Lexer_raw.Fail _ -> assert false - | Lexer_raw.Return x -> x - | Lexer_raw.Refill k -> lexer (k ()) - in - let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in - (Parser_raw.interface lexer lexbuf : Parsetree.signature) - -let type_sig env sg = - let sg = Typemod.transl_signature env sg in - sg.Typedtree.sig_type - -(* -let add_hidden_signature env sign = - let add_item env comp = - match comp with - | Types.Sig_value(id, decl) -> Env.add_value (Ident.hide id) decl env - | Types.Sig_type(id, decl, _) -> Env.add_type ~check:false (Ident.hide id) decl env - | Types.Sig_typext(id, decl, _) -> Env.add_extension ~check:false (Ident.hide id) decl env - | Types.Sig_module(id, mty, _) -> Env.add_module (Ident.hide id) mty.Types.md_type env - | Types.Sig_modtype(id, decl) -> Env.add_modtype (Ident.hide id) decl env - | Types.Sig_class(id, decl, _) -> Env.add_class (Ident.hide id) decl env - | Types.Sig_class_type(id, decl, _) -> Env.add_cltype (Ident.hide id) decl env - in - List.fold_left ~f:add_item ~init:env sign -*) - -let register exts env = - (* Log errors ? *) - let try_type sg' = try type_sig env sg' with _exn -> [] in - let exts = List.filter_dup exts in - let exts = List.filter_map ~f:(fun ext -> - match String.Map.find ext registry with - | ext -> Some ext - | exception Not_found -> None - ) exts - in - let process_ext e = - let prv = List.concat_map ~f:parse_sig e.private_def in - let pub = List.concat_map ~f:parse_sig e.public_def in - try_type prv, try_type pub - in - let fakes, tops = List.split (List.map ~f:process_ext exts) in - let env = Env.add_signature (List.concat tops) env in - Env.add_merlin_extension_module ident - (Types.Mty_signature (List.concat fakes)) env diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/extension.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/extension.mli deleted file mode 100644 index b46fd50fa..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/extension.mli +++ /dev/null @@ -1,75 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -exception Unknown - -(* Adjust typing environment for syntax extensions. - * See [Fake] for AST part *) - -(* Extension environment is composed of two part: - * - private definitions, not exposed to user but accessed by AST rewriters, - * - public definitions, those are made available to user in default scope, - * like the Pervasives module. - * See [Typer.initial_env] for initial environment generation. - *) - -(** Definition of an extension (as seen from Lexer and Typer) *) -type t = { - name : string; - private_def : string list; - public_def : string list; - packages : string list; - keywords : (string * Parser_raw.token) list; -} - -(* Private definitions are put in a fake module named "_" with the following - * ident. Use it to test or find private definitions. *) -val ident : Ident.t - -(** Set of extension name *) -type set = string list - -(* Lexer keywords needed by extensions *) -val keywords : set -> Lexer_raw.keywords -(* Register extensions in typing environment *) -val register : set -> Env.t -> Env.t - -(* Known extensions *) -val all : set -val registry : t String.Map.t -val lookup : string -> t option - -(* Compute set of extensions from package names (used to enable support for - "lwt" if "lwt.syntax" package is loaded by user. *) -val from : extensions:string list -> packages:string list -> set - -(* Merlin expects a few extensions to be always enabled, otherwise error - recovery may fail arbitrarily *) -val empty : set diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mbrowse.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mbrowse.ml deleted file mode 100644 index 0a8b5b11d..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mbrowse.ml +++ /dev/null @@ -1,260 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Typedtree -open Browse_raw - -type node = Browse_raw.node -type t = (Env.t * node) list - -let node_of_binary_part = Browse_raw.node_of_binary_part - -let fold_node f env t acc = - let acc = - match - Msupport.get_saved_types_from_attributes (Browse_raw.node_attributes t) - with - | [] -> acc - | parts -> - let rec aux acc = function - | [] -> acc - | part :: parts -> - let t = node_of_binary_part env part in - aux (f (Browse_raw.node_update_env env t) t acc) parts - in - aux acc parts - in - Browse_raw.fold_node f env t acc - -let approximate_loc get_loc node = - let loc = get_loc Location.none node in - if loc == Location.none then - let rec aux env node acc = - let loc = get_loc Location.none node in - if loc != Location.none then - Location_aux.union loc acc - else fold_node aux env node acc - in - aux Env.empty node Location.none - else - loc - -let node_loc node = approximate_loc Browse_raw.node_real_loc node - -(* Fuzzy locations, more likely to locate the appropriate node *) -let node_merlin_loc node = approximate_loc Browse_raw.node_merlin_loc node - -let leaf_node = List.hd -let leaf_loc t = node_loc (snd (leaf_node t)) - -let drop_leaf t = - match t with - | [] | [ _ ] -> None - | _leaf :: parents -> Some parents - -let has_attr attr_name attrs = - List.exists ~f:(fun a -> - let (str,_) = Ast_helper.Attr.as_tuple a in - str.Location.txt = attr_name - ) attrs - -let select_leafs pos root = - let branches = ref [] in - let rec select_child branch env node has_selected = - let loc = node_merlin_loc node in - let attrs = Browse_raw.node_attributes node in - if Location_aux.compare_pos pos loc = 0 && - not (has_attr "merlin.hide" attrs) - then - (traverse ((env, node) :: branch); true) - else - has_selected - and traverse branch = - let env, node = leaf_node branch in - let attrs = Browse_raw.node_attributes node in - if (has_attr "merlin.focus" attrs) then ( - branches := []; - let has_leaves = fold_node (select_child branch) env node false in - if not has_leaves then - branches := [branch]; - raise Exit - ) - else if not (has_attr "merlin.hide" attrs) then ( - let has_leaves = fold_node (select_child branch) env node false in - if not has_leaves then - branches := branch :: !branches - ) - in - (try traverse root with Exit -> ()); - !branches - -let compare_locations pos l1 l2 = - let t2_first = +1 in - let t1_first = -1 in - match - Location_aux.compare_pos pos l1, - Location_aux.compare_pos pos l2 - with - | 0, 0 -> - (* Cursor inside both locations: favor closer to the end *) - Lexing.compare_pos l1.Location.loc_end l2.Location.loc_end - (* Cursor inside one location: it has priority *) - | 0, _ -> t1_first - | _, 0 -> t2_first - (* Cursor outside locations: favor before *) - | n, m when n > 0 && m < 0 -> t1_first - | n, m when m > 0 && n < 0 -> t2_first - (* Cursor is after both, select the closest one *) - | _, _ -> - Lexing.compare_pos l2.Location.loc_end l1.Location.loc_end - -let best_node pos = function - | [] -> [] - | init :: xs -> - let f acc x = - if compare_locations pos (leaf_loc acc) (leaf_loc x) <= 0 - then acc - else x - in - List.fold_left ~f ~init xs - -let enclosing pos roots = - match best_node pos roots with - | [] -> [] - | root -> best_node pos (select_leafs pos root) - -let deepest_before pos roots = - match enclosing pos roots with - | [] -> [] - | root -> - let rec aux path = - let env0, node0 = leaf_node path in - let loc0 = node_merlin_loc node0 in - let select_candidate env node acc = - let loc = node_merlin_loc node in - if path == root || - Location_aux.compare_pos pos loc = 0 || - Lexing.compare_pos loc.Location.loc_end loc0.Location.loc_end = 0 - then match acc with - | Some (_,loc',_) when compare_locations pos loc' loc <= 0 -> acc - | Some _ | None -> Some (env,loc,node) - else acc - in - match fold_node select_candidate env0 node0 None with - | None -> path - | Some (env, _,node) -> - aux ((env,node) :: path) - in - (aux root) - -(* Select open nodes *) - -let rec select_open_node = - function[@warning "-9"] - | (_, ( Structure_item ({str_desc = - Tstr_open { open_expr = - { mod_desc = Tmod_ident (p, {txt = longident}) }}}, - _))) - :: ancestors -> - Some (p, longident, ancestors) - | (_, ( Signature_item ({sig_desc = Tsig_open op}, _))) :: ancestors -> - let (p, { Asttypes.txt = longident; }) = op.open_expr in - Some (p, longident, ancestors) - | (_, Expression { exp_desc = - Texp_open ({ open_expr = - { mod_desc = Tmod_ident (p, {txt = longident})}}, _); _}) - :: _ as ancestors -> - Some (p, longident, ancestors) - | (_, Pattern {pat_extra; _}) :: ancestors - when List.exists pat_extra - ~f:(function (Tpat_open _, _ ,_) -> true | _ -> false) -> - let (p, longident) = List.find_map pat_extra - ~f:(function | Tpat_open (p,{ txt = longident; },_), _ ,_ -> Some (p, longident) - | _ -> None) - in - Some (p, longident, ancestors) - | [] -> None - | _ :: ancestors -> select_open_node ancestors - -let of_structure str = - let env = - match str.str_items with - | [] -> str.str_final_env - | item :: _ -> item.str_env - in - [env, Browse_raw.Structure str] - -let of_signature sg = - let env = - match sg.sig_items with - | [] -> sg.sig_final_env - | item :: _ -> item.sig_env - in - [env, Browse_raw.Signature sg] - -let of_typedtree = function - | `Implementation str -> of_structure str - | `Interface sg -> of_signature sg - -let optional_label_sugar = function - | Typedtree.Texp_construct (id, _, [e]) - when id.Location.loc.Location.loc_ghost - && id.Location.txt = Longident.Lident "Some" -> - Some e - | _ -> None - -let rec is_recovered_expression e = - match e.Typedtree.exp_desc with - | (* Recovery on arbitrary expressions *) - Texp_tuple [_] -> - true - | (* Recovery on unbound identifier *) - Texp_ident (Path.Pident id, _, _) - when Ident.name id = "*type-error*" -> - true - | (* Recovery on desugared optional label application *) - Texp_construct _ as cstr - when is_recovered_Texp_construct cstr -> - true - | _ -> false - -and is_recovered_Texp_construct cstr = - match optional_label_sugar cstr with - | Some e -> is_recovered_expression e - | _ -> false - -let is_recovered = function - | Expression e -> is_recovered_expression e - | _ -> false - -let print_node () node = - Browse_raw.string_of_node node - -let print () t = - List.print (fun () (_,node) -> print_node () node) () t diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mbrowse.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mbrowse.mli deleted file mode 100644 index 4dc10b558..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mbrowse.mli +++ /dev/null @@ -1,78 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -type node = Browse_raw.node -type t = (Env.t * node) list - -val fold_node : (Env.t -> Browse_raw.node -> 'a -> 'a) -> - Env.t -> Browse_raw.node -> 'a -> 'a -val node_loc : Browse_raw.node -> Location.t -val leaf_node : t -> Env.t * node -val drop_leaf : t -> t option - -(* Navigate through tree *) - -(** The deepest context inside or before the node, for instance, navigating - * through: - * foo bar (baz :: tail) - * asking for node from cursor position will return context of "tail". - * Returns the matching node and all its ancestors or the empty list. *) -val deepest_before : Lexing.position -> t list -> t - - -val select_open_node : t -> (Path.t * Longident.t * t) option - -val enclosing : Lexing.position -> t list -> t - -val of_structure : Typedtree.structure -> t -val of_signature : Typedtree.signature -> t - -val of_typedtree : - [ `Implementation of Typedtree.structure - | `Interface of Typedtree.signature ] -> t - -val node_of_binary_part : Env.t -> Cmt_format.binary_part -> node - -(** Identify nodes introduced by recovery *) -val is_recovered_expression : Typedtree.expression -> bool -val is_recovered : Browse_raw.node -> bool - -(** When an optional argument is applied with labelled syntax - sugar (~a:v instead of ?a:(Some v)), the frontend will have - wrapped it in [Some _]. - [optional_label_sugar exp] returns [Some exp'] with the sugar - removed in that case. *) -val optional_label_sugar : - Typedtree.expression_desc -> Typedtree.expression option - -(** {1 Dump} *) - -val print_node : unit -> node -> string -val print : unit -> t -> string diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig.ml deleted file mode 100644 index e542384c5..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig.ml +++ /dev/null @@ -1,755 +0,0 @@ -open Std - -(** {1 OCaml commandline parsing} *) - -let {Logger. log} = Logger.for_section "Mconfig" - -type ocaml = { - include_dirs : string list; - no_std_include : bool; - unsafe : bool; - classic : bool; - principal : bool; - real_paths : bool; - threads : [ `None | `Threads | `Vmthreads ]; - recursive_types : bool; - strict_sequence : bool; - applicative_functors : bool; - unsafe_string : bool; - nopervasives : bool; - strict_formats : bool; - open_modules : string list; - ppx : string with_workdir list; - pp : string with_workdir option; - warnings : Warnings.state; -} - -let dump_warnings st = - let st' = Warnings.backup () in - Warnings.restore st; - Misc.try_finally Warnings.dump - ~always:(fun () -> Warnings.restore st') - -let dump_ocaml x = `Assoc [ - "include_dirs" , `List (List.map ~f:Json.string x.include_dirs); - "no_std_include" , `Bool x.no_std_include; - "unsafe" , `Bool x.unsafe; - "classic" , `Bool x.classic; - "principal" , `Bool x.principal; - "real_paths" , `Bool x.real_paths; - "recursive_types" , `Bool x.recursive_types; - "strict_sequence" , `Bool x.strict_sequence; - "applicative_functors" , `Bool x.applicative_functors; - "unsafe_string" , `Bool x.unsafe_string; - "nopervasives" , `Bool x.nopervasives; - "strict_formats" , `Bool x.strict_formats; - "open_modules" , Json.list Json.string x.open_modules; - "ppx" , Json.list (dump_with_workdir Json.string) x.ppx; - "pp" , Json.option (dump_with_workdir Json.string) x.pp; - "warnings" , dump_warnings x.warnings; - ] - -(** Some paths can be resolved relative to a current working directory *) - -let cwd = ref None - -let unsafe_get_cwd () = match !cwd with - | None -> assert false - | Some cwd -> cwd - -let canonicalize_filename path = - Misc.canonicalize_filename ?cwd:!cwd path - -let marg_path f = - Marg.param "path" (fun path acc -> f (canonicalize_filename path) acc) - -let marg_commandline f = - Marg.param "command" - (fun workval acc -> f {workdir = unsafe_get_cwd (); workval} acc) - -(** {1 Merlin high-level settings} *) - -type merlin = { - build_path : string list; - source_path : string list; - cmi_path : string list; - cmt_path : string list; - extensions : string list; - suffixes : (string * string) list; - stdlib : string option; - reader : string list; - protocol : [`Json | `Sexp]; - log_file : string option; - log_sections : string list; - config_path : string option; - - exclude_query_dir : bool; - - flags_to_apply : string list with_workdir list; - - flags_applied : string list with_workdir list; - - failures : string list; - extension_to_reader : (string * string) list - -} - -let dump_merlin x = - let dump_flag_list flags = - dump_with_workdir (Json.list Json.string) flags - in - `Assoc [ - "build_path" , `List (List.map ~f:Json.string x.build_path); - "source_path" , `List (List.map ~f:Json.string x.source_path); - "cmi_path" , `List (List.map ~f:Json.string x.cmi_path); - "cmt_path" , `List (List.map ~f:Json.string x.cmt_path); - "flags_applied", `List (List.map ~f:dump_flag_list x.flags_applied); - "extensions" , `List (List.map ~f:Json.string x.extensions); - "suffixes" , `List ( - List.map ~f:(fun (impl,intf) -> `Assoc [ - "impl", `String impl; - "intf", `String intf; - ]) x.suffixes - ); - "stdlib" , Json.option Json.string x.stdlib; - "reader" , `List (List.map ~f:Json.string x.reader); - "protocol" , (match x.protocol with - | `Json -> `String "json" - | `Sexp -> `String "sexp" - ); - "log_file" , Json.option Json.string x.log_file; - "log_sections" , Json.list Json.string x.log_sections; - "flags_to_apply" , `List (List.map ~f:dump_flag_list x.flags_to_apply); - - "failures" , `List (List.map ~f:Json.string x.failures); - "assoc_suffixes" , `List ( - List.map ~f:(fun (suffix,reader) -> `Assoc [ - "extension", `String suffix; - "reader", `String reader; - ]) x.extension_to_reader - ) - ] - -type query = { - filename : string; - directory : string; - printer_width : int; - verbosity : int; -} - -let dump_query x = `Assoc [ - "filename" , `String x.filename; - "directory" , `String x.directory; - "printer_width", `Int x.printer_width; - "verbosity" , `Int x.verbosity; - ] - -type t = { - ocaml : ocaml; - merlin : merlin; - query : query; -} - -let dump x = `Assoc [ - "ocaml" , dump_ocaml x.ocaml; - "merlin" , dump_merlin x.merlin; - "query" , dump_query x.query; - ] - -let arguments_table = Hashtbl.create 67 - -let stdlib = - let env = - try Some (Sys.getenv "OCAMLLIB") - with Not_found -> - try Some (Sys.getenv "CAMLLIB") - with Not_found -> None - in - fun config -> - match config.merlin.stdlib with - | Some stdlib -> stdlib - | None -> match env with - | Some stdlib -> stdlib - | None -> Standard_library.path - -let normalize_step t = - let merlin = t.merlin in - if merlin.flags_to_apply <> [] then - let flagss = merlin.flags_to_apply in - let t = {t with merlin = { merlin with - flags_to_apply = []; - flags_applied = flagss @ merlin.flags_applied; - } } - in - let failures = ref [] in - let warning failure = failures := failure :: !failures in - let t = List.fold_left ~f:(fun t {workdir; workval} -> fst ( - let_ref cwd (Some workdir) - (Marg.parse_all ~warning arguments_table [] workval t) - )) ~init:t flagss - in - {t with merlin = {t.merlin with failures = !failures @ t.merlin.failures}} - else - t - -let is_normalized t = - let merlin = t.merlin in - merlin.flags_to_apply = [] - -let rec normalize t = - if is_normalized t then ( - log ~title:"normalize" "%a" Logger.json (fun () -> dump t); - t - ) else - normalize (normalize_step t) - -let get_external_config path t = - let path = Misc.canonicalize_filename path in - let directory = Filename.dirname path in - match Mconfig_dot.find_project_context directory with - | None -> t - | Some (ctxt, config_path) -> - let dot, failures = Mconfig_dot.get_config ctxt path in - let merlin = t.merlin in - let merlin = { - merlin with - build_path = dot.build_path @ merlin.build_path; - source_path = dot.source_path @ merlin.source_path; - cmi_path = dot.cmi_path @ merlin.cmi_path; - cmt_path = dot.cmt_path @ merlin.cmt_path; - exclude_query_dir = dot.exclude_query_dir || merlin.exclude_query_dir; - extensions = dot.extensions @ merlin.extensions; - suffixes = dot.suffixes @ merlin.suffixes; - stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib); - reader = - if dot.reader = [] - then merlin.reader - else dot.reader; - flags_to_apply = dot.flags @ merlin.flags_to_apply; - failures = failures @ merlin.failures; - config_path = Some config_path; - } in - normalize { t with merlin } - -let merlin_flags = [ - ( - "-build-path", - marg_path (fun dir merlin -> - {merlin with build_path = dir :: merlin.build_path}), - " Add to merlin build path" - ); - ( - "-source-path", - marg_path (fun dir merlin -> - {merlin with source_path = dir :: merlin.source_path}), - " Add to merlin source path" - ); - ( - "-cmi-path", - marg_path (fun dir merlin -> - {merlin with cmi_path = dir :: merlin.cmi_path}), - " Add to merlin cmi path" - ); - ( - "-cmt-path", - marg_path (fun dir merlin -> - {merlin with cmt_path = dir :: merlin.cmt_path}), - " Add to merlin cmt path" - ); - ( - "-reader", - Marg.param "command" (fun reader merlin -> - {merlin with reader = Shell.split_command reader }), - " Use as a merlin reader" - ); - ( - "-assocsuffix", - Marg.param "suffix:reader" - (fun assoc_pair merlin -> - match Misc.rev_string_split ~on:':' assoc_pair with - | [reader;suffix] -> - {merlin with - extension_to_reader = (suffix,reader)::merlin.extension_to_reader} - | _ -> merlin - ), - "Associate suffix with reader" - ); - ( - "-addsuffix", - Marg.param "implementation Suffix, interface Suffix" - (fun suffix_pair merlin -> - match Misc.rev_string_split ~on:':' suffix_pair with - | [intf;impl] -> - {merlin with suffixes = (impl,intf)::merlin.suffixes} - | _ -> merlin - ), - "Add a suffix implementation,interface pair" - ); - ( - "-extension", - Marg.param "extension" (fun extension merlin -> - match Extension.lookup extension with - | None -> invalid_arg "Unknown extension" - | Some _ -> - {merlin with extensions = extension :: merlin.extensions}), - " Load merlin syntax extension" - ); - ( - "-flags", - Marg.param "string" (fun flags merlin -> - let flags = - { workdir = unsafe_get_cwd (); workval = Shell.split_command flags } - in - {merlin with flags_to_apply = flags :: merlin.flags_to_apply}), - " Unescape argument and interpret it as more flags" - ); - ( - "-protocol", - Marg.param "protocol" (fun prot merlin -> - match prot with - | "json" -> {merlin with protocol = `Json} - | "sexp" -> {merlin with protocol = `Sexp} - | _ -> invalid_arg "Valid protocols are 'json' and 'sexp'"; - ), - " Select frontend protocol ('json' or 'sexp')" - ); - ( - "-log-file", - Marg.param "file" (fun file merlin -> {merlin with log_file = Some file}), - " Log messages to specified file ('' for disabling, '-' for stderr)" - ); - ( - "-log-section", - Marg.param "file" (fun section merlin -> - let sections = String.split_on_char_ ',' section in - {merlin with log_sections = sections @ merlin.log_sections}), - " Only log specific sections (separated by comma)" - ); - ( - "-ocamllib-path", - marg_path (fun path merlin -> {merlin with stdlib = Some path}), - " Change path of ocaml standard library" - ); - ( - (* Legacy support for janestreet. Ignored. To be removed soon. *) - "-attributes-allowed", - Marg.unit_ignore, - " DEPRECATED" - ); -] - -let query_flags = [ - ( - "-verbosity", - Marg.param "integer" (fun verbosity query -> - let verbosity = - try int_of_string verbosity - with _ -> invalid_arg "argument should be an integer" - in - {query with verbosity}), - " Verbosity determines the number of expansions of aliases in answers" - ); - ( - "-printer-width", - Marg.param "integer" (fun width query -> - let printer_width = - try int_of_string width - with _ -> invalid_arg "argument should be an integer" - in - {query with printer_width}), - " Optimal width for formatting types, signatures, etc" - ) -] - -let ocaml_ignored_flags = [ - "-a"; "-absname"; "-alias-deps"; "-annot"; "-app-funct"; "-bin-annot"; - "-c"; "-compact"; "-compat-32"; "-config"; "-custom"; "-dalloc"; - "-dclambda"; "-dcmm"; "-dcombine"; "-dcse"; "-dflambda"; - "-dflambda-no-invariants"; "-dflambda-verbose"; "-dinstr"; "-dinterf"; - "-dlambda"; "-dlinear"; "-dlive"; "-dparsetree"; "-dprefer"; - "-drawclambda"; "-drawflambda"; "-drawlambda"; "-dreload"; "-dscheduling"; - "-dsel"; "-dsource"; "-dspill"; "-dsplit"; "-dstartup"; "-dtimings"; - "-dtypedtree"; "-dtypes"; "-dump-pass"; "-fno-PIC"; "-fPIC"; "-g"; "-i"; - "-inlining-report"; "-keep-docs"; "-keep-docs"; "-keep-locs"; "-linkall"; - "-make_runtime"; "-make-runtime"; "-modern"; "-no-alias-deps"; "-noassert"; - "-noautolink"; "-no-check-prims"; "-nodynlink"; "-no-float-const-prop"; - "-no-keep-locs"; "-no-principal"; "-no-rectypes"; "-no-strict-formats"; - "-no-strict-sequence"; "-no-unbox-free-vars-of-clos"; - "-no-unbox-specialised-args"; "-O2"; "-O3"; "-Oclassic"; "-opaque"; - "-output-complete-obj"; "-output-obj"; "-p"; "-pack"; - "-remove-unused-arguments"; "-S"; "-shared"; "-unbox-closures"; "-v"; - "-verbose"; "-where"; -] - -let ocaml_ignored_parametrized_flags = [ - "-cc"; "-cclib"; "-ccopt"; "-color"; "-dflambda-let"; "-dllib"; "-dllpath"; - "-for-pack"; "-impl"; "-inline-alloc-cost"; "-inline-branch-cost"; - "-inline-branch-factor"; "-inline-call-cost"; "-inline-indirect-cost"; - "-inline-lifting-benefit"; "-inline-max-depth"; "-inline-max-unroll"; - "-inline"; "-inline-prim-cost"; "-inline-toplevel"; "-intf"; - "-intf_suffix"; "-intf-suffix"; "-o"; "-rounds"; "-runtime-variant"; - "-unbox-closures-factor"; "-use-prims"; "-use_runtime"; "-use-runtime"; - "-error-style"; -] - -let ocaml_warnings_spec ~error = - Marg.param "warning specification" (fun spec ocaml -> - let b' = Warnings.backup () in - Warnings.restore ocaml.warnings; - Misc.try_finally (fun () -> - ignore @@ Warnings.parse_options error spec; - { ocaml with warnings = Warnings.backup () }) - ~always:(fun () -> Warnings.restore b')) - -let ocaml_alert_spec = - Marg.param "alert specification" (fun spec ocaml -> - let b' = Warnings.backup () in - Warnings.restore ocaml.warnings; - Misc.try_finally (fun () -> - Warnings.parse_alert_option spec; - { ocaml with warnings = Warnings.backup () }) - ~always:(fun () -> Warnings.restore b')) - -let ocaml_flags = [ - ( - "-I", - marg_path (fun dir ocaml -> - {ocaml with include_dirs = dir :: ocaml.include_dirs}), - " Add to the list of include directories" - ); - ( - "-nostdlib", - Marg.unit (fun ocaml -> {ocaml with no_std_include = true}), - " Do not add default directory to the list of include directories" - ); - ( - "-unsafe", - Marg.unit (fun ocaml -> {ocaml with unsafe = true}), - " Do not compile bounds checking on array and string access" - ); - ( - "-labels", - Marg.unit (fun ocaml -> {ocaml with classic = false}), - " Use commuting label mode" - ); - ( - "-nolabels", - Marg.unit (fun ocaml -> {ocaml with classic = true}), - " Ignore non-optional labels in types" - ); - ( - "-principal", - Marg.unit (fun ocaml -> {ocaml with principal = true}), - " Check principality of type inference" - ); - ( - "-real-paths", - Marg.unit (fun ocaml -> {ocaml with real_paths = true}), - " Display real paths in types rather than short ones" - ); - ( - "-short-paths", - Marg.unit (fun ocaml -> {ocaml with real_paths = false}), - " Shorten paths in types" - ); - ( - "-rectypes", - Marg.unit (fun ocaml -> {ocaml with recursive_types = true}), - " Allow arbitrary recursive types" - ); - ( - "-strict-sequence", - Marg.unit (fun ocaml -> {ocaml with strict_sequence = true}), - " Left-hand part of a sequence must have type unit" - ); - ( - "-no-app-funct", - Marg.unit (fun ocaml -> {ocaml with applicative_functors = false}), - " Deactivate applicative functors" - ); - ( - "-thread", - Marg.unit (fun ocaml -> {ocaml with threads = `Threads}), - " Add support for system threads library" - ); - ( - "-vmthread", - Marg.unit (fun ocaml -> {ocaml with threads = `None}), - " Add support for VM-scheduled threads library" - ); - ( - "-unsafe-string", - Marg.unit (fun ocaml -> {ocaml with unsafe_string = true}), - Printf.sprintf - " Make strings mutable (default: %B)" - (not Config.safe_string) - ); - ( - "-safe-string", - Marg.unit (fun ocaml -> {ocaml with unsafe_string = false}), - Printf.sprintf - " Make strings immutable (default: %B)" - Config.safe_string - ); - ( - "-nopervasives", - Marg.unit (fun ocaml -> {ocaml with nopervasives = true}), - " Don't open Pervasives module (advanced)" - ); - ( - "-strict-formats", - Marg.unit (fun ocaml -> {ocaml with strict_formats = true}), - " Reject invalid formats accepted by legacy implementations" - ); - ( - "-open", - Marg.param "module" (fun md ocaml -> - {ocaml with open_modules = md :: ocaml.open_modules}), - " Opens the module before typing" - ); - ( - "-ppx", - marg_commandline (fun command ocaml -> - {ocaml with ppx = command :: ocaml.ppx}), - " Pipe abstract syntax trees through preprocessor " - ); - ( - "-pp", - marg_commandline (fun pp ocaml -> {ocaml with pp = Some pp}), - " Pipe sources through preprocessor " - ); - ( "-w", - ocaml_warnings_spec ~error:false, - Printf.sprintf - " Enable or disable warnings according to :\n\ - \ + enable warnings in \n\ - \ - disable warnings in \n\ - \ @ enable warnings in and treat them as errors\n\ - \ can be:\n\ - \ a single warning number\n\ - \ .. a range of consecutive warning numbers\n\ - \ a predefined set\n\ - \ default setting is %S" - Warnings.defaults_w - ); - ( "-warn-error", - ocaml_warnings_spec ~error:true, - Printf.sprintf - " Enable or disable error status for warnings according\n\ - \ to . See option -w for the syntax of .\n\ - \ Default setting is %S" - Warnings.defaults_warn_error - ); - ( "-alert", - ocaml_alert_spec, - Printf.sprintf - " Enable or disable alerts according to :\n\ - \ + enable alert \n\ - \ - disable alert \n\ - \ ++ treat as fatal error\n\ - \ -- treat as non-fatal\n\ - \ @ enable and treat it as fatal error\n\ - \ can be 'all' to refer to all alert names" - ); -] - -(** {1 Main configuration} *) - -let initial = { - ocaml = { - include_dirs = []; - no_std_include = false; - unsafe = false; - classic = false; - principal = false; - real_paths = true; - threads = `None; - recursive_types = false; - strict_sequence = false; - applicative_functors = true; - unsafe_string = not Config.safe_string; - nopervasives = false; - strict_formats = false; - open_modules = []; - ppx = []; - pp = None; - warnings = Warnings.backup (); - }; - merlin = { - build_path = []; - source_path = []; - cmi_path = []; - cmt_path = []; - extensions = []; - suffixes = [(".ml", ".mli"); (".re", ".rei")]; - stdlib = None; - reader = []; - protocol = `Json; - log_file = None; - log_sections = []; - config_path = None; - - exclude_query_dir = false; - - flags_to_apply = []; - flags_applied = []; - - failures = []; - extension_to_reader = [(".re","reason");(".rei","reason")]; - }; - query = { - filename = "*buffer*"; - directory = Sys.getcwd (); - verbosity = 0; - printer_width = 0; - } -} - -let parse_arguments ~wd ~warning local_spec args t local = - let_ref cwd (Some wd) @@ fun () -> - Marg.parse_all ~warning arguments_table local_spec args t local - -let global_flags = [ - ( - "-filename", - marg_path (fun path t -> - let query = t.query in - let path = Misc.canonicalize_filename path in - let filename = Filename.basename path in - let directory = Filename.dirname path in - let t = {t with query = {query with filename; directory}} in - Logger.with_log_file t.merlin.log_file - ~sections:t.merlin.log_sections @@ fun () -> - get_external_config path t), - " Path of the buffer; \ - extension determines the kind of file (interface or implementation), \ - basename is used as name of the module being definer, \ - directory is used to resolve other relative paths" - ); - ( - "-dot-merlin", - marg_path (fun dotmerlin t -> get_external_config dotmerlin t), - " Load as a .merlin; if it is a directory, \ - look for .merlin here or in a parent directory" - ); -] - -let () = - List.iter ~f:(fun name -> Hashtbl.add arguments_table name Marg.unit_ignore) - ocaml_ignored_flags; - List.iter ~f:(fun name -> Hashtbl.add arguments_table name Marg.param_ignore) - ocaml_ignored_parametrized_flags; - let lens prj upd flag : _ Marg.t = fun args a -> - let cwd' = match !cwd with - | None when a.query.directory <> "" -> Some a.query.directory - | cwd -> cwd - in - let_ref cwd cwd' @@ fun () -> - let args, b = flag args (prj a) in - args, (upd a b) - in - let add prj upd (name,flag,_doc) = - assert (not (Hashtbl.mem arguments_table name)); - Hashtbl.add arguments_table name (lens prj upd flag) - in - List.iter - ~f:(add (fun x -> x.ocaml) (fun x ocaml -> {x with ocaml})) - ocaml_flags; - List.iter - ~f:(add (fun x -> x.merlin) (fun x merlin -> {x with merlin})) - merlin_flags; - List.iter - ~f:(add (fun x -> x.query) (fun x query -> {x with query})) - query_flags; - List.iter - ~f:(add (fun x -> x) (fun _ x -> x)) - global_flags - -let flags_for_completion () = - List.sort ~cmp:compare ( - "-dot-merlin" :: "-reader" :: - List.map ~f:(fun (x,_,_) -> x) ocaml_flags - ) - -let document_arguments oc = - let print_doc flags = - List.iter ~f:(fun (name,_flag,doc) -> Printf.fprintf oc " %s\t%s\n" name doc) - flags - in - output_string oc "Flags affecting Merlin:\n"; - print_doc merlin_flags; - print_doc query_flags; - output_string oc "Flags affecting OCaml frontend:\n"; - print_doc ocaml_flags; - output_string oc "Flags accepted by ocamlc and ocamlopt but not affecting merlin will be ignored.\n" - -let source_path config = - let stdlib = if config.ocaml.no_std_include then [] else [stdlib config] in - List.concat - [[config.query.directory]; - stdlib; - config.merlin.source_path] - |> List.filter_dup - -let build_path config = ( - let dirs = - match config.ocaml.threads with - | `None -> config.ocaml.include_dirs - | `Threads -> "+threads" :: config.ocaml.include_dirs - | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs - in - let dirs = - config.merlin.cmi_path @ - config.merlin.build_path @ - dirs - in - let stdlib = stdlib config in - let exp_dirs = - List.map ~f:(Misc.expand_directory stdlib) dirs - in - let stdlib = if config.ocaml.no_std_include then [] else [stdlib] in - let dirs = List.rev_append exp_dirs stdlib in - let result = - if config.merlin.exclude_query_dir - then dirs - else config.query.directory :: dirs - in - let result' = List.filter_dup result in - log ~title:"build_path" "%d items in path, %d after deduplication" - (List.length result) (List.length result'); - result' -) - -let cmt_path config = ( - let dirs = - match config.ocaml.threads with - | `None -> config.ocaml.include_dirs - | `Threads -> "+threads" :: config.ocaml.include_dirs - | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs - in - let dirs = - config.merlin.cmt_path @ - config.merlin.build_path @ - dirs - in - let stdlib = stdlib config in - let exp_dirs = - List.map ~f:(Misc.expand_directory stdlib) dirs - in - let stdlib = if config.ocaml.no_std_include then [] else [stdlib] in - config.query.directory :: List.rev_append exp_dirs stdlib -) - -let global_modules ?(include_current=false) config = ( - let modules = Misc.modules_in_path ~ext:".cmi" (build_path config) in - if include_current then modules - else match config.query.filename with - | "" -> modules - | filename -> List.remove (Misc.unitname filename) modules -) - -(** {1 Accessors for other information} *) - -let filename t = t.query.filename - -let unitname t = Misc.unitname t.query.filename diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig.mli deleted file mode 100644 index 7f82ba7e7..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig.mli +++ /dev/null @@ -1,106 +0,0 @@ -open Std - -(** {1 OCaml commandline parsing} *) - -type ocaml = { - include_dirs : string list; - no_std_include : bool; - unsafe : bool; - classic : bool; - principal : bool; - real_paths : bool; - threads : [ `None | `Threads | `Vmthreads ]; - recursive_types : bool; - strict_sequence : bool; - applicative_functors : bool; - unsafe_string : bool; - nopervasives : bool; - strict_formats : bool; - open_modules : string list; - ppx : string with_workdir list; - pp : string with_workdir option; - warnings : Warnings.state; -} - -val dump_ocaml : ocaml -> json - - -(** {1 Merlin high-level settings} *) - -type merlin = { - build_path : string list; - source_path : string list; - cmi_path : string list; - cmt_path : string list; - extensions : string list; - suffixes : (string * string) list; - stdlib : string option; - reader : string list; - protocol : [`Json | `Sexp]; - log_file : string option; - log_sections: string list; - config_path : string option; - - exclude_query_dir : bool; - - flags_to_apply : string list with_workdir list; - - flags_applied : string list with_workdir list; - - failures : string list; - extension_to_reader : (string * string) list -} - -val dump_merlin : merlin -> json - -(** {1 Some flags affecting queries} *) - -type query = { - filename : string; - directory : string; - printer_width : int; - verbosity : int; -} - -(** {1 Main configuration} *) - -type t = { - ocaml : ocaml; - merlin : merlin; - query : query; -} - -val initial : t - -val dump : t -> json - -val get_external_config : string -> t -> t - -val normalize : t -> t - -val is_normalized : t -> bool - -val parse_arguments : - wd:string -> - warning:(string -> unit) -> 'a Marg.spec list -> string list -> - t -> 'a -> t * 'a - -val flags_for_completion : unit -> string list - -val document_arguments : out_channel -> unit - -(** {1 Computing project paths} *) - -val source_path : t -> string list - -val build_path : t -> string list - -val cmt_path : t -> string list - -val global_modules : ?include_current:bool -> t -> string list - -(** {1 Accessors for other information} *) - -val filename : t -> string - -val unitname : t -> string diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig_dot.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig_dot.ml deleted file mode 100644 index 688f64c9a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig_dot.ml +++ /dev/null @@ -1,405 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -let {Logger. log} = Logger.for_section "Mconfig_dot" - -type directive = Merlin_dot_protocol.directive - -type config = { - build_path : string list; - source_path : string list; - cmi_path : string list; - cmt_path : string list; - flags : string list with_workdir list; - extensions : string list; - suffixes : (string * string) list; - stdlib : string option; - reader : string list; - exclude_query_dir : bool; -} - -let empty_config = { - build_path = []; - source_path = []; - cmi_path = []; - cmt_path = []; - extensions = []; - suffixes = []; - flags = []; - stdlib = None; - reader = []; - exclude_query_dir = false; -} - -let white_regexp = Str.regexp "[ \t]+" - -(* Parses suffixes pairs that were supplied as whitespace separated pairs - designating implementation/interface suffixes. These would be supplied in - the .merlin file as: - - SUFFIX .sfx .sfxi *) -let parse_suffix str = - let trimmed = String.trim str in - let split_on_white = Str.split white_regexp trimmed in - if List.length split_on_white != 2 then [] - else - let (first, second) = (List.nth split_on_white 0, List.nth split_on_white 1) in - if String.get first 0 != '.' || String.get second 0 != '.' then [] - else [(first, second)] - -(* This module contains invariants around processes that need to be preserved *) -module Configurator : sig - type t = - | Dot_merlin - | Dune - - val of_string_opt : string -> t option - val to_string : t -> string - - module Process : sig - type nonrec t = { - kind: t; - initial_cwd: string; - stdin: out_channel; - stdout: in_channel; - stderr: in_channel - } - end - - (* [Some] if the process is live, [None] if the process died immediately after - spawning. The check is a bit fragile, but is principally there to check if - `dot-merlin-reader` isn't installed or isn't on the PATH; it only needs to - be best-effort besides that. *) - val get_process : dir:string -> t -> Process.t option -end = struct - type t = - | Dot_merlin - | Dune - - let of_string_opt = function - | ".merlin" -> - Some Dot_merlin - | "dune-project" | "dune-workspace" -> - Some Dune - | _ -> None - - let to_string = function - | Dot_merlin -> "dot-merlin-reader" - | Dune -> "dune" - - module Process = struct - type nonrec t = { - kind : t; - initial_cwd : string; - stdin: out_channel; - stdout: in_channel; - stderr: in_channel; - } - - module With_pid = struct - type nonrec t = { - pid: int; - process: t - } - end - - let start ~dir cfg = - let prog, args = - match cfg with - | Dot_merlin -> - let prog = "dot-merlin-reader" in - prog, [| prog |] - | Dune -> - let prog = "dune" in - prog, [| prog; "ocaml-merlin"; "--no-print-directory" |] - in - let cwd = Sys.getcwd () in - let stdin_r, stdin_w = Unix.pipe () in - let stdout_r, stdout_w = Unix.pipe () in - let stderr_r, stderr_w = Unix.pipe () in - Unix.chdir dir; - Unix.set_close_on_exec stdin_w; - (* Set the windows equivalent of close on exec for and stdin stderr - - Most processes spawned by merlin are supposed to inherit stderr to - output their debug information. This is fine because these processes - are short-lived. - However the dune helper we are about to spawn is long-lived, which can - cause issues with inherited descriptors because it will outlive - merlin's client process. - This is not an issue under Unix because file descriptors are replaced - (stdin/out/err are new), but under Windows, handle can accumulate. - This makes emacs block, synchronously waiting for the inherited (but - unused) stdout/stderr to be closed. - - Os_ipc.merlin_dont_inherit_stdio is a no-op under Unix. - *) - Os_ipc.merlin_dont_inherit_stdio true; - log ~title:"get_config" "Starting %s configuration provider from dir %s." - (to_string cfg) - dir; - let pid = Unix.create_process prog args stdin_r stdout_w stderr_w in - Os_ipc.merlin_dont_inherit_stdio false; - Unix.chdir cwd; - Unix.close stdin_r; - Unix.close stdout_w; - Unix.close stderr_w; - let stdin = Unix.out_channel_of_descr stdin_w in - let stdout = Unix.in_channel_of_descr stdout_r in - let stderr = Unix.in_channel_of_descr stderr_r in - let initial_cwd = Misc.canonicalize_filename dir in - With_pid.{ - pid; - process = { kind = cfg; initial_cwd; stdin; stdout; stderr } - } - end - - (* Invariant: Every PID in this hashtable can be waited on. This means it's - either running or hasn't been waited on yet. To ensure this invariant is - preserved, we don't expose the PIDs outside of the [Configurator] - module. *) - let running_processes : (string * t, Process.With_pid.t) Hashtbl.t = - Hashtbl.create 0 - - let get_process_with_pid ~dir configurator = - try - let p = Hashtbl.find running_processes (dir, configurator) in - let i, _ = Unix.waitpid [ WNOHANG ] p.pid in - if i = 0 then - p - else - let p = Process.start ~dir configurator in - Hashtbl.replace running_processes (dir, configurator) p; - p - with Not_found -> - let p = Process.start ~dir configurator in - Hashtbl.add running_processes (dir, configurator) p; - p - - let get_process ~dir configurator = - let p = get_process_with_pid ~dir configurator in - match Unix.waitpid [ WNOHANG ] p.pid with - | 0, _ -> Some p.process - | _ -> begin - Hashtbl.remove running_processes (dir, configurator); - None - end -end - -let prepend_config ~dir:cwd configurator (directives : directive list) config = - List.fold_left ~init:(config, []) ~f:(fun (config, errors) -> - function - | `B path -> {config with build_path = path :: config.build_path}, errors - | `S path -> {config with source_path = path :: config.source_path}, errors - | `CMI path -> {config with cmi_path = path :: config.cmi_path}, errors - | `CMT path -> {config with cmt_path = path :: config.cmt_path}, errors - | `EXT exts -> - {config with extensions = exts @ config.extensions}, errors - | `SUFFIX suffix -> - {config with suffixes = (parse_suffix suffix) @ config.suffixes}, errors - | `FLG flags -> - let flags = {workdir = cwd; workval = flags} in - {config with flags = flags :: config.flags}, errors - | `STDLIB path -> - {config with stdlib = Some path}, errors - | `READER reader -> - {config with reader}, errors - | `EXCLUDE_QUERY_DIR -> - {config with exclude_query_dir = true}, errors - | `ERROR_MSG str -> - config, str :: errors - | `UNKNOWN_TAG _ when configurator = Configurator.Dune -> - (* For easier forward compatibility we ignore unknown configuration tags - when they are provided by dune *) - config, errors - | `UNKNOWN_TAG tag -> - let error = Printf.sprintf "Unknown configuration tag \"%s\"" tag in - config, error :: errors - ) directives - -let postprocess_config config = - let clean list = List.rev (List.filter_dup list) in - { - build_path = clean config.build_path; - source_path = clean config.source_path; - cmi_path = clean config.cmi_path; - cmt_path = clean config.cmt_path; - extensions = clean config.extensions; - suffixes = clean config.suffixes; - flags = clean config.flags; - stdlib = config.stdlib; - reader = config.reader; - exclude_query_dir = config.exclude_query_dir; - } - -type context = { - workdir: string; - configurator: Configurator.t; - process_dir: string; -} - -exception Process_exited -exception End_of_input - -let get_config { workdir; process_dir; configurator } path_abs = - let log_query path = - log - ~title:"get_config" - "Querying %s (inital cwd: %s) for file: %s.\nWorkdir: %s" - (Configurator.to_string configurator) - process_dir - path - workdir - in - let query path (p : Configurator.Process.t) = - log_query path; - Merlin_dot_protocol.Commands.send_file - ~out_channel:p.stdin - path; - flush p.stdin; - Merlin_dot_protocol.read ~in_channel:p.stdout - in - try - let p = - match Configurator.get_process ~dir:process_dir configurator with - | Some p -> p - | None -> raise Process_exited - in - (* Both [p.initial_cwd] and [path_abs] have gone through - [canonicalize_filename] *) - let path_rel = - String.chop_prefix ~prefix:p.initial_cwd path_abs - |> Option.map ~f:(fun path -> - (* We need to remove the leading path separator after chopping. - There is one case where no separator is left: when [initial_cwd] - was the root of the filesystem *) - if String.length path > 0 && path.[0] = Filename.dir_sep.[0] then - String.drop 1 path - else path) - in - - let path = - match p.kind, path_rel with - | Dune, Some path_rel -> path_rel - | _, _ -> path_abs - in - - (* Starting with Dune 2.8.3 relative paths are preferred. However to maintain - compatibility with 2.8 <= Dune <= 2.8.2 we always retry with an absolute - path if using a relative one failed *) - let answer = - match query path p with - | Ok ([`ERROR_MSG _]) when p.kind = Dune -> - query path_abs p - | answer -> answer - in - - match answer with - | Ok directives -> - let cfg, failures = - prepend_config ~dir:workdir configurator directives empty_config - in - postprocess_config cfg, failures - | Error (Merlin_dot_protocol.Unexpected_output msg) -> empty_config, [ msg ] - | Error (Merlin_dot_protocol.Csexp_parse_error _) -> raise End_of_input - with - | Process_exited -> - (* This can happen - - If `dot-merlin-reader` is not installed and the project use `.merlin` - files - - There was a bug in the external reader causing a crash *) - let error = Printf.sprintf - "A problem occurred with merlin external configuration reader. %s If \ - the problem persists, please file an issue on Merlin's tracker." - (match configurator with - | Dot_merlin -> "Check that `dot-merlin-reader` is installed." - | Dune -> "Check that `dune` is installed and up-to-date.") - in - empty_config, [ error ] - | End_of_input -> - (* This can happen - - if a project using old-dune has not been built and Merlin wrongly tries to - start `new-dune ocaml-merlin` in the absence of `.merlin` files - - the process stopped in the middle of its answer (which is very unlikely) *) - let error = Printf.sprintf - "Merlin could not load its configuration from the external reader. %s" - (match configurator with - | Dot_merlin -> "If the problem persists, please file an issue on \ - Merlin's tracker." - | Dune -> "Building your project with `dune` might solve this issue.") - in - empty_config, [ error ] - -let find_project_context start_dir = - (* The workdir is the first directory we find which contains a [dune] file. - We need to keep track of this folder because [dune ocaml-merlin] might be - started from a folder that is a parent of the [workdir]. Thus we cannot - always use that starting folder as the workdir. *) - let map_workdir dir = function - | Some dir -> Some dir - | None -> - let fnames = List.map ~f:(Filename.concat dir) ["dune"; "dune-file"] in - if List.exists ~f:(fun fname -> - Sys.file_exists fname && not (Sys.is_directory fname)) fnames - then Some dir else None - in - - let rec loop workdir dir = - try - Some ( - List.find_map [ - ".merlin"; "dune-project"; "dune-workspace" - ] - ~f:(fun f -> - let fname = Filename.concat dir f in - if Sys.file_exists fname && not (Sys.is_directory fname) - then - (* When starting [dot-merlin-reader] from [dir] - the workdir is always [dir] *) - let workdir = if f = ".merlin" then None else workdir in - let workdir = Option.value ~default:dir workdir in - Some ({ - workdir; - process_dir = dir; - configurator = Option.get (Configurator.of_string_opt f) - }, fname) - else None - ) - ) - with Not_found -> - let parent = Filename.dirname dir in - if parent <> dir - then - (* Was this directory the workdir ? *) - let workdir = map_workdir dir workdir in - loop workdir parent - else None - in - loop None start_dir diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig_dot.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig_dot.mli deleted file mode 100644 index 03006b378..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mconfig_dot.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -type config = { - build_path : string list; - source_path : string list; - cmi_path : string list; - cmt_path : string list; - flags : string list with_workdir list; - extensions : string list; - suffixes : (string * string) list; - stdlib : string option; - reader : string list; - exclude_query_dir : bool; -} - -type context - -val get_config : context -> string -> config * string list - -val find_project_context : string -> (context * string) option -(** [find_project_config dir] searches for a "project configuration file" in dir - and its parent directories. Stopping on the first one it finds and returning - a configuration context along with the path to the configuration file, - returning None otherwise (if '/' was reached without finding such a file). - - A project configuration files is one of: - - .merlin - - dune-project - - dune-workspace - - They are detected in that order. [dune] and [jbuild] file do not need to be taken into account because any project using a recent version of dune should have a dune-project file which is even auto-generated when it is missing. And only recent versions of dune will stop writing .merlin files. -*) diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mocaml.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mocaml.ml deleted file mode 100644 index 6b4cd38dc..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mocaml.ml +++ /dev/null @@ -1,115 +0,0 @@ -open Std -open Local_store - -(* Instance of environment cache & btype unification log *) - -type typer_state = Local_store.store - -let current_state = s_ref None - -let new_state () = - let store = Local_store.fresh () in - Local_store.with_store store (fun () -> current_state := Some store); - store - -let with_state state f = - if Local_store.is_bound () then - failwith "Mocaml.with_state: another instance is already in use"; - match Local_store.with_store state f with - | r -> Cmt_format.clear (); r - | exception exn -> Cmt_format.clear (); reraise exn - -let is_current_state state = match !current_state with - | Some state' -> state == state' - | None -> false - -(* Build settings *) - -let setup_reader_config config = ( - assert Local_store.(is_bound ()); - let open Mconfig in - let open Clflags in - let ocaml = config.ocaml in - Env.set_unit_name (Mconfig.unitname config); - Location.input_name := config.query.filename; - fast := ocaml.unsafe ; - classic := ocaml.classic ; - principal := ocaml.principal ; - real_paths := ocaml.real_paths ; - recursive_types := ocaml.recursive_types ; - strict_sequence := ocaml.strict_sequence ; - applicative_functors := ocaml.applicative_functors ; - unsafe_string := ocaml.unsafe_string ; - nopervasives := ocaml.nopervasives ; - strict_formats := ocaml.strict_formats ; - open_modules := ocaml.open_modules ; -) - -let setup_typer_config config = ( - setup_reader_config config; - Load_path.init (Mconfig.build_path config); -) - -(** Switchable implementation of Oprint *) - -let default_out_value = !Oprint.out_value -let default_out_type = !Oprint.out_type -let default_out_class_type = !Oprint.out_class_type -let default_out_module_type = !Oprint.out_module_type -let default_out_sig_item = !Oprint.out_sig_item -let default_out_signature = !Oprint.out_signature -let default_out_type_extension = !Oprint.out_type_extension -let default_out_phrase = !Oprint.out_phrase - -let replacement_printer = ref None - -let oprint default inj ppf x = match !replacement_printer with - | None -> default ppf x - | Some printer -> printer ppf (inj x) - -let () = - let open Extend_protocol.Reader in - Oprint.out_value := - oprint default_out_value (fun x -> Out_value x); - Oprint.out_type := - oprint default_out_type (fun x -> Out_type x); - Oprint.out_class_type := - oprint default_out_class_type (fun x -> Out_class_type x); - Oprint.out_module_type := - oprint default_out_module_type (fun x -> Out_module_type x); - Oprint.out_sig_item := - oprint default_out_sig_item (fun x -> Out_sig_item x); - Oprint.out_signature := - oprint default_out_signature (fun x -> Out_signature x); - Oprint.out_type_extension := - oprint default_out_type_extension (fun x -> Out_type_extension x); - Oprint.out_phrase := - oprint default_out_phrase (fun x -> Out_phrase x) - -let default_printer ppf = - let open Extend_protocol.Reader in function - | Out_value x -> default_out_value ppf x - | Out_type x -> default_out_type ppf x - | Out_class_type x -> default_out_class_type ppf x - | Out_module_type x -> default_out_module_type ppf x - | Out_sig_item x -> default_out_sig_item ppf x - | Out_signature x -> default_out_signature ppf x - | Out_type_extension x -> default_out_type_extension ppf x - | Out_phrase x -> default_out_phrase ppf x - - -let with_printer printer f = - let_ref replacement_printer (Some printer) f - -(* Cleanup caches *) -let clear_caches () = ( - Cmi_cache.clear (); - Cmt_cache.clear (); - Directory_content_cache.clear (); -) - -(* Flush cache *) -let flush_caches ?older_than () = ( - Cmi_cache.flush ?older_than (); - Cmt_cache.flush ?older_than () -) diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mocaml.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mocaml.mli deleted file mode 100644 index 3a8fb6d55..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mocaml.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* An instance of load path, environment cache & btype unification log *) -type typer_state - -val new_state : unit -> typer_state -val with_state : typer_state -> (unit -> 'a) -> 'a -val is_current_state : typer_state -> bool - -(* Build settings *) -val setup_reader_config : Mconfig.t -> unit -val setup_typer_config : Mconfig.t -> unit - -(* Replace Outcome printer *) -val default_printer : - Format.formatter -> Extend_protocol.Reader.outcometree -> unit - -val with_printer : - (Format.formatter -> Extend_protocol.Reader.outcometree -> unit) -> - (unit -> 'a) -> 'a - -(* Clear caches, remove all items *) -val clear_caches : unit -> unit - -(* Flush caches, remove outdated items *) -val flush_caches : ?older_than:float -> unit -> unit diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mpipeline.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mpipeline.ml deleted file mode 100644 index 7f58735b3..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mpipeline.ml +++ /dev/null @@ -1,197 +0,0 @@ -open Std - -let {Logger. log} = Logger.for_section "Pipeline" - -let time_shift = ref 0.0 - -let timed_lazy r x = - lazy ( - let start = Misc.time_spent () in - let time_shift0 = !time_shift in - let update () = - let delta = Misc.time_spent () -. start in - let shift = !time_shift -. time_shift0 in - time_shift := time_shift0 +. delta; - r := !r +. delta -. shift; - in - match Lazy.force x with - | x -> update (); x - | exception exn -> update (); Std.reraise exn - ) - -module Cache = struct - let cache = ref [] - - (* Values from configuration that are used as a key for the cache. - These values should: - - allow to maximize reuse; associating a single typechecker instance to a - filename and directory is natural, but keying also based on verbosity - makes no sense - - prevent reuse in different environments (if there is a change in - loadpath, a new typechecker should be produced). - - It would be better to guarantee that the typechecker was well-behaved - when the loadpath changes (so that we can reusing the same instance, and - let the typechecker figure which part of its internal state should be - invalidated). - However we already had many bug related to that. There are subtle changes - in the type checker behavior across the different versions of OCaml. - It is simpler to create new instances upfront. - *) - - let key config = - Mconfig.( - config.query.filename, - config.query.directory, - config.ocaml, - {config.merlin with log_file = None; log_sections = []} - ) - - let get config = - let title = "pop_cache" in - let key = key config in - match List.assoc key !cache with - | state -> - cache := (key, state) :: List.remove_assoc key !cache; - log ~title "found entry for this configuration"; - state - | exception Not_found -> - log ~title "nothing cached for this configuration"; - let state = Mocaml.new_state () in - cache := (key, state) :: List.take_n 5 !cache; - state -end - -module Typer = struct - type t = { - errors : exn list lazy_t; - result : Mtyper.result; - } -end - -module Ppx = struct - type t = { - config : Mconfig.t; - errors : exn list; - parsetree : Mreader.parsetree; - } -end - -type t = { - config : Mconfig.t; - state : Mocaml.typer_state; - raw_source : Msource.t; - source : (Msource.t * Mreader.parsetree option) lazy_t; - reader : (Mreader.result * Mconfig.t) lazy_t; - ppx : Ppx.t lazy_t; - typer : Typer.t lazy_t; - - pp_time : float ref; - reader_time : float ref; - ppx_time : float ref; - typer_time : float ref; - error_time : float ref; -} - -let raw_source t = t.raw_source - -let input_config t = t.config -let input_source t = fst (Lazy.force t.source) - -let with_pipeline t f = - Mocaml.with_state t.state @@ fun () -> - Mreader.with_ambient_reader t.config (input_source t) f - -let get_lexing_pos t pos = - Msource.get_lexing_pos - (input_source t) ~filename:(Mconfig.filename t.config) pos - -let reader t = Lazy.force t.reader - -let ppx t = Lazy.force t.ppx -let typer t = Lazy.force t.typer - -let reader_config t = (snd (reader t)) -let reader_parsetree t = (fst (reader t)).Mreader.parsetree -let reader_comments t = (fst (reader t)).Mreader.comments -let reader_lexer_keywords t = (fst (reader t)).Mreader.lexer_keywords -let reader_lexer_errors t = (fst (reader t)).Mreader.lexer_errors -let reader_parser_errors t = (fst (reader t)).Mreader.parser_errors -let reader_no_labels_for_completion t = - (fst (reader t)).Mreader.no_labels_for_completion - -let ppx_parsetree t = (ppx t).Ppx.parsetree -let ppx_errors t = (ppx t).Ppx.errors - -let final_config t = (ppx t).Ppx.config - -let typer_result t = (typer t).Typer.result -let typer_errors t = Lazy.force (typer t).Typer.errors - -let process - ?state - ?(pp_time=ref 0.0) - ?(reader_time=ref 0.0) - ?(ppx_time=ref 0.0) - ?(typer_time=ref 0.0) - ?(error_time=ref 0.0) - ?for_completion - config raw_source = - let state = match state with - | None -> Cache.get config - | Some state -> state - in - let source = timed_lazy pp_time (lazy ( - match Mconfig.(config.ocaml.pp) with - | None -> raw_source, None - | Some { workdir; workval } -> - let source = Msource.text raw_source in - match - Pparse.apply_pp - ~workdir ~filename:Mconfig.(config.query.filename) - ~source ~pp:workval - with - | `Source source -> Msource.make source, None - | (`Interface _ | `Implementation _) as ast -> - raw_source, Some ast - )) in - let reader = timed_lazy reader_time (lazy ( - let lazy source = source in - let config = Mconfig.normalize config in - Mocaml.setup_reader_config config; - let result = Mreader.parse ?for_completion config source in - result, config - )) in - let ppx = timed_lazy ppx_time (lazy ( - let lazy ({Mreader.parsetree; _}, config) = reader in - let caught = ref [] in - Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> - let parsetree = Mppx.rewrite config parsetree in - { Ppx. config; parsetree; errors = !caught } - )) in - let typer = timed_lazy typer_time (lazy ( - let lazy { Ppx. config; parsetree; _ } = ppx in - Mocaml.setup_typer_config config; - let result = Mtyper.run config parsetree in - let errors = timed_lazy error_time (lazy (Mtyper.get_errors result)) in - { Typer. errors; result } - )) in - { config; state; raw_source; source; reader; ppx; typer; - pp_time; reader_time; ppx_time; typer_time; error_time } - -let make config source = - process (Mconfig.normalize config) source - -let for_completion position - {config; state; raw_source; - pp_time; reader_time; ppx_time; typer_time; error_time; _} = - process config raw_source ~for_completion:position - ~state ~pp_time ~reader_time ~ppx_time ~typer_time ~error_time - -let timing_information t = [ - "pp" , !(t.pp_time); - "reader" , !(t.reader_time); - "ppx" , !(t.ppx_time); - "typer" , !(t.typer_time); - "error" , !(t.error_time); -] diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mpipeline.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mpipeline.mli deleted file mode 100644 index 24355f19f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mpipeline.mli +++ /dev/null @@ -1,28 +0,0 @@ -type t -val make : Mconfig.t -> Msource.t -> t -val with_pipeline : t -> (unit -> 'a) -> 'a -val for_completion : Msource.position -> t -> t - -val raw_source : t -> Msource.t - -val input_config : t -> Mconfig.t -val input_source : t -> Msource.t -val get_lexing_pos : t -> [< Msource.position] -> Lexing.position - -val reader_config : t -> Mconfig.t -val reader_comments : t -> (string * Location.t) list -val reader_parsetree : t -> Mreader.parsetree -val reader_lexer_keywords : t -> string list -val reader_lexer_errors : t -> exn list -val reader_parser_errors : t -> exn list -val reader_no_labels_for_completion : t -> bool - -val ppx_parsetree : t -> Mreader.parsetree -val ppx_errors : t -> exn list - -val final_config : t -> Mconfig.t - -val typer_result : t -> Mtyper.result -val typer_errors : t -> exn list - -val timing_information : t -> (string * float) list diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mppx.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mppx.ml deleted file mode 100644 index 989be680f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mppx.ml +++ /dev/null @@ -1,40 +0,0 @@ -open Mconfig - -let {Logger. log} = Logger.for_section "Mppx" - -let with_include_dir path f = - let saved = !Clflags.include_dirs in - let restore () = Clflags.include_dirs := saved in - Clflags.include_dirs := path; - let result = - begin - try - f () - with - | e -> - restore (); - raise e - end - in - restore (); - result - - -let rewrite cfg parsetree = - let ppx = cfg.ocaml.ppx in - (* add include path attribute to the parsetree *) - with_include_dir (Mconfig.build_path cfg) @@ fun () -> - match - Pparse.apply_rewriters ~restore:false ~ppx ~tool_name:"merlin" parsetree - with - | parsetree -> parsetree - | exception exn -> - log ~title:"rewrite" "failed with %a" Logger.fmt (fun fmt -> - match Location.error_of_exn exn with - | None | Some `Already_displayed -> - Format.fprintf fmt "%s" (Printexc.to_string exn) - | Some (`Ok err) -> - Location.print_main fmt err - ); - Msupport.raise_error exn; - parsetree diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mppx.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mppx.mli deleted file mode 100644 index bae4dee83..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mppx.mli +++ /dev/null @@ -1 +0,0 @@ -val rewrite : Mconfig.t -> Mreader.parsetree -> Mreader.parsetree diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader.ml deleted file mode 100644 index 61a238eec..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader.ml +++ /dev/null @@ -1,180 +0,0 @@ -open Std - -type parsetree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -type comment = (string * Location.t) - -type result = { - lexer_keywords: string list; - lexer_errors : exn list; - parser_errors : exn list; - comments : comment list; - parsetree : parsetree; - no_labels_for_completion : bool; -} - -(* Normal entry point *) - -let normal_parse ?for_completion config source = - let kind = - let filename = Mconfig.(config.query.filename) in - let extension = - match String.rindex filename '.' with - | exception Not_found -> "" - | pos -> String.sub ~pos ~len:(String.length filename - pos) filename - in - Logger.log ~section:"Mreader" ~title:"run" - "extension(%S) = %S" filename extension; - if List.exists ~f:(fun (_impl,intf) -> intf = extension) - Mconfig.(config.merlin.suffixes) - then Mreader_parser.MLI - else Mreader_parser.ML - in - let lexer = - let keywords = Extension.keywords Mconfig.(config.merlin.extensions) in - Mreader_lexer.make Mconfig.(config.ocaml.warnings) keywords config source - in - let no_labels_for_completion, lexer = match for_completion with - | None -> false, lexer - | Some pos -> - let pos = Msource.get_lexing_pos source - ~filename:(Mconfig.filename config) pos - in - Mreader_lexer.for_completion lexer pos - in - let parser = Mreader_parser.make Mconfig.(config.ocaml.warnings) lexer kind in - let lexer_keywords = Mreader_lexer.keywords lexer - and lexer_errors = Mreader_lexer.errors lexer - and parser_errors = Mreader_parser.errors parser - and parsetree = Mreader_parser.result parser - and comments = Mreader_lexer.comments lexer - in - { lexer_keywords; lexer_errors; parser_errors; comments; parsetree; - no_labels_for_completion; } - -(* Pretty-printing *) - -type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree -type outcometree = Extend_protocol.Reader.outcometree - -let ambient_reader = ref None - -let instantiate_reader spec config source = match spec with - | [] -> ((lazy None), ignore) - | name :: args -> - let reader = lazy (Mreader_extend.start name args config source) in - (reader, (fun () -> - if Lazy.is_val reader then - match Lazy.force reader with - | None -> () - | Some reader -> Mreader_extend.stop reader)) - -let get_reader config = - let rec find_reader assocsuffixes = - match assocsuffixes with - | [] -> [] - | (suffix,reader)::t -> - if Filename.check_suffix Mconfig.(config.query.filename) suffix then [reader] else find_reader t - in - match Mconfig.(config.merlin.reader) with - (* if a reader flag exists then this is explicitly used disregarding suffix association *) - | [] -> find_reader Mconfig.(config.merlin.extension_to_reader) - | x -> x - -let mocaml_printer reader ppf otree = - let str = match reader with - | lazy (Some reader) -> Mreader_extend.print_outcome otree reader - | _ -> None - in - match str with - | Some str -> Format.pp_print_string ppf str - | None -> Mocaml.default_printer ppf otree - -let with_ambient_reader config source f = - let ambient_reader' = !ambient_reader in - let reader_spec = get_reader config in - let reader, stop = instantiate_reader reader_spec config source in - ambient_reader := Some (reader, reader_spec, source); - Misc.try_finally - (fun () -> Mocaml.with_printer (mocaml_printer reader) f) - ~always:(fun () -> ambient_reader := ambient_reader'; stop ()) - -let try_with_reader config source f = - let reader_spec = get_reader config in - let lazy reader, stop = - match !ambient_reader with - | Some (reader, reader_spec', source') - when compare reader_spec reader_spec' = 0 && - compare source source' = 0 -> reader, ignore - | _ -> instantiate_reader reader_spec config source - in - match reader with - | None -> stop (); None - | Some reader -> - Misc.try_finally (fun () -> f reader) ~always:stop - -let print_pretty config source tree = - match try_with_reader config source - (Mreader_extend.print_pretty tree) with - | Some result -> result - | None -> - let ppf, to_string = Std.Format.to_string () in - let open Extend_protocol.Reader in - begin match tree with - | Pretty_case_list x -> Pprintast.case_list ppf x - | Pretty_core_type x -> Pprintast.core_type ppf x - | Pretty_expression x -> Pprintast.expression ppf x - | Pretty_pattern x -> Pprintast.pattern ppf x - | Pretty_signature x -> Pprintast.signature ppf x - | Pretty_structure x -> Pprintast.structure ppf x - | Pretty_toplevel_phrase x -> Pprintast.toplevel_phrase ppf x - end; - to_string () - -let default_print_outcome tree = - Mocaml.default_printer Format.str_formatter tree; - Format.flush_str_formatter () - -let print_outcome config source tree = - match try_with_reader config source - (Mreader_extend.print_outcome tree) with - | Some result -> result - | None -> default_print_outcome tree - -let print_batch_outcome config source tree = - match try_with_reader config source - (Mreader_extend.print_outcomes tree) with - | Some result -> result - | None -> List.map ~f:default_print_outcome tree - -let reconstruct_identifier config source pos = - match - try_with_reader config source - (Mreader_extend.reconstruct_identifier pos) - with - | None | Some [] -> Mreader_lexer.reconstruct_identifier config source pos - | Some result -> result - -(* Entry point *) - -let parse ?for_completion config = function - | (source, None) -> - begin match - try_with_reader config source - (Mreader_extend.parse ?for_completion) - with - | Some (`No_labels no_labels_for_completion, parsetree) -> - let (lexer_errors, parser_errors, comments) = ([], [], []) in - let lexer_keywords = [] (* TODO? *) in - { lexer_keywords; lexer_errors; parser_errors; comments; - parsetree; no_labels_for_completion; } - | None -> normal_parse ?for_completion config source - end - | (_, Some parsetree) -> - let (lexer_errors, parser_errors, comments) = ([], [], []) in - let lexer_keywords = [] in - { lexer_keywords; lexer_errors; parser_errors; comments; parsetree; - no_labels_for_completion = false; } diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader.mli deleted file mode 100644 index 2594d65c8..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader.mli +++ /dev/null @@ -1,43 +0,0 @@ -type parsetree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -type comment = (string * Location.t) - -type result = { - lexer_keywords: string list; - lexer_errors : exn list; - parser_errors : exn list; - comments : comment list; - parsetree : parsetree; - no_labels_for_completion : bool; -} - -type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree -type outcometree = Extend_protocol.Reader.outcometree - -(* Ambient reader. - - Some actions need to interact with an external process. - `with_ambient_reader' will setup this process to speed up later calls. -*) - -val with_ambient_reader : Mconfig.t -> Msource.t -> (unit -> 'a) -> 'a - -(* Main functions *) - -val parse : - ?for_completion:Msource.position -> Mconfig.t -> Msource.t * parsetree option -> result - -val print_pretty : - Mconfig.t -> Msource.t -> pretty_parsetree -> string - -val print_outcome : - Mconfig.t -> Msource.t -> outcometree -> string - -val print_batch_outcome : - Mconfig.t -> Msource.t -> outcometree list -> string list - -val reconstruct_identifier: - Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_explain.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_explain.ml deleted file mode 100644 index 83c5186dd..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_explain.ml +++ /dev/null @@ -1,104 +0,0 @@ -open Parser_raw -open MenhirInterpreter - -let opening (type a) : a terminal -> string option = function - | T_STRUCT -> Some "struct" - | T_SIG -> Some "sig" - | T_OBJECT -> Some "object" - | T_BEGIN -> Some "begin" - | T_LPAREN -> Some "(" - | T_LBRACKET -> Some "[" - | T_LBRACE -> Some "{" - | T_LBRACKETBAR -> Some "[|" - | T_LBRACKETLESS -> Some "[<" - | T_LBRACELESS -> Some "{<" - | _ -> None - -let opening_st st = - match incoming_symbol st with - | T term -> opening term - | _ -> None - -let closing (type a) : a terminal -> bool = function - | T_END -> true - | T_RPAREN -> true - | T_RBRACKET -> true - | T_RBRACE -> true - | T_BARRBRACKET -> true - | T_GREATERRBRACE -> true - | T_GREATERRBRACKET -> true - | _ -> false - -let closing_st st = - match incoming_symbol st with - | T term -> closing term - | _ -> false - -type explanation = { - item: (string * Location.t) option; - unclosed: (string * Location.t) option; - location: Location.t; - popped: MenhirInterpreter.xsymbol list; - shifted: MenhirInterpreter.xsymbol option; - unexpected: MenhirInterpreter.token; -} - -let explain env (unexpected, startp, endp) popped shifted = - let mkloc s e = {Location. loc_start = s; loc_end = e; loc_ghost = false} in - let open MenhirInterpreter in - let location = mkloc startp endp in - let closed = ref 0 in - let unclosed = ref None in - let return item = - { item; unclosed = !unclosed; location; popped; shifted; unexpected } - in - let rec process env = match top env with - | None -> return None - | Some (Element (st, _, startp, endp)) -> - if closing_st st then incr closed; - begin match opening_st st with - | None -> () - | Some st -> - if !closed = 0 && !unclosed = None then - unclosed := Some (st, mkloc startp endp) - else - decr closed - end; - match Parser_explain.named_item_at (number st) with - | name -> return (Some (name, mkloc startp endp)) - | exception Not_found -> - match pop env with - | None -> return None - | Some env -> process env - in - process env - -let to_error { item; unclosed; location; popped; shifted; unexpected = _ } = - let inside = match item with - | None -> "" - | Some (name, _) -> " inside `" ^ name ^ "'" in - let after = match unclosed with - | None -> "" - | Some (name, _) -> " after unclosed " ^ name in - let friendly_name sym = match sym with - | X (T _) -> "`" ^ Parser_printer.print_symbol sym ^ "'" - | X (N _) -> Parser_printer.print_symbol sym - in - let popped = String.concat " " (List.rev_map friendly_name popped) in - let expecting = match shifted with - | None -> if popped = "" then "" else ", maybe remove " ^ popped - | Some (X (T T_EOF)) -> "" - | Some sym -> - if popped = "" then ", expecting " ^ (friendly_name sym) - else ", maybe replace " ^ popped ^ " by " ^ (friendly_name sym) - in - let msg = Printf.sprintf "Syntax error%s%s%s" inside after expecting in - Location.error ~loc:location ~source:Location.Parser msg - -exception Syntax_explanation of explanation - -let syntax_explanation = function - | Syntax_explanation explanation -> Some (to_error explanation) - | _ -> None - -let () = Location.register_error_of_exn syntax_explanation diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_extend.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_extend.ml deleted file mode 100644 index b5c59a53e..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_extend.ml +++ /dev/null @@ -1,148 +0,0 @@ -open Std -open Extend_protocol.Reader - -let {Logger. log} = Logger.for_section "Mreader_extend" - -type t = { - name : string; - args : string list; - config : Mconfig.t; - source : Msource.t; - driver : Extend_driver.t; - mutable stopped : bool; -} - -let print () t = t.name - -let incorrect_behavior fn t = - log ~title:fn "Extension %S has incorrect behavior" t.name - -let stop t = - if t.stopped then - log ~title:"stop" "%a: already closed" print t - else ( - log ~title:"stop" "%a" print t; - t.stopped <- true; - Extend_driver.stop t.driver - ) - -let stop_finalise t = - if not t.stopped then ( - log ~title:"stop_finalise" "leaked process %s" t.name; - stop t - ) - -let load_source t config source = - let buffer = { - path = Mconfig.filename config; - flags = t.args; - text = Msource.text source; - } in - match Extend_driver.reader t.driver (Req_load buffer) with - | Res_loaded -> Some t - | _ -> - Extend_driver.stop t.driver; - incorrect_behavior "load_source" t; - None - -let start name args config source = - let section = "(ext)" ^ name in - let notify str = Logger.notify ~section "%s" str in - let debug str = Logger.log ~section:"reader" ~title:section "%s" str in - let driver = Extend_driver.run ~notify ~debug name in - let process = { name; args; config; source; driver; stopped = false } in - Gc.finalise stop_finalise process; - load_source process config source - -let parsetree = function - | Signature sg -> `Interface sg - | Structure str -> `Implementation str - -let parse ?for_completion t = - log ~title:"parse" "?for_completion:%a %a" - (Option.print Msource.print_position) for_completion - print t; - assert (not t.stopped); - match - Extend_driver.reader t.driver - (match for_completion with - | None -> Req_parse - | Some pos -> - let pos = Msource.get_lexing_pos t.source - ~filename:(Mconfig.filename t.config) pos - in - Req_parse_for_completion pos) - with - | Res_parse ast -> - Some (`No_labels false, parsetree ast) - | Res_parse_for_completion (info, ast) -> - Some (`No_labels (not info.complete_labels), parsetree ast) - | _ -> - incorrect_behavior "parse" t; - None - -let reconstruct_identifier pos t = - log ~title:"reconstruct_identifier" "%a %a" - Lexing.print_position pos print t; - match Extend_driver.reader t.driver (Req_get_ident_at pos) with - | Res_get_ident_at ident -> Some ident - | _ -> - incorrect_behavior "reconstruct_identifier" t; - None - -let attr_cleaner = - let open Ast_mapper in - let attributes mapper attrs = - let not_merlin_attribute attr = - let (name,_) = Ast_helper.Attr.as_tuple attr in - not (String.is_prefixed ~by:"merlin." name.Location.txt) in - let attrs = List.filter ~f:not_merlin_attribute attrs in - default_mapper.attributes mapper attrs - in - { default_mapper with attributes } - -let clean_tree = - let open Ast_mapper in function - | Pretty_case_list x -> - Pretty_case_list (attr_cleaner.cases attr_cleaner x) - | Pretty_core_type x -> - Pretty_core_type (attr_cleaner.typ attr_cleaner x) - | Pretty_expression x -> - Pretty_expression (attr_cleaner.expr attr_cleaner x) - | Pretty_pattern x -> - Pretty_pattern (attr_cleaner.pat attr_cleaner x) - | Pretty_signature x -> - Pretty_signature (attr_cleaner.signature attr_cleaner x) - | Pretty_structure x -> - Pretty_structure (attr_cleaner.structure attr_cleaner x) - | Pretty_toplevel_phrase (Parsetree.Ptop_def x) -> - let x = attr_cleaner.structure attr_cleaner x in - Pretty_toplevel_phrase (Parsetree.Ptop_def x) - | Pretty_toplevel_phrase (Parsetree.Ptop_dir _) as tree -> tree - -let print_pretty tree t = - log ~title:"print_pretty" "TODO %a" print t; - let tree = clean_tree tree in - match Extend_driver.reader t.driver (Req_pretty_print tree) with - | Res_pretty_print str -> Some str - | _ -> - incorrect_behavior "pretty_print" t; - None - -let print_outcomes ts t = - log ~title:"print_outcomes" "TODO %a" print t; - match ts with - | [] -> Some [] - | ts -> match Extend_driver.reader t.driver (Req_print_outcome ts) with - | Res_print_outcome ts -> Some ts - | _ -> - incorrect_behavior "print_batch_outcome" t; - None - -let print_outcome o t = - log ~title:"print_outcome" "TODO %a" print t; - match Extend_driver.reader t.driver (Req_print_outcome [o]) with - | Res_print_outcome [o] -> Some o - | _ -> - incorrect_behavior "print_batch_outcome" t; - None diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_extend.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_extend.mli deleted file mode 100644 index 01ee90fa4..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_extend.mli +++ /dev/null @@ -1,23 +0,0 @@ -type t - -val stop : t -> unit - -val start : string -> string list -> Mconfig.t -> Msource.t -> t option - -val parse : - ?for_completion:Msource.position -> t -> - ([`No_labels of bool ] * - [`Implementation of Parsetree.structure | `Interface of Parsetree.signature]) - option - -val reconstruct_identifier : - Lexing.position -> t -> string Location.loc list option - -val print_pretty : - Extend_protocol.Reader.pretty_parsetree -> t -> string option - -val print_outcomes : - Extend_protocol.Reader.outcometree list -> t -> string list option - -val print_outcome : - Extend_protocol.Reader.outcometree -> t -> string option diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_lexer.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_lexer.ml deleted file mode 100644 index c889790b3..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_lexer.ml +++ /dev/null @@ -1,366 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -type keywords = Lexer_raw.keywords - -type triple = Parser_raw.token * Lexing.position * Lexing.position - -type item = - | Triple of triple - | Comment of (string * Location.t) - | Error of Lexer_raw.error * Location.t - -type t = { - keywords: keywords; - config: Mconfig.t; - source: Msource.t; - items: item list; -} - -let get_tokens keywords pos text = - let state = Lexer_raw.make keywords in - let lexbuf = Lexing.from_string text in - Lexing.move lexbuf pos; - let rec aux items = function - | Lexer_raw.Return (Parser_raw.COMMENT comment) -> - continue (Comment comment :: items) - | Lexer_raw.Refill k -> aux items (k ()) - | Lexer_raw.Return t -> - let triple = (t, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in - let items = Triple triple :: items in - if t = Parser_raw.EOF - then items - else continue items - | Lexer_raw.Fail (err, loc) -> - continue (Error (err, loc) :: items) - - and continue items = - aux items (Lexer_raw.token state lexbuf) - - in - function - | [] -> - (* First line: skip #! ... *) - aux [] (Lexer_raw.skip_sharp_bang state lexbuf) - | items -> - (* Resume *) - continue items - -let initial_position config = - { Lexing. - pos_fname = (Mconfig.filename config); - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0; - } - -let make warnings keywords config source = - Msupport.catch_errors warnings (ref []) @@ fun () -> - let items = - get_tokens keywords - (initial_position config) - (Msource.text source) - [] - in - { keywords; items; config; source } - -let item_start = function - | Triple (_,s,_) -> s - | Comment (_, l) | Error (_, l) -> - l.Location.loc_start - -let item_end = function - | Triple (_,_,e) -> e - | Comment (_, l) | Error (_, l) -> - l.Location.loc_end - -let initial_position t = - initial_position t.config - -let rev_filter_map ~f lst = - let rec aux acc = function - | [] -> acc - | x :: xs -> - let acc = - match f x with - | Some x' -> x' :: acc - | None -> acc - in - aux acc xs - in - aux [] lst - -let tokens t = - rev_filter_map t.items - ~f:(function Triple t -> Some t | _ -> None) - -let keywords t = - Lexer_raw.list_keywords t.keywords - -let errors t = - rev_filter_map t.items - ~f:(function Error (err, loc) -> Some (Lexer_raw.Error (err, loc)) - | _ -> None) - -let comments t = - rev_filter_map t.items - ~f:(function Comment t -> Some t | _ -> None) - -open Parser_raw - -let is_operator = function - | PREFIXOP s - | LETOP s | ANDOP s - | INFIXOP0 s | INFIXOP1 s | INFIXOP2 s | INFIXOP3 s | INFIXOP4 s -> Some s - | BANG -> Some "!" - | PERCENT -> Some "%" - | PLUS -> Some "+" | PLUSDOT -> Some "+." - | MINUS -> Some "-" | MINUSDOT -> Some "-." - | STAR -> Some "*" | EQUAL -> Some "=" - | LESS -> Some "<" | GREATER -> Some ">" - | OR -> Some "or" | BARBAR -> Some "||" - | AMPERSAND -> Some "&" | AMPERAMPER -> Some "&&" - | COLONEQUAL -> Some ":=" | PLUSEQ -> Some "+=" - | _ -> None - -(* [reconstruct_identifier] is impossible to read at the moment, here is a - pseudo code version of the function: - (many thanks to Gabriel for this contribution) - - 00| let h = parse (focus h) with - 01| | . { h+1 } - 02| | _ { h } - 03| in - 04| parse h with - 05| | BOF x=operator { [x] } - 06| | ¬( x=operator { [x] } - 07| | ' x=ident { [] } - 08| | _ { - 09| let acc, h = parse (h ! tail h) with - 10| | x=ident ! { [x], h } - 11| | ( ! x=operator ) { [x], h } - 12| | ( x=operator ! ) { [x], h - 1 } - 13| | ( x=operator ) ! { [x], h - 2 } - 14| | _ { [], h } - 15| in - 16| let h = h - 1 in - 17| let rec head acc = parse (h !) with - 18| | tl x=ident . ! { head (x :: acc) tl } - 19| | x=ident . ! { ident :: acc } - 20| | _ { acc } - 21| in head acc - 22| } - - Now for the explanations: - line 0-3: if we're on a dot, skip it and move to the right - - line 5,6: if we're on an operator not preceded by an opening parenthesis, - just return that. - - line 7: if we're on a type variable, don't return anything. - reconstruct_identifier is called when locating and getting the - type of an expression, in both cases there's nothing we can do - with a type variable. - See #317 - - line 8-22: two step approach: - - line 9-15: retrieve the identifier - OR retrieve the parenthesized operator and move before the - opening parenthesis - - - line 16-21: retrieve the "path" prefix of the identifier/operator we - got in the previous step. - - - Additionally, the message of commit fc0b152 explains what we consider is an - identifier: - - « - Interpreting an OCaml identifier out of context is a bit ambiguous. - - A prefix of the form (UIDENT DOT)* is the module path, - A UIDENT suffix is either a module name, a module type name (in case the - whole path is a module path), or a value constructor. - A LIDENT suffix is either a value name, a type constructor or a module - type name. - A LPAREN OPERATOR RPAREN suffix is a value name (and soon, maybe a - value constructor if beginning by ':' ?!) . - - In the middle, LIDENT DOT (UIDENT DOT)* is projection of the field of a - record. In this case, merlin will drop everything up to the first - UIDENT and complete in the scope of the (UIDENT DOT)* interpreted as a - module path. - Soon, the last UIDENT might also be the type of an inline record. - (Module2.f.Module1.A <- type of the record of the value constructor named A of - type f, defined in Module1 and aliased in Module2, pfffff). - » -*) - -let reconstruct_identifier_from_tokens tokens pos = - let rec look_for_component acc = function - - (* Skip 'a and `A *) - | ((LIDENT _ | UIDENT _), _, _) :: - ((BACKQUOTE | QUOTE), _, _) :: items -> - check acc items - - (* UIDENT is a regular a component *) - | (UIDENT _, _, _) as item :: items -> - look_for_dot (item :: acc) items - - (* LIDENT always begin a new identifier *) - | (LIDENT _, _, _) as item :: items -> - if acc = [] - then look_for_dot [item] items - else check acc (item :: items) - - (* Reified operators behave like LIDENT *) - | (RPAREN, _, _) :: (token, _, _ as item) :: (LPAREN, _, _) :: items - when is_operator token <> None && acc = [] -> - look_for_dot [item] items - - (* An operator alone is an identifier on its own *) - | (token, _, _ as item) :: items - when is_operator token <> None && acc = [] -> - check [item] items - - (* Otherwise, check current accumulator and scan the rest of the input *) - | _ :: items -> - check acc items - - | [] -> raise Not_found - - and look_for_dot acc = function - | (DOT,_,_) :: items -> look_for_component acc items - | items -> check acc items - - and check acc items = - if acc <> [] && - (let startp = match acc with - | (_, startp, _) :: _ -> startp - | _ -> assert false in - Lexing.compare_pos startp pos <= 0) && - (let endp = match List.last acc with - | Some ((_, _, endp)) -> endp - | _ -> assert false in - Lexing.compare_pos pos endp <= 0) - then acc - else match items with - | [] -> raise Not_found - | (_, _, endp) :: _ when Lexing.compare_pos endp pos < 0 -> - raise Not_found - | _ -> look_for_component [] items - - in - match look_for_component [] tokens with - | exception Not_found -> [] - | acc -> - let fmt (token, loc_start, loc_end) = - let id = - match token with - | UIDENT s | LIDENT s -> s - | _ -> match is_operator token with - | Some t -> t - | None -> assert false - in - Location.mkloc id {Location. loc_start; loc_end; loc_ghost = false} - in - let before_pos = function - | (_, s, _) -> - Lexing.compare_pos s pos <= 0 - in - List.map ~f:fmt (List.filter ~f:before_pos acc) - -let reconstruct_identifier config source pos = - let rec lex acc lexbuf = - let token = Lexer_ident.token lexbuf in - let item = (token, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in - match token with - | EOF -> (item :: acc) - | EOL when Lexing.compare_pos lexbuf.Lexing.lex_curr_p pos > 0 -> - (item :: acc) - | EOL -> lex [] lexbuf - | _ -> lex (item :: acc) lexbuf - in - let lexbuf = Lexing.from_string (Msource.text source) in - Location.init lexbuf (Mconfig.filename config); - let tokens = lex [] lexbuf in - reconstruct_identifier_from_tokens tokens pos - -let is_uppercase {Location. txt = x; _} = - x <> "" && Char.is_uppercase x.[0] - -let rec drop_lowercase acc = function - | [x] -> List.rev (x :: acc) - | x :: xs when not (is_uppercase x) -> drop_lowercase [] xs - | x :: xs -> drop_lowercase (x :: acc) xs - | [] -> List.rev acc - -let for_completion t pos = - let no_labels = ref false in - let check_label = function - | Triple ((LABEL _ | OPTLABEL _), _, _) -> no_labels := true - | _ -> () - in - let rec aux acc = function - (* Cursor is before item: continue *) - | item :: items when Lexing.compare_pos (item_start item) pos >= 0 -> - aux (item :: acc) items - - (* Cursor is in the middle of item: stop *) - | item :: _ when Lexing.compare_pos (item_end item) pos > 0 -> - check_label item; - raise Exit - - (* Cursor is at the end *) - | ((Triple (token, _, loc_end) as item) :: _) as items - when Lexing.compare_pos pos loc_end = 0 -> - check_label item; - begin match token with - (* Already on identifier, no need to introduce *) - | UIDENT _ | LIDENT _ -> raise Exit - | _ -> acc, items - end - - | items -> acc, items - in - let t = - match aux [] t.items with - | exception Exit -> t - | acc, items -> - {t with items = - List.rev_append acc (Triple (LIDENT "", pos, pos) :: items)} - in - (!no_labels, t) - -let identifier_suffix ident = - match List.last ident with - | Some x when is_uppercase x -> drop_lowercase [] ident - | _ -> ident diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_lexer.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_lexer.mli deleted file mode 100644 index f9236a72f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_lexer.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -type keywords = Lexer_raw.keywords - -type triple = Parser_raw.token * Lexing.position * Lexing.position - -type t - -val make : Warnings.state -> keywords -> Mconfig.t -> Msource.t -> t - -val for_completion: t -> Lexing.position -> - bool (* complete labels or not *) * t - -val initial_position : t -> Lexing.position - -val tokens : t -> triple list -val keywords : t -> string list -val errors : t -> exn list -val comments : t -> (string * Location.t) list - -val reconstruct_identifier: - Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list - -val identifier_suffix: string Location.loc list -> string Location.loc list diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_parser.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_parser.ml deleted file mode 100644 index f05ec067e..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_parser.ml +++ /dev/null @@ -1,211 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -module I = Parser_raw.MenhirInterpreter - -type kind = - | ML - | MLI - (*| MLL | MLY*) - -module Dump = struct - let symbol () = Parser_printer.print_symbol -end - -module R = Mreader_recover.Make - (I) - (struct - include Parser_recover - - let default_value loc x = - Default.default_loc := loc; - default_value x - - let guide (type a) : a I.symbol -> bool = function - | I.T I.T_BEGIN -> true - | _ -> false - - let token_of_terminal = Parser_printer.token_of_terminal - - let nullable = Parser_explain.nullable - end) - (Dump) - -type 'a step = - | Correct of 'a I.checkpoint - | Recovering of 'a R.candidates - -type tree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -type steps =[ - | `Signature of (Parsetree.signature step * Mreader_lexer.triple) list - | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list -] - -type t = { - kind: kind; - tree: tree; - steps: steps; - errors: exn list; - lexer: Mreader_lexer.t; -} - -let eof_token = (Parser_raw.EOF, Lexing.dummy_pos, Lexing.dummy_pos) - -let errors_ref = ref [] - -let resume_parse = - let rec normal acc tokens = function - | I.InputNeeded env as checkpoint -> - let token, tokens = match tokens with - | token :: tokens -> token, tokens - | [] -> eof_token, [] - in - check_for_error acc token tokens env (I.offer checkpoint token) - - | I.Shifting (_,env,_) | I.AboutToReduce (env,_) as checkpoint -> - begin match I.resume checkpoint with - | checkpoint' -> normal acc tokens checkpoint' - | exception exn -> - Msupport.raise_error exn; - let token = match acc with - | [] -> assert false - (* Parser raised error before parsing anything *) - | (_, token) :: _ -> token - in - enter_error acc token tokens env - end - - | I.Accepted v -> acc, v - - | I.Rejected | I.HandlingError _ -> - assert false - - and check_for_error acc token tokens env = function - | I.HandlingError _ -> - enter_error acc token tokens env - - | I.Shifting _ | I.AboutToReduce _ as checkpoint -> - begin match I.resume checkpoint with - | checkpoint' -> check_for_error acc token tokens env checkpoint' - | exception exn -> - Msupport.raise_error exn; - enter_error acc token tokens env - end - - | checkpoint -> - normal ((Correct checkpoint, token) :: acc) tokens checkpoint - - and enter_error acc token tokens env = - let candidates = R.generate env in - let explanation = - Mreader_explain.explain env token - candidates.R.popped candidates.R.shifted - in - errors_ref := Mreader_explain.Syntax_explanation explanation :: !errors_ref; - recover acc (token :: tokens) candidates - - and recover acc tokens candidates = - let token, tokens = match tokens with - | token :: tokens -> token, tokens - | [] -> eof_token, [] - in - let acc' = ((Recovering candidates, token) :: acc) in - match R.attempt candidates token with - | `Fail -> - if tokens = [] then - match candidates.R.final with - | None -> failwith "Empty file" - | Some v -> acc', v - else - recover acc tokens candidates - | `Accept v -> acc', v - | `Ok (checkpoint, _) -> - normal ((Correct checkpoint, token) :: acc) tokens checkpoint - in - fun acc tokens -> function - | Correct checkpoint -> normal acc tokens checkpoint - | Recovering candidates -> recover acc tokens candidates - -let seek_step steps tokens = - let rec aux acc = function - | (step :: steps), (token :: tokens) when snd step = token -> - aux (step :: acc) (steps, tokens) - | _, tokens -> acc, tokens - in - aux [] (steps, tokens) - -let parse initial steps tokens initial_pos = - let acc, tokens = seek_step steps tokens in - let step = - match acc with - | (step, _) :: _ -> step - | [] -> Correct (initial initial_pos) - in - let acc, result = resume_parse acc tokens step in - List.rev acc, result - -let run_parser warnings lexer previous kind = - Msupport.catch_errors warnings errors_ref @@ fun () -> - let tokens = Mreader_lexer.tokens lexer in - let initial_pos = Mreader_lexer.initial_position lexer in - match kind with - | ML -> - let steps = match previous with - | `Structure steps -> steps - | _ -> [] - in - let steps, result = - let state = Parser_raw.Incremental.implementation in - parse state steps tokens initial_pos in - `Structure steps, `Implementation result - | MLI -> - let steps = match previous with - | `Signature steps -> steps - | _ -> [] - in - let steps, result = - let state = Parser_raw.Incremental.interface in - parse state steps tokens initial_pos in - `Signature steps, `Interface result - -let make warnings lexer kind = - errors_ref := []; - let steps, tree = run_parser warnings lexer `None kind in - let errors = !errors_ref in - errors_ref := []; - {kind; steps; tree; errors; lexer} - -let result t = t.tree - -let errors t = t.errors diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_parser.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_parser.mli deleted file mode 100644 index d2b9ebff0..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_parser.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -type kind = - | ML - | MLI - (*| MLL | MLY*) - -type t - -val make : Warnings.state -> Mreader_lexer.t -> kind -> t - -type tree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -val result : t -> tree - -val errors : t -> exn list diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_recover.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_recover.ml deleted file mode 100644 index 401590503..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_recover.ml +++ /dev/null @@ -1,283 +0,0 @@ -open Std - -let {Logger. log} = Logger.for_section "Mreader_recover" - -module Make - (Parser : MenhirLib.IncrementalEngine.EVERYTHING) - (Recovery : sig - val default_value : Location.t -> 'a Parser.symbol -> 'a - - type action = - | Abort - | R of int - | S : 'a Parser.symbol -> action - | Sub of action list - - type decision = - | Nothing - | One of action list - | Select of (int -> action list) - - val depth : int array - - val recover : int -> decision - - val guide : 'a Parser.symbol -> bool - - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - - val nullable : 'a Parser.nonterminal -> bool - end) - (Dump : sig - val symbol : unit -> Parser.xsymbol -> string - end) = -struct - - type 'a candidate = { - line: int; - min_col: int; - max_col: int; - env: 'a Parser.env; - } - - type 'a candidates = { - popped: Parser.xsymbol list; - shifted: Parser.xsymbol option; - final: 'a option; - candidates: 'a candidate list; - } - - module T = struct - (* FIXME: this is a bit ugly. We should ask for the type to be exported - publicly by MenhirLib. *) - - [@@@ocaml.warning "-37"] - - type 'a checkpoint = - | InputNeeded of 'a Parser.env - | Shifting of 'a Parser.env * 'a Parser.env * bool - | AboutToReduce of 'a Parser.env * Parser.production - | HandlingError of 'a Parser.env - | Accepted of 'a - | Rejected - external inj : 'a checkpoint -> 'a Parser.checkpoint = "%identity" - end - - (*let env_state env = - match Parser.top env with - | None -> -1 - | Some (Parser.Element (state, _, _, _)) -> - Parser.number state*) - - let feed_token ~allow_reduction token env = - let rec aux allow_reduction = function - | Parser.HandlingError _ | Parser.Rejected -> `Fail - | Parser.AboutToReduce _ when not allow_reduction -> `Fail - | Parser.Accepted v -> `Accept v - | Parser.Shifting _ | Parser.AboutToReduce _ as checkpoint -> - aux true (Parser.resume checkpoint) - | Parser.InputNeeded env as checkpoint -> `Recovered (checkpoint, env) - in - aux allow_reduction (Parser.offer (T.inj (T.InputNeeded env)) token) - - let rec follow_guide col env = match Parser.top env with - | None -> col - | Some (Parser.Element (state, _, pos, _)) -> - if Recovery.guide (Parser.incoming_symbol state) then - match Parser.pop env with - | None -> col - | Some env -> follow_guide (snd (Lexing.split_pos pos)) env - else - col - - let candidate env = - let line, min_col, max_col = - match Parser.top env with - | None -> 1, 0, 0 - | Some (Parser.Element (state, _, pos, _)) -> - let depth = Recovery.depth.(Parser.number state) in - let line, col = Lexing.split_pos pos in - if depth = 0 then - line, col, col - else - let col' = match Parser.pop_many depth env with - | None -> max_int - | Some env -> - match Parser.top env with - | None -> max_int - | Some (Parser.Element (_, _, pos, _)) -> - follow_guide (snd (Lexing.split_pos pos)) env - in - line, min col col', max col col' - in - { line; min_col; max_col; env } - - let attempt r token = - let _, startp, _ = token in - let line, col = Lexing.split_pos startp in - let more_indented candidate = - line <> candidate.line && candidate.min_col > col in - let recoveries = List.drop_while ~f:more_indented r.candidates in - let same_indented candidate = - line = candidate.line || - (candidate.min_col <= col && col <= candidate.max_col) - in - let recoveries = List.take_while ~f:same_indented recoveries in - let rec aux = function - | [] -> `Fail - | x :: xs -> match feed_token ~allow_reduction:true token x.env with - | `Fail -> - (*if not (is_closed k) then - printf k "Couldn't resume %d with %S.\n" - (env_state x.env) (let (t,_,_) = token in Dump.token t);*) - aux xs - | `Recovered (checkpoint, _) -> `Ok (checkpoint, x.env) - | `Accept v -> - begin match aux xs with - | `Fail -> `Accept v - | x -> x - end - in - aux recoveries - - let decide env = - let rec nth_state env n = - if n = 0 then - match Parser.top env with - | None -> -1 (*allow giving up recovery on empty files*) - | Some (Parser.Element (state, _, _, _)) -> Parser.number state - else - match Parser.pop env with - | None -> assert (n = 1); -1 - | Some env -> nth_state env (n - 1) - in - let st = nth_state env 0 in - match Recovery.recover st with - | Recovery.Nothing -> [] - | Recovery.One actions -> actions - | Recovery.Select f -> f (nth_state env Recovery.depth.(st)) - - let generate (type a) (env : a Parser.env) = - let module E = struct - exception Result of a - end in - let shifted = ref None in - let rec aux acc env = - match Parser.top env with - | None -> None, acc - | Some (Parser.Element (state, _, _startp, endp)) -> - (*Dump.element k elt;*) - log ~title:"decide state" "%d" (Parser.number state); - let actions = decide env in - let candidate0 = candidate env in - let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env = function - | Recovery.Abort -> - log ~title:"eval Abort" ""; - raise Not_found - | Recovery.R prod -> - log ~title:"eval Reduce" ""; - let prod = Parser.find_production prod in - Parser.force_reduction prod env - | Recovery.S (Parser.N n as sym) -> - let xsym = Parser.X sym in - if !shifted = None && not (Recovery.nullable n) then - shifted := Some xsym; - log ~title:"eval Shift N" "%a" Dump.symbol xsym; - (* FIXME: if this is correct remove the fixme, otherwise use - [startp] *) - let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in - let v = Recovery.default_value loc sym in - Parser.feed sym endp v endp env - | Recovery.S (Parser.T t as sym) -> - let xsym = Parser.X sym in - if !shifted = None then shifted := Some xsym; - log ~title:"eval Shift T" "%a" Dump.symbol xsym; - let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in - let v = Recovery.default_value loc sym in - let token = (Recovery.token_of_terminal t v, endp, endp) in - begin match feed_token ~allow_reduction:true token env with - | `Fail -> assert false - | `Accept v -> raise (E.Result v) - | `Recovered (_,env) -> env - end - | Recovery.Sub actions -> - log ~title:"enter Sub" ""; - let env = List.fold_left ~f:eval ~init:env actions in - log ~title:"leave Sub" ""; - env - in - match - List.rev_scan_left [] ~f:eval ~init:env actions - |> List.map ~f:(fun env -> {candidate0 with env}) - with - | exception Not_found -> None, acc - | exception (E.Result v) -> Some v, acc - | [] -> None, acc - | (candidate :: _) as candidates -> - aux (candidates @ acc) candidate.env - in - let popped = ref [] in - (*let should_pop stack = - let Parser.Element (state, _, _, _) = Parser.stack_element stack in - match Parser.incoming_symbol state with - | (Parser.T term) as t1 when Recovery.can_pop term -> - log "Pop" "pop %s" - (Dump.symbol (Parser.X t1)); - begin match Parser.stack_next stack with - | None -> false - | Some stack' -> - let rec check_next = function - | Recovery.S (Parser.T term' as t2) :: _ - when Parser.X t1 = Parser.X t2 -> - false - | Recovery.S sym :: _ -> - log "Pop" "then push %s" - (Dump.symbol (Parser.X sym)); - popped := Parser.X t1 :: !popped; - true - | Recovery.Sub xs :: _ -> - check_next xs - | _ -> - popped := Parser.X t1 :: !popped; - true - in - check_next (decide stack') - end - | _ -> false - in*) - let final, candidates = aux [] env in - (List.rev !popped, !shifted, final, candidates) - - let generate env = - let popped, shifted, final, candidates = generate env in - let candidates = List.rev_filter candidates - ~f:(fun t -> not (Parser.env_has_default_reduction t.env)) - in - { popped; shifted; final; candidates = (candidate env) :: candidates } - - (*let dump {Nav. nav; body; _} ~wrong:(t,s,_ as token) ~rest:tokens env = - if not (is_closed body) then ( - let l, c = Lexing.split_pos s in - printf body "Unexpected %S at %d:%d, " (Dump.token t) l c; - link body "see recoveries" - (fun _ -> Nav.push nav "Recoveries" @@ fun {Nav. body; _} -> - let r = generate body env in - let rec aux = function - | [] -> () - | token :: tokens -> - match attempt body r token with - | `Fail -> aux tokens - | `Accept _ -> - text body "\nCouldn't resume, generated final AST.\n" - | `Ok (_, recovered_from) -> - printf body "\nResumed with %S from:\n" - (let (t,_,_) = token in Dump.token t); - Dump.env body recovered_from - in - aux (token :: tokens) - ); - text body ".\n"; - Dump.env body env; - text body "\n" - )*) -end diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_recover.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_recover.mli deleted file mode 100644 index 5cf5c0a2d..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mreader_recover.mli +++ /dev/null @@ -1,56 +0,0 @@ -module Make - (Parser : MenhirLib.IncrementalEngine.EVERYTHING) - (Recovery : sig - val default_value : Location.t -> 'a Parser.symbol -> 'a - - type action = - | Abort - | R of int - | S : 'a Parser.symbol -> action - | Sub of action list - - type decision = - | Nothing - | One of action list - | Select of (int -> action list) - - val depth : int array - - val can_pop : 'a Parser.terminal -> bool - - val recover : int -> decision - - val guide : 'a Parser.symbol -> bool - - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - - val nullable : 'a Parser.nonterminal -> bool - end) - (Dump : sig - val symbol : unit -> Parser.xsymbol -> string - end) : -sig - - type 'a candidate = { - line: int; - min_col: int; - max_col: int; - env: 'a Parser.env; - } - - type 'a candidates = { - popped: Parser.xsymbol list; - shifted: Parser.xsymbol option; - final: 'a option; - candidates: 'a candidate list; - } - - val attempt : 'a candidates -> - Parser.token * Lexing.position * Lexing.position -> - [> `Accept of 'a - | `Fail - | `Ok of 'a Parser.checkpoint * 'a Parser.env ] - - val generate : 'a Parser.env -> 'a candidates - -end diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/msource.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/msource.ml deleted file mode 100644 index f8991e99b..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/msource.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* Merlin representation of a textual source code *) -open Std - -let {Logger. log} = Logger.for_section "Msource" - -type t = { - text: string; -} - -let dump t = `Assoc [ - "text" , `String t.text; - ] - -let print_position () = function - | `Start -> "start" - | `Offset o -> string_of_int o - | `Logical (l,c) -> string_of_int l ^ ":" ^ string_of_int c - | `End -> "end" - -let make text = {text} - -(* Position management *) - -type position = [ - | `Start - | `Offset of int - | `Logical of int * int - | `End -] - -exception Found of int - -let find_line line {text} = - if line <= 0 then - Printf.ksprintf invalid_arg - "Msource.find_line: invalid line number %d. \ - Numbering starts from 1" line; - if line = 1 then 0 else - let line' = ref line in - try - for i = 0 to String.length text - 1 do - if text.[i] = '\n' then begin - decr line'; - if !line' = 1 then - raise (Found i); - end - done; - log ~title:"find_line" "line %d out of bounds (max = %d)" - line (line - !line'); - String.length text - with Found n -> - n + 1 - -let find_offset ({text} as t) line col = - assert (col >= 0); - let offset = find_line line t in - if col = 0 then offset else - try - for i = offset to min (offset + col) (String.length text) - 1 do - if text.[i] = '\n' then begin - log ~title:"find_offset" - "%d:%d out of line bounds, line %d only has %d columns" - line col line (i - offset); - raise (Found i) - end - done; - if (offset + col) > (String.length text) then begin - log ~title:"find_offset" "%d:%d out of file bounds" line col - end; - offset + col - with Found off -> off - -let get_offset t = function - | `Start -> `Offset 0 - | `Offset x -> - assert (x >= 0); - if x <= String.length t.text then - (`Offset x) - else begin - log ~title:"get_offset" - "offset %d out of bounds (size is %d)" x (String.length t.text); - (`Offset (String.length t.text)) - end - | `End -> - `Offset (String.length t.text) - | `Logical (line, col) -> - `Offset (find_offset t line col) - -let get_logical {text} = function - | `Start -> `Logical (1, 0) - | `Logical _ as p -> p - | `Offset _ | `End as r -> - let len = String.length text in - let offset = match r with - | `Offset x when x > len -> - log ~title:"get_logical" "offset %d out of bounds (size is %d)" x len; - len - | `Offset x -> - assert (x >= 0); - x - | `End -> len - in - let line = ref 1 in - let cnum = ref 0 in - for i = 0 to offset - 1 do - if text.[i] = '\n' then begin - incr line; - cnum := i + 1; - end; - done; - `Logical (!line, offset - !cnum) - -let get_lexing_pos t ~filename pos = - let `Offset o = get_offset t pos in - let `Logical (line, col) = get_logical t pos in - { Lexing. - pos_fname = filename; - pos_lnum = line; - pos_bol = o - col; - pos_cnum = o; - } - -let substitute t starting ending text = - let len = String.length t.text in - let `Offset starting = get_offset t starting in - let `Offset ending = match ending with - | `End -> `Offset len - | `Length l -> - if starting + l <= len then - `Offset (starting + l) - else begin - log ~title:"substitute" - "offset %d + length %d out of bounds (size is %d)" starting l len; - `Offset len - end - | #position as p -> get_offset t p - in - if ending < starting then - invalid_arg "Source.substitute: ending < starting"; - let text = - String.sub t.text ~pos:0 ~len:starting ^ - text ^ - String.sub t.text ~pos:ending ~len:(len - ending) - in - {text} - -(* Accessing content *) - -let text t = t.text diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/msource.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/msource.mli deleted file mode 100644 index e8e2bbee8..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/msource.mli +++ /dev/null @@ -1,36 +0,0 @@ -(** {0 Merlin representation of a textual source code} - - It bundles filename and a content, and offers functions for computing - positions in the source. -*) -type t - -(** Making a content from name and contents. *) -val make : string -> t - -(** {1 Position management} *) - -type position = [ - | `Start - | `Offset of int - | `Logical of int * int - | `End -] - -val get_offset : t -> [< position] -> [> `Offset of int] - -val get_logical : t -> [< position] -> [> `Logical of int * int] - -val get_lexing_pos : t -> filename:string -> [< position] -> Lexing.position - -(** {1 Managing content} *) - -(** Updating content *) -val substitute : t -> [< position] -> [< position | `Length of int] -> string -> t - -(** Source code of the file *) -val text : t -> string - -val dump : t -> Std.json - -val print_position : unit -> [< position] -> string diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mtyper.ml b/ocaml-lsp-server/vendor/merlin/src/kernel/mtyper.ml deleted file mode 100644 index 161913039..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mtyper.ml +++ /dev/null @@ -1,210 +0,0 @@ -open Std -open Local_store - -let {Logger. log} = Logger.for_section "Mtyper" - -type ('p,'t) item = { - parsetree_item: 'p; - typedtree_items: 't list * Types.signature_item list; - part_snapshot : Types.snapshot; - part_env : Env.t; - part_errors : exn list; - part_checks : Typecore.delayed_check list; - part_warnings : Warnings.state; -} - -type typedtree = [ - | `Interface of Typedtree.signature - | `Implementation of Typedtree.structure -] - -let cache = s_ref None - -let fresh_env config = - let env0 = Typer_raw.fresh_env () in - let env0 = Extension.register Mconfig.(config.merlin.extensions) env0 in - let snap0 = Btype.snapshot () in - (env0, snap0) - -let get_cache config = - match !cache with - | Some (env0, snap0, items) when Types.is_valid snap0 -> - env0, snap0, Some items - | Some _ | None -> - let env0, snap0 = fresh_env config in - env0, snap0, None - -let return_and_cache status = - cache := Some status; - status - -type result = { - config : Mconfig.t; - initial_env : Env.t; - initial_snapshot : Types.snapshot; - typedtree : [ - | `Interface of - (Parsetree.signature_item, Typedtree.signature_item) item list - | `Implementation of - (Parsetree.structure_item, Typedtree.structure_item) item list - ]; -} - -let initial_env res = res.initial_env - -let compatible_prefix result_items tree_items = - let rec aux acc = function - | (ritem :: ritems, pitem :: pitems) - when Types.is_valid ritem.part_snapshot - && compare ritem.parsetree_item pitem = 0 -> - aux (ritem :: acc) (ritems, pitems) - | (_, pitems) -> - log ~title:"compatible_prefix" "reusing %d items, %d new items to type" - (List.length acc) (List.length pitems); - acc, pitems - in - aux [] (result_items, tree_items) - -let rec type_structure caught env = function - | parsetree_item :: rest -> - let items, _, part_env = - Typemod.merlin_type_structure env [parsetree_item] - in - let typedtree_items = - (items.Typedtree.str_items, items.Typedtree.str_type) in - let item = { - parsetree_item; typedtree_items; part_env; - part_snapshot = Btype.snapshot (); - part_errors = !caught; - part_checks = !Typecore.delayed_checks; - part_warnings = Warnings.backup (); - } in - item :: type_structure caught part_env rest - | [] -> [] - -let rec type_signature caught env = function - | parsetree_item :: rest -> - let {Typedtree. sig_final_env = part_env; sig_items; sig_type} = - Typemod.merlin_transl_signature env [parsetree_item] in - let item = { - parsetree_item; typedtree_items = (sig_items, sig_type); part_env; - part_snapshot = Btype.snapshot (); - part_errors = !caught; - part_checks = !Typecore.delayed_checks; - part_warnings = Warnings.backup (); - } in - item :: type_signature caught part_env rest - | [] -> [] - -let type_implementation config caught parsetree = - let env0, snap0, prefix = get_cache config in - let prefix, parsetree = - match prefix with - | Some (`Implementation items) -> compatible_prefix items parsetree - | Some (`Interface _) | None -> ([], parsetree) - in - let env', snap', warn' = match prefix with - | [] -> (env0, snap0, Warnings.backup ()) - | x :: _ -> - caught := x.part_errors; - Typecore.delayed_checks := x.part_checks; - (x.part_env, x.part_snapshot, x.part_warnings) - in - Btype.backtrack snap'; - Warnings.restore warn'; - let suffix = type_structure caught env' parsetree in - return_and_cache - (env0, snap0, `Implementation (List.rev_append prefix suffix)) - -let type_interface config caught parsetree = - let env0, snap0, prefix = get_cache config in - let prefix, parsetree = - match prefix with - | Some (`Interface items) -> compatible_prefix items parsetree - | Some (`Implementation _) | None -> ([], parsetree) - in - let env', snap', warn' = match prefix with - | [] -> (env0, snap0, Warnings.backup ()) - | x :: _ -> - caught := x.part_errors; - Typecore.delayed_checks := x.part_checks; - (x.part_env, x.part_snapshot, x.part_warnings) - in - Btype.backtrack snap'; - Warnings.restore warn'; - let suffix = type_signature caught env' parsetree in - return_and_cache - (env0, snap0, `Interface (List.rev_append prefix suffix)) - -let run config parsetree = - if not (Env.check_state_consistency ()) then ( - (* Resetting the local store will clear the load_path cache. - Save it now, reset the store and then restore the path. *) - let load_path = Load_path.get_paths () in - Mocaml.flush_caches (); - Local_store.reset (); - Load_path.reset (); - Load_path.init load_path; - ); - let caught = ref [] in - Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> - Typecore.reset_delayed_checks (); - let initial_env, initial_snapshot, typedtree = match parsetree with - | `Implementation parsetree -> type_implementation config caught parsetree - | `Interface parsetree -> type_interface config caught parsetree - in - Typecore.reset_delayed_checks (); - { config; initial_env; initial_snapshot; typedtree } - -let get_env ?pos:_ t = - Option.value ~default:t.initial_env ( - match t.typedtree with - | `Implementation l -> Option.map ~f:(fun x -> x.part_env) (List.last l) - | `Interface l -> Option.map ~f:(fun x -> x.part_env) (List.last l) - ) - -let get_errors t = - let errors, checks = Option.value ~default:([],[]) ( - let f x = x.part_errors, x.part_checks in - match t.typedtree with - | `Implementation l -> Option.map ~f (List.last l) - | `Interface l -> Option.map ~f (List.last l) - ) - in - let caught = ref errors in - Typecore.delayed_checks := checks; - Msupport.catch_errors Mconfig.(t.config.ocaml.warnings) caught - Typecore.force_delayed_checks; - Typecore.reset_delayed_checks (); - (!caught) - -let get_typedtree t = - let split_items l = - let typd, typs = List.split (List.map ~f:(fun x -> x.typedtree_items) l) in - (List.concat typd, List.concat typs) - in - match t.typedtree with - | `Implementation l -> - let str_items, str_type = split_items l in - `Implementation {Typedtree. str_items; str_type; str_final_env = get_env t} - | `Interface l -> - let sig_items, sig_type = split_items l in - `Interface {Typedtree. sig_items; sig_type; sig_final_env = get_env t} - -let node_at ?(skip_recovered=false) t pos_cursor = - let node = Mbrowse.of_typedtree (get_typedtree t) in - log ~title:"node_at" "Node: %s" (Mbrowse.print () node); - let rec select = function - (* If recovery happens, the incorrect node is kept and a recovery node - is introduced, so the node to check for recovery is the second one. *) - | (_,_) :: ((_,node') :: _ as ancestors) - when Mbrowse.is_recovered node' -> select ancestors - | l -> l - in - match Mbrowse.deepest_before pos_cursor [node] with - | [] -> [get_env t, Browse_raw.Dummy] - | path when skip_recovered -> select path - | path -> - log ~title:"node_at" "Deepest before %s" - (Mbrowse.print () path); - path diff --git a/ocaml-lsp-server/vendor/merlin/src/kernel/mtyper.mli b/ocaml-lsp-server/vendor/merlin/src/kernel/mtyper.mli deleted file mode 100644 index 77820e2b1..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/kernel/mtyper.mli +++ /dev/null @@ -1,42 +0,0 @@ -(** {1 Result of typechecker} - - [Mtyper] essentially produces a typedtree, but to make sense of it - the OCaml typechecker need to be in a specific state. - - The [result] type wraps a snapshot of this state with the typedtree to - ensure correct accesses. -*) - -type result - -type typedtree = [ - | `Interface of Typedtree.signature - | `Implementation of Typedtree.structure -] - -val run : Mconfig.t -> Mreader.parsetree -> result - -val get_env : ?pos:Msource.position -> result -> Env.t - -val get_typedtree : result -> typedtree - -val get_errors : result -> exn list - -val initial_env : result -> Env.t - -(** Heuristic to find suitable environment to complete / type at given position. - * 1. Try to find environment near given cursor. - * 2. Check if there is an invalid construct between found env and cursor : - * Case a. - * > let x = valid_expr || - * The env found is the right most env from valid_expr, it's a correct - * answer. - * Case b. - * > let x = valid_expr - * > let y = invalid_construction|| - * In this case, the env found is the same as in case a, however it is - * preferable to use env from enclosing module rather than an env from - * inside x definition. - *) -val node_at : - ?skip_recovered:bool -> result -> Lexing.position -> Mbrowse.t diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/driver/pparse.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/driver/pparse.ml deleted file mode 100644 index 6e1cb5305..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/driver/pparse.ml +++ /dev/null @@ -1,214 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Std - -let {Logger. log} = Logger.for_section "Pparse" - -type error = - | CannotRun of string - | WrongMagic of string - -(* Note: some of the functions here should go to Ast_mapper instead, - which would encapsulate the "binary AST" protocol. *) - -let write_ast magic ast = - let fn = Filename.temp_file "camlppx" "" in - let oc = open_out_bin fn in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc; - fn - -let report_error = function - | CannotRun cmd -> - log ~title:"report_error" - "Error while running external preprocessor. Command line: %s" cmd - | WrongMagic cmd -> - log ~title:"report_error" - "External preprocessor does not produce a valid file. Command line: %s" cmd - - -external windows_merlin_system_command : string -> cwd:string -> int = "ml_merlin_system_command" - -let merlin_system_command = - if Sys.win32 then - windows_merlin_system_command - else - fun cmd ~cwd -> - let prog = "/bin/bash" in - let argv = ["sh"; "-c"; cmd] in - let stdin = Unix.openfile "/dev/null" [ Unix.O_RDONLY ] 0x777 in - let pid = - let cwd : Spawn.Working_dir.t = Path cwd in - let stdout = Unix.stderr in - Spawn.spawn ~cwd ~prog ~argv ~stdin ~stdout () - in - let (_, status) = Unix.waitpid [] pid in - let res = - match (status : Unix.process_status) with - | WEXITED n -> n - | WSIGNALED _ -> -1 - | WSTOPPED _ -> -1 - in - Unix.close stdin; - res - -let ppx_commandline cmd fn_in fn_out = - Printf.sprintf "%s %s %s%s" - cmd (Filename.quote fn_in) (Filename.quote fn_out) - (if Sys.win32 then "" else " 1>&2") - -let apply_rewriter magic ppx (fn_in, failures) = - let title = "apply_rewriter" in - let fn_out = Filename.temp_file "camlppx" "" in - let comm = ppx_commandline ppx.workval fn_in fn_out in - log ~title "running %s from directory %S" comm ppx.workdir; - Logger.log_flush (); - let failure = - let ok = merlin_system_command comm ~cwd:ppx.workdir = 0 in - if not ok then Some (CannotRun comm) - else if not (Sys.file_exists fn_out) then - Some (WrongMagic comm) - else - (* check magic before passing to the next ppx *) - let ic = open_in_bin fn_out in - let buffer = - try really_input_string ic (String.length magic) - with End_of_file -> "" - in - close_in ic; - if buffer <> magic then - Some (WrongMagic comm) - else - None - in - match failure with - | Some err -> - Misc.remove_file fn_out; - let fallback = - let fallback = - Filename.concat (Filename.get_temp_dir_name ()) - ("camlppx.lastfail" ^ string_of_int failures) - in - match Sys.rename fn_in fallback with - | () -> fallback - | exception exn -> - log ~title "exception while renaming ast: %a" - Logger.exn exn; - fn_in - in - report_error err; - (fallback, failures + 1) - | None -> - Misc.remove_file fn_in; - (fn_out, failures) - -let read_ast magic fn = - let ic = open_in_bin fn in - try - let buffer = really_input_string ic (String.length magic) in - assert(buffer = magic); (* already checked by apply_rewriter *) - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - Misc.remove_file fn; - ast - with exn -> - close_in ic; - Misc.remove_file fn; - raise exn - -let rewrite magic ast ppxs = - let fn_out, _ = - List.fold_right - ~f:(apply_rewriter magic) ~init:(write_ast magic ast, 0) ppxs - in - read_ast magic fn_out - - -let apply_rewriters_str ~ppx ?(restore = true) ~tool_name ast = - match ppx with - | [] -> ast - | ppxs -> - let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in - let ast = rewrite Config.ast_impl_magic_number ast ppxs in - Ast_mapper.drop_ppx_context_str ~restore ast - -let apply_rewriters_sig ~ppx ?(restore = true) ~tool_name ast = - match ppx with - | [] -> ast - | ppxs -> - let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in - let ast = rewrite Config.ast_intf_magic_number ast ppxs in - Ast_mapper.drop_ppx_context_sig ~restore ast - -let apply_rewriters ~ppx ?restore ~tool_name = function - | `Interface ast -> - `Interface (apply_rewriters_sig ~ppx ?restore ~tool_name ast) - | `Implementation ast -> - `Implementation (apply_rewriters_str ~ppx ?restore ~tool_name ast) - -let pp_commandline cmd fn_in fn_out = - Printf.sprintf "%s %s 1>%s" - cmd (Filename.quote fn_in) (Filename.quote fn_out) - -(* FIXME: remove this once we drop support for 4.02 *) -type ('a, 'b) res = Ok of 'a | Error of 'b - -let apply_pp ~workdir ~filename ~source ~pp = - let fn_in = Filename.temp_file "merlinpp" (Filename.basename filename) in - begin - let oc = open_out_bin fn_in in - output_string oc source; - close_out oc - end; - let fn_out = fn_in ^ ".out" in - let comm = pp_commandline pp fn_in fn_out in - let ok = merlin_system_command comm ~cwd:workdir = 0 in - Misc.remove_file fn_in; - if not ok then begin - Misc.remove_file fn_out; - Error (CannotRun comm) - end else if not (Sys.file_exists fn_out) then - Error (WrongMagic comm) - else - let ic = open_in fn_out in - let result = Misc.string_of_file ic in - close_in ic; - Ok result - -let decode_potential_ast source = - let decoder = - if Std.String.is_prefixed ~by:Config.ast_impl_magic_number source then - Some (fun x -> `Implementation (Obj.obj x : Parsetree.structure)) - else if Std.String.is_prefixed ~by:Config.ast_intf_magic_number source then - Some (fun x -> `Interface (Obj.obj x : Parsetree.signature)) - else - None - in - match decoder with - | None -> `Source source - | Some inj -> - let offset = String.length Config.ast_impl_magic_number in - Location.input_name := Marshal.from_string source offset; - let offset = offset + Marshal.total_size (Bytes.unsafe_of_string source) offset in - let ast = Marshal.from_string source offset in - inj ast - -let apply_pp ~workdir ~filename ~source ~pp = - match apply_pp ~workdir ~filename ~source ~pp with - | Ok result -> decode_potential_ast result - | Error err -> - report_error err; - `Source source diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/driver/pparse.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/driver/pparse.mli deleted file mode 100644 index 2f3ea5bb8..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/driver/pparse.mli +++ /dev/null @@ -1,24 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Std - -(** If [restore = true] (the default), cookies set by external rewriters will be - kept for later calls. *) - -val apply_rewriters_str: ppx:string with_workdir list -> ?restore:bool -> tool_name:string -> Parsetree.structure -> Parsetree.structure -val apply_rewriters_sig: ppx:string with_workdir list -> ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature - -val apply_rewriters: ppx:string with_workdir list -> ?restore:bool -> tool_name:string -> Mreader.parsetree -> Mreader.parsetree - -val apply_pp : workdir:string -> filename:string -> source:string -> pp:string -> - [ `Implementation of Parsetree.structure | `Interface of Parsetree.signature | `Source of string ] diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/browse_raw.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/browse_raw.ml deleted file mode 100644 index a737f6eec..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/browse_raw.ml +++ /dev/null @@ -1,965 +0,0 @@ -(* {{{ Copying *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2017 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -[@@@ocaml.warning "-9"] - -open Std - -type constructor_declaration = Typedtree.constructor_declaration - -open Typedtree - -type node = - | Dummy - | Pattern : _ general_pattern -> node - | Expression of expression - | Case : _ case -> node - | Class_expr of class_expr - | Class_structure of class_structure - | Class_field of class_field - | Class_field_kind of class_field_kind - | Module_expr of module_expr - | Module_type_constraint of module_type_constraint - | Structure of structure - | Signature of signature - | Structure_item of structure_item * Env.t - | Signature_item of signature_item * Env.t - | Module_binding of module_binding - | Value_binding of value_binding - | Module_type of module_type - | Module_declaration of module_declaration - | Module_type_declaration of module_type_declaration - | With_constraint of with_constraint - | Core_type of core_type - | Package_type of package_type - | Row_field of row_field - | Value_description of value_description - | Type_declaration of type_declaration - | Type_kind of type_kind - | Type_extension of type_extension - | Extension_constructor of extension_constructor - | Label_declaration of label_declaration - | Constructor_declaration of constructor_declaration - | Class_type of class_type - | Class_signature of class_signature - | Class_type_field of class_type_field - | Class_declaration of class_declaration - | Class_description of class_description - | Class_type_declaration of class_type_declaration - - | Include_description of include_description - | Include_declaration of include_declaration - | Open_description of open_description - | Open_declaration of open_declaration - - | Method_call of expression * meth * Location.t - | Record_field of [`Expression of expression | `Pattern of pattern] - * Types.label_description - * Longident.t Location.loc - | Module_binding_name of module_binding - | Module_declaration_name of module_declaration - | Module_type_declaration_name of module_type_declaration - -let node_update_env env0 = function - | Pattern {pat_env = env} | Expression {exp_env = env} - | Class_expr {cl_env = env} | Method_call ({exp_env = env}, _, _) - | Record_field (`Expression {exp_env = env}, _, _) - | Record_field (`Pattern {pat_env = env}, _, _) - | Module_expr {mod_env = env} | Module_type {mty_env = env} - | Structure_item (_, env) | Signature_item (_, env) - | Core_type {ctyp_env = env} | Class_type {cltyp_env = env} - -> env - | Dummy | Case _ - | Class_structure _ | Class_signature _ - | Class_field _ | Class_field_kind _ - | Type_extension _ | Extension_constructor _ - | Package_type _ | Row_field _ - | Type_declaration _ | Type_kind _ - | Module_binding _ | Module_declaration _ - | Module_binding_name _ | Module_declaration_name _ - | Module_type_declaration _ | Module_type_constraint _ - | Module_type_declaration_name _ | With_constraint _ - | Structure _ | Signature _ - | Value_description _ | Value_binding _ - | Constructor_declaration _ | Label_declaration _ - | Class_declaration _ | Class_description _ - | Class_type_declaration _ | Class_type_field _ - | Include_description _ | Include_declaration _ - | Open_description _ | Open_declaration _ - -> env0 - -let node_real_loc loc0 = function - | Expression {exp_loc = loc} - | Pattern {pat_loc = loc} - | Method_call (_, _, loc) - | Record_field (_, _, {loc}) - | Class_expr {cl_loc = loc} - | Module_expr {mod_loc = loc} - | Structure_item ({str_loc = loc}, _) - | Signature_item ({sig_loc = loc}, _) - | Module_type {mty_loc = loc} - | Core_type {ctyp_loc = loc} - | Class_type {cltyp_loc = loc} - | Class_field {cf_loc = loc} - | Module_binding {mb_loc = loc} - | Module_declaration {md_loc = loc} - | Module_type_declaration {mtd_loc = loc} - | Value_description {val_loc = loc} - | Value_binding {vb_loc = loc} - | Type_declaration {typ_loc = loc} - | Label_declaration {ld_loc = loc} - | Constructor_declaration {cd_loc = loc} - | Class_type_field {ctf_loc = loc} - | Class_declaration {ci_loc = loc} - | Class_description {ci_loc = loc} - | Class_type_declaration {ci_loc = loc} - | Extension_constructor {ext_loc = loc} - | Include_description {incl_loc = loc} - | Include_declaration {incl_loc = loc} - | Open_description {open_loc = loc} - | Open_declaration {open_loc = loc} - -> loc - | Module_type_declaration_name {mtd_name = loc} - -> loc.Location.loc - | Module_declaration_name {md_name = loc} - | Module_binding_name {mb_name = loc} - -> loc.Location.loc - | Structure _ | Signature _ | Case _ | Class_structure _ | Type_extension _ - | Class_field_kind _ | Module_type_constraint _ | With_constraint _ - | Row_field _ | Type_kind _ | Class_signature _ | Package_type _ - | Dummy - -> loc0 - -let node_attributes = function - | Expression exp -> exp.exp_attributes - | Pattern pat -> pat.pat_attributes - | Class_expr cl -> cl.cl_attributes - | Class_field cf -> cf.cf_attributes - | Module_expr me -> me.mod_attributes - | Structure_item ({str_desc = Tstr_eval (_,attr)},_) -> attr - | Structure_item ({str_desc = Tstr_attribute a},_) -> [a] - | Signature_item ({sig_desc = Tsig_attribute a},_) -> [a] - | Module_binding mb -> mb.mb_attributes - | Value_binding vb -> vb.vb_attributes - | Module_type mt -> mt.mty_attributes - | Module_declaration md -> md.md_attributes - | Module_type_declaration mtd -> mtd.mtd_attributes - | Open_description o -> o.open_attributes - | Include_declaration i -> i.incl_attributes - | Include_description i -> i.incl_attributes - | Core_type ct -> ct.ctyp_attributes - | Row_field rf -> rf.rf_attributes - | Value_description vd -> vd.val_attributes - | Type_declaration td -> td.typ_attributes - | Label_declaration ld -> ld.ld_attributes - | Constructor_declaration cd -> cd.cd_attributes - | Type_extension te -> te.tyext_attributes - | Extension_constructor ec -> ec.ext_attributes - | Class_type ct -> ct.cltyp_attributes - | Class_type_field ctf -> ctf.ctf_attributes - | Class_declaration ci -> ci.ci_attributes - | Class_description ci -> ci.ci_attributes - | Class_type_declaration ci -> ci.ci_attributes - | Method_call (obj,_,_) -> obj.exp_attributes - | Record_field (`Expression obj,_,_) -> obj.exp_attributes - | Record_field (`Pattern obj,_,_) -> obj.pat_attributes - | _ -> [] - -let node_merlin_loc loc0 node = - let attributes = node_attributes node in - let loc = - let open Parsetree in - let pred { attr_name = loc; _ } = Location_aux.is_relaxed_location loc in - match List.find attributes ~f:pred with - | { attr_name; _ } -> attr_name.Location.loc - | exception Not_found -> node_real_loc loc0 node - in - let loc = match node with - | Expression {exp_extra; _} -> - List.fold_left ~f:(fun loc0 (_,loc,_) -> Location_aux.union loc0 loc) - ~init:loc exp_extra - | Pattern {pat_extra; _} -> - List.fold_left ~f:(fun loc0 (_,loc,_) -> Location_aux.union loc0 loc) - ~init:loc pat_extra - | _ -> loc - in - loc - -let app node env f acc = - f (node_update_env env node) - node acc - -type 'a f0 = Env.t -> node -> 'a -> 'a -type ('b,'a) f1 = 'b -> Env.t -> 'a f0 -> 'a -> 'a - -let id_fold _env (_f : _ f0) acc = acc - -let ( ** ) f1 f2 env (f : _ f0) acc = - f2 env f (f1 env f acc) - -let rec list_fold (f' : _ f1) xs env f acc = match xs with - | x :: xs -> list_fold f' xs env f (f' x env f acc) - | [] -> acc - -let array_fold (f' : _ f1) arr env f acc = - let acc = ref acc in - for i = 0 to Array.length arr - 1 do - acc := f' arr.(i) env f !acc - done; - !acc - -let rec list_fold_with_next (f' : _ -> _ f1) xs env f acc = match xs with - | x :: (y :: _ as xs) -> list_fold_with_next f' xs env f (f' (Some y) x env f acc) - | [x] -> f' None x env f acc - | [] -> acc - -let option_fold f' o env (f : _ f0) acc = match o with - | None -> acc - | Some x -> f' x env f acc - -let of_core_type ct = app (Core_type ct) - -let of_exp_extra (exp,_,_) = match exp with - | Texp_constraint ct -> - of_core_type ct - | Texp_coerce (cto,ct) -> - of_core_type ct ** option_fold of_core_type cto - | Texp_poly cto -> - option_fold of_core_type cto - | Texp_newtype' _ - | Texp_newtype _ -> - id_fold -let of_expression e = app (Expression e) ** list_fold of_exp_extra e.exp_extra - -let of_pat_extra (pat,_,_) = match pat with - | Tpat_constraint ct -> of_core_type ct - | Tpat_type _ | Tpat_unpack | Tpat_open _ -> id_fold - -let of_pattern (type k) (p : k general_pattern) = - app (Pattern p) ** list_fold of_pat_extra p.pat_extra - -let of_case c = app (Case c) -let of_label_declaration ct = app (Label_declaration ct) -let of_value_binding vb = app (Value_binding vb) -let of_module_type mt = app (Module_type mt) -let of_module_expr me = app (Module_expr me) -let of_typ_param (ct,_) = of_core_type ct -let of_constructor_arguments = function - | Cstr_tuple cts -> list_fold of_core_type cts - | Cstr_record lbls -> list_fold of_label_declaration lbls - -let of_bop { bop_op_path = _; bop_op_val = _; bop_exp; _ } = - of_expression bop_exp - -let of_record_field obj loc lbl = - fun env (f : _ f0) acc -> - app (Record_field (obj,lbl,loc)) env f acc - -let of_exp_record_field obj lid_loc lbl = - of_record_field (`Expression obj) lid_loc lbl - -let of_pat_record_field obj loc lbl = - of_record_field (`Pattern obj) loc lbl - -let of_pattern_desc (type k) (desc : k pattern_desc) = - match desc with - | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> id_fold - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p - | Tpat_exception p -> of_pattern p - | Tpat_value p -> of_pattern (p :> value general_pattern) - | Tpat_tuple ps | Tpat_construct (_,_,ps,None) | Tpat_array ps -> - list_fold of_pattern ps - | Tpat_construct (_,_,ps,Some (_, ct)) -> - list_fold of_pattern ps ** of_core_type ct - | Tpat_record (ls,_) -> - list_fold (fun (lid_loc,desc,p) -> - of_pat_record_field p lid_loc desc ** of_pattern p) ls - | Tpat_or (p1,p2,_) -> - of_pattern p1 ** of_pattern p2 - -let of_method_call obj meth loc = - fun env (f : _ f0) acc -> - let loc_start = obj.exp_loc.Location.loc_end in - let loc_end = loc.Location.loc_end in - let loc = {loc with Location. loc_start; loc_end} in - app (Method_call (obj,meth,loc)) env f acc - -let of_expression_desc loc = function - | Texp_ident _ | Texp_constant _ | Texp_instvar _ - | Texp_variant (_,None) | Texp_new _ | Texp_hole -> id_fold - | Texp_let (_,vbs,e) -> - of_expression e ** list_fold of_value_binding vbs - | Texp_function { cases; _ } -> - list_fold of_case cases - | Texp_apply (e,ls) -> - of_expression e ** - list_fold (function - | (_,None) -> id_fold - | (_,Some e) -> of_expression e) - ls - | Texp_match (e,cs,_) -> - of_expression e ** - list_fold of_case cs - | Texp_try (e,cs) -> - of_expression e ** - list_fold of_case cs - | Texp_tuple es | Texp_construct (_,_,es) | Texp_array es -> - list_fold of_expression es - | Texp_variant (_,Some e) - | Texp_assert e | Texp_lazy e | Texp_setinstvar (_,_,_,e) -> - of_expression e - | Texp_record { fields; extended_expression } -> - option_fold of_expression extended_expression ** - let fold_field = function - | (_,Typedtree.Kept _) -> id_fold - | (desc,Typedtree.Overridden (lid_loc,e)) -> - of_exp_record_field e lid_loc desc ** of_expression e - in - array_fold fold_field fields - | Texp_field (e,lid_loc,lbl) -> - of_expression e ** of_exp_record_field e lid_loc lbl - | Texp_setfield (e1,lid_loc,lbl,e2) -> - of_expression e1 ** of_expression e2 ** of_exp_record_field e1 lid_loc lbl - | Texp_ifthenelse (e1,e2,None) - | Texp_sequence (e1,e2) | Texp_while (e1,e2) -> - of_expression e1 ** of_expression e2 - | Texp_ifthenelse (e1,e2,Some e3) | Texp_for (_,_,e1,e2,_,e3) -> - of_expression e1 ** of_expression e2 ** of_expression e3 - | Texp_send (e,meth) -> - of_expression e ** - of_method_call e meth loc (* TODO ulysse CHECK*) - | Texp_override (_,ls) -> - list_fold (fun (_,_,e) -> of_expression e) ls - | Texp_letmodule (mb_id, mb_name, mb_presence, mb_expr, e) -> - let mb = - {mb_id;mb_name;mb_expr;mb_loc=Location.none;mb_attributes=[] - ; mb_presence } - in - app (Module_binding mb) ** of_expression e - | Texp_letexception (ec,e) -> - app (Extension_constructor ec) ** of_expression e - | Texp_object (cs,_) -> - app (Class_structure cs) - | Texp_pack me -> - of_module_expr me - | Texp_unreachable | Texp_extension_constructor _ -> - id_fold - | Texp_letop { let_; ands; body; _ } -> - of_bop let_ ** - list_fold of_bop ands ** - of_case body - | Texp_open (od, e) -> - app (Module_expr od.open_expr) ** of_expression e - -and of_class_expr_desc = function - | Tcl_ident (_,_,cts) -> - list_fold of_core_type cts - | Tcl_structure cs -> - app (Class_structure cs) - | Tcl_fun (_,p,es,ce,_) -> - list_fold (fun (_,e) -> of_expression e) es ** - of_pattern p ** - app (Class_expr ce) - | Tcl_apply (ce,es) -> - list_fold (function - | (_,None) -> id_fold - | (_,Some e) -> of_expression e) - es ** - app (Class_expr ce) - | Tcl_let (_,vbs,es,ce) -> - list_fold of_value_binding vbs ** - list_fold (fun (_,e) -> of_expression e) es ** - app (Class_expr ce) - | Tcl_constraint (ce,cto,_,_,_) -> - option_fold (fun ct -> app (Class_type ct)) cto ** - app (Class_expr ce) - | Tcl_open (_,ce) -> - app (Class_expr ce) - -and of_class_field_desc = function - | Tcf_inherit (_,ce,_,_,_) -> - app (Class_expr ce) - | Tcf_val (_,_,_,cfk,_) | Tcf_method (_,_,cfk) -> - app (Class_field_kind cfk) - | Tcf_constraint (ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Tcf_initializer e -> - of_expression e - | Tcf_attribute _ -> - id_fold (*TODO*) - -and of_module_expr_desc = function - | Tmod_ident _ -> id_fold - | Tmod_structure str -> - app (Structure str) - | Tmod_functor (Unit,me) -> of_module_expr me - | Tmod_functor (Named (_, _, mt),me) -> - of_module_type mt ** of_module_expr me - | Tmod_apply (me1,me2,_) -> - of_module_expr me1 ** - of_module_expr me2 - | Tmod_constraint (me,_,mtc,_) -> - of_module_expr me ** - app (Module_type_constraint mtc) - | Tmod_unpack (e,_) -> - of_expression e - | Tmod_hole -> id_fold - -and of_structure_item_desc = function - | Tstr_eval (e,_) -> - of_expression e - | Tstr_value (_,vbs) -> - list_fold of_value_binding vbs - | Tstr_primitive vd -> - app (Value_description vd) - | Tstr_type (_,tds) -> - list_fold (fun td -> app (Type_declaration td)) tds - | Tstr_typext text -> - app (Type_extension text) - | Tstr_exception texn -> - app (Extension_constructor texn.tyexn_constructor) - | Tstr_module mb -> - app (Module_binding mb) - | Tstr_recmodule mbs -> - list_fold (fun x -> app (Module_binding x)) mbs - | Tstr_modtype mtd -> - app (Module_type_declaration mtd) - | Tstr_class cds -> - list_fold (fun (cd,_) -> app (Class_declaration cd)) cds - | Tstr_class_type ctds -> - list_fold (fun (_,_,ctd) -> app (Class_type_declaration ctd)) ctds - | Tstr_include i -> - app (Include_declaration i) - | Tstr_open d -> - app (Open_declaration d) - | Tstr_attribute _ -> - id_fold - -and of_module_type_desc = function - | Tmty_ident _ | Tmty_alias _ -> id_fold - | Tmty_signature sg -> - app (Signature sg) - | Tmty_functor (Named (_,_,mt1),mt2) -> - of_module_type mt1 ** of_module_type mt2 - | Tmty_functor (Unit,mt) -> of_module_type mt - | Tmty_with (mt,wcs) -> - list_fold (fun (_,_,wc) -> app (With_constraint wc)) wcs ** - of_module_type mt - | Tmty_typeof me -> - of_module_expr me - -and of_signature_item_desc = function - | Tsig_attribute _ -> - id_fold - | Tsig_open d -> - app (Open_description d) - | Tsig_value vd -> - app (Value_description vd) - | Tsig_type (_,tds) -> - list_fold (fun td -> app (Type_declaration td)) tds - | Tsig_typext text -> - app (Type_extension text) - | Tsig_exception texn -> - app (Extension_constructor texn.tyexn_constructor) - | Tsig_module md -> - app (Module_declaration md) - | Tsig_recmodule mds -> - list_fold (fun md -> app (Module_declaration md)) mds - | Tsig_modtype mtd -> - app (Module_type_declaration mtd) - | Tsig_include i -> - app (Include_description i) - | Tsig_class cds -> - list_fold (fun cd -> app (Class_description cd)) cds - | Tsig_class_type ctds -> - list_fold (fun ctd -> app (Class_type_declaration ctd)) ctds - | Tsig_typesubst tds -> - (* FIXME: shitty approximation *) - list_fold (fun td -> app (Type_declaration td)) tds - | Tsig_modsubst _ms -> - (* TODO. *) - id_fold - | Tsig_modtypesubst _mts -> - (* TODO. *) - id_fold - -and of_core_type_desc = function - | Ttyp_any | Ttyp_var _ -> id_fold - | Ttyp_arrow (_,ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Ttyp_tuple cts | Ttyp_constr (_,_,cts) | Ttyp_class (_,_,cts) -> - list_fold of_core_type cts - | Ttyp_object (cts,_) -> - list_fold (fun of_ -> - match of_.of_desc with - | OTtag (_,ct) - | OTinherit ct -> of_core_type ct - ) cts - | Ttyp_poly (_,ct) | Ttyp_alias (ct,_) -> - of_core_type ct - | Ttyp_variant (rfs,_,_) -> - list_fold (fun rf -> app (Row_field rf)) rfs - | Ttyp_package pt -> - app (Package_type pt) - -and of_class_type_desc = function - | Tcty_constr (_,_,cts) -> - list_fold of_core_type cts - | Tcty_signature cs -> - app (Class_signature cs) - | Tcty_arrow (_,ct,clt) -> - of_core_type ct ** app (Class_type clt) - | Tcty_open (_,ct) -> - app (Class_type ct) - -and of_class_type_field_desc = function - | Tctf_inherit ct -> - app (Class_type ct) - | Tctf_val (_,_,_,ct) | Tctf_method (_,_,_,ct) -> - of_core_type ct - | Tctf_constraint (ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Tctf_attribute _ -> - id_fold - -let of_node = function - | Dummy -> id_fold - | Pattern { pat_desc; pat_extra=_ } -> - of_pattern_desc pat_desc - | Expression { exp_desc; exp_extra=_; exp_loc } -> - of_expression_desc exp_loc exp_desc - | Case { c_lhs; c_guard; c_rhs } -> - of_pattern c_lhs ** of_expression c_rhs ** - option_fold of_expression c_guard - | Class_expr { cl_desc } -> - of_class_expr_desc cl_desc - | Class_structure { cstr_self; cstr_fields } -> - of_pattern cstr_self ** - list_fold (fun f -> app (Class_field f)) cstr_fields - | Class_field { cf_desc } -> - of_class_field_desc cf_desc - | Class_field_kind (Tcfk_virtual ct) -> - of_core_type ct - | Class_field_kind (Tcfk_concrete (_,e)) -> - of_expression e - | Module_expr { mod_desc } -> - of_module_expr_desc mod_desc - | Module_type_constraint Tmodtype_implicit -> - id_fold - | Module_type_constraint (Tmodtype_explicit mt) -> - of_module_type mt - | Structure { str_items; str_final_env } -> - list_fold_with_next (fun next item -> - match next with - | None -> app (Structure_item (item, str_final_env)) - | Some item' -> app (Structure_item (item, item'.str_env))) - str_items - | Structure_item ({ str_desc }, _) -> - of_structure_item_desc str_desc - | Module_binding mb -> - app (Module_expr mb.mb_expr) ** - app (Module_binding_name mb) - | Value_binding { vb_pat; vb_expr } -> - of_pattern vb_pat ** - of_expression vb_expr - | Module_type { mty_desc } -> - of_module_type_desc mty_desc - | Signature { sig_items; sig_final_env } -> - list_fold_with_next (fun next item -> - match next with - | None -> app (Signature_item (item, sig_final_env)) - | Some item' -> app (Signature_item (item, item'.sig_env))) - sig_items - | Signature_item ({ sig_desc }, _) -> - of_signature_item_desc sig_desc - | Module_declaration md -> - of_module_type md.md_type ** - app (Module_declaration_name md) - | Module_type_declaration mtd -> - option_fold of_module_type mtd.mtd_type ** - app (Module_type_declaration_name mtd) - | With_constraint (Twith_type td | Twith_typesubst td) -> - app (Type_declaration td) - | With_constraint (Twith_module _ | Twith_modsubst _) -> - id_fold - | With_constraint (Twith_modtype mt | Twith_modtypesubst mt) -> - of_module_type mt - | Core_type { ctyp_desc } -> - of_core_type_desc ctyp_desc - | Package_type { pack_fields } -> - list_fold (fun (_,ct) -> of_core_type ct) pack_fields - | Row_field rf -> begin - match rf.rf_desc with - | Ttag (_,_,cts) -> list_fold of_core_type cts - | Tinherit ct -> of_core_type ct - end - | Value_description { val_desc } -> - of_core_type val_desc - | Type_declaration { typ_params; typ_cstrs; typ_kind; typ_manifest } -> - let of_typ_cstrs (ct1,ct2,_) = of_core_type ct1 ** of_core_type ct2 in - option_fold of_core_type typ_manifest ** - list_fold of_typ_param typ_params ** - app (Type_kind typ_kind) ** - list_fold of_typ_cstrs typ_cstrs - | Type_kind (Ttype_abstract | Ttype_open) -> - id_fold - | Type_kind (Ttype_variant cds) -> - list_fold (fun cd -> app (Constructor_declaration cd)) cds - | Type_kind (Ttype_record lds) -> - list_fold of_label_declaration lds - | Type_extension { tyext_params; tyext_constructors } -> - list_fold of_typ_param tyext_params ** - list_fold (fun ec -> app (Extension_constructor ec)) tyext_constructors - | Extension_constructor { ext_kind = Text_decl (_, carg,cto) } -> - option_fold of_core_type cto ** - of_constructor_arguments carg - | Extension_constructor { ext_kind = Text_rebind _ } -> - id_fold - | Label_declaration { ld_type } -> - of_core_type ld_type - | Constructor_declaration { cd_args; cd_res } -> - option_fold of_core_type cd_res ** - of_constructor_arguments cd_args - | Class_type { cltyp_desc } -> - of_class_type_desc cltyp_desc - | Class_signature { csig_self; csig_fields } -> - of_core_type csig_self ** - list_fold (fun x -> app (Class_type_field x)) csig_fields - | Class_type_field { ctf_desc } -> - of_class_type_field_desc ctf_desc - | Class_declaration { ci_params; ci_expr } -> - app (Class_expr ci_expr) ** - list_fold of_typ_param ci_params - | Class_description { ci_params; ci_expr } -> - app (Class_type ci_expr) ** - list_fold of_typ_param ci_params - | Class_type_declaration { ci_params; ci_expr } -> - app (Class_type ci_expr) ** - list_fold of_typ_param ci_params - | Method_call _ -> id_fold - | Record_field _ -> id_fold - | Module_binding_name _ -> id_fold - | Module_declaration_name _ -> id_fold - | Module_type_declaration_name _ -> id_fold - | Open_description _ -> id_fold - | Open_declaration od -> - app (Module_expr od.open_expr) - | Include_declaration i -> - of_module_expr i.incl_mod - | Include_description i -> - of_module_type i.incl_mod - -let fold_node f env node acc = - of_node node env f acc - -(** Accessors for information specific to a node *) - -let string_of_node = function - | Dummy -> "dummy" - | Pattern p -> - let fmt, printer = Format.to_string () in - Printtyped.pattern 0 fmt p ; - printer () - | Expression _ -> "expression" - | Case _ -> "case" - | Class_expr _ -> "class_expr" - | Class_structure _ -> "class_structure" - | Class_field _ -> "class_field" - | Class_field_kind _ -> "class_field_kind" - | Module_expr _ -> "module_expr" - | Module_type_constraint _ -> "module_type_constraint" - | Structure _ -> "structure" - | Structure_item _ -> "structure_item" - | Module_binding _ -> "module_binding" - | Value_binding _ -> "value_binding" - | Module_type _ -> "module_type" - | Signature _ -> "signature" - | Signature_item _ -> "signature_item" - | Module_declaration _ -> "module_declaration" - | Module_type_declaration _ -> "module_type_declaration" - | With_constraint _ -> "with_constraint" - | Core_type _ -> "core_type" - | Package_type _ -> "package_type" - | Row_field _ -> "row_field" - | Value_description _ -> "value_description" - | Type_declaration _ -> "type_declaration" - | Type_kind _ -> "type_kind" - | Type_extension _ -> "type_extension" - | Extension_constructor _ -> "extension_constructor" - | Label_declaration _ -> "label_declaration" - | Constructor_declaration _ -> "constructor_declaration" - | Class_type _ -> "class_type" - | Class_signature _ -> "class_signature" - | Class_type_field _ -> "class_type_field" - | Class_declaration _ -> "class_declaration" - | Class_description _ -> "class_description" - | Class_type_declaration _ -> "class_type_declaration" - | Method_call _ -> "method_call" - | Record_field _ -> "record_field" - | Module_binding_name _ -> "module_binding_name" - | Module_declaration_name _ -> "module_declaration_name" - | Module_type_declaration_name _ -> "module_type_declaration_name" - | Open_description _ -> "open_description" - | Open_declaration _ -> "open_declaration" - | Include_description _ -> "include_description" - | Include_declaration _ -> "include_declaration" - -let mkloc = Location.mkloc -let reloc txt loc = {loc with Location. txt} - -let mk_lident x = Longident.Lident x - -let type_constructor_path typ = - match Types.get_desc typ with - | Types.Tconstr (p,_,_) -> p - | _ -> raise Not_found - -(* Build a fake path for value constructors and labels *) -let fake_path {Location.loc ; txt = lid} typ name = - match type_constructor_path typ with - | Path.Pdot (p, _) -> - [mkloc (Path.Pdot (p, name)) loc, Some lid] - | Path.Pident _ -> - [mkloc (Path.Pident (Ident.create_persistent name)) loc, Some lid] - | _ | exception Not_found -> [] - -let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } = - let init = - match (pat_desc : k pattern_desc) with - | Tpat_construct (lid_loc,{Types. cstr_name; cstr_res; _},_,_) -> - fake_path lid_loc cstr_res cstr_name - | Tpat_var (id, {Location. loc; txt}) -> - [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)] - | Tpat_alias (_,id,loc) -> - [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] - | _ -> [] - in - List.fold_left ~init pat_extra - ~f:(fun acc (extra,_,_) -> - match extra with - | Tpat_open (path,loc,_) | Tpat_type (path,loc) -> - (reloc path loc, Some loc.txt) :: acc - | _ -> acc) - -let module_expr_paths { Typedtree. mod_desc } = - match mod_desc with - | Tmod_ident (path, loc) -> [reloc path loc, Some loc.txt] - | Tmod_functor (Named (Some id, loc, _), _) -> - [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt] - | _ -> [] - -let bindop_path { bop_op_name; bop_op_path } = - let loc = bop_op_name in - let path = bop_op_path in - (reloc path loc, Some (Longident.Lident loc.txt)) - -let expression_paths { Typedtree. exp_desc; exp_extra; _ } = - let init = - match exp_desc with - | Texp_ident (path,loc,_) -> [reloc path loc, Some loc.txt] - | Texp_letop {let_; ands} -> - bindop_path let_ :: List.map ~f:bindop_path ands - | Texp_new (path,loc,_) -> [reloc path loc, Some loc.txt] - | Texp_instvar (_,path,loc) -> [reloc path loc, Some (Lident loc.txt)] - | Texp_setinstvar (_,path,loc,_) -> [reloc path loc, Some (Lident loc.txt)] - | Texp_override (_,ps) -> - List.map ~f:(fun (id,loc,_) -> - reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt) - ) ps - | Texp_letmodule (Some id,loc,_,_,_) -> - [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt] - | Texp_for (id,{Parsetree.ppat_loc = loc; ppat_desc},_,_,_,_) -> - let lid = - match ppat_desc with - | Ppat_any -> None - | Ppat_var {txt} -> Some (Longident.Lident txt) - | _ -> assert false - in - [mkloc (Path.Pident id) loc, lid] - | Texp_construct (lid_loc, {Types. cstr_name; cstr_res; _}, _) -> - fake_path lid_loc cstr_res cstr_name - | Texp_open (od,_) -> module_expr_paths od.open_expr - | _ -> [] - in - List.fold_left ~init exp_extra - ~f:(fun acc (extra, _, _) -> - match extra with - | Texp_newtype' (id, label_loc) -> - let path = Path.Pident id in - let lid = Longident.Lident (label_loc.txt) in - (mkloc path label_loc.loc, Some lid) :: acc - | _ -> acc) - -let core_type_paths { Typedtree. ctyp_desc } = - match ctyp_desc with - | Ttyp_constr (path,loc,_) -> [reloc path loc, Some loc.txt] - | Ttyp_class (path,loc,_) -> [reloc path loc, Some loc.txt] - | _ -> [] - -let class_expr_paths { Typedtree. cl_desc } = - match cl_desc with - | Tcl_ident (path, loc, _) -> [reloc path loc, Some loc.txt] - | _ -> [] - -let class_field_paths { Typedtree. cf_desc } = - match cf_desc with - | Tcf_val (loc,_,id,_,_) -> - [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] - | _ -> [] - -let structure_item_paths { Typedtree. str_desc } = - match str_desc with - | Tstr_class_type cls -> - List.map ~f:(fun (id,loc,_) -> - reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt) - ) cls - | Tstr_open od -> module_expr_paths od.open_expr - | _ -> [] - -let module_type_paths { Typedtree. mty_desc } = - match mty_desc with - | Tmty_ident (path, loc) | Tmty_alias (path, loc) -> - [reloc path loc, Some loc.txt] - | Tmty_functor (Named (Some id,loc,_),_) -> - [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt] - | Tmty_with (_,ls) -> - List.map ~f:(fun (p,l,_) -> reloc p l, Some l.txt) ls - | _ -> [] - -let signature_item_paths { Typedtree. sig_desc } = - match sig_desc with - | Tsig_open { Typedtree. open_expr = (open_path, open_txt); _ } -> - [reloc open_path open_txt, Some open_txt.txt] - | _ -> [] - -let with_constraint_paths = function - | Twith_module (path,loc) | Twith_modsubst (path,loc) -> - [reloc path loc, Some loc.txt] - | _ -> [] - -let ci_paths {Typedtree. ci_id_name; ci_id_class } = - [reloc (Path.Pident ci_id_class) ci_id_name, - Some (Longident.Lident ci_id_name.txt)] - -let node_paths_full = - let open Typedtree in function - | Pattern p -> pattern_paths p - | Expression e -> expression_paths e - | Class_expr e -> class_expr_paths e - | Class_field f -> class_field_paths f - | Module_expr me -> module_expr_paths me - | Structure_item (i,_) -> structure_item_paths i - | Module_binding_name { mb_id = Some mb_id; mb_name } -> - [reloc (Path.Pident mb_id) mb_name, Option.map ~f:mk_lident mb_name.txt] - | Module_type mt -> module_type_paths mt - | Signature_item (i,_) -> signature_item_paths i - | Module_declaration_name { md_id = Some md_id; md_name } -> - [reloc (Path.Pident md_id) md_name, Option.map ~f:mk_lident md_name.txt] - | Module_type_declaration_name { mtd_id; mtd_name } -> - [reloc (Path.Pident mtd_id) mtd_name, Some (Lident mtd_name.txt) ] - | With_constraint c -> with_constraint_paths c - | Core_type ct -> core_type_paths ct - | Package_type { pack_path; pack_txt } -> - [reloc pack_path pack_txt, Some pack_txt.txt] - | Value_description { val_id; val_name } -> - [reloc (Path.Pident val_id) val_name, Some (Lident val_name.txt)] - | Type_declaration { typ_id; typ_name } -> - [reloc (Path.Pident typ_id) typ_name, Some (Lident typ_name.txt)] - | Type_extension { tyext_path; tyext_txt } -> - [reloc tyext_path tyext_txt, Some tyext_txt.txt] - | Extension_constructor { ext_id; ext_name } -> - [reloc (Path.Pident ext_id) ext_name, Some (Lident ext_name.txt)] - | Label_declaration { ld_id; ld_name } -> - [reloc (Path.Pident ld_id) ld_name, Some (Lident ld_name.txt)] - | Constructor_declaration { cd_id; cd_name } -> - [reloc (Path.Pident cd_id) cd_name, Some (Lident cd_name.txt)] - | Class_declaration ci -> ci_paths ci - | Class_description ci -> ci_paths ci - | Class_type_declaration ci -> ci_paths ci - | Record_field (_,{Types.lbl_res; lbl_name; _},lid_loc) -> - fake_path lid_loc lbl_res lbl_name - | _ -> [] - -let node_paths t = List.map (node_paths_full t) ~f:fst -let node_paths_and_longident t = - List.filter_map (node_paths_full t) ~f:(function - | _, None -> None - | p, Some lid -> Some (p, lid) - ) - -let node_is_constructor = function - | Constructor_declaration decl -> - Some {decl.cd_name with Location.txt = `Declaration decl} - | Expression {exp_desc = Texp_construct (loc, desc, _)} -> - Some {loc with Location.txt = `Description desc} - | Pattern {pat_desc = Tpat_construct (loc, desc, _, _)} -> - Some {loc with Location.txt = `Description desc} - | _ -> None - -let node_of_binary_part env part = - let open Cmt_format in - match part with - | Partial_structure x -> - Structure x - | Partial_structure_item x -> - Structure_item (x, env) - | Partial_expression x -> - Expression x - | Partial_pattern (_, x) -> - Pattern x - | Partial_class_expr x -> - Class_expr x - | Partial_signature x -> - Signature x - | Partial_signature_item x -> - Signature_item (x, env) - | Partial_module_type x -> - Module_type x - -let all_holes (env, node) = - let rec aux acc (env, node) = - let f env node acc = match node with - | Expression { - exp_desc = Texp_hole; - exp_loc; - exp_type; - exp_env; - _ - } -> (exp_loc, exp_env, `Exp exp_type) :: acc - | Module_expr { - mod_desc = Tmod_hole; - mod_loc; - mod_type; - mod_env; - _ - } -> (mod_loc, mod_env, `Mod mod_type) :: acc - | _ -> aux acc (env, node) - in - fold_node f env node acc - in - aux [] (env, node) |> List.rev diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/browse_raw.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/browse_raw.mli deleted file mode 100644 index 0e919a954..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/browse_raw.mli +++ /dev/null @@ -1,126 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2014 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -(** [Browse_node] offers a uniform interface to traverse constructions from - * [TypedTree]. - * - * Mutually recursive types from [TypedTree] are wrapped into different - * constructors of the type [node]. - * Then the [fold] function traverses one-level of sub-nodes. - * - * In the meantime, the most specific environment and location are threaded - * (FIXME: should these two be managed separately?). - * - * Finally [BrowseT] module a node into a tree which structure mimics - * the recursive structure of the [TypedTree] node. - * - *) - -(* Compatibility with previous versions of OCaml *) -type constructor_declaration = Typedtree.constructor_declaration - -open Typedtree - -type node = - | Dummy - | Pattern : _ general_pattern -> node - | Expression of expression - | Case : _ case -> node - | Class_expr of class_expr - | Class_structure of class_structure - | Class_field of class_field - | Class_field_kind of class_field_kind - | Module_expr of module_expr - | Module_type_constraint of module_type_constraint - | Structure of structure - | Signature of signature - | (* Items come with their final environment *) - Structure_item of structure_item * Env.t - | Signature_item of signature_item * Env.t - | Module_binding of module_binding - | Value_binding of value_binding - | Module_type of module_type - | Module_declaration of module_declaration - | Module_type_declaration of module_type_declaration - | With_constraint of with_constraint - | Core_type of core_type - | Package_type of package_type - | Row_field of row_field - | Value_description of value_description - | Type_declaration of type_declaration - | Type_kind of type_kind - | Type_extension of type_extension - | Extension_constructor of extension_constructor - | Label_declaration of label_declaration - | Constructor_declaration of constructor_declaration - | Class_type of class_type - | Class_signature of class_signature - | Class_type_field of class_type_field - | Class_declaration of class_declaration - | Class_description of class_description - | Class_type_declaration of class_type_declaration - - | Include_description of include_description - | Include_declaration of include_declaration - | Open_description of open_description - | Open_declaration of open_declaration - - | Method_call of expression * meth * Location.t - | Record_field of [ `Expression of expression - | `Pattern of pattern ] - * Types.label_description - * Longident.t Location.loc - | Module_binding_name of module_binding - | Module_declaration_name of module_declaration - | Module_type_declaration_name of module_type_declaration - -val fold_node : (Env.t -> node -> 'a -> 'a) -> Env.t -> node -> 'a -> 'a - -(** Accessors for information specific to a node *) - -val node_update_env : Env.t -> node -> Env.t -val node_real_loc : Location.t -> node -> Location.t -val node_merlin_loc : Location.t -> node -> Location.t -val node_attributes : node -> attribute list - -val string_of_node : node -> string - -val node_paths : node -> Path.t Location.loc list -val node_paths_and_longident : node -> (Path.t Location.loc * Longident.t) list - -val node_is_constructor : node -> - [ `Description of Types.constructor_description - | `Declaration of Typedtree.constructor_declaration ] Location.loc option - -val node_of_binary_part : Env.t -> Cmt_format.binary_part -> node - -val all_holes : - Env.t * node -> - (Location.t * - Env.t * - [`Exp of Types.type_expr | `Mod of Types.module_type]) list diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/dune b/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/dune deleted file mode 100644 index cf45ef9a9..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/dune +++ /dev/null @@ -1,12 +0,0 @@ -(library - (name merlin_specific) - (public_name merlin-lib.ocaml_merlin_specific) - (flags - :standard - -open Ocaml_utils - -open Ocaml_parsing - -open Ocaml_preprocess - -open Ocaml_typing - -open Ocaml_preprocess - -open Merlin_utils) - (libraries merlin_utils ocaml_parsing ocaml_preprocess ocaml_typing ocaml_utils)) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/tast_helper.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/tast_helper.ml deleted file mode 100644 index 1664fa158..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/tast_helper.ml +++ /dev/null @@ -1,40 +0,0 @@ -open Typedtree - -module Pat = struct - let pat_extra = [] - let pat_attributes = [] - - let constant ?(loc=Location.none) pat_env pat_type c = - let pat_desc = Tpat_constant c in - { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - - let var ?loc pat_env pat_type str = - let pat_loc = - match loc with - | None -> str.Asttypes.loc - | Some loc -> loc - in - let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str) in - { pat_desc; pat_loc; pat_extra; pat_attributes; pat_type; pat_env } - - let record ?(loc=Location.none) pat_env pat_type lst closed_flag = - let pat_desc = Tpat_record (lst, closed_flag) in - { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - - let tuple ?(loc=Location.none) pat_env pat_type lst = - let pat_desc = Tpat_tuple lst in - { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - - let construct ?(loc=Location.none) - pat_env pat_type lid cstr_desc args locs_coretype = - let pat_desc = Tpat_construct (lid, cstr_desc, args, locs_coretype) in - { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - - let pat_or ?(loc=Location.none) ?row_desc pat_env pat_type p1 p2 = - let pat_desc = Tpat_or (p1, p2, row_desc) in - { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - - let variant ?(loc=Location.none) pat_env pat_type lbl sub rd = - let pat_desc = Tpat_variant (lbl, sub, rd) in - { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } -end diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/typer_raw.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/typer_raw.ml deleted file mode 100644 index 7413e3d7f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/typer_raw.ml +++ /dev/null @@ -1,593 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Location -open Parsetree - -let fresh_env () = - (*Ident.reinit();*) - let initially_opened_module = - if !Clflags.nopervasives then - None - else - Some "Stdlib" - in - Typemod.initial_env - ~loc:(Location.in_file "command line") - ~safe_string:(not !Clflags.unsafe_string) - ~initially_opened_module - ~open_implicit_modules:(List.rev !Clflags.open_modules) - -module Rewrite_loc = struct - let queue = ref [] - - let update l = - if l <> none then - match !queue with - | [] -> assert false - | l' :: ls -> queue := Location_aux.union l l' :: ls - - let enter () = queue := Location.none :: !queue - let leave l0 = match !queue with - | [] -> assert false - | [l] -> queue := []; Location_aux.extend l0 l - | l :: l' :: ls -> - let l = Location_aux.extend l0 l in - queue := Location_aux.union l l' :: ls; - l - - let start () = assert (!queue = []); enter () - let exit () = match !queue with - | [_] -> queue := [] - | _ -> assert false - - let u_option f = function - | None -> None - | Some x -> Some (f x) - - let u_loc (loc : _ Location.loc) = - update loc.loc; loc - - let rec u_attribute { attr_name = loc ; attr_payload; attr_loc } = - let loc = if Location_aux.is_relaxed_location loc then loc else u_loc loc in - { attr_name = loc - ; attr_payload = u_payload attr_payload - ; attr_loc } - - and u_extension (loc, payload) = - let loc = if Location_aux.is_relaxed_location loc then loc else u_loc loc in - (loc, u_payload payload) - - and u_attributes l = List.map ~f:u_attribute l - - and u_payload = function - | PStr str -> PStr (u_structure str) - | PSig sg -> PSig (u_signature sg) - | PTyp ct -> PTyp (u_core_type ct) - | PPat (p, eo) -> PPat (u_pattern p, u_option u_expression eo) - - and u_core_type {ptyp_desc; ptyp_attributes; ptyp_loc; ptyp_loc_stack} = - enter (); - let ptyp_desc = u_core_type_desc ptyp_desc in - let ptyp_attributes = u_attributes ptyp_attributes in - let ptyp_loc = leave ptyp_loc in - {ptyp_desc; ptyp_loc; ptyp_attributes; ptyp_loc_stack} - - and u_core_type_desc = function - | Ptyp_any | Ptyp_var _ as desc -> desc - | Ptyp_arrow (l, t1, t2) -> Ptyp_arrow (l, u_core_type t1, u_core_type t2) - | Ptyp_tuple ts -> Ptyp_tuple (List.map ~f:u_core_type ts) - | Ptyp_constr (loc, ts) -> Ptyp_constr (u_loc loc, List.map ~f:u_core_type ts) - | Ptyp_object (fields, flag) -> - let object_field_desc = function - | Otag (lbl, ct) -> Otag (lbl, u_core_type ct) - | Oinherit ct -> Oinherit (u_core_type ct) - in - let object_field { pof_desc; pof_loc; pof_attributes } = - { pof_desc = object_field_desc pof_desc - ; pof_attributes = u_attributes pof_attributes - ; pof_loc } - in - Ptyp_object (List.map ~f:object_field fields, flag) - | Ptyp_class (loc, ts) -> Ptyp_class (u_loc loc, List.map ~f:u_core_type ts) - | Ptyp_alias (ct, name) -> Ptyp_alias (u_core_type ct, name) - | Ptyp_variant (fields, flag, label) -> Ptyp_variant (List.map ~f:u_row_field fields, flag, label) - | Ptyp_poly (ss,ct) -> Ptyp_poly (ss, u_core_type ct) - | Ptyp_package pt -> Ptyp_package (u_package_type pt) - | Ptyp_extension ext -> Ptyp_extension (u_extension ext) - - and u_package_type (loc, cts) = - (u_loc loc, List.map ~f:(fun (l,ct) -> u_loc l, u_core_type ct) cts) - - and u_row_field { prf_desc; prf_loc; prf_attributes } = - let desc = function - | Rtag (l,has_const,cts) -> - Rtag (l, has_const, List.map ~f:u_core_type cts) - | Rinherit ct -> Rinherit (u_core_type ct) - in - { prf_desc = desc prf_desc - ; prf_loc - ; prf_attributes = u_attributes prf_attributes } - - and u_pattern {ppat_desc; ppat_loc; ppat_attributes; ppat_loc_stack} = - enter (); - let ppat_desc = u_pattern_desc ppat_desc in - let ppat_attributes = u_attributes ppat_attributes in - let ppat_loc = leave ppat_loc in - {ppat_desc; ppat_loc; ppat_attributes; ppat_loc_stack} - - and u_pattern_desc = function - | Ppat_any | Ppat_constant _ | Ppat_interval _ as p -> p - | Ppat_var l -> Ppat_var (u_loc l) - | Ppat_alias (p, l) -> Ppat_alias (u_pattern p, u_loc l) - | Ppat_tuple ps -> Ppat_tuple (List.map ~f:u_pattern ps) - | Ppat_construct (loc, po) -> Ppat_construct (u_loc loc, u_option - (fun (locs, p) -> locs, u_pattern p) po) - | Ppat_variant (lbl, po) -> Ppat_variant (lbl, u_option u_pattern po) - | Ppat_record (fields, flag) -> Ppat_record (List.map ~f:(fun (l,p) -> (u_loc l, u_pattern p)) fields, flag) - | Ppat_array ps -> Ppat_array (List.map ~f:u_pattern ps) - | Ppat_or (p1, p2) -> Ppat_or (u_pattern p1, u_pattern p2) - | Ppat_constraint (p, ct) -> Ppat_constraint (u_pattern p, u_core_type ct) - | Ppat_type loc -> Ppat_type (u_loc loc) - | Ppat_lazy p -> Ppat_lazy (u_pattern p) - | Ppat_unpack loc -> Ppat_unpack (u_loc loc) - | Ppat_exception p -> Ppat_exception (u_pattern p) - | Ppat_extension ext -> Ppat_extension (u_extension ext) - | Ppat_open (l,p) -> Ppat_open (u_loc l, u_pattern p) - - and u_expression {pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack} = - enter (); - let pexp_desc = u_expression_desc pexp_desc in - let pexp_attributes = u_attributes pexp_attributes in - let pexp_loc = leave pexp_loc in - {pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack} - - and u_expression_desc = function - | Pexp_ident loc -> Pexp_ident (u_loc loc) - | Pexp_constant _ as e -> e - | Pexp_let (flag, vs, e) -> - Pexp_let (flag, List.map ~f:u_value_binding vs, u_expression e) - | Pexp_function cs -> - Pexp_function (List.map ~f:u_case cs) - | Pexp_fun (lbl, eo, pattern, expr) -> - Pexp_fun (lbl, u_option u_expression eo, u_pattern pattern, u_expression expr) - | Pexp_apply (e, les) -> - Pexp_apply (u_expression e, List.map ~f:(fun (l,e) -> (l, u_expression e)) les) - | Pexp_match (e, cs) -> Pexp_match (u_expression e, List.map ~f:u_case cs) - | Pexp_try (e, cs) -> Pexp_try (u_expression e, List.map ~f:u_case cs) - | Pexp_tuple es -> Pexp_tuple (List.map ~f:u_expression es) - | Pexp_construct (loc, eo) -> - Pexp_construct (u_loc loc, u_option u_expression eo) - | Pexp_variant (lbl, eo) -> - Pexp_variant (lbl, u_option u_expression eo) - | Pexp_record (les, eo) -> - Pexp_record (List.map ~f:(fun (loc,e) -> (u_loc loc, u_expression e)) les, u_option u_expression eo) - | Pexp_field (e, loc) -> Pexp_field (u_expression e, u_loc loc) - | Pexp_setfield (e1, loc, e2) -> Pexp_setfield (u_expression e1, u_loc loc, u_expression e2) - | Pexp_array es -> Pexp_array (List.map ~f:u_expression es) - | Pexp_ifthenelse (e1,e2,e3) -> Pexp_ifthenelse (u_expression e1, u_expression e2, u_option u_expression e3) - | Pexp_sequence (e1, e2) -> Pexp_sequence (u_expression e1, u_expression e2) - | Pexp_while (e1, e2) -> Pexp_while (u_expression e1, u_expression e2) - | Pexp_for (p, e1, e2, flag, e3) -> Pexp_for (u_pattern p, u_expression e1, u_expression e2, flag, u_expression e3) - | Pexp_constraint (e, ct) -> Pexp_constraint (u_expression e, u_core_type ct) - | Pexp_coerce (e, cto, ct) -> Pexp_coerce (u_expression e, u_option u_core_type cto, u_core_type ct) - | Pexp_send (e, s) -> Pexp_send (u_expression e, s) - | Pexp_new loc -> Pexp_new (u_loc loc) - | Pexp_setinstvar (s, e) -> Pexp_setinstvar (u_loc s, u_expression e) - | Pexp_override es -> Pexp_override (List.map ~f:(fun (loc,e) -> (u_loc loc, u_expression e)) es) - | Pexp_letmodule (s, me, e) -> Pexp_letmodule (u_loc s, u_module_expr me, u_expression e) - | Pexp_letexception (c, e) -> Pexp_letexception (u_extension_constructor c, u_expression e) - | Pexp_assert e -> Pexp_assert (u_expression e) - | Pexp_lazy e -> Pexp_lazy (u_expression e) - | Pexp_poly (e, cto) -> Pexp_poly (u_expression e, u_option u_core_type cto) - | Pexp_object cs -> Pexp_object (u_class_structure cs) - | Pexp_newtype (s, e) -> Pexp_newtype (s, u_expression e) - | Pexp_pack me -> Pexp_pack (u_module_expr me) - | Pexp_open (od, e) -> Pexp_open (u_open_declaration od, u_expression e) - | Pexp_extension ext -> Pexp_extension (u_extension ext) - | Pexp_unreachable -> Pexp_unreachable - | Pexp_letop { let_; ands; body } -> - Pexp_letop { - let_ = u_binding_op let_; - ands = List.map ~f:u_binding_op ands; - body = u_expression body; - } - | Pexp_hole -> Pexp_hole - - and u_binding_op { pbop_op; pbop_pat; pbop_exp; pbop_loc } = - { pbop_op = u_loc pbop_op - ; pbop_pat = u_pattern pbop_pat - ; pbop_exp = u_expression pbop_exp - ; pbop_loc } - - and u_case {pc_lhs; pc_guard; pc_rhs} = { - pc_lhs = u_pattern pc_lhs; - pc_guard = u_option u_expression pc_guard; - pc_rhs = u_expression pc_rhs; - } - - and u_value_description {pval_name; pval_type; pval_prim; pval_attributes; pval_loc} = - enter (); - let pval_name = u_loc pval_name in - let pval_type = u_core_type pval_type in - let pval_attributes = u_attributes pval_attributes in - let pval_loc = leave pval_loc in - {pval_name; pval_type; pval_prim; pval_attributes; pval_loc} - - and u_type_declaration {ptype_name; ptype_params; ptype_cstrs; ptype_kind; - ptype_private; ptype_manifest; ptype_attributes; ptype_loc} = - enter (); - let ptype_name = u_loc ptype_name - and ptype_params = List.map ~f:(fun (ct,v) -> (u_core_type ct, v)) ptype_params - and ptype_cstrs = List.map ~f:(fun (ct1,ct2,l) -> - update l; (u_core_type ct1, u_core_type ct2, l)) ptype_cstrs - and ptype_kind = u_type_kind ptype_kind - and ptype_manifest = u_option u_core_type ptype_manifest - and ptype_attributes = u_attributes ptype_attributes - in - let ptype_loc = leave ptype_loc in - {ptype_name; ptype_params; ptype_cstrs; ptype_kind; - ptype_private; ptype_manifest; ptype_attributes; ptype_loc} - - and u_type_kind = function - | Ptype_abstract | Ptype_open as k -> k - | Ptype_variant cstrs -> Ptype_variant (List.map ~f:u_constructor_declaration cstrs) - | Ptype_record lbls -> Ptype_record (List.map ~f:u_label_declaration lbls) - - and u_label_declaration {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} = - enter (); - let pld_name = u_loc pld_name in - let pld_type = u_core_type pld_type in - let pld_attributes = u_attributes pld_attributes in - let pld_loc = leave pld_loc in - {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} - - and u_constructor_declaration {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = - enter (); - let pcd_name = u_loc pcd_name in - let pcd_vars = List.map ~f:u_loc pcd_vars in - let pcd_args = u_constructor_arguments pcd_args in - let pcd_res = u_option u_core_type pcd_res in - let pcd_attributes = u_attributes pcd_attributes in - let pcd_loc = leave pcd_loc in - {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} - - and u_constructor_arguments = function - | Pcstr_tuple cts -> Pcstr_tuple (List.map ~f:u_core_type cts) - | Pcstr_record lbls -> Pcstr_record (List.map ~f:u_label_declaration lbls) - - and u_type_extension - {ptyext_path; ptyext_params; ptyext_constructors; ptyext_private - ; ptyext_attributes; ptyext_loc } = - let ptyext_path = u_loc ptyext_path in - let ptyext_params = List.map ~f:(fun (ct,v) -> (u_core_type ct, v)) ptyext_params in - let ptyext_constructors = List.map ~f:u_extension_constructor ptyext_constructors in - let ptyext_attributes = u_attributes ptyext_attributes in - {ptyext_path; ptyext_params; ptyext_constructors; ptyext_private - ; ptyext_attributes; ptyext_loc } - - and u_extension_constructor {pext_name; pext_kind; pext_loc; pext_attributes} = - enter (); - let pext_name = u_loc pext_name in - let pext_kind = u_extension_constructor_kind pext_kind in - let pext_attributes = u_attributes pext_attributes in - let pext_loc = leave pext_loc in - {pext_name; pext_kind; pext_loc; pext_attributes} - - and u_extension_constructor_kind = function - | Pext_decl (locs, cargs, cto) -> - Pext_decl (List.map ~f:u_loc locs, - u_constructor_arguments cargs, - u_option u_core_type cto) - | Pext_rebind loc -> Pext_rebind (u_loc loc) - - (** {2 Class language} *) - - (* Type expressions for the class language *) - - and u_class_type {pcty_desc; pcty_loc; pcty_attributes} = - enter (); - let pcty_desc = u_class_type_desc pcty_desc in - let pcty_attributes = u_attributes pcty_attributes in - let pcty_loc = leave pcty_loc in - {pcty_desc; pcty_loc; pcty_attributes} - - and u_class_type_desc = function - | Pcty_constr (loc, cts) -> - Pcty_constr (u_loc loc, List.map ~f:u_core_type cts) - | Pcty_signature cs -> Pcty_signature (u_class_signature cs) - | Pcty_arrow (lbl, ct, clt) -> - Pcty_arrow (lbl, u_core_type ct, u_class_type clt) - | Pcty_extension ext -> - Pcty_extension (u_extension ext) - | Pcty_open (od, cty) -> - Pcty_open (u_open_description od, u_class_type cty) - - and u_class_signature {pcsig_self; pcsig_fields} = - let pcsig_self = u_core_type pcsig_self in - let pcsig_fields = List.map ~f:u_class_type_field pcsig_fields in - {pcsig_self; pcsig_fields} - - and u_class_type_field {pctf_desc; pctf_loc; pctf_attributes} = - enter (); - let pctf_desc = u_class_type_field_desc pctf_desc in - let pctf_attributes = u_attributes pctf_attributes in - let pctf_loc = leave pctf_loc in - {pctf_desc; pctf_loc; pctf_attributes} - - and u_class_type_field_desc = function - | Pctf_inherit clt -> Pctf_inherit (u_class_type clt) - | Pctf_val (s, fl1, fl2, ct) -> Pctf_val (s, fl1, fl2, u_core_type ct) - | Pctf_method (s, fl1, fl2, ct) -> Pctf_method (s, fl1, fl2, u_core_type ct) - | Pctf_constraint (ct1, ct2) -> Pctf_constraint (u_core_type ct1, u_core_type ct2) - | Pctf_attribute attr -> - Pctf_attribute (u_attribute attr) - | Pctf_extension ext -> Pctf_extension (u_extension ext) - - and u_class_infos : 'a 'b. ('a -> 'b) -> 'a class_infos -> 'b class_infos = - fun u_a {pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes} -> - enter (); - let pci_params = List.map ~f:(fun (ct,v) -> (u_core_type ct, v)) pci_params in - let pci_name = u_loc pci_name in - let pci_expr = u_a pci_expr in - let pci_attributes = u_attributes pci_attributes in - let pci_loc = leave pci_loc in - {pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes} - - and u_class_description clt = u_class_infos u_class_type clt - - and u_class_type_declaration clt = u_class_infos u_class_type clt - - and u_class_expr {pcl_desc; pcl_loc; pcl_attributes} = - enter (); - let pcl_desc = u_class_expr_desc pcl_desc in - let pcl_attributes = u_attributes pcl_attributes in - let pcl_loc = leave pcl_loc in - {pcl_desc; pcl_loc; pcl_attributes} - - and u_class_expr_desc = function - | Pcl_constr (loc, cts) -> Pcl_constr (u_loc loc, List.map ~f:u_core_type cts) - | Pcl_structure cs -> Pcl_structure (u_class_structure cs) - | Pcl_fun (lbl, eo, p, ce) -> - Pcl_fun (lbl, u_option u_expression eo, u_pattern p, u_class_expr ce) - | Pcl_apply (ce, les) -> - Pcl_apply (u_class_expr ce, List.map ~f:(fun (l,e) -> (l, u_expression e)) les) - | Pcl_let (rf, vbs, ce) -> - Pcl_let (rf, List.map ~f:u_value_binding vbs, u_class_expr ce) - | Pcl_constraint (ce, ct) -> Pcl_constraint (u_class_expr ce, u_class_type ct) - | Pcl_extension ext -> Pcl_extension (u_extension ext) - | Pcl_open (od, ce) -> - Pcl_open (u_open_description od, u_class_expr ce) - - and u_class_structure {pcstr_self; pcstr_fields} = - let pcstr_self = u_pattern pcstr_self in - let pcstr_fields = List.map ~f:u_class_field pcstr_fields in - {pcstr_self; pcstr_fields} - - and u_class_field {pcf_desc; pcf_loc; pcf_attributes} = - enter (); - let pcf_desc = u_class_field_desc pcf_desc in - let pcf_attributes = u_attributes pcf_attributes in - let pcf_loc = leave pcf_loc in - {pcf_desc; pcf_loc; pcf_attributes} - - and u_class_field_desc = function - | Pcf_inherit (fl, ce, so) -> Pcf_inherit (fl, u_class_expr ce, so) - | Pcf_val (loc, fl, cfk) -> Pcf_val (u_loc loc, fl, u_class_field_kind cfk) - | Pcf_method (loc, fl, cfk) -> Pcf_method (u_loc loc, fl, u_class_field_kind cfk) - | Pcf_constraint (c1, c2) -> Pcf_constraint (u_core_type c1, u_core_type c2) - | Pcf_initializer e -> Pcf_initializer (u_expression e) - | Pcf_attribute attr -> Pcf_attribute (u_attribute attr) - | Pcf_extension ext -> Pcf_extension (u_extension ext) - - and u_class_field_kind = function - | Cfk_virtual ct -> Cfk_virtual (u_core_type ct) - | Cfk_concrete (fl,e) -> Cfk_concrete (fl, u_expression e) - - and u_class_declaration cd = u_class_infos u_class_expr cd - - and u_module_type {pmty_desc; pmty_loc; pmty_attributes} = - enter (); - let pmty_desc = u_module_type_desc pmty_desc in - let pmty_attributes = u_attributes pmty_attributes in - let pmty_loc = leave pmty_loc in - {pmty_desc; pmty_loc; pmty_attributes} - - and u_module_type_desc = function - | Pmty_ident loc -> Pmty_ident (u_loc loc) - | Pmty_signature sg -> Pmty_signature (u_signature sg) - | Pmty_functor (fp, mt) -> Pmty_functor (u_functor_parameter fp, u_module_type mt) - | Pmty_with (mt, wts) -> Pmty_with (u_module_type mt, List.map ~f:u_with_constraint wts) - | Pmty_typeof me -> Pmty_typeof (u_module_expr me) - | Pmty_extension ext -> Pmty_extension (u_extension ext) - | Pmty_alias loc -> Pmty_alias (u_loc loc) - - and u_functor_parameter = function - | Unit -> Unit - | Named (name, mt) -> Named (u_loc name, u_module_type mt) - - and u_signature l = List.map ~f:u_signature_item l - - and u_signature_item {psig_desc; psig_loc} = - enter (); - let psig_desc = u_signature_item_desc psig_desc in - let psig_loc = leave psig_loc in - {psig_desc; psig_loc} - - and u_signature_item_desc = function - | Psig_value vd -> Psig_value (u_value_description vd) - | Psig_type (fl, tds) -> Psig_type (fl, List.map ~f:u_type_declaration tds) - | Psig_typext text -> Psig_typext (u_type_extension text) - | Psig_exception texn -> Psig_exception (u_type_exception texn) - | Psig_module md -> Psig_module (u_module_declaration md) - | Psig_recmodule mds -> Psig_recmodule (List.map ~f:u_module_declaration mds) - | Psig_modtype mtd -> Psig_modtype (u_module_type_declaration mtd) - | Psig_open od -> Psig_open (u_open_description od) - | Psig_include id -> Psig_include (u_include_description id) - | Psig_class cds -> Psig_class (List.map ~f:u_class_description cds) - | Psig_class_type cts -> Psig_class_type (List.map ~f:u_class_type_declaration cts) - | Psig_attribute attr -> Psig_attribute (u_attribute attr) - | Psig_extension (ext, attrs) -> Psig_extension (u_extension ext, u_attributes attrs) - | Psig_typesubst tds -> Psig_typesubst (List.map ~f:u_type_declaration tds) - | Psig_modsubst ms -> Psig_modsubst (u_module_substitution ms) - | Psig_modtypesubst mtd -> Psig_modtype (u_module_type_declaration mtd) - - and u_type_exception {ptyexn_constructor; ptyexn_loc; ptyexn_attributes } = - { ptyexn_constructor = u_extension_constructor ptyexn_constructor - ; ptyexn_loc - ; ptyexn_attributes = u_attributes ptyexn_attributes } - - and u_module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} = - enter (); - let pmd_name = u_loc pmd_name in - let pmd_type = u_module_type pmd_type in - let pmd_attributes = u_attributes pmd_attributes in - let pmd_loc = leave pmd_loc in - {pmd_name; pmd_type; pmd_attributes; pmd_loc} - - and u_module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} = - let pms_name = u_loc pms_name in - let pms_manifest = u_loc pms_manifest in - let pms_attributes = u_attributes pms_attributes in - { pms_name; pms_manifest; pms_attributes; pms_loc } - - and u_module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = - enter (); - let pmtd_name = u_loc pmtd_name in - let pmtd_type = u_option u_module_type pmtd_type in - let pmtd_attributes = u_attributes pmtd_attributes in - let pmtd_loc = leave pmtd_loc in - {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} - - and u_open_declaration {popen_expr; popen_override; popen_loc; popen_attributes} = - enter (); - let popen_expr = u_module_expr popen_expr in - let popen_attributes = u_attributes popen_attributes in - let popen_loc = leave popen_loc in - {popen_expr; popen_override; popen_loc; popen_attributes} - - and u_open_description {popen_expr; popen_override; popen_loc; popen_attributes} = - enter (); - let popen_expr = u_loc popen_expr in - let popen_attributes = u_attributes popen_attributes in - let popen_loc = leave popen_loc in - {popen_expr; popen_override; popen_loc; popen_attributes} - - and u_include_infos : 'a 'b . ('a -> 'b) -> 'a include_infos -> 'b include_infos = - fun u_a {pincl_mod; pincl_loc; pincl_attributes} -> - enter (); - let pincl_mod = u_a pincl_mod in - let pincl_attributes = u_attributes pincl_attributes in - let pincl_loc = leave pincl_loc in - {pincl_mod; pincl_loc; pincl_attributes} - - and u_include_description id = u_include_infos u_module_type id - and u_include_declaration id = u_include_infos u_module_expr id - - and u_with_constraint = function - | Pwith_type (loc, td) -> Pwith_type (u_loc loc, u_type_declaration td) - | Pwith_module (loc1, loc2) -> Pwith_module (u_loc loc1, u_loc loc2) - | Pwith_typesubst (loc, td) -> - Pwith_typesubst (u_loc loc, u_type_declaration td) - | Pwith_modsubst (loc1, loc2) -> Pwith_modsubst (u_loc loc1, u_loc loc2) - | Pwith_modtype (loc, mt) -> Pwith_modtype (u_loc loc, u_module_type mt) - | Pwith_modtypesubst (loc, mt) -> - Pwith_modtypesubst (u_loc loc, u_module_type mt) - - and u_module_expr {pmod_desc; pmod_loc; pmod_attributes} = - enter (); - let pmod_desc = u_module_expr_desc pmod_desc in - let pmod_attributes = u_attributes pmod_attributes in - let pmod_loc = leave pmod_loc in - {pmod_desc; pmod_loc; pmod_attributes} - - and u_module_expr_desc = function - | Pmod_ident loc -> Pmod_ident (u_loc loc) - | Pmod_structure str -> Pmod_structure (u_structure str) - | Pmod_functor (fp, me) -> - Pmod_functor (u_functor_parameter fp, u_module_expr me) - | Pmod_apply (me1, me2) -> - Pmod_apply (u_module_expr me1, u_module_expr me2) - | Pmod_constraint (me, mt) -> - Pmod_constraint (u_module_expr me, u_module_type mt) - | Pmod_unpack e -> Pmod_unpack (u_expression e) - | Pmod_extension ext -> Pmod_extension (u_extension ext) - | Pmod_hole -> Pmod_hole - - and u_structure l = List.map ~f:u_structure_item l - - and u_structure_item {pstr_desc; pstr_loc} = - enter (); - let pstr_desc = u_structure_item_desc pstr_desc in - let pstr_loc = leave pstr_loc in - {pstr_desc; pstr_loc} - - and u_structure_item_desc = function - | Pstr_eval (expr, attrs) -> Pstr_eval (u_expression expr, u_attributes attrs) - | Pstr_value (fl, vbs) -> Pstr_value (fl, List.map ~f:u_value_binding vbs) - | Pstr_primitive vd -> Pstr_primitive (u_value_description vd) - | Pstr_type (fl, tds) -> Pstr_type (fl, List.map ~f:u_type_declaration tds) - | Pstr_typext text -> Pstr_typext (u_type_extension text) - | Pstr_exception texn -> Pstr_exception (u_type_exception texn) - | Pstr_module mb -> Pstr_module (u_module_binding mb) - | Pstr_recmodule mbs -> Pstr_recmodule (List.map ~f:u_module_binding mbs) - | Pstr_modtype mtd -> Pstr_modtype (u_module_type_declaration mtd) - | Pstr_open od -> Pstr_open (u_open_declaration od) - | Pstr_class cds -> Pstr_class (List.map ~f:u_class_declaration cds) - | Pstr_class_type ctds -> Pstr_class_type (List.map ~f:u_class_type_declaration ctds) - | Pstr_include id -> Pstr_include (u_include_declaration id) - | Pstr_attribute attr -> Pstr_attribute (u_attribute attr) - | Pstr_extension (ext, attrs) -> Pstr_extension (u_extension ext, u_attributes attrs) - - and u_value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = - enter (); - let pvb_pat = u_pattern pvb_pat in - let pvb_expr = u_expression pvb_expr in - let pvb_attributes = u_attributes pvb_attributes in - let pvb_loc = leave pvb_loc in - {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} - - and u_module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} = - enter (); - let pmb_name = u_loc pmb_name in - let pmb_expr = u_module_expr pmb_expr in - let pmb_attributes = u_attributes pmb_attributes in - let pmb_loc = leave pmb_loc in - {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -end - -let rewrite_loc t = - Rewrite_loc.start (); - let t = match t with - | `str str -> `str (Rewrite_loc.u_structure str) - | `fake str -> `fake (Rewrite_loc.u_structure str) - | `sg sg -> `sg (Rewrite_loc.u_signature sg) - in - Rewrite_loc.exit (); - t diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/typer_raw.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/typer_raw.mli deleted file mode 100644 index 669bdf1dd..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/merlin_specific/typer_raw.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -val fresh_env : unit -> Env.t - -val rewrite_loc : - [ `str of Parsetree.structure | `sg of Parsetree.signature - | `fake of Parsetree.structure ] -> - [ `str of Parsetree.structure | `sg of Parsetree.signature - | `fake of Parsetree.structure ] diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_helper.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_helper.ml deleted file mode 100644 index 4eeaf9f10..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_helper.ml +++ /dev/null @@ -1,685 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments *) - -open Asttypes -open Parsetree -open Docstrings -open Msupport_parsing - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -let default_loc = ref Location.none - -let const_string s = Pconst_string (s, !default_loc, None) - -let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - -module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) -end - -module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - - let as_tuple { attr_name; attr_payload; _ } = (attr_name, attr_payload) -end - -module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise_error Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - -end - -module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) -end - -module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letmodule_no_opt ?loc ?attrs s b c= - let a = Location.mknoloc (Some s) in - mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - let hole ?loc ?attrs () = mk ?loc ?attrs Pexp_hole - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } -end - -module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) -end - -module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - let hole ?loc ?attrs () = mk ?loc ?attrs Pmod_hole -end - -module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) -end - -module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) -end - -module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - -end - -module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - -end - -module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } -end - -module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } -end - -module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } -end - -module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } -end - -module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } -end - -module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } -end - -module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - -end - -module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } -end - -module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } -end - -module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_vars = vars; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - -end - -(** Type extensions *) -module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(vars, args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - -end - -module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } -end - -module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } -end - -(** Row fields *) -module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) -end - -(** Object fields *) -module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) -end - -(** merlin: refactored out of Parser *) - -type let_binding = - { lb_pattern: pattern; - lb_expression: expression; - lb_is_pun: bool; - lb_attributes: attributes; - lb_docs: docs Lazy.t; - lb_text: text Lazy.t; - lb_loc: Location.t; } - -type let_bindings = - { lbs_bindings: let_binding list; - lbs_rec: rec_flag; - lbs_extension: string Asttypes.loc option } - - -(* merlin specific *) - -let no_label = Nolabel - -(* Can't be put in Raw_compat because that module depends on library "parsing", - but we need that function in this library *) -let extract_str_payload = function - | PStr [{ pstr_desc = Pstr_eval ( - {Parsetree. pexp_loc; pexp_desc = - Parsetree.Pexp_constant (Parsetree.Pconst_string (msg, _, _)) ; _ }, _ - ); _ }] -> - Some (msg, pexp_loc) - | _ -> None diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_helper.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_helper.mli deleted file mode 100644 index bde42a48a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_helper.mli +++ /dev/null @@ -1,525 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Docstrings -open Parsetree - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -val const_string : string -> constant - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Attributes} *) -module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - - val as_tuple : attribute -> str * payload -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letmodule_no_opt: ?loc:loc -> ?attrs:attrs -> label -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - val hole: ?loc:loc -> ?attrs:attrs -> unit -> expression - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - val hole: ?loc:loc -> ?attrs:attrs -> unit -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - -(** Module substitutions *) -module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -(** Row fields *) -module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - -(** Object fields *) -module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end - -(** merlin: refactored out of Parser *) - -type let_binding = - { lb_pattern: pattern; - lb_expression: expression; - lb_is_pun: bool; - lb_attributes: attributes; - lb_docs: docs Lazy.t; - lb_text: text Lazy.t; - lb_loc: Location.t; } - -type let_bindings = - { lbs_bindings: let_binding list; - lbs_rec: rec_flag; - lbs_extension: string Asttypes.loc option } - - -(* merlin specific *) - -val no_label : arg_label -val extract_str_payload : payload -> (string * Location.t) option diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_iterator.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_iterator.ml deleted file mode 100644 index 0bfd568a5..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_iterator.ml +++ /dev/null @@ -1,687 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nicolas Ojeda Bar, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - - -open Parsetree -open Location - -type iterator = { - attribute: iterator -> attribute -> unit; - attributes: iterator -> attribute list -> unit; - binding_op: iterator -> binding_op -> unit; - case: iterator -> case -> unit; - cases: iterator -> case list -> unit; - class_declaration: iterator -> class_declaration -> unit; - class_description: iterator -> class_description -> unit; - class_expr: iterator -> class_expr -> unit; - class_field: iterator -> class_field -> unit; - class_signature: iterator -> class_signature -> unit; - class_structure: iterator -> class_structure -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; - constructor_declaration: iterator -> constructor_declaration -> unit; - expr: iterator -> expression -> unit; - extension: iterator -> extension -> unit; - extension_constructor: iterator -> extension_constructor -> unit; - include_declaration: iterator -> include_declaration -> unit; - include_description: iterator -> include_description -> unit; - label_declaration: iterator -> label_declaration -> unit; - location: iterator -> Location.t -> unit; - module_binding: iterator -> module_binding -> unit; - module_declaration: iterator -> module_declaration -> unit; - module_substitution: iterator -> module_substitution -> unit; - module_expr: iterator -> module_expr -> unit; - module_type: iterator -> module_type -> unit; - module_type_declaration: iterator -> module_type_declaration -> unit; - open_declaration: iterator -> open_declaration -> unit; - open_description: iterator -> open_description -> unit; - pat: iterator -> pattern -> unit; - payload: iterator -> payload -> unit; - signature: iterator -> signature -> unit; - signature_item: iterator -> signature_item -> unit; - structure: iterator -> structure -> unit; - structure_item: iterator -> structure_item -> unit; - typ: iterator -> core_type -> unit; - row_field: iterator -> row_field -> unit; - object_field: iterator -> object_field -> unit; - type_declaration: iterator -> type_declaration -> unit; - type_extension: iterator -> type_extension -> unit; - type_exception: iterator -> type_exception -> unit; - type_kind: iterator -> type_kind -> unit; - value_binding: iterator -> value_binding -> unit; - value_description: iterator -> value_description -> unit; - with_constraint: iterator -> with_constraint -> unit; -} -(** A [iterator] record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the iterator to be applied to children in the syntax - tree. *) - -let iter_fst f (x, _) = f x -let iter_snd f (_, y) = f y -let iter_tuple f1 f2 (x, y) = f1 x; f2 y -let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z -let iter_opt f = function None -> () | Some x -> f x - -let iter_loc sub {loc; txt = _} = sub.location sub loc - -module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - sub.location sub prf_loc; - sub.attributes sub prf_attributes; - match prf_desc with - | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl - | Rinherit t -> sub.typ sub t - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - sub.location sub pof_loc; - sub.attributes sub pof_attributes; - match pof_desc with - | Otag (_, t) -> sub.typ sub t - | Oinherit t -> sub.typ sub t - - let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Ptyp_any - | Ptyp_var _ -> () - | Ptyp_arrow (_lab, t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl - | Ptyp_constr (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_object (ol, _o) -> - List.iter (object_field sub) ol - | Ptyp_class (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_alias (t, _) -> sub.typ sub t - | Ptyp_variant (rl, _b, _ll) -> - List.iter (row_field sub) rl - | Ptyp_poly (_, t) -> sub.typ sub t - | Ptyp_package (lid, l) -> - iter_loc sub lid; - List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l - | Ptyp_extension x -> sub.extension sub x - - let iter_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private = _; - ptype_manifest; - ptype_attributes; - ptype_loc} = - iter_loc sub ptype_name; - List.iter (iter_fst (sub.typ sub)) ptype_params; - List.iter - (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs; - sub.type_kind sub ptype_kind; - iter_opt (sub.typ sub) ptype_manifest; - sub.location sub ptype_loc; - sub.attributes sub ptype_attributes - - let iter_type_kind sub = function - | Ptype_abstract -> () - | Ptype_variant l -> - List.iter (sub.constructor_declaration sub) l - | Ptype_record l -> List.iter (sub.label_declaration sub) l - | Ptype_open -> () - - let iter_constructor_arguments sub = function - | Pcstr_tuple l -> List.iter (sub.typ sub) l - | Pcstr_record l -> - List.iter (sub.label_declaration sub) l - - let iter_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private = _; - ptyext_loc; - ptyext_attributes} = - iter_loc sub ptyext_path; - List.iter (sub.extension_constructor sub) ptyext_constructors; - List.iter (iter_fst (sub.typ sub)) ptyext_params; - sub.location sub ptyext_loc; - sub.attributes sub ptyext_attributes - - let iter_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - sub.extension_constructor sub ptyexn_constructor; - sub.location sub ptyexn_loc; - sub.attributes sub ptyexn_attributes - - let iter_extension_constructor_kind sub = function - Pext_decl(vars, ctl, cto) -> - List.iter (iter_loc sub) vars; - iter_constructor_arguments sub ctl; - iter_opt (sub.typ sub) cto - | Pext_rebind li -> - iter_loc sub li - - let iter_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - iter_loc sub pext_name; - iter_extension_constructor_kind sub pext_kind; - sub.location sub pext_loc; - sub.attributes sub pext_attributes - -end - -module CT = struct - (* Type expressions for the class language *) - - let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcty_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcty_signature x -> sub.class_signature sub x - | Pcty_arrow (_lab, t, ct) -> - sub.typ sub t; sub.class_type sub ct - | Pcty_extension x -> sub.extension sub x - | Pcty_open (o, e) -> - sub.open_description sub o; sub.class_type sub e - - let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pctf_inherit ct -> sub.class_type sub ct - | Pctf_val (_s, _m, _v, t) -> sub.typ sub t - | Pctf_method (_s, _p, _v, t) -> sub.typ sub t - | Pctf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Pctf_attribute x -> sub.attribute sub x - | Pctf_extension x -> sub.extension sub x - - let iter_signature sub {pcsig_self; pcsig_fields} = - sub.typ sub pcsig_self; - List.iter (sub.class_type_field sub) pcsig_fields -end - -let iter_functor_param sub = function - | Unit -> () - | Named (name, mty) -> - iter_loc sub name; - sub.module_type sub mty - -module MT = struct - (* Type expressions for the module language *) - - let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pmty_ident s -> iter_loc sub s - | Pmty_alias s -> iter_loc sub s - | Pmty_signature sg -> sub.signature sub sg - | Pmty_functor (param, mt2) -> - iter_functor_param sub param; - sub.module_type sub mt2 - | Pmty_with (mt, l) -> - sub.module_type sub mt; - List.iter (sub.with_constraint sub) l - | Pmty_typeof me -> sub.module_expr sub me - | Pmty_extension x -> sub.extension sub x - - let iter_with_constraint sub = function - | Pwith_type (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d - | Pwith_module (lid, lid2) -> - iter_loc sub lid; iter_loc sub lid2 - | Pwith_modtype (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty - | Pwith_typesubst (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d - | Pwith_modsubst (s, lid) -> - iter_loc sub s; iter_loc sub lid - | Pwith_modtypesubst (lid, mty) -> - iter_loc sub lid; sub.module_type sub mty - - let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = - sub.location sub loc; - match desc with - | Psig_value vd -> sub.value_description sub vd - | Psig_type (_, l) - | Psig_typesubst l -> - List.iter (sub.type_declaration sub) l - | Psig_typext te -> sub.type_extension sub te - | Psig_exception ed -> sub.type_exception sub ed - | Psig_module x -> sub.module_declaration sub x - | Psig_modsubst x -> sub.module_substitution sub x - | Psig_recmodule l -> - List.iter (sub.module_declaration sub) l - | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x - | Psig_open x -> sub.open_description sub x - | Psig_include x -> sub.include_description sub x - | Psig_class l -> List.iter (sub.class_description sub) l - | Psig_class_type l -> - List.iter (sub.class_type_declaration sub) l - | Psig_extension (x, attrs) -> - sub.attributes sub attrs; - sub.extension sub x - | Psig_attribute x -> sub.attribute sub x -end - - -module M = struct - (* Value expressions for the module language *) - - let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pmod_ident x -> iter_loc sub x - | Pmod_structure str -> sub.structure sub str - | Pmod_functor (param, body) -> - iter_functor_param sub param; - sub.module_expr sub body - | Pmod_apply (m1, m2) -> - sub.module_expr sub m1; sub.module_expr sub m2 - | Pmod_constraint (m, mty) -> - sub.module_expr sub m; sub.module_type sub mty - | Pmod_unpack e -> sub.expr sub e - | Pmod_extension x -> sub.extension sub x - | Pmod_hole -> () - - let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - sub.location sub loc; - match desc with - | Pstr_eval (x, attrs) -> - sub.attributes sub attrs; sub.expr sub x - | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs - | Pstr_primitive vd -> sub.value_description sub vd - | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l - | Pstr_typext te -> sub.type_extension sub te - | Pstr_exception ed -> sub.type_exception sub ed - | Pstr_module x -> sub.module_binding sub x - | Pstr_recmodule l -> List.iter (sub.module_binding sub) l - | Pstr_modtype x -> sub.module_type_declaration sub x - | Pstr_open x -> sub.open_declaration sub x - | Pstr_class l -> List.iter (sub.class_declaration sub) l - | Pstr_class_type l -> - List.iter (sub.class_type_declaration sub) l - | Pstr_include x -> sub.include_declaration sub x - | Pstr_extension (x, attrs) -> - sub.attributes sub attrs; sub.extension sub x - | Pstr_attribute x -> sub.attribute sub x -end - -module E = struct - (* Value expressions for the core language *) - - let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pexp_ident x -> iter_loc sub x - | Pexp_constant _ -> () - | Pexp_let (_r, vbs, e) -> - List.iter (sub.value_binding sub) vbs; - sub.expr sub e - | Pexp_fun (_lab, def, p, e) -> - iter_opt (sub.expr sub) def; - sub.pat sub p; - sub.expr sub e - | Pexp_function pel -> sub.cases sub pel - | Pexp_apply (e, l) -> - sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l - | Pexp_match (e, pel) -> - sub.expr sub e; sub.cases sub pel - | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel - | Pexp_tuple el -> List.iter (sub.expr sub) el - | Pexp_construct (lid, arg) -> - iter_loc sub lid; iter_opt (sub.expr sub) arg - | Pexp_variant (_lab, eo) -> - iter_opt (sub.expr sub) eo - | Pexp_record (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; - iter_opt (sub.expr sub) eo - | Pexp_field (e, lid) -> - sub.expr sub e; iter_loc sub lid - | Pexp_setfield (e1, lid, e2) -> - sub.expr sub e1; iter_loc sub lid; - sub.expr sub e2 - | Pexp_array el -> List.iter (sub.expr sub) el - | Pexp_ifthenelse (e1, e2, e3) -> - sub.expr sub e1; sub.expr sub e2; - iter_opt (sub.expr sub) e3 - | Pexp_sequence (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 - | Pexp_while (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 - | Pexp_for (p, e1, e2, _d, e3) -> - sub.pat sub p; sub.expr sub e1; sub.expr sub e2; - sub.expr sub e3 - | Pexp_coerce (e, t1, t2) -> - sub.expr sub e; iter_opt (sub.typ sub) t1; - sub.typ sub t2 - | Pexp_constraint (e, t) -> - sub.expr sub e; sub.typ sub t - | Pexp_send (e, _s) -> sub.expr sub e - | Pexp_new lid -> iter_loc sub lid - | Pexp_setinstvar (s, e) -> - iter_loc sub s; sub.expr sub e - | Pexp_override sel -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel - | Pexp_letmodule (s, me, e) -> - iter_loc sub s; sub.module_expr sub me; - sub.expr sub e - | Pexp_letexception (cd, e) -> - sub.extension_constructor sub cd; - sub.expr sub e - | Pexp_assert e -> sub.expr sub e - | Pexp_lazy e -> sub.expr sub e - | Pexp_poly (e, t) -> - sub.expr sub e; iter_opt (sub.typ sub) t - | Pexp_object cls -> sub.class_structure sub cls - | Pexp_newtype (_s, e) -> sub.expr sub e - | Pexp_pack me -> sub.module_expr sub me - | Pexp_open (o, e) -> - sub.open_declaration sub o; sub.expr sub e - | Pexp_letop {let_; ands; body} -> - sub.binding_op sub let_; - List.iter (sub.binding_op sub) ands; - sub.expr sub body - | Pexp_extension x -> sub.extension sub x - | Pexp_unreachable | Pexp_hole -> () - - let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - iter_loc sub pbop_op; - sub.pat sub pbop_pat; - sub.expr sub pbop_exp; - sub.location sub pbop_loc - -end - -module P = struct - (* Patterns *) - - let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Ppat_any -> () - | Ppat_var s -> iter_loc sub s - | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s - | Ppat_constant _ -> () - | Ppat_interval _ -> () - | Ppat_tuple pl -> List.iter (sub.pat sub) pl - | Ppat_construct (l, p) -> - iter_loc sub l; - iter_opt - (fun (vl,p) -> - List.iter (iter_loc sub) vl; - sub.pat sub p) - p - | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p - | Ppat_record (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl - | Ppat_array pl -> List.iter (sub.pat sub) pl - | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 - | Ppat_constraint (p, t) -> - sub.pat sub p; sub.typ sub t - | Ppat_type s -> iter_loc sub s - | Ppat_lazy p -> sub.pat sub p - | Ppat_unpack s -> iter_loc sub s - | Ppat_exception p -> sub.pat sub p - | Ppat_extension x -> sub.extension sub x - | Ppat_open (lid, p) -> - iter_loc sub lid; sub.pat sub p - -end - -module CE = struct - (* Value expressions for the class language *) - - let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcl_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcl_structure s -> - sub.class_structure sub s - | Pcl_fun (_lab, e, p, ce) -> - iter_opt (sub.expr sub) e; - sub.pat sub p; - sub.class_expr sub ce - | Pcl_apply (ce, l) -> - sub.class_expr sub ce; - List.iter (iter_snd (sub.expr sub)) l - | Pcl_let (_r, vbs, ce) -> - List.iter (sub.value_binding sub) vbs; - sub.class_expr sub ce - | Pcl_constraint (ce, ct) -> - sub.class_expr sub ce; sub.class_type sub ct - | Pcl_extension x -> sub.extension sub x - | Pcl_open (o, e) -> - sub.open_description sub o; sub.class_expr sub e - - let iter_kind sub = function - | Cfk_concrete (_o, e) -> sub.expr sub e - | Cfk_virtual t -> sub.typ sub t - - let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce - | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k - | Pcf_method (s, _p, k) -> - iter_loc sub s; iter_kind sub k - | Pcf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Pcf_initializer e -> sub.expr sub e - | Pcf_attribute x -> sub.attribute sub x - | Pcf_extension x -> sub.extension sub x - - let iter_structure sub {pcstr_self; pcstr_fields} = - sub.pat sub pcstr_self; - List.iter (sub.class_field sub) pcstr_fields - - let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - List.iter (iter_fst (sub.typ sub)) pl; - iter_loc sub pci_name; - f pci_expr; - sub.location sub pci_loc; - sub.attributes sub pci_attributes -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_iterator = - { - structure = (fun this l -> List.iter (this.structure_item this) l); - structure_item = M.iter_structure_item; - module_expr = M.iter; - signature = (fun this l -> List.iter (this.signature_item this) l); - signature_item = MT.iter_signature_item; - module_type = MT.iter; - with_constraint = MT.iter_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.iter; - class_field = CE.iter_field; - class_structure = CE.iter_structure; - class_type = CT.iter; - class_type_field = CT.iter_field; - class_signature = CT.iter_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.iter_type_declaration; - type_kind = T.iter_type_kind; - typ = T.iter; - row_field = T.row_field; - object_field = T.object_field; - type_extension = T.iter_type_extension; - type_exception = T.iter_type_exception; - extension_constructor = T.iter_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim = _; pval_loc; - pval_attributes} -> - iter_loc this pval_name; - this.typ this pval_type; - this.location this pval_loc; - this.attributes this pval_attributes; - ); - - pat = P.iter; - expr = E.iter; - binding_op = E.iter_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - iter_loc this pmd_name; - this.module_type this pmd_type; - this.location this pmd_loc; - this.attributes this pmd_attributes; - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - iter_loc this pms_name; - iter_loc this pms_manifest; - this.location this pms_loc; - this.attributes this pms_attributes; - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - iter_loc this pmtd_name; - iter_opt (this.module_type this) pmtd_type; - this.location this pmtd_loc; - this.attributes this pmtd_attributes; - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - iter_loc this pmb_name; this.module_expr this pmb_expr; - this.location this pmb_loc; - this.attributes this pmb_attributes; - ); - - open_declaration = - (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> - this.module_expr this popen_expr; - this.location this popen_loc; - this.attributes this popen_attributes - ); - - open_description = - (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_expr; - this.location this popen_loc; - this.attributes this popen_attributes - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_type this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_expr this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - this.pat this pvb_pat; - this.expr this pvb_expr; - this.location this pvb_loc; - this.attributes this pvb_attributes - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_vars; pcd_args; - pcd_res; pcd_loc; pcd_attributes} -> - iter_loc this pcd_name; - List.iter (iter_loc this) pcd_vars; - T.iter_constructor_arguments this pcd_args; - iter_opt (this.typ this) pcd_res; - this.location this pcd_loc; - this.attributes this pcd_attributes - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}-> - iter_loc this pld_name; - this.typ this pld_type; - this.location this pld_loc; - this.attributes this pld_attributes - ); - - cases = (fun this l -> List.iter (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - this.pat this pc_lhs; - iter_opt (this.expr this) pc_guard; - this.expr this pc_rhs - ); - - location = (fun _this _l -> ()); - - extension = (fun this (s, e) -> iter_loc this s; this.payload this e); - attribute = (fun this a -> - iter_loc this a.attr_name; - this.payload this a.attr_payload; - this.location this a.attr_loc - ); - attributes = (fun this l -> List.iter (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> this.structure this x - | PSig x -> this.signature this x - | PTyp x -> this.typ this x - | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g - ); - } diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_iterator.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_iterator.mli deleted file mode 100644 index 638ac5e8b..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_iterator.mli +++ /dev/null @@ -1,84 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nicolas Ojeda Bar, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A - typical mapper would be based on {!Ast_iterator.default_iterator}, a - trivial iterator, and will fall back on it for handling the syntax it does - not modify. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Parsetree - -(** {1 A generic Parsetree iterator} *) - -type iterator = { - attribute: iterator -> attribute -> unit; - attributes: iterator -> attribute list -> unit; - binding_op: iterator -> binding_op -> unit; - case: iterator -> case -> unit; - cases: iterator -> case list -> unit; - class_declaration: iterator -> class_declaration -> unit; - class_description: iterator -> class_description -> unit; - class_expr: iterator -> class_expr -> unit; - class_field: iterator -> class_field -> unit; - class_signature: iterator -> class_signature -> unit; - class_structure: iterator -> class_structure -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; - constructor_declaration: iterator -> constructor_declaration -> unit; - expr: iterator -> expression -> unit; - extension: iterator -> extension -> unit; - extension_constructor: iterator -> extension_constructor -> unit; - include_declaration: iterator -> include_declaration -> unit; - include_description: iterator -> include_description -> unit; - label_declaration: iterator -> label_declaration -> unit; - location: iterator -> Location.t -> unit; - module_binding: iterator -> module_binding -> unit; - module_declaration: iterator -> module_declaration -> unit; - module_substitution: iterator -> module_substitution -> unit; - module_expr: iterator -> module_expr -> unit; - module_type: iterator -> module_type -> unit; - module_type_declaration: iterator -> module_type_declaration -> unit; - open_declaration: iterator -> open_declaration -> unit; - open_description: iterator -> open_description -> unit; - pat: iterator -> pattern -> unit; - payload: iterator -> payload -> unit; - signature: iterator -> signature -> unit; - signature_item: iterator -> signature_item -> unit; - structure: iterator -> structure -> unit; - structure_item: iterator -> structure_item -> unit; - typ: iterator -> core_type -> unit; - row_field: iterator -> row_field -> unit; - object_field: iterator -> object_field -> unit; - type_declaration: iterator -> type_declaration -> unit; - type_extension: iterator -> type_extension -> unit; - type_exception: iterator -> type_exception -> unit; - type_kind: iterator -> type_kind -> unit; - value_binding: iterator -> value_binding -> unit; - value_description: iterator -> value_description -> unit; - with_constraint: iterator -> with_constraint -> unit; -} -(** A [iterator] record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the iterator to be applied to children in the syntax - tree. *) - -val default_iterator: iterator -(** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_mapper.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_mapper.ml deleted file mode 100644 index 1e92f4112..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_mapper.ml +++ /dev/null @@ -1,1085 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - -open Parsetree -open Ast_helper -open Location - -module String = Misc.String - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} - -let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) -let map_tuple f1 f2 (x, y) = (f1 x, f2 y) -let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let map_opt f = function None -> None | Some x -> Some (f x) - -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - -module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s -end - -module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(vars, ctl, cto) -> - Pext_decl(List.map (map_loc sub) vars, - map_constructor_arguments sub ctl, - map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - -end - -module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) -end - -let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - -module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_modtypesubst x -> - modtype_subst ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) -end - - -module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pmod_hole -> hole ~loc ~attrs () - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) -end - -module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - | Pexp_hole -> hole ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - -end - -module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> - interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) - (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) - p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) -end - -module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_vars; pcd_args; - pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~vars:(List.map (map_loc this) pcd_vars) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - -let extension_of_error {kind; main; sub} = - if kind <> Location.Report_error then - raise (Invalid_argument "extension_of_error: expected kind Report_error"); - let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in - let extension_of_sub sub = - { loc = sub.loc; txt = "ocaml.error" }, - PStr ([Str.eval (Exp.constant - (Pconst_string (str_of_pp sub.txt, sub.loc, None)))]) - in - { loc = main.loc; txt = "ocaml.error" }, - PStr (Str.eval (Exp.constant - (Pconst_string (str_of_pp main.txt, main.loc, None))) :: - List.map (fun msg -> Str.extension (extension_of_sub msg)) sub) - -let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - -let cookies = ref String.Map.empty - -let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - -let set_cookie k v = - cookies := String.Map.add k v !cookies - -let tool_name_ref = ref "_none_" - -let tool_name () = !tool_name_ref - - -module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Load_path.get_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool false; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool !Clflags.unboxed_types; - lid "unsafe_string", make_bool !Clflags.unsafe_string; - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Load_path.init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - (*| "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - *) - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Clflags.unboxed_types := get_bool payload - | "unsafe_string" -> - Clflags.unsafe_string := get_bool payload - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] -end - -let ppx_context = PpxContext.make - -let extension_of_exn exn = - match error_of_exn exn with - | Some (`Ok error) -> extension_of_error error - | Some `Already_displayed -> - { loc = Location.none; txt = "ocaml.error" }, PStr [] - | None -> raise exn - - -let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - -let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - -let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - -let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - -let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - -let register_function = ref (fun _name f -> run_main f) -let register name f = !register_function name f diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_mapper.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_mapper.mli deleted file mode 100644 index 69f6b017a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/ast_mapper.mli +++ /dev/null @@ -1,208 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} enables AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ -open Asttypes -open Parsetree -open Ast_mapper - -let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - -let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - -open Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper: mapper -(** A default mapper, which implements a "deep identity" mapping. *) - -(** {1 Apply mappers to compilation units} *) - -val tool_name: unit -> string -(** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - -val apply: source:string -> target:string -> mapper -> unit -(** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - -val run_main: (string list -> mapper) -> unit -(** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - -(** {1 Registration API} *) - -val register_function: (string -> (string list -> mapper) -> unit) ref - -val register: string -> (string list -> mapper) -> unit -(** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - -(** {1 Convenience functions to write mappers} *) - -val map_opt: ('a -> 'b) -> 'a option -> 'b option - -val extension_of_error: Location.error -> extension -(** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - -val attribute_of_warning: Location.t -> string -> attribute -(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - -(** {1 Helper functions to call external mappers} *) - -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure -(** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) - -val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature -(** Same as [add_ppx_context_str], but for signatures. *) - -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure -(** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) - -val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature -(** Same as [drop_ppx_context_str], but for signatures. *) - -(** {1 Cookies} *) - -(** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) - -val set_cookie: string -> Parsetree.expression -> unit -val get_cookie: string -> Parsetree.expression option diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/asttypes.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/asttypes.mli deleted file mode 100644 index 7a4f1c191..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/asttypes.mli +++ /dev/null @@ -1,67 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Auxiliary AST types used by parsetree and typedtree. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -type constant = - Const_int of int - | Const_char of char - | Const_string of string * Location.t * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - -type rec_flag = Nonrecursive | Recursive - -type direction_flag = Upto | Downto - -(* Order matters, used in polymorphic comparison *) -type private_flag = Private | Public - -type mutable_flag = Immutable | Mutable - -type virtual_flag = Virtual | Concrete - -type override_flag = Override | Fresh - -type closed_flag = Closed | Open - -type label = string - -type arg_label = - Nolabel - | Labelled of string (** [label:T -> ...] *) - | Optional of string (** [?label:T -> ...] *) - -type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; -} - - -type variance = - | Covariant - | Contravariant - | NoVariance - -type injectivity = - | Injective - | NoInjectivity diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/attr_helper.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/attr_helper.ml deleted file mode 100644 index 0a616cd74..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/attr_helper.ml +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2015 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Parsetree - -type error = - | Multiple_attributes of string - | No_payload_expected of string - -exception Error of Location.t * error - -let get_no_payload_attribute alt_names attrs = - match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with - | [] -> None - | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name - | [ {attr_name = name; _} ] -> - raise (Error (name.loc, No_payload_expected name.txt)) - | _ :: {attr_name = name; _} :: _ -> - raise (Error (name.loc, Multiple_attributes name.txt)) - -let has_no_payload_attribute alt_names attrs = - match get_no_payload_attribute alt_names attrs with - | None -> false - | Some _ -> true - -open Format - -let report_error ppf = function - | Multiple_attributes name -> - fprintf ppf "Too many `%s' attributes" name - | No_payload_expected name -> - fprintf ppf "Attribute `%s' does not accept a payload" name - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/attr_helper.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/attr_helper.mli deleted file mode 100644 index a3ddc0c9c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/attr_helper.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2015 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Helpers for attributes - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Parsetree - -type error = - | Multiple_attributes of string - | No_payload_expected of string - -(** The [string list] argument of the following functions is a list of - alternative names for the attribute we are looking for. For instance: - - {[ - ["foo"; "ocaml.foo"] - ]} *) -val get_no_payload_attribute : string list -> attributes -> string loc option -val has_no_payload_attribute : string list -> attributes -> bool - -exception Error of Location.t * error - -val report_error: Format.formatter -> error -> unit diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/builtin_attributes.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/builtin_attributes.ml deleted file mode 100644 index 0db213314..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/builtin_attributes.ml +++ /dev/null @@ -1,289 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes -open Parsetree - -let string_of_cst = function - | Pconst_string(s, _, _) -> Some s - | _ -> None - -let string_of_payload = function - | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> - string_of_cst c - | _ -> None - -let string_of_opt_payload p = - match string_of_payload p with - | Some s -> s - | None -> "" - -let error_of_extension ext = - let submessage_from main_loc main_txt = function - | {pstr_desc=Pstr_extension - (({txt = ("ocaml.error"|"error"); loc}, p), _)} -> - begin match p with - | PStr([{pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)} - ]) -> - { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg } - | _ -> - { Location.loc; txt = fun ppf -> - Format.fprintf ppf - "Invalid syntax for sub-message of extension '%s'." main_txt } - end - | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} -> - { Location.loc; txt = fun ppf -> - Format.fprintf ppf "Uninterpreted extension '%s'." txt } - | _ -> - { Location.loc = main_loc; txt = fun ppf -> - Format.fprintf ppf - "Invalid syntax for sub-message of extension '%s'." main_txt } - in - match ext with - | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> - begin match p with - | PStr [] -> raise Location.Already_displayed_error - | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}:: - inner) -> - let sub = List.map (submessage_from loc txt) inner in - Location.error_of_printer ~loc ~sub Format.pp_print_text msg - | _ -> - Location.errorf ~loc "Invalid syntax for extension '%s'." txt - end - | ({txt; loc}, _) -> - Location.errorf ~loc "Uninterpreted extension '%s'." txt - -let kind_and_message = function - | PStr[ - {pstr_desc= - Pstr_eval - ({pexp_desc=Pexp_apply - ({pexp_desc=Pexp_ident{txt=Longident.Lident id}}, - [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}]) - },_)}] -> - Some (id, s) - | PStr[ - {pstr_desc= - Pstr_eval - ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] -> - Some (id, "") - | _ -> None - -let cat s1 s2 = - if s2 = "" then s1 else s1 ^ "\n" ^ s2 - -let alert_attr x = - match x.attr_name.txt with - | "ocaml.deprecated"|"deprecated" -> - Some (x, "deprecated", string_of_opt_payload x.attr_payload) - | "ocaml.alert"|"alert" -> - begin match kind_and_message x.attr_payload with - | Some (kind, message) -> Some (x, kind, message) - | None -> None (* note: bad payloads detected by warning_attribute *) - end - | _ -> None - -let alert_attrs l = - List.filter_map alert_attr l - -let alerts_of_attrs l = - List.fold_left - (fun acc (_, kind, message) -> - let upd = function - | None | Some "" -> Some message - | Some s -> Some (cat s message) - in - Misc.String.Map.update kind upd acc - ) - Misc.String.Map.empty - (alert_attrs l) - -let check_alerts loc attrs s = - Misc.String.Map.iter - (fun kind message -> Location.alert loc ~kind (cat s message)) - (alerts_of_attrs attrs) - -let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s = - let m2 = alerts_of_attrs attrs2 in - Misc.String.Map.iter - (fun kind msg -> - if not (Misc.String.Map.mem kind m2) then - Location.alert ~def ~use ~kind loc (cat s msg) - ) - (alerts_of_attrs attrs1) - -let rec deprecated_mutable_of_attrs = function - | [] -> None - | {attr_name = {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}; - attr_payload = p} :: _ -> - Some (string_of_opt_payload p) - | _ :: tl -> deprecated_mutable_of_attrs tl - -let check_deprecated_mutable loc attrs s = - match deprecated_mutable_of_attrs attrs with - | None -> () - | Some txt -> - Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) - -let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = - match deprecated_mutable_of_attrs attrs1, - deprecated_mutable_of_attrs attrs2 - with - | None, _ | Some _, Some _ -> () - | Some txt, None -> - Location.deprecated ~def ~use loc - (Printf.sprintf "mutating field %s" (cat s txt)) - -let rec attrs_of_sig = function - | {psig_desc = Psig_attribute a} :: tl -> - a :: attrs_of_sig tl - | _ -> - [] - -let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg) - -let rec attrs_of_str = function - | {pstr_desc = Pstr_attribute a} :: tl -> - a :: attrs_of_str tl - | _ -> - [] - -let alerts_of_str str = alerts_of_attrs (attrs_of_str str) - -let check_no_alert attrs = - List.iter - (fun (a, _, _) -> - Location.prerr_warning a.attr_loc - (Warnings.Misplaced_attribute a.attr_name.txt) - ) - (alert_attrs attrs) - -let warn_payload loc txt msg = - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)) - -let warning_attribute ?(ppwarning = true) = - let process loc txt errflag payload = - match string_of_payload payload with - | Some s -> - begin try - Option.iter (Location.prerr_alert loc) - (Warnings.parse_options errflag s) - with Arg.Bad msg -> warn_payload loc txt msg - end - | None -> - warn_payload loc txt "A single string literal is expected" - in - let process_alert loc txt = function - | PStr[{pstr_desc= - Pstr_eval( - {pexp_desc=Pexp_constant(Pconst_string(s,_,_))}, - _) - }] -> - begin try Warnings.parse_alert_option s - with Arg.Bad msg -> warn_payload loc txt msg - end - | k -> - match kind_and_message k with - | Some ("all", _) -> - warn_payload loc txt "The alert name 'all' is reserved" - | Some _ -> () - | None -> warn_payload loc txt "Invalid payload" - in - function - | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _}; - attr_loc; - attr_payload; - } -> - process attr_loc txt false attr_payload - | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _}; - attr_loc; - attr_payload - } -> - process attr_loc txt true attr_payload - | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _}; - attr_loc = _; - attr_payload = - PStr [ - { pstr_desc= - Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _, _))},_); - pstr_loc } - ]; - } when ppwarning -> - Location.prerr_warning pstr_loc (Warnings.Preprocessor s) - | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _}; - attr_loc; - attr_payload; - } -> - process_alert attr_loc txt attr_payload - | _ -> - () - -let warning_scope ?ppwarning attrs f = - let prev = Warnings.backup () in - try - List.iter (warning_attribute ?ppwarning) (List.rev attrs); - let ret = f () in - Warnings.restore prev; - ret - with exn -> - Warnings.restore prev; - raise exn - - -let warn_on_literal_pattern = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true - | _ -> false - ) - -let explicit_arity = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.explicit_arity"|"explicit_arity" -> true - | _ -> false - ) - -let immediate = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.immediate"|"immediate" -> true - | _ -> false - ) - -let immediate64 = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.immediate64"|"immediate64" -> true - | _ -> false - ) - -(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" - attributes cannot be input by the user, they are added by the - compiler when applying the default setting. This is done to record - in the .cmi the default used by the compiler when compiling the - source file because the default can change between compiler - invocations. *) - -let check l a = List.mem a.attr_name.txt l - -let has_unboxed attr = - List.exists (check ["ocaml.unboxed"; "unboxed"]) - attr - -let has_boxed attr = - List.exists (check ["ocaml.boxed"; "boxed"]) attr diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/builtin_attributes.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/builtin_attributes.mli deleted file mode 100644 index 6200fd74e..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/builtin_attributes.mli +++ /dev/null @@ -1,84 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Support for some of the builtin attributes - - - ocaml.deprecated - - ocaml.alert - - ocaml.error - - ocaml.ppwarning - - ocaml.warning - - ocaml.warnerror - - ocaml.explicit_arity (for camlp4/camlp5) - - ocaml.warn_on_literal_pattern - - ocaml.deprecated_mutable - - ocaml.immediate - - ocaml.immediate64 - - ocaml.boxed / ocaml.unboxed - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -val check_alerts: Location.t -> Parsetree.attributes -> string -> unit -val check_alerts_inclusion: - def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> - Parsetree.attributes -> string -> unit -val alerts_of_attrs: Parsetree.attributes -> Misc.alerts -val alerts_of_sig: Parsetree.signature -> Misc.alerts -val alerts_of_str: Parsetree.structure -> Misc.alerts - -val check_deprecated_mutable: - Location.t -> Parsetree.attributes -> string -> unit -val check_deprecated_mutable_inclusion: - def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> - Parsetree.attributes -> string -> unit - -val check_no_alert: Parsetree.attributes -> unit - -val error_of_extension: Parsetree.extension -> Location.error - -val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit - (** Apply warning settings from the specified attribute. - "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) - are processed and other attributes are ignored. - - Also implement ocaml.ppwarning (unless ~ppwarning:false is - passed). - *) - -val warning_scope: - ?ppwarning:bool -> - Parsetree.attributes -> (unit -> 'a) -> 'a - (** Execute a function in a new scope for warning settings. This - means that the effect of any call to [warning_attribute] during - the execution of this function will be discarded after - execution. - - The function also takes a list of attributes which are processed - with [warning_attribute] in the fresh scope before the function - is executed. - *) - -val warn_on_literal_pattern: Parsetree.attributes -> bool -val explicit_arity: Parsetree.attributes -> bool - - -val immediate: Parsetree.attributes -> bool -val immediate64: Parsetree.attributes -> bool - -val has_unboxed: Parsetree.attributes -> bool -val has_boxed: Parsetree.attributes -> bool diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/docstrings.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/docstrings.ml deleted file mode 100644 index a39f75d25..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/docstrings.ml +++ /dev/null @@ -1,425 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Location - -(* Docstrings *) - -(* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) -type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - -(* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) -type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - -(* List of docstrings *) - -let docstrings : docstring list ref = ref [] - -(* Warn for unused and ambiguous docstrings *) - -let warn_bad_docstrings () = - if Warnings.is_active (Warnings.Unexpected_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false)) - (List.rev !docstrings) -end - -(* Docstring constructors and destructors *) - -let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - -let register ds = - docstrings := ds :: !docstrings - -let docstring_body ds = ds.ds_body - -let docstring_loc ds = ds.ds_loc - -(* Docstrings attached to items *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -let empty_docs = { docs_pre = None; docs_post = None } - -let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - -let docs_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - -(* Docstrings attached to constructors or fields *) - -type info = docstring option - -let empty_info = None - -let info_attr = docs_attr - -let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - -(* Docstrings not attached to a specific item *) - -type text = docstring list - -let empty_text = [] -let empty_text_lazy = lazy [] - -let text_loc = {txt = "ocaml.text"; loc = Location.none} - -let text_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -(* Find the first non-info docstring in a list, attach it and return it *) -let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - -(* Find all the non-info docstrings in a list, attach them and return them *) -let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - -(* "Associate" all the docstrings in a list *) -let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - -(* Map from positions to pre docstrings *) - -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - -let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - -(* Map from positions to post docstrings *) - -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - -let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - -let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - -(* Map from positions to floating docstrings *) - -let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - -let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - -let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Maps from positions to extra docstrings *) - -let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - -let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - -let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Docstrings from parser actions *) -module WithParsing = struct -let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - -let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - -let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - -let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - -let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - -let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) -end - -include WithParsing - -module WithMenhir = struct -let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - -let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - -let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - -let symbol_info endpos = - get_info endpos - -let rhs_info endpos = - get_info endpos - -let symbol_text startpos = - get_text startpos - -let symbol_text_lazy startpos = - lazy (get_text startpos) - -let rhs_text pos = - get_text pos - -let rhs_post_text pos = - get_post_text pos - -let rhs_text_lazy pos = - lazy (get_text pos) - -let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - -let symbol_post_extra_text endpos = - get_post_extra_text endpos - -let rhs_pre_extra_text pos = - get_pre_extra_text pos - -let rhs_post_extra_text pos = - get_post_extra_text pos -end - -(* (Re)Initialise all comment state *) - -let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/docstrings.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/docstrings.mli deleted file mode 100644 index bf2508fdc..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/docstrings.mli +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text - -module WithMenhir: sig -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : Lexing.position * Lexing.position -> docs -val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : Lexing.position -> Lexing.position -> docs -val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : Lexing.position * Lexing.position -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - -(** Fetch the field info for the current symbol. *) -val symbol_info : Lexing.position -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : Lexing.position -> info - -(** Fetch the text preceding the current symbol. *) -val symbol_text : Lexing.position -> text -val symbol_text_lazy : Lexing.position -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : Lexing.position -> text -val rhs_text_lazy : Lexing.position -> text Lazy.t - -(** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : Lexing.position -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : Lexing.position -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : Lexing.position -> text - -end diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/dune b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/dune deleted file mode 100644 index ac394faf2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/dune +++ /dev/null @@ -1,9 +0,0 @@ -(rule (copy# ../../extend/extend_helper.ml extend_helper.ml )) -(rule (copy# ../../extend/extend_helper.mli extend_helper.mli)) - -(library - (name ocaml_parsing) - (public_name merlin-lib.ocaml_parsing) - (flags -open Ocaml_utils -open Merlin_utils (:standard -w -9)) - (modules_without_implementation asttypes parsetree) - (libraries merlin_utils ocaml_utils)) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/fake.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/fake.ml deleted file mode 100644 index 19716c390..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/fake.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Parsetree - -let app a b = - let loc = - if a.pexp_loc.Location.loc_ghost - then {b.pexp_loc with Location.loc_ghost = true} - else b.pexp_loc - in - Ast_helper.Exp.apply ~loc a [Ast_helper.no_label, b] - -let pat_app f (pat,expr) = pat, app f expr - -let prim_ident prim = Longident.parse ("_." ^ prim) -let prim ?(ghost=true) prim = - let open Location in - let ident = mknoloc (prim_ident prim) in - let ident = if ghost - then ident - else {ident with loc = {ident.loc with loc_ghost = false}} - in - Ast_helper.Exp.ident ~loc:ident.loc ident - -(* Lwt extension *) -module Lwt = struct - let un_lwt = prim "Lwt.un_lwt" - let to_lwt = prim "Lwt.to_lwt" - let in_lwt = prim "Lwt.in_lwt" - let unit_lwt = prim "Lwt.unit_lwt" - let un_stream = prim "Lwt.un_stream" - let finally_ = prim "Lwt.finally'" - let raise_lwt_ = prim_ident "Lwt.raise_lwt'" -end - -(* MetaOCaml support *) -module Meta = struct - let prim_code = prim "Meta.code" - let prim_uncode = prim "Meta.uncode" - - let code loc_start loc_end expr = - let loc = {expr.pexp_loc with Location. loc_start; loc_end} in - Ast_helper.Exp.apply ~loc prim_code [Ast_helper.no_label, expr] - - let uncode loc_start loc_end expr = - let loc = {expr.pexp_loc with Location. loc_start; loc_end} in - Ast_helper.Exp.apply ~loc prim_uncode [Ast_helper.no_label, expr] -end diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/fake.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/fake.mli deleted file mode 100644 index 3dbbc19c6..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/fake.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -(* Definitions to help generating or rewriting pieces of AST, - * used to simulate some CamlP4 extensions. *) - -(* Generate AST faking value application *) -val app : Parsetree.expression -> - Parsetree.expression -> Parsetree.expression -val pat_app : Parsetree.expression -> - ('a * Parsetree.expression) -> ('a * Parsetree.expression ) - -(* Lwt extension *) -module Lwt : sig - val un_lwt : Parsetree.expression - val to_lwt : Parsetree.expression - val in_lwt : Parsetree.expression - val unit_lwt : Parsetree.expression - val un_stream : Parsetree.expression - val finally_ : Parsetree.expression - val raise_lwt_ : Longident.t -end - -(* MetaOCaml support *) -module Meta : sig - val code : Lexing.position -> Lexing.position -> - Parsetree.expression -> Parsetree.expression - val uncode : Lexing.position -> Lexing.position -> - Parsetree.expression -> Parsetree.expression -end diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location.ml deleted file mode 100644 index bfb71c08a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location.ml +++ /dev/null @@ -1,820 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Lexing - -type t = Warnings.loc = - { loc_start: position; loc_end: position; loc_ghost: bool };; - -let in_file name = - let loc = { dummy_pos with pos_fname = name } in - { loc_start = loc; loc_end = loc; loc_ghost = true } -;; - -let none = in_file "_none_";; -let is_none l = (l = none);; - -let curr lexbuf = { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.lex_curr_p; - loc_ghost = false -};; - -let init lexbuf fname = - lexbuf.lex_curr_p <- { - pos_fname = fname; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0; - } -;; - -let symbol_rloc () = { - loc_start = Parsing.symbol_start_pos (); - loc_end = Parsing.symbol_end_pos (); - loc_ghost = false; -};; - -let symbol_gloc () = { - loc_start = Parsing.symbol_start_pos (); - loc_end = Parsing.symbol_end_pos (); - loc_ghost = true; -};; - -let rhs_loc n = { - loc_start = Parsing.rhs_start_pos n; - loc_end = Parsing.rhs_end_pos n; - loc_ghost = false; -};; - -let rhs_interval m n = { - loc_start = Parsing.rhs_start_pos m; - loc_end = Parsing.rhs_end_pos n; - loc_ghost = false; -};; - -(* return file, line, char from the given position *) -let get_pos_info pos = - (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) -;; - -type 'a loc = { - txt : 'a; - loc : t; -} - -let mkloc txt loc = { txt ; loc } -let mknoloc txt = mkloc txt none - -(******************************************************************************) -(* Input info *) - -let input_name = ref "_none_" -let input_lexbuf = ref (None : lexbuf option) - -(******************************************************************************) -(* Terminal info *) - -(* The number of lines already printed after input. - - This is used by [highlight_terminfo] to identify the current position of the - input in the terminal. This would not be possible without this information, - since printing several warnings/errors adds text between the user input and - the bottom of the terminal. -*) -let num_loc_lines = ref 0 - -(* This is used by the toplevel to reset [num_loc_lines] before each phrase *) -let reset () = - num_loc_lines := 0 - -(* This is used by the toplevel *) -let echo_eof () = - print_newline (); - incr num_loc_lines - -(* Code printing errors and warnings must be wrapped using this function, in - order to update [num_loc_lines]. - - [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf - arg], and additionally updates [num_loc_lines]. *) -let print_updating_num_loc_lines ppf f arg = - let open Format in - let out_functions = pp_get_formatter_out_functions ppf () in - let out_string str start len = - let rec count i c = - if i = start + len then c - else if String.get str i = '\n' then count (succ i) (succ c) - else count (succ i) c in - num_loc_lines := !num_loc_lines + count start 0 ; - out_functions.out_string str start len in - pp_set_formatter_out_functions ppf - { out_functions with out_string } ; - f ppf arg ; - pp_print_flush ppf (); - pp_set_formatter_out_functions ppf out_functions - -(******************************************************************************) -(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *) - -let rewrite_absolute_path path = - (* - match Misc.get_build_path_prefix_map () with - | None -> path - | Some map -> Build_path_prefix_map.rewrite map path - *) - path - -let absolute_path s = (* This function could go into Filename *) - let open Filename in - let s = - if not (is_relative s) then s - else (rewrite_absolute_path (concat (Sys.getcwd ()) s)) - in - (* Now simplify . and .. components *) - let rec aux s = - let base = basename s in - let dir = dirname s in - if dir = s then dir - else if base = current_dir_name then aux dir - else if base = parent_dir_name then dirname (aux dir) - else concat (aux dir) base - in - aux s - -let show_filename file = - (* if !Clflags.absname then absolute_path file else *) file - -let print_filename ppf file = - Format.pp_print_string ppf (show_filename file) - -(* Best-effort printing of the text describing a location, of the form - 'File "foo.ml", line 3, characters 10-12'. - - Some of the information (filename, line number or characters numbers) in the - location might be invalid; in which case we do not print it. - *) -let print_loc ppf loc = - let file_valid = function - | "_none_" -> - (* This is a dummy placeholder, but we print it anyway to please editors - that parse locations in error messages (e.g. Emacs). *) - true - | "" | "//toplevel//" -> false - | _ -> true - in - let line_valid line = line > 0 in - let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in - - let file = - (* According to the comment in location.mli, if [pos_fname] is "", we must - use [!input_name]. *) - if loc.loc_start.pos_fname = "" then !input_name - else loc.loc_start.pos_fname - in - let line = loc.loc_start.pos_lnum in - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in - - let first = ref true in - let capitalize s = - if !first then (first := false; String.capitalize_ascii s) - else s in - let comma () = - if !first then () else Format.fprintf ppf ", " in - - Format.fprintf ppf "@{"; - - if file_valid file then - Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file; - - (* Print "line 1" in the case of a dummy line number. This is to please the - existing setup of editors that parse locations in error messages (e.g. - Emacs). *) - comma (); - Format.fprintf ppf "%s %i" (capitalize "line") - (if line_valid line then line else 1); - - if chars_valid ~startchar ~endchar then ( - comma (); - Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar - ); - - Format.fprintf ppf "@}" - -(* Print a comma-separated list of locations *) -let print_locs ppf locs = - Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - print_loc ppf locs - -(******************************************************************************) -(* An interval set structure; additionally, it stores user-provided information - at interval boundaries. - - The implementation provided here is naive and assumes the number of intervals - to be small, but the interface would allow for a more efficient - implementation if needed. - - Note: the structure only stores maximal intervals (that therefore do not - overlap). -*) - -(* -module ISet : sig - type 'a bound = 'a * int - type 'a t - (* bounds are included *) - val of_intervals : ('a bound * 'a bound) list -> 'a t - - val mem : 'a t -> pos:int -> bool - val find_bound_in : 'a t -> range:(int * int) -> 'a bound option - - val is_start : 'a t -> pos:int -> 'a option - val is_end : 'a t -> pos:int -> 'a option - - val extrema : 'a t -> ('a bound * 'a bound) option -end -= -struct - type 'a bound = 'a * int - - (* non overlapping intervals *) - type 'a t = ('a bound * 'a bound) list - - let of_intervals intervals = - let pos = - List.map (fun ((a, x), (b, y)) -> - if x > y then [] else [((a, x), `S); ((b, y), `E)] - ) intervals - |> List.flatten - |> List.sort (fun ((_, x), k) ((_, y), k') -> - (* Make `S come before `E so that consecutive intervals get merged - together in the fold below *) - let kn = function `S -> 0 | `E -> 1 in - compare (x, kn k) (y, kn k')) - in - let nesting, acc = - List.fold_left (fun (nesting, acc) (a, kind) -> - match kind, nesting with - | `S, `Outside -> `Inside (a, 0), acc - | `S, `Inside (s, n) -> `Inside (s, n+1), acc - | `E, `Outside -> assert false - | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc) - | `E, `Inside (s, n) -> `Inside (s, n-1), acc - ) (`Outside, []) pos in - assert (nesting = `Outside); - List.rev acc - - let mem iset ~pos = - List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset - - let find_bound_in iset ~range:(start, end_) = - try Some ( - List.find_map ~f:(fun ((a, x), (b, y)) -> - if start <= x && x <= end_ then Some (a, x) - else if start <= y && y <= end_ then Some (b, y) - else None - ) iset - ) with Not_found -> None - - let is_start iset ~pos = - try Some ( - List.find_map ~f:(fun ((a, x), _) -> - if pos = x then Some a else None - ) iset - ) with Not_found -> None - - let is_end iset ~pos = - try Some ( - List.find_map ~f:(fun (_, (b, y)) -> - if pos = y then Some b else None - ) iset - ) with Not_found -> None - - let extrema iset = - if iset = [] then None - else Some (fst (List.hd iset), snd (List.hd (List.rev iset))) -end -*) - - -(* Highlight the location by printing it again. - - There are two different styles for highlighting errors in "dumb" mode, - depending if the error fits on a single line or spans across several lines. - - For single-line errors, - - foo the_error bar - - gets displayed as follows, where X is the line number: - - X | foo the_error bar - ^^^^^^^^^ - - - For multi-line errors, - - foo the_ - error bar - - gets displayed as: - - X1 | ....the_ - X2 | error.... - - An ellipsis hides the middle lines of the multi-line error if it has more - than [max_lines] lines. - - If [locs] is empty then this function is a no-op. -*) - -(* -type input_line = { - text : string; - start_pos : int; -} -*) - -(* Takes a list of lines with possibly missing line numbers. - - If the line numbers that are present are consistent with the number of lines - between them, then infer the intermediate line numbers. - - This is not always the case, typically if lexer line directives are - involved... *) -(* -let infer_line_numbers - (lines: (int option * input_line) list): - (int option * input_line) list - = - let (_, offset, consistent) = - List.fold_left (fun (i, offset, consistent) (lnum, _) -> - match lnum, offset with - | None, _ -> (i+1, offset, consistent) - | Some n, None -> (i+1, Some (n - i), consistent) - | Some n, Some m -> (i+1, offset, consistent && n = m + i) - ) (0, None, true) lines - in - match offset, consistent with - | Some m, true -> - List.mapi (fun i (_, line) -> (Some (m + i), line)) lines - | _, _ -> - lines -*) -(* [get_lines] must return the lines to highlight, given starting and ending - positions. - - See [lines_around_from_current_input] below for an instantiation of - [get_lines] that reads from the current input. -*) - - - -(* -let lines_around - ~(start_pos: position) ~(end_pos: position) - ~(seek: int -> unit) - ~(read_char: unit -> char option): - input_line list - = - seek start_pos.pos_bol; - let lines = ref [] in - let bol = ref start_pos.pos_bol in - let cur = ref start_pos.pos_bol in - let b = Buffer.create 80 in - let add_line () = - if !bol < !cur then begin - let text = Buffer.contents b in - Buffer.clear b; - lines := { text; start_pos = !bol } :: !lines; - bol := !cur - end - in - let rec loop () = - if !bol >= end_pos.pos_cnum then () - else begin - match read_char () with - | None -> - (* end of input *) - add_line () - | Some c -> - incr cur; - match c with - | '\r' -> loop () - | '\n' -> add_line (); loop () - | _ -> Buffer.add_char b c; loop () - end - in - loop (); - List.rev !lines -*) - -(* -(* Try to get lines from a lexbuf *) -let lines_around_from_lexbuf - ~(start_pos: position) ~(end_pos: position) - (lb: lexbuf): - input_line list - = - (* Converts a global position to one that is relative to the lexing buffer *) - let rel n = n - lb.lex_abs_pos in - if rel start_pos.pos_bol < 0 then begin - (* Do nothing if the buffer does not contain the input (because it has been - refilled while lexing it) *) - [] - end else begin - let pos = ref 0 in (* relative position *) - let seek n = pos := rel n in - let read_char () = - if !pos >= lb.lex_buffer_len then (* end of buffer *) None - else - let c = Bytes.get lb.lex_buffer !pos in - incr pos; Some c - in - lines_around ~start_pos ~end_pos ~seek ~read_char - end -*) - -(* -(* Get lines from a file *) -let lines_around_from_file - ~(start_pos: position) ~(end_pos: position) - (filename: string): - input_line list - = - try - let cin = open_in_bin filename in - let read_char () = - try Some (input_char cin) with End_of_file -> None - in - let lines = - lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char - in - close_in cin; - lines - with Sys_error _ -> [] -*) - -(* -(* A [get_lines] function for [highlight_quote] that reads from the current - input. - - It first tries to read from [!input_lexbuf], then if that fails (because the - lexbuf no longer contains the input we want), it reads from [!input_name] - directly *) -let lines_around_from_current_input ~start_pos ~end_pos = - (* Be a bit defensive, and do not try to open one of the possible - [!input_name] values that we know do not denote valid filenames. *) - let file_valid = function - | "//toplevel//" | "_none_" | "" -> false - | _ -> true - in - let from_file () = - if file_valid !input_name then - lines_around_from_file !input_name ~start_pos ~end_pos - else - [] - in - match !input_lexbuf with - | Some lb -> - begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with - | [] -> (* The input is likely not in the lexbuf anymore *) - from_file () - | lines -> - lines - end - | None -> - from_file () -*) - -(******************************************************************************) -(* Reporting errors and warnings *) - -type msg = (Format.formatter -> unit) loc - -let msg ?(loc = none) fmt = - Format.kdprintf (fun txt -> { loc; txt }) fmt - -type report_kind = - | Report_error - | Report_warning of string - | Report_warning_as_error of string - | Report_alert of string - | Report_alert_as_error of string - -type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config - -type report = { - kind : report_kind; - main : msg; - sub : msg list; - source : error_source; -} - -let loc_of_report { main; _ } = main.loc -let print_msg fmt msg = msg.txt fmt -let print_main fmt { main; _ } = print_msg fmt main -let print_sub_msg = print_msg - - -type report_printer = { - (* The entry point *) - pp : report_printer -> - Format.formatter -> report -> unit; - - pp_report_kind : report_printer -> report -> - Format.formatter -> report_kind -> unit; - pp_main_loc : report_printer -> report -> - Format.formatter -> t -> unit; - pp_main_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; - pp_submsgs : report_printer -> report -> - Format.formatter -> msg list -> unit; - pp_submsg : report_printer -> report -> - Format.formatter -> msg -> unit; - pp_submsg_loc : report_printer -> report -> - Format.formatter -> t -> unit; - pp_submsg_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; -} - -(* -let is_dummy_loc loc = - (* Fixme: this should be just [loc.loc_ghost] and the function should be - inlined below. However, currently, the compiler emits in some places ghost - locations with valid ranges that should still be printed. These locations - should be made non-ghost -- in the meantime we just check if the ranges are - valid. *) - loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1 -*) - -(* It only makes sense to highlight (i.e. quote or underline the corresponding - source code) locations that originate from the current input. - - As of now, this should only happen in the following cases: - - - if dummy locs or ghost locs leak out of the compiler or a buggy ppx; - - - more generally, if some code uses the compiler-libs API and feeds it - locations that do not match the current values of [!Location.input_name], - [!Location.input_lexbuf]; - - - when calling the compiler on a .ml file that contains lexer line directives - indicating an other file. This should happen relatively rarely in practice -- - in particular this is not what happens when using -pp or -ppx or a ppx - driver. -*) - (* -let is_quotable_loc loc = - not (is_dummy_loc loc) - && loc.loc_start.pos_fname = !input_name - && loc.loc_end.pos_fname = !input_name - -let error_style () = - let open Misc.Error_style in - match !Clflags.error_style with - | Some Contextual | None -> Contextual - | Some Short -> Short - *) - -let batch_mode_printer : report_printer = - let pp_loc _self _report _ppf _loc = - (* - let tag = match report.kind with - | Report_warning_as_error _ - | Report_alert_as_error _ - | Report_error -> "error" - | Report_warning _ - | Report_alert _ -> "warning" - in - let highlight ppf loc = - match error_style () with - | Misc.Error_style.Contextual -> - if is_quotable_loc loc then - highlight_quote ppf - ~get_lines:lines_around_from_current_input - tag [loc] - | Misc.Error_style.Short -> - () - in - Format.fprintf ppf "@[%a:@ %a@]" print_loc loc highlight loc - *) - () - in - let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in - let pp self ppf report = - (* Make sure we keep [num_loc_lines] updated. - The tabulation box is here to give submessage the option - to be aligned with the main message box - *) - print_updating_num_loc_lines ppf (fun ppf () -> - Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." - Format.pp_open_tbox () - (self.pp_main_loc self report) report.main.loc - (self.pp_report_kind self report) report.kind - Format.pp_set_tab () - (self.pp_main_txt self report) report.main.txt - (self.pp_submsgs self report) report.sub - Format.pp_close_tbox () - ) () - in - let pp_report_kind _self _ ppf = function - | Report_error -> Format.fprintf ppf "@{Error@}" - | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w - | Report_warning_as_error w -> - Format.fprintf ppf "@{Error@} (warning %s)" w - | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w - | Report_alert_as_error w -> - Format.fprintf ppf "@{Error@} (alert %s)" w - in - let pp_main_loc self report ppf loc = - pp_loc self report ppf loc - in - let pp_main_txt _self _ ppf txt = - pp_txt ppf txt - in - let pp_submsgs self report ppf msgs = - List.iter (fun msg -> - Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg - ) msgs - in - let pp_submsg self report ppf { loc; txt } = - Format.fprintf ppf "@[%a %a@]" - (self.pp_submsg_loc self report) loc - (self.pp_submsg_txt self report) txt - in - let pp_submsg_loc self report ppf loc = - if not loc.loc_ghost then - pp_loc self report ppf loc - in - let pp_submsg_txt _self _ ppf loc = - pp_txt ppf loc - in - { pp; pp_report_kind; pp_main_loc; pp_main_txt; - pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt } - -(* Creates a printer for the current input *) -let default_report_printer () : report_printer = - batch_mode_printer - -let report_printer = ref default_report_printer - -let print_report ppf report = - let printer = !report_printer () in - printer.pp printer ppf report - -(******************************************************************************) -(* Reporting errors *) - -type error = report - -let report_error ppf err = - print_report ppf err - -let mkerror loc sub txt source = - { kind = Report_error; main = { loc; txt }; sub; source } - -let errorf ?(loc = none) ?(sub = []) ?(source=Typer) = - Format.kdprintf (fun msg -> mkerror loc sub msg source) - -let error ?(loc = none) ?(sub = []) ?(source=Typer) msg_str = - mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) source - -let error_of_printer ?(loc = none) ?(sub = []) ?(source=Typer) pp x = - mkerror loc sub (fun ppf -> pp ppf x) source - -let error_of_printer_file ?source print x = - error_of_printer ?source ~loc:(in_file !input_name) print x - -(******************************************************************************) -(* Reporting warnings: generating a report from a warning number using the - information in [Warnings] + convenience functions. *) - -let default_warning_alert_reporter ?(source = Typer) report mk (loc: t) w : report option = - match report w with - | `Inactive -> None - | `Active { Warnings.id; message; is_error; sub_locs } -> - let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in - let kind = mk is_error id in - let main = { loc; txt = msg_of_str message } in - let sub = List.map (fun (loc, sub_message) -> - { loc; txt = msg_of_str sub_message } - ) sub_locs in - Some { kind; main; sub; source } - - -let default_warning_reporter = - default_warning_alert_reporter - Warnings.report - (fun is_error id -> - if is_error then Report_warning_as_error id - else Report_warning id - ) - -let warning_reporter = ref default_warning_reporter -let report_warning loc w = !warning_reporter loc w - -let formatter_for_warnings = ref Format.err_formatter - -let print_warning loc ppf w = - match report_warning loc w with - | None -> () - | Some report -> print_report ppf report - -let prerr_warning_ref = - ref (fun loc w -> print_warning loc !formatter_for_warnings w);; -let prerr_warning loc w = !prerr_warning_ref loc w - -let default_alert_reporter = - default_warning_alert_reporter - Warnings.report_alert - (fun is_error id -> - if is_error then Report_alert_as_error id - else Report_alert id - ) - -let alert_reporter = ref default_alert_reporter -let report_alert loc w = !alert_reporter loc w - -let print_alert loc ppf w = - match report_alert loc w with - | None -> () - | Some report -> print_report ppf report - -let prerr_alert_ref = - ref (fun loc w -> print_alert loc !formatter_for_warnings w) - -let prerr_alert loc w = !prerr_alert_ref loc w - -let alert ?(def = none) ?(use = none) ~kind loc message = - prerr_alert loc {Warnings.kind; message; def; use} - -let deprecated ?def ?use loc message = - alert ?def ?use ~kind:"deprecated" loc message - -(******************************************************************************) -(* Reporting errors on exceptions *) - -let error_of_exn : (exn -> error option) list ref = ref [] - -let register_error_of_exn f = error_of_exn := f :: !error_of_exn - -exception Already_displayed_error = Warnings.Errors - -let error_of_exn exn = - match exn with - | Already_displayed_error -> Some `Already_displayed - | _ -> - let rec loop = function - | [] -> None - | f :: rest -> - match f exn with - | Some error -> Some (`Ok error) - | None -> loop rest - in - loop !error_of_exn - -let () = - register_error_of_exn - (function - | Sys_error msg -> - Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) - | _ -> None - ) - -external reraise : exn -> 'a = "%reraise" - -let report_exception ppf exn = - let rec loop n exn = - match error_of_exn exn with - | None -> reraise exn - | Some `Already_displayed -> () - | Some (`Ok err) -> report_error ppf err - | exception exn when n > 0 -> loop (n-1) exn - in - loop 5 exn - -exception Error of error - -let () = - register_error_of_exn - (function - | Error e -> Some e - | _ -> None - ) - -let raise_errorf ?(loc = none) ?(sub = []) ?(source = Typer)= - Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt source))) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location.mli deleted file mode 100644 index 63038ca62..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location.mli +++ /dev/null @@ -1,280 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Source code locations (ranges of positions), used in parsetree. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Format - -type t = Warnings.loc = { - loc_start: Lexing.position; - loc_end: Lexing.position; - loc_ghost: bool; -} - -(** Note on the use of Lexing.position in this module. - If [pos_fname = ""], then use [!input_name] instead. - If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and - re-parse the file to get the line and character numbers. - Else all fields are correct. -*) - -val none : t -(** An arbitrary value of type [t]; describes an empty ghost range. *) - -val is_none : t -> bool - -val in_file : string -> t -(** Return an empty ghost range located in a given file. *) - -val init : Lexing.lexbuf -> string -> unit -(** Set the file name and line number of the [lexbuf] to be the start - of the named file. *) - -val curr : Lexing.lexbuf -> t -(** Get the location of the current token from the [lexbuf]. *) - -val symbol_rloc: unit -> t -val symbol_gloc: unit -> t - -(** [rhs_loc n] returns the location of the symbol at position [n], starting - at 1, in the current parser rule. *) -val rhs_loc: int -> t - -val rhs_interval: int -> int -> t - -val get_pos_info: Lexing.position -> string * int * int -(** file, line, char *) - -type 'a loc = { - txt : 'a; - loc : t; -} - -val mknoloc : 'a -> 'a loc -val mkloc : 'a -> t -> 'a loc - - -(** {1 Input info} *) - -val input_name: string ref -val input_lexbuf: Lexing.lexbuf option ref - - -(** {1 Toplevel-specific functions} *) - -val echo_eof: unit -> unit -val reset: unit -> unit - - -(** {1 Printing locations} *) - -val rewrite_absolute_path: string -> string - (** rewrite absolute path to honor the BUILD_PATH_PREFIX_MAP - variable (https://reproducible-builds.org/specs/build-path-prefix-map/) - if it is set. *) - -val absolute_path: string -> string - -val show_filename: string -> string - (** In -absname mode, return the absolute path for this filename. - Otherwise, returns the filename unchanged. *) - -val print_filename: formatter -> string -> unit - -val print_loc: formatter -> t -> unit -val print_locs: formatter -> t list -> unit - - - -(** {1 Reporting errors and warnings} *) - -(** {2 The type of reports and report printers} *) - -type msg = (Format.formatter -> unit) loc - -val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a - -type report_kind = - | Report_error - | Report_warning of string - | Report_warning_as_error of string - | Report_alert of string - | Report_alert_as_error of string - -type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config - -type report = { - kind : report_kind; - main : msg; - sub : msg list; - source : error_source; -} - -val loc_of_report: report -> t -val print_main : formatter -> report -> unit -val print_sub_msg : formatter -> msg -> unit - -type report_printer = { - (* The entry point *) - pp : report_printer -> - Format.formatter -> report -> unit; - - pp_report_kind : report_printer -> report -> - Format.formatter -> report_kind -> unit; - pp_main_loc : report_printer -> report -> - Format.formatter -> t -> unit; - pp_main_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; - pp_submsgs : report_printer -> report -> - Format.formatter -> msg list -> unit; - pp_submsg : report_printer -> report -> - Format.formatter -> msg -> unit; - pp_submsg_loc : report_printer -> report -> - Format.formatter -> t -> unit; - pp_submsg_txt : report_printer -> report -> - Format.formatter -> (Format.formatter -> unit) -> unit; -} -(** A printer for [report]s, defined using open-recursion. - The goal is to make it easy to define new printers by re-using code from - existing ones. -*) - -(** {2 Report printers used in the compiler} *) - -val batch_mode_printer: report_printer - -(** {2 Printing a [report]} *) - -val print_report: formatter -> report -> unit -(** Display an error or warning report. *) - -val report_printer: (unit -> report_printer) ref -(** Hook for redefining the printer of reports. - - The hook is a [unit -> report_printer] and not simply a [report_printer]: - this is useful so that it can detect the type of the output (a file, a - terminal, ...) and select a printer accordingly. *) - -val default_report_printer: unit -> report_printer -(** Original report printer for use in hooks. *) - - -(** {1 Reporting warnings} *) - -(** {2 Converting a [Warnings.t] into a [report]} *) - -val report_warning: t -> Warnings.t -> report option -(** [report_warning loc w] produces a report for the given warning [w], or - [None] if the warning is not to be printed. *) - -val warning_reporter: (t -> Warnings.t -> report option) ref -(** Hook for intercepting warnings. *) - -val default_warning_reporter: t -> Warnings.t -> report option -(** Original warning reporter for use in hooks. *) - -(** {2 Printing warnings} *) - -val formatter_for_warnings : formatter ref - -val print_warning: t -> formatter -> Warnings.t -> unit -(** Prints a warning. This is simply the composition of [report_warning] and - [print_report]. *) - -val prerr_warning_ref: (t -> Warnings.t -> unit) ref - -val prerr_warning: t -> Warnings.t -> unit -(** Same as [print_warning], but uses [!formatter_for_warnings] as output - formatter. *) - -(** {1 Reporting alerts} *) - -(** {2 Converting an [Alert.t] into a [report]} *) - -val report_alert: t -> Warnings.alert -> report option -(** [report_alert loc w] produces a report for the given alert [w], or - [None] if the alert is not to be printed. *) - -val alert_reporter: (t -> Warnings.alert -> report option) ref -(** Hook for intercepting alerts. *) - -val default_alert_reporter: t -> Warnings.alert -> report option -(** Original alert reporter for use in hooks. *) - -(** {2 Printing alerts} *) - -val print_alert: t -> formatter -> Warnings.alert -> unit -(** Prints an alert. This is simply the composition of [report_alert] and - [print_report]. *) - -val prerr_alert_ref: (t -> Warnings.alert -> unit) ref - -val prerr_alert: t -> Warnings.alert -> unit -(** Same as [print_alert], but uses [!formatter_for_warnings] as output - formatter. *) - -val deprecated: ?def:t -> ?use:t -> t -> string -> unit -(** Prints a deprecation alert. *) - -val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit -(** Prints an arbitrary alert. *) - - -(** {1 Reporting errors} *) - -type error = report -(** An [error] is a [report] which [report_kind] must be [Report_error]. *) - -val error: ?loc:t -> ?sub:msg list -> ?source:error_source -> string -> error - -val errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> - ('a, Format.formatter, unit, error) format4 -> 'a - -val error_of_printer: ?loc:t -> ?sub:msg list -> ?source:error_source -> - (formatter -> 'a -> unit) -> 'a -> error - -val error_of_printer_file: ?source:error_source -> (formatter -> 'a -> unit) -> 'a -> error - - -(** {1 Automatically reporting errors for raised exceptions} *) - -val register_error_of_exn: (exn -> error option) -> unit -(** Each compiler module which defines a custom type of exception - which can surface as a user-visible error should register - a "printer" for this exception using [register_error_of_exn]. - The result of the printer is an [error] value containing - a location, a message, and optionally sub-messages (each of them - being located as well). *) - -val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option - -exception Error of error -(** Raising [Error e] signals an error [e]; the exception will be caught and the - error will be printed. *) - -exception Already_displayed_error -(** Raising [Already_displayed_error] signals an error which has already been - printed. The exception will be caught, but nothing will be printed *) - -val raise_errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> - ('a, Format.formatter, unit, 'b) format4 -> 'a - -val report_exception: formatter -> exn -> unit -(** Reraise the exception if it is unknown. *) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location_aux.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location_aux.ml deleted file mode 100644 index 966ebdd3f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location_aux.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -type t - = Location.t - = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool } - -let compare (l1: t) (l2: t) = - match Lexing.compare_pos l1.loc_start l2.loc_start with - | (-1 | 1) as r -> r - | 0 -> Lexing.compare_pos l1.loc_end l2.loc_end - | _ -> assert false - -let compare_pos pos loc = - if Lexing.compare_pos pos loc.Location.loc_start < 0 then - -1 - else if Lexing.compare_pos pos loc.Location.loc_end > 0 then - 1 - else - 0 - -let union l1 l2 = - if l1 = Location.none then l2 - else if l2 = Location.none then l1 - else { - Location. - loc_start = Lexing.min_pos l1.Location.loc_start l2.Location.loc_start; - loc_end = Lexing.max_pos l1.Location.loc_end l2.Location.loc_end; - loc_ghost = l1.Location.loc_ghost && l2.Location.loc_ghost; - } - -let extend l1 l2 = - if l1 = Location.none then l2 - else if l2 = Location.none then l1 - else { - Location. - loc_start = Lexing.min_pos l1.Location.loc_start l2.Location.loc_start; - loc_end = Lexing.max_pos l1.Location.loc_end l2.Location.loc_end; - loc_ghost = l1.Location.loc_ghost; - } - -(** Filter valid errors, log invalid ones *) -let prepare_errors exns = - List.filter_map exns - ~f:(fun exn -> - match Location.error_of_exn exn with - | None -> - Logger.log ~section:"Mreader" ~title:"errors" - "Location.error_of_exn (%a) = None" - (fun () -> Printexc.to_string) exn; - None - | Some `Already_displayed -> None - | Some (`Ok err) -> Some err - ) - -let print () {Location. loc_start; loc_end; loc_ghost} = - let l1, c1 = Lexing.split_pos loc_start in - let l2, c2 = Lexing.split_pos loc_end in - sprintf "%d:%d-%d:%d%s" - l1 c1 l2 c2 (if loc_ghost then "{ghost}" else "") - -let print_loc f () {Location. txt; loc} = - sprintf "%a@%a" f txt print loc - -let is_relaxed_location = function - | { Location. txt = "merlin.relaxed-location" | "merlin.loc"; _ } -> true - | _ -> false diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location_aux.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location_aux.mli deleted file mode 100644 index 7d99d36a0..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/location_aux.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -type t - = Location.t - = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool } - -(** [compare l1 l2] compares start positions, if equal compares end positions *) -val compare : t -> t -> int - -val compare_pos: Lexing.position -> t -> int - -(** Return the smallest location covered by both arguments, - ghost if both are ghosts *) -val union : t -> t -> t - -(** Like location_union, but keep loc_ghost'ness of first argument *) -val extend : t -> t -> t - -(** Filter valid errors, log invalid ones *) -val prepare_errors : exn list -> Location.error list - -(** {1 Dump} *) - -val print : unit -> t -> string -val print_loc : (unit -> 'a -> string) -> unit -> 'a Location.loc -> string - -val is_relaxed_location : string Location.loc -> bool diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/longident.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/longident.ml deleted file mode 100644 index 837c6a952..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/longident.ml +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t - -let rec flat accu = function - Lident s -> s :: accu - | Ldot(lid, s) -> flat (s :: accu) lid - | Lapply(_, _) -> Misc.fatal_error "Longident.flat" - -let flatten lid = flat [] lid - -let rec head = function - Lident s -> s - | Ldot(lid, _) -> head lid - | Lapply(_, _) -> assert false - -let last = function - Lident s -> s - | Ldot(_, s) -> s - | Lapply(_, _) -> Misc.fatal_error "Longident.last" - - -let rec split_at_dots s pos = - try - let dot = String.index_from s pos '.' in - String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) - with Not_found -> - [String.sub s pos (String.length s - pos)] - -let unflatten l = - match l with - | [] -> None - | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) - -let parse s = - match unflatten (split_at_dots s 0) with - | None -> Lident "" (* should not happen, but don't put assert false - so as not to crash the toplevel (see Genprintval) *) - | Some v -> v - -let keep_suffix = - let rec aux = function - | Lident str -> - if String.uncapitalize_ascii str <> str then - Some (Lident str, false) - else - None - | Ldot (t, str) -> - if String.uncapitalize_ascii str <> str then - match aux t with - | None -> Some (Lident str, true) - | Some (t, is_label) -> Some (Ldot (t, str), is_label) - else - None - | t -> Some (t, false) (* Can be improved... *) - in - function - | Lident s -> Lident s, false - | Ldot (t, s) -> - begin match aux t with - | None -> Lident s, true - | Some (t, is_label) -> Ldot (t, s), is_label - end - | otherwise -> otherwise, false diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/longident.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/longident.mli deleted file mode 100644 index 72c5964fb..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/longident.mli +++ /dev/null @@ -1,74 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Long identifiers, used in parsetree. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - To print a longident, see {!Pprintast.longident}, using - {!Format.asprintf} to convert to a string. - -*) - -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t - -val flatten: t -> string list -val unflatten: string list -> t option -(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is - the long identifier created by concatenating the elements of [l] - with [Ldot]. - [unflatten []] is [None]. -*) - -(** [head lid] returns the leftmost part of [lid], e.g., - given [String.Map.empty], returns [String]. - - @raise Assert_failure if encounters [Lapply] *) -val head: t -> string -val last: t -> string -val parse: string -> t - (* (* disabled in merlin. *) -[@@deprecated "this function may misparse its input,\n\ -use \"Parse.longident\" or \"Longident.unflatten\""] - *) -(** - - This function is broken on identifiers that are not just "Word.Word.word"; - for example, it returns incorrect results on infix operators - and extended module paths. - - If you want to generate long identifiers that are a list of - dot-separated identifiers, the function {!unflatten} is safer and faster. - {!unflatten} is available since OCaml 4.06.0. - - If you want to parse any identifier correctly, use the long-identifiers - functions from the {!Parse} module, in particular {!Parse.longident}. - They are available since OCaml 4.11, and also provide proper - input-location support. - -*) - -(* Merlin specific. *) - -val keep_suffix : t -> t * bool -(** if [li', b = keep_suffix li] then: - - the prefix of [li'] is a module path - - [b = false] iff [li' = li]. - Corollary: [b = true] if [li] is a label access - (i.e. [li = X.Y.z.Foo.Bar...]) *) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/msupport_parsing.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/msupport_parsing.ml deleted file mode 100644 index 567e5e28e..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/msupport_parsing.ml +++ /dev/null @@ -1,6 +0,0 @@ -(* Filled in from Msupport. *) -let msupport_raise_error : (exn -> unit) ref = - ref raise - -let raise_error exn = - !msupport_raise_error exn diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/parsetree.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/parsetree.mli deleted file mode 100644 index 7e9e2d9f5..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/parsetree.mli +++ /dev/null @@ -1,1051 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Abstract syntax tree produced by parsing - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes - -type constant = - | Pconst_integer of string * char option - (** Integer constants such as [3] [3l] [3L] [3n]. - - Suffixes [[g-z][G-Z]] are accepted by the parser. - Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker - *) - | Pconst_char of char (** Character such as ['c']. *) - | Pconst_string of string * Location.t * string option - (** Constant string such as ["constant"] or - [{delim|other constant|delim}]. - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (** Float constant such as [3.4], [2e5] or [1.4e-4]. - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - -type location_stack = Location.t list - -(** {1 Extension points} *) - -type attribute = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } -(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - -and extension = string loc * payload -(** Extension points such as [[%id ARG] and [%%id ARG]]. - - Sub-language placeholder -- rejected by the typechecker. - *) - -and attributes = attribute list - -and payload = - | PStr of structure - | PSig of signature (** [: SIG] in an attribute or an extension point *) - | PTyp of core_type (** [: T] in an attribute or an extension point *) - | PPat of pattern * expression option - (** [? P] or [? P when E], in an attribute or an extension point *) - -(** {1 Core language} *) -(** {2 Type expressions} *) - -and core_type = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and core_type_desc = - | Ptyp_any (** [_] *) - | Ptyp_var of string (** A type variable such as ['a] *) - | Ptyp_arrow of arg_label * core_type * core_type - (** [Ptyp_arrow(lbl, T1, T2)] represents: - - [T1 -> T2] when [lbl] is - {{!Asttypes.arg_label.Nolabel}[Nolabel]}, - - [~l:T1 -> T2] when [lbl] is - {{!Asttypes.arg_label.Labelled}[Labelled]}, - - [?l:T1 -> T2] when [lbl] is - {{!Asttypes.arg_label.Optional}[Optional]}. - *) - | Ptyp_tuple of core_type list - (** [Ptyp_tuple([T1 ; ... ; Tn])] - represents a product type [T1 * ... * Tn]. - - Invariant: [n >= 2]. - *) - | Ptyp_constr of Longident.t loc * core_type list - (** [Ptyp_constr(lident, l)] represents: - - [tconstr] when [l=[]], - - [T tconstr] when [l=[T]], - - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. - *) - | Ptyp_object of object_field list * closed_flag - (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: - - [< l1:T1; ...; ln:Tn >] when [flag] is - {{!Asttypes.closed_flag.Closed}[Closed]}, - - [< l1:T1; ...; ln:Tn; .. >] when [flag] is - {{!Asttypes.closed_flag.Open}[Open]}. - *) - | Ptyp_class of Longident.t loc * core_type list - (** [Ptyp_class(tconstr, l)] represents: - - [#tconstr] when [l=[]], - - [T #tconstr] when [l=[T]], - - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. - *) - | Ptyp_alias of core_type * string (** [T as 'a]. *) - | Ptyp_variant of row_field list * closed_flag * label list option - (** [Ptyp_variant([`A;`B], flag, labels)] represents: - - [[ `A|`B ]] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, - and [labels] is [None], - - [[> `A|`B ]] - when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, - and [labels] is [None], - - [[< `A|`B ]] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, - and [labels] is [Some []], - - [[< `A|`B > `X `Y ]] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, - and [labels] is [Some ["X";"Y"]]. - *) - | Ptyp_poly of string loc list * core_type - (** ['a1 ... 'an. T] - - Can only appear in the following context: - - - As the {!core_type} of a - {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding - to a constraint on a let-binding: - {[let x : 'a1 ... 'an. T = e ...]} - - - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods - (not values). - - - As the {!core_type} of a - {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. - - - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} - node. - - - As the {{!label_declaration.pld_type}[pld_type]} field of a - {!label_declaration}. - - - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} - node. - - - As the {{!value_description.pval_type}[pval_type]} field of a - {!value_description}. - *) - | Ptyp_package of package_type (** [(module S)]. *) - | Ptyp_extension of extension (** [[%id]]. *) - -and package_type = Longident.t loc * (Longident.t loc * core_type) list -(** As {!package_type} typed values: - - [(S, [])] represents [(module S)], - - [(S, [(t1, T1) ; ... ; (tn, Tn)])] - represents [(module S with type t1 = T1 and ... and tn = Tn)]. - *) - -and row_field = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; -} - -and row_field_desc = - | Rtag of label loc * bool * core_type list - (** [Rtag(`A, b, l)] represents: - - [`A] when [b] is [true] and [l] is [[]], - - [`A of T] when [b] is [false] and [l] is [[T]], - - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], - - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. - - - The [bool] field is true if the tag contains a - constant (empty) constructor. - - [&] occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type (** [[ | t ]] *) - -and object_field = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; -} - -and object_field_desc = - | Otag of label loc * core_type - | Oinherit of core_type - -(** {2 Patterns} *) - -and pattern = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and pattern_desc = - | Ppat_any (** The pattern [_]. *) - | Ppat_var of string loc (** A variable pattern such as [x] *) - | Ppat_alias of pattern * string loc - (** An alias pattern such as [P as 'a] *) - | Ppat_constant of constant - (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) - | Ppat_interval of constant * constant - (** Patterns such as ['a'..'z']. - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (** Patterns [(P1, ..., Pn)]. - - Invariant: [n >= 2] - *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option - (** [Ppat_construct(C, args)] represents: - - [C] when [args] is [None], - - [C P] when [args] is [Some ([], P)] - - [C (P1, ..., Pn)] when [args] is - [Some ([], Ppat_tuple [P1; ...; Pn])] - - [C (type a b) P] when [args] is [Some ([a; b], P)] - *) - | Ppat_variant of label * pattern option - (** [Ppat_variant(`A, pat)] represents: - - [`A] when [pat] is [None], - - [`A P] when [pat] is [Some P] - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: - - [{ l1=P1; ...; ln=Pn }] - when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} - - [{ l1=P1; ...; ln=Pn; _}] - when [flag] is {{!Asttypes.closed_flag.Open}[Open]} - - Invariant: [n > 0] - *) - | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) - | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) - | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) - | Ppat_type of Longident.t loc (** Pattern [#tconst] *) - | Ppat_lazy of pattern (** Pattern [lazy P] *) - | Ppat_unpack of string option loc - (** [Ppat_unpack(s)] represents: - - [(module P)] when [s] is [Some "P"] - - [(module _)] when [s] is [None] - - Note: [(module P : S)] is represented as - [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] - *) - | Ppat_exception of pattern (** Pattern [exception P] *) - | Ppat_extension of extension (** Pattern [[%id]] *) - | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) - -(** {2 Value expressions} *) - -and expression = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and expression_desc = - | Pexp_ident of Longident.t loc - (** Identifiers such as [x] and [M.x] - *) - | Pexp_constant of constant - (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], - [1L], [1n] *) - | Pexp_let of rec_flag * value_binding list * expression - (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: - - [let P1 = E1 and ... and Pn = EN in E] - when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, - - [let rec P1 = E1 and ... and Pn = EN in E] - when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - [fun P -> E1] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [fun ~l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [fun ?l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Notes: - - If [E0] is provided, only - {{!Asttypes.arg_label.Optional}[Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - [let f P = E] is represented using - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - *) - | Pexp_apply of expression * (arg_label * expression) list - (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] - represents [E0 ~l1:E1 ... ~ln:En] - - [li] can be - {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), - {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or - {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). - - Invariant: [n > 0] - *) - | Pexp_match of expression * case list - (** [match E0 with P1 -> E1 | ... | Pn -> En] *) - | Pexp_try of expression * case list - (** [try E0 with P1 -> E1 | ... | Pn -> En] *) - | Pexp_tuple of expression list - (** Expressions [(E1, ..., En)] - - Invariant: [n >= 2] - *) - | Pexp_construct of Longident.t loc * expression option - (** [Pexp_construct(C, exp)] represents: - - [C] when [exp] is [None], - - [C E] when [exp] is [Some E], - - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] - *) - | Pexp_variant of label * expression option - (** [Pexp_variant(`A, exp)] represents - - [`A] when [exp] is [None] - - [`A E] when [exp] is [Some E] - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents - - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] - - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] - - Invariant: [n > 0] - *) - | Pexp_field of expression * Longident.t loc (** [E.l] *) - | Pexp_setfield of expression * Longident.t loc * expression - (** [E1.l <- E2] *) - | Pexp_array of expression list (** [[| E1; ...; En |]] *) - | Pexp_ifthenelse of expression * expression * expression option - (** [if E1 then E2 else E3] *) - | Pexp_sequence of expression * expression (** [E1; E2] *) - | Pexp_while of expression * expression (** [while E1 do E2 done] *) - | Pexp_for of pattern * expression * expression * direction_flag * expression - (** [Pexp_for(i, E1, E2, direction, E3)] represents: - - [for i = E1 to E2 do E3 done] - when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} - - [for i = E1 downto E2 do E3 done] - when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} - *) - | Pexp_constraint of expression * core_type (** [(E : T)] *) - | Pexp_coerce of expression * core_type option * core_type - (** [Pexp_coerce(E, from, T)] represents - - [(E :> T)] when [from] is [None], - - [(E : T0 :> T)] when [from] is [Some T0]. - *) - | Pexp_send of expression * label loc (** [E # m] *) - | Pexp_new of Longident.t loc (** [new M.c] *) - | Pexp_setinstvar of label loc * expression (** [x <- 2] *) - | Pexp_override of (label loc * expression) list - (** [{< x1 = E1; ...; xn = En >}] *) - | Pexp_letmodule of string option loc * module_expr * expression - (** [let module M = ME in E] *) - | Pexp_letexception of extension_constructor * expression - (** [let exception C in E] *) - | Pexp_assert of expression - (** [assert E]. - - Note: [assert false] is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression (** [lazy E] *) - | Pexp_poly of expression * core_type option - (** Used for method bodies. - - Can only be used as the expression under - {{!class_field_kind.Cfk_concrete}[Cfk_concrete]} for methods (not - values). *) - | Pexp_object of class_structure (** [object ... end] *) - | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) - | Pexp_pack of module_expr - (** [(module ME)]. - - [(module ME : S)] is represented as - [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) - | Pexp_open of open_declaration * expression - (** - [M.(E)] - - [let open M in E] - - [let open! M in E] *) - | Pexp_letop of letop - (** - [let* P = E0 in E1] - - [let* P0 = E00 and* P1 = E01 in E1] *) - | Pexp_extension of extension (** [[%id]] *) - | Pexp_unreachable (** [.] *) - | Pexp_hole (** A typed hole (merlin specific) [_] *) - -and case = - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } -(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) - -and letop = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - -and binding_op = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - -(** {2 Value descriptions} *) - -and value_description = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pval_loc: Location.t; - } -(** Values of type {!value_description} represents: - - [val x: T], - when {{!value_description.pval_prim}[pval_prim]} is [[]] - - [external x: T = "s1" ... "sn"] - when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] -*) - -(** {2 Type declarations} *) - -and type_declaration = - { - ptype_name: string loc; - ptype_params: (core_type * (variance * injectivity)) list; - (** [('a1,...'an) t] *) - ptype_cstrs: (core_type * core_type * Location.t) list; - (** [... constraint T1=T1' ... constraint Tn=Tn'] *) - ptype_kind: type_kind; - ptype_private: private_flag; (** for [= private ...] *) - ptype_manifest: core_type option; (** represents [= T] *) - ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - ptype_loc: Location.t; - } -(** - Here are type declarations and their representation, - for various {{!type_declaration.ptype_kind}[ptype_kind]} - and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: - - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, - and [manifest] is [None], - - [type t = T0] - when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, - and [manifest] is [Some T0], - - [type t = C of T | ...] - when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, - and [manifest] is [None], - - [type t = T0 = C of T | ...] - when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, - and [manifest] is [Some T0], - - [type t = {l: T; ...}] - when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, - and [manifest] is [None], - - [type t = T0 = {l : T; ...}] - when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, - and [manifest] is [Some T0], - - [type t = ..] - when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, - and [manifest] is [None]. -*) - -and type_kind = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list (** Invariant: non-empty list *) - | Ptype_open - -and label_declaration = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) - } -(** - - [{ ...; l: T; ... }] - when {{!label_declaration.pld_mutable}[pld_mutable]} - is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, - - [{ ...; mutable l: T; ... }] - when {{!label_declaration.pld_mutable}[pld_mutable]} - is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. - - Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. -*) - -and constructor_declaration = - { - pcd_name: string loc; - pcd_vars: string loc list; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) - } - -and constructor_arguments = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - (** Values of type {!constructor_declaration} - represents the constructor arguments of: - - [C of T1 * ... * Tn] when [res = None], - and [args = Pcstr_tuple [T1; ... ; Tn]], - - [C: T0] when [res = Some T0], - and [args = Pcstr_tuple []], - - [C: T1 * ... * Tn -> T0] when [res = Some T0], - and [args = Pcstr_tuple [T1; ... ; Tn]], - - [C of {...}] when [res = None], - and [args = Pcstr_record [...]], - - [C: {...} -> T0] when [res = Some T0], - and [args = Pcstr_record [...]]. -*) - -and type_extension = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * (variance * injectivity)) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) - } -(** - Definition of new extensions constructors for the extensive sum type [t] - ([type t += ...]). -*) - -and extension_constructor = - { - pext_name: string loc; - pext_kind: extension_constructor_kind; - pext_loc: Location.t; - pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) - } - -and type_exception = - { - ptyexn_constructor : extension_constructor; - ptyexn_loc : Location.t; - ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) - } -(** Definition of a new exception ([exception E]). *) - -and extension_constructor_kind = - | Pext_decl of string loc list * constructor_arguments * core_type option - (** [Pext_decl(existentials, c_args, t_opt)] - describes a new extension constructor. It can be: - - [C of T1 * ... * Tn] when: - {ul {- [existentials] is [[]],} - {- [c_args] is [[T1; ...; Tn]],} - {- [t_opt] is [None]}.} - - [C: T0] when - {ul {- [existentials] is [[]],} - {- [c_args] is [[]],} - {- [t_opt] is [Some T0].}} - - [C: T1 * ... * Tn -> T0] when - {ul {- [existentials] is [[]],} - {- [c_args] is [[T1; ...; Tn]],} - {- [t_opt] is [Some T0].}} - - [C: 'a... . T1 * ... * Tn -> T0] when - {ul {- [existentials] is [['a;...]],} - {- [c_args] is [[T1; ... ; Tn]],} - {- [t_opt] is [Some T0].}} - *) - | Pext_rebind of Longident.t loc - (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) - -(** {1 Class language} *) -(** {2 Type expressions for the class language} *) - -and class_type = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and class_type_desc = - | Pcty_constr of Longident.t loc * core_type list - (** - [c] - - [['a1, ..., 'an] c] *) - | Pcty_signature of class_signature (** [object ... end] *) - | Pcty_arrow of arg_label * core_type * class_type - (** [Pcty_arrow(lbl, T, CT)] represents: - - [T -> CT] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, - - [~l:T -> CT] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, - - [?l:T -> CT] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. - *) - | Pcty_extension of extension (** [%id] *) - | Pcty_open of open_description * class_type (** [let open M in CT] *) - -and class_signature = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } -(** Values of type [class_signature] represents: - - [object('selfpat) ... end] - - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} - is {{!core_type_desc.Ptyp_any}[Ptyp_any]} -*) - -and class_type_field = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - } - -and class_type_field_desc = - | Pctf_inherit of class_type (** [inherit CT] *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (** [val x: T] *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (** [method x: T] - - Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. - *) - | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) - | Pctf_attribute of attribute (** [[\@\@\@id]] *) - | Pctf_extension of extension (** [[%%id]] *) - -and 'a class_infos = - { - pci_virt: virtual_flag; - pci_params: (core_type * (variance * injectivity)) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - } -(** Values of type [class_expr class_infos] represents: - - [class c = ...] - - [class ['a1,...,'an] c = ...] - - [class virtual c = ...] - - They are also used for "class type" declaration. -*) - -and class_description = class_type class_infos - -and class_type_declaration = class_type class_infos - -(** {2 Value expressions for the class language} *) - -and class_expr = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and class_expr_desc = - | Pcl_constr of Longident.t loc * core_type list - (** [c] and [['a1, ..., 'an] c] *) - | Pcl_structure of class_structure (** [object ... end] *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (** [Pcl_fun(lbl, exp0, P, CE)] represents: - - [fun P -> CE] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None], - - [fun ~l:P -> CE] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None], - - [fun ?l:P -> CE] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None], - - [fun ?l:(P = E0) -> CE] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0]. - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] - represents [CE ~l1:E1 ... ~ln:En]. - [li] can be empty (non labeled argument) or start with [?] - (optional argument). - - Invariant: [n > 0] - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: - - [let P1 = E1 and ... and Pn = EN in CE] - when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, - - [let rec P1 = E1 and ... and Pn = EN in CE] - when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) - | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) - | Pcl_extension of extension (** [[%id]] *) - | Pcl_open of open_description * class_expr (** [let open M in CE] *) - -and class_structure = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } -(** Values of type {!class_structure} represents: - - [object(selfpat) ... end] - - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} - is {{!pattern_desc.Ppat_any}[Ppat_any]} -*) - -and class_field = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - } - -and class_field_desc = - | Pcf_inherit of override_flag * class_expr * string loc option - (** [Pcf_inherit(flag, CE, s)] represents: - - [inherit CE] - when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} - and [s] is [None], - - [inherit CE as x] - when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} - and [s] is [Some x], - - [inherit! CE] - when [flag] is {{!Asttypes.override_flag.Override}[Override]} - and [s] is [None], - - [inherit! CE as x] - when [flag] is {{!Asttypes.override_flag.Override}[Override]} - and [s] is [Some x] - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (** [Pcf_val(x,flag, kind)] represents: - - [val x = E] - when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} - and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} - - [val virtual x: T] - when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} - and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} - - [val mutable x = E] - when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} - and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} - - [val mutable virtual x: T] - when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} - and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (** - [method x = E] - ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) - - [method virtual x: T] - ([T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}) - *) - | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) - | Pcf_initializer of expression (** [initializer E] *) - | Pcf_attribute of attribute (** [[\@\@\@id]] *) - | Pcf_extension of extension (** [[%%id]] *) - -and class_field_kind = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - -and class_declaration = class_expr class_infos - -(** {1 Module language} *) -(** {2 Type expressions for the module language} *) - -and module_type = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and module_type_desc = - | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [S] *) - | Pmty_signature of signature (** [sig ... end] *) - | Pmty_functor of functor_parameter * module_type - (** [functor(X : MT1) -> MT2] *) - | Pmty_with of module_type * with_constraint list (** [MT with ...] *) - | Pmty_typeof of module_expr (** [module type of ME] *) - | Pmty_extension of extension (** [[%id]] *) - | Pmty_alias of Longident.t loc (** [(module M)] *) - -and functor_parameter = - | Unit (** [()] *) - | Named of string option loc * module_type - (** [Named(name, MT)] represents: - - [(X : MT)] when [name] is [Some X], - - [(_ : MT)] when [name] is [None] *) - -and signature = signature_item list - -and signature_item = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - -and signature_item_desc = - | Psig_value of value_description - (** - [val x: T] - - [external x: T = "s1" ... "sn"] - *) - | Psig_type of rec_flag * type_declaration list - (** [type t1 = ... and ... and tn = ...] *) - | Psig_typesubst of type_declaration list - (** [type t1 := ... and ... and tn := ...] *) - | Psig_typext of type_extension (** [type t1 += ...] *) - | Psig_exception of type_exception (** [exception C of T] *) - | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) - | Psig_modsubst of module_substitution (** [module X := M] *) - | Psig_recmodule of module_declaration list - (** [module rec X1 : MT1 and ... and Xn : MTn] *) - | Psig_modtype of module_type_declaration - (** [module type S = MT] and [module type S] *) - | Psig_modtypesubst of module_type_declaration - (** [module type S := ...] *) - | Psig_open of open_description (** [open X] *) - | Psig_include of include_description (** [include MT] *) - | Psig_class of class_description list - (** [class c1 : ... and ... and cn : ...] *) - | Psig_class_type of class_type_declaration list - (** [class type ct1 = ... and ... and ctn = ...] *) - | Psig_attribute of attribute (** [[\@\@\@id]] *) - | Psig_extension of extension * attributes (** [[%%id]] *) - -and module_declaration = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pmd_loc: Location.t; - } -(** Values of type [module_declaration] represents [S : MT] *) - -and module_substitution = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pms_loc: Location.t; - } -(** Values of type [module_substitution] represents [S := M] *) - -and module_type_declaration = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) - pmtd_loc: Location.t; - } -(** Values of type [module_type_declaration] represents: - - [S = MT], - - [S] for abstract module type declaration, - when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. -*) - -and 'a open_infos = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } -(** Values of type ['a open_infos] represents: - - [open! X] when {{!open_infos.popen_override}[popen_override]} - is {{!Asttypes.override_flag.Override}[Override]} - (silences the "used identifier shadowing" warning) - - [open X] when {{!open_infos.popen_override}[popen_override]} - is {{!Asttypes.override_flag.Fresh}[Fresh]} -*) - -and open_description = Longident.t loc open_infos -(** Values of type [open_description] represents: - - [open M.N] - - [open M(N).O] *) - -and open_declaration = module_expr open_infos -(** Values of type [open_declaration] represents: - - [open M.N] - - [open M(N).O] - - [open struct ... end] *) - -and 'a include_infos = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - -and include_description = module_type include_infos -(** Values of type [include_description] represents [include MT] *) - -and include_declaration = module_expr include_infos -(** Values of type [include_declaration] represents [include ME] *) - -and with_constraint = - | Pwith_type of Longident.t loc * type_declaration - (** [with type X.t = ...] - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (** [with module X.Y = Z] *) - | Pwith_modtype of Longident.t loc * module_type - (** [with module type X.Y = Z] *) - | Pwith_modtypesubst of Longident.t loc * module_type - (** [with module type X.Y := sig end] *) - | Pwith_typesubst of Longident.t loc * type_declaration - (** [with type X.t := ..., same format as [Pwith_type]] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (** [with module X.Y := Z] *) - -(** {2 Value expressions for the module language} *) - -and module_expr = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) - } - -and module_expr_desc = - | Pmod_ident of Longident.t loc (** [X] *) - | Pmod_structure of structure (** [struct ... end] *) - | Pmod_functor of functor_parameter * module_expr - (** [functor(X : MT1) -> ME] *) - | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) - | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) - | Pmod_unpack of expression (** [(val E)] *) - | Pmod_extension of extension (** [[%id]] *) - | Pmod_hole (** A typed hole (merlin specific) [_] *) - -and structure = structure_item list - -and structure_item = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - -and structure_item_desc = - | Pstr_eval of expression * attributes (** [E] *) - | Pstr_value of rec_flag * value_binding list - (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: - - [let P1 = E1 and ... and Pn = EN] - when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, - - [let rec P1 = E1 and ... and Pn = EN ] - when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. - *) - | Pstr_primitive of value_description - (** - [val x: T] - - [external x: T = "s1" ... "sn" ]*) - | Pstr_type of rec_flag * type_declaration list - (** [type t1 = ... and ... and tn = ...] *) - | Pstr_typext of type_extension (** [type t1 += ...] *) - | Pstr_exception of type_exception - (** - [exception C of T] - - [exception C = M.X] *) - | Pstr_module of module_binding (** [module X = ME] *) - | Pstr_recmodule of module_binding list - (** [module rec X1 = ME1 and ... and Xn = MEn] *) - | Pstr_modtype of module_type_declaration (** [module type S = MT] *) - | Pstr_open of open_declaration (** [open X] *) - | Pstr_class of class_declaration list - (** [class c1 = ... and ... and cn = ...] *) - | Pstr_class_type of class_type_declaration list - (** [class type ct1 = ... and ... and ctn = ...] *) - | Pstr_include of include_declaration (** [include ME] *) - | Pstr_attribute of attribute (** [[\@\@\@id]] *) - | Pstr_extension of extension * attributes (** [[%%id]] *) - -and value_binding = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - -and module_binding = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } -(** Values of type [module_binding] represents [module X = ME] *) - -(** {1 Toplevel} *) - -(** {2 Toplevel phrases} *) - -type toplevel_phrase = - | Ptop_def of structure - | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) - -and toplevel_directive = - { - pdir_name: string loc; - pdir_arg: directive_argument option; - pdir_loc: Location.t; - } - -and directive_argument = - { - pdira_desc: directive_argument_desc; - pdira_loc: Location.t; - } - -and directive_argument_desc = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/pprintast.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/pprintast.ml deleted file mode 100644 index 5c7390a02..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/pprintast.ml +++ /dev/null @@ -1,1770 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire, OCamlPro *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* Hongbo Zhang, University of Pennsylvania *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) -(* Printing code expressions *) -(* Authors: Ed Pizzi, Fabrice Le Fessant *) -(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) -(* TODO more fine-grained precedence pretty-printing *) - -open Asttypes -open Format -open Location -open Longident -open Parsetree -open Ast_helper - -let prefix_symbols = [ '!'; '?'; '~' ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] - -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] - -let letop s = - String.length s > 3 - && s.[0] = 'l' - && s.[1] = 'e' - && s.[2] = 't' - && List.mem s.[3] infix_symbols - -let andop s = - String.length s > 3 - && s.[0] = 'a' - && s.[1] = 'n' - && s.[2] = 'd' - && List.mem s.[3] infix_symbols - -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) -let fixity_of_string = function - | "" -> `Normal - | s when List.mem s special_infix_strings -> `Infix s - | s when List.mem s.[0] infix_symbols -> `Infix s - | s when List.mem s.[0] prefix_symbols -> `Prefix s - | s when s.[0] = '.' -> `Mixfix s - | s when letop s -> `Letop s - | s when andop s -> `Andop s - | _ -> `Normal - -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal - -let is_infix = function `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false -let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false - -let first_is c str = - str <> "" && str.[0] = c -let last_is c str = - str <> "" && str.[String.length str - 1] = c - -let first_is_in cs str = - str <> "" && List.mem str.[0] cs - -(* which identifiers are in fact operators needing parentheses *) -let needs_parens txt = - let fix = fixity_of_string txt in - is_infix fix - || is_mixfix fix - || is_kwdop fix - || first_is_in prefix_symbols txt - -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - first_is '*' txt || last_is '*' txt - -let string_loc ppf x = fprintf ppf "%s" x.txt - -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protect_ident ppf txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt - -let protect_longident ppf print_longident longprefix txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "%a.(@;%s@;)" - else "%a.(%s)" in - fprintf ppf format print_longident longprefix txt - -type space_formatter = (unit, Format.formatter, unit) format - -let override = function - | Override -> "!" - | Fresh -> "" - -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | NoVariance -> "" - | Covariant -> "+" - | Contravariant -> "-" - -let type_injectivity = function - | NoInjectivity -> "" - | Injective -> "!" - -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] - -let view_expr x = - match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil - | Pexp_construct ( {txt= Lident"::";_},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); - pexp_attributes = []} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([e1;e2]); - pexp_attributes = []})); - pexp_attributes = []} - -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b then - `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple (x.txt) - | _ -> `normal - -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false - -let pp = fprintf - -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} - -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } -let under_pipe ctxt = { ctxt with pipe=true } -let under_semi ctxt = { ctxt with semi=true } -let under_ifthenelse ctxt = { ctxt with ifthenelse=true } -(* -let reset_semi ctxt = { ctxt with semi=false } -let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } -let reset_pipe ctxt = { ctxt with pipe=false } -*) - -let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> - ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a list -> unit - = fun ?sep ?first ?last fu f xs -> - let first = match first with Some x -> x |None -> ("": _ format6) - and last = match last with Some x -> x |None -> ("": _ format6) - and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in - let aux f = function - | [] -> () - | [x] -> fu f x - | xs -> - let rec loop f = function - | [x] -> fu f x - | x::xs -> fu f x; pp f sep; loop f xs; - | _ -> assert false in begin - pp f first; loop f xs; pp f last; - end in - aux f xs - -let option : 'a. ?first:space_formatter -> ?last:space_formatter -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - = fun ?first ?last fu f a -> - let first = match first with Some x -> x | None -> ("": _ format6) - and last = match last with Some x -> x | None -> ("": _ format6) in - match a with - | None -> () - | Some x -> pp f first; fu f x; pp f last - -let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> - bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit - = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> - if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") - else fu f x - -let rec longident f = function - | Lident s -> protect_ident f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s - -let longident_loc f x = pp f "%a" longident x.txt - -let constant f = function - | Pconst_char i -> - pp f "%C" i - | Pconst_string (i, _, None) -> - pp f "%S" i - | Pconst_string (i, _, Some delim) -> - pp f "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> - paren (first_is '-' i) (fun f -> pp f "%s") f i - | Pconst_integer (i, Some m) -> - paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m) - | Pconst_float (i, None) -> - paren (first_is '-' i) (fun f -> pp f "%s") f i - | Pconst_float (i, Some m) -> - paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) - -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" - -(* trailing space added *) -let rec_flag f rf = - match rf with - | Nonrecursive -> () - | Recursive -> pp f "rec " -let nonrec_flag f rf = - match rf with - | Nonrecursive -> pp f "nonrec " - | Recursive -> () -let direction_flag f = function - | Upto -> pp f "to@ " - | Downto -> pp f "downto@ " -let private_flag f = function - | Public -> () - | Private -> pp f "private@ " - -let iter_loc f ctxt {txt; loc = _} = f ctxt txt - -let constant_string f s = pp f "%S" s - -let tyvar ppf s = - if String.length s >= 2 && s.[1] = '\'' then - (* without the space, this would be parsed as - a character literal *) - Format.fprintf ppf "' %s" s - else - Format.fprintf ppf "'%s" s - -let tyvar_loc f str = tyvar f str.txt -let string_quot f x = pp f "`%s" x - -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l - -and type_with_label ctxt f (label, c) = - match label with - | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) - | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c - | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - -and core_type ctxt f x = - if x.ptyp_attributes <> [] then begin - pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} - (attributes ctxt) x.ptyp_attributes - end - else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 - | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s - | Ptyp_poly ([], ct) -> - core_type ctxt f ct - | Ptyp_poly (sl, ct) -> - pp f "@[<2>%a%a@]" - (fun f l -> - pp f "%a" - (fun f l -> match l with - | [] -> () - | _ -> - pp f "%a@;.@;" - (list tyvar_loc ~sep:"@;") l) - l) - sl (core_type ctxt) ct - | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - -and core_type1 ctxt f x = - if x.ptyp_attributes <> [] then core_type ctxt f x - else match x.ptyp_desc with - | Ptyp_any -> pp f "_"; - | Ptyp_var s -> tyvar f s; - | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Ptyp_constr (li, l) -> - pp f (* "%a%a@;" *) "%a%a" - (fun f l -> match l with - |[] -> () - |[x]-> pp f "%a@;" (core_type1 ctxt) x - | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li - | Ptyp_variant (l, closed, low) -> - let first_is_inherit = match l with - | {Parsetree.prf_desc = Rinherit _}::_ -> true - | _ -> false in - let type_variant_helper f x = - match x.prf_desc with - | Rtag (l, _, ctl) -> - pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l - (fun f l -> match l with - |[] -> () - | _ -> pp f "@;of@;%a" - (list (core_type ctxt) ~sep:"&") ctl) ctl - (attributes ctxt) x.prf_attributes - | Rinherit ct -> core_type ctxt f ct in - pp f "@[<2>[%a%a]@]" - (fun f l -> - match l, closed with - | [], Closed -> () - | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) - | _ -> - pp f "%s@;%a" - (match (closed,low) with - | (Closed,None) -> if first_is_inherit then " |" else "" - | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) - | (Open,_) -> ">") - (list type_variant_helper ~sep:"@;<1 -2>| ") l) l - (fun f low -> match low with - |Some [] |None -> () - |Some xs -> - pp f ">@ %a" - (list string_quot) xs) low - | Ptyp_object (l, o) -> - let core_field_type f x = match x.pof_desc with - | Otag (l, ct) -> - (* Cf #7200 *) - pp f "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) x.pof_attributes - | Oinherit ct -> - pp f "@[%a@ @]" (core_type ctxt) ct - in - let field_var f = function - | Asttypes.Closed -> () - | Asttypes.Open -> - match l with - | [] -> pp f ".." - | _ -> pp f " ;.." - in - pp f "@[<@ %a%a@ > @]" - (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%a#%a@]" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l - longident_loc li - | Ptyp_package (lid, cstrs) -> - let aux f (s, ct) = - pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in - (match cstrs with - |[] -> pp f "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid - (list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x - -(********************pattern********************) -(* be cautious when use [pattern], [pattern1] is preferred *) -and pattern ctxt f x = - if x.ppat_attributes <> [] then begin - pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} - (attributes ctxt) x.ppat_attributes - end - else match x.ppat_desc with - | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt - | _ -> pattern_or ctxt f x - -and pattern_or ctxt f x = - let rec left_associative x acc = match x with - | {ppat_desc=Ppat_or (p1,p2); ppat_attributes = []} -> - left_associative p1 (p2 :: acc) - | x -> x :: acc - in - match left_associative x [] with - | [] -> assert false - | [x] -> pattern1 ctxt f x - | orpats -> - pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats - -and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f = function - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_})); - ppat_attributes = []} - - -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | p -> pattern1 ctxt f p - in - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p - | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> - simple_pattern ctxt f x - | Ppat_construct (({txt;_} as li), po) -> - (* FIXME The third field always false *) - if txt = Lident "::" then - pp f "%a" pattern_list_helper x - else - (match po with - | Some ([], x) -> - pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | Some (vl, x) -> - pp f "%a@ (type %a)@;%a" longident_loc li - (list ~sep:"@ " string_loc) vl - (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) - | _ -> simple_pattern ctxt f x - -and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), None) -> - pp f "%s" x - | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt - | Ppat_array l -> - pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l - | Ppat_unpack { txt = None } -> - pp f "(module@ _)@ " - | Ppat_unpack { txt = Some s } -> - pp f "(module@ %s)@ " s - | Ppat_type li -> - pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end - | Ppat_tuple l -> - pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) - | Ppat_constant (c) -> pp f "%a" constant c - | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l,None) -> pp f "`%s" l - | Ppat_constraint (p, ct) -> - pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p - | Ppat_exception p -> - pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p - | Ppat_extension e -> extension ctxt f e - | Ppat_open (lid, p) -> - let with_paren = - match p.ppat_desc with - | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), None) -> false - | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid - (paren with_paren @@ pattern1 ctxt) p - | _ -> paren true (pattern ctxt) f x - -and label_exp ctxt f (l,opt,p) = - match l with - | Nolabel -> - (* single case pattern parens needed here *) - pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> - begin match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = rest -> - (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) - | _ -> - (match opt with - | Some o -> - pp f "?%s:(%a=@;%a)@;" - rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) - end - | Labelled l -> match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = l -> - pp f "~%s@;" l - | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p - -and sugar_expr ctxt f e = - if e.pexp_attributes <> [] then false - else match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; - pexp_attributes=[]; _}, args) - when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin - let print_indexop a path_prefix assign left sep right print_index indices - rem_args = - let print_path ppf = function - | None -> () - | Some m -> pp ppf ".%a" longident m in - match assign, rem_args with - | false, [] -> - pp f "@[%a%a%s%a%s@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep print_index) indices right; true - | true, [v] -> - pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep print_index) indices right - (simple_expr ctxt) v; true - | _ -> false in - match id, List.map snd args with - | Lident "!", [e] -> - pp f "@[!%a@]" (simple_expr ctxt) e; true - | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin - let assign = func = "set" in - let print = print_indexop a None assign in - match path, other_args with - | Lident "Array", i :: rest -> - print ".(" "" ")" (expression ctxt) [i] rest - | Lident "String", i :: rest -> - print ".[" "" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "," "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), - {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> - print ".{" "," "}" (simple_expr ctxt) indexes rest - | _ -> false - end - | (Lident s | Ldot(_,s)) , a :: i :: rest - when first_is '.' s -> - (* extract operator: - assignment operators end with [right_bracket ^ "<-"], - access operators end with [right_bracket] directly - *) - let multi_indices = String.contains s ';' in - let i = - match i.pexp_desc with - | Pexp_array l when multi_indices -> l - | _ -> [ i ] in - let assign = last_is '-' s in - let kind = - (* extract the right end bracket *) - let n = String.length s in - if assign then s.[n - 3] else s.[n - 1] in - let left, right = match kind with - | ')' -> '(', ")" - | ']' -> '[', "]" - | '}' -> '{', "}" - | _ -> assert false in - let path_prefix = match id with - | Ldot(m,_) -> Some m - | _ -> None in - let left = String.sub s 0 (1+String.index s left) in - print_indexop a path_prefix assign left ";" right - (if multi_indices then expression ctxt else simple_expr ctxt) - i rest - | _ -> false - end - | _ -> false - -and uncurry params e = - match e.pexp_desc with - | Pexp_fun (l, e0, p, e) -> - uncurry ((l, e0, p) :: params) e - | _ -> List.rev params, e - -and expression ctxt f x = - if x.pexp_attributes <> [] then - pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} - (attributes ctxt) x.pexp_attributes - else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ - | Pexp_newtype _ - when ctxt.pipe || ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> - paren true (expression reset_ctxt) f x - | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ - | Pexp_letexception _ | Pexp_letop _ - when ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - let params, body = uncurry [l, e0, p] e in - pp f "@[<2>fun@;%a->@;%a@]" - (pp_print_list (label_exp ctxt)) params - (expression ctxt) body - | Pexp_newtype (lid, e) -> - pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt - (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l - - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> - (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" - (*no indentation here, a new line*) *) - (* rec_flag rf *) - pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) - (expression ctxt) e - | Pexp_apply (e, l) -> - begin if not (sugar_expr ctxt f x) then - match view_fixity_of_exp e with - | `Infix s -> - begin match l with - | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> - (* FIXME associativity label_x_expression_param *) - pp f "@[<2>%a@;%s@;%a@]" - (label_x_expression_param reset_ctxt) arg1 s - (label_x_expression_param ctxt) arg2 - | _ -> - pp f "@[<2>%a %a@]" - (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | `Prefix s -> - let s = - if List.mem s ["~+";"~-";"~+.";"~-."] && - (match l with - (* See #7200: avoid turning (~- 1) into (- 1) which is - parsed as an int literal *) - |[(_,{pexp_desc=Pexp_constant _})] -> false - | _ -> true) - then String.sub s 1 (String.length s -1) - else s in - begin match l with - | [(Nolabel, x)] -> - pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x - | _ -> - pp f "@[<2>%a %a@]" (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | _ -> - pp f "@[%a@]" begin fun f (e,l) -> - pp f "%a@ %a" (expression2 ctxt) e - (list (label_x_expression_param reset_ctxt)) l - (* reset here only because [function,match,try,sequence] - are lower priority *) - end (e,l) - end - - | Pexp_construct (li, Some eo) - when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) - (match view_expr x with - | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li - (simple_expr ctxt) eo - | _ -> assert false) - | Pexp_setfield (e1, li, e2) -> - pp f "@[<2>%a.%a@ <-@ %a@]" - (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 - | Pexp_ifthenelse (e1, e2, eo) -> - (* @;@[<2>else@ %a@]@] *) - let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in - let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in - pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 - (fun f eo -> match eo with - | Some x -> - pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x - | None -> () (* pp f "()" *)) eo - | Pexp_sequence _ -> - let rec sequence_helper acc = function - | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> - sequence_helper (e1::acc) e2 - | v -> List.rev (v::acc) in - let lst = sequence_helper [] x in - pp f "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" - (Option.value s.txt ~default:"_") - (module_expr reset_ctxt) me (expression ctxt) e - | Pexp_letexception (cd, e) -> - pp f "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[lazy@ %a@]" (simple_expr ctxt) e - (* Pexp_poly: impossible but we should print it anyway, rather than - assert false *) - | Pexp_poly (e, None) -> - pp f "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!poly!@ %a@ : %a)@]" - (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) (module_expr ctxt) o.popen_expr - (expression ctxt) e - | Pexp_variant (l,Some eo) -> - pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo - | Pexp_letop {let_; ands; body} -> - pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" - (binding_op ctxt) let_ - (list ~sep:"@," (binding_op ctxt)) ands - (expression ctxt) body - | Pexp_extension e -> extension ctxt f e - | Pexp_unreachable -> pp f "." - | _ -> expression1 ctxt f x - -and expression1 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs - | _ -> expression2 ctxt f x -(* used in [Pexp_apply] *) - -and expression2 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_field (e, li) -> - pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt - - | _ -> simple_expr ctxt f x - -and simple_expr ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_construct _ when is_simple_construct (view_expr x) -> - (match view_expr x with - | `nil -> pp f "[]" - | `tuple -> pp f "()" - | `list xs -> - pp f "@[[%a]@]" - (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x - | _ -> assert false) - | Pexp_ident li -> - longident_loc f li - (* (match view_fixity_of_exp x with *) - (* |`Normal -> longident_loc f li *) - (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) - | Pexp_constant c -> constant f c; - | Pexp_pack me -> - pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_tuple l -> - pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l - | Pexp_constraint (e, ct) -> - pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_coerce (e, cto1, ct) -> - pp f "(%a%a :> %a)" (expression ctxt) e - (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) - (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l - | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l - | Pexp_array (l) -> - pp f "@[<0>@[<2>[|%a|]@]@]" - (list (simple_expr (under_semi ctxt)) ~sep:";") l - | Pexp_while (e1, e2) -> - let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in - pp f fmt (expression ctxt) e1 (expression ctxt) e2 - | Pexp_for (s, e1, e2, df, e3) -> - let fmt:(_,_,_)format = - "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in - let expression = expression ctxt in - pp f fmt (pattern ctxt) s expression e1 direction_flag - df expression e2 expression e3 - | Pexp_hole -> - pp f "_" - | _ -> paren true (expression ctxt) f x - -and attributes ctxt f l = - List.iter (attribute ctxt f) l - -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l - -and attribute ctxt f a = - pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and item_attribute ctxt f a = - pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and floating_attribute ctxt f a = - pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload - -and value_description ctxt f x = - (* note: value_description has an attribute field, - but they're already printed by the callers this method *) - pp f "@[%a%a@]" (core_type ctxt) x.pval_type - (fun f x -> - if x.pval_prim <> [] - then pp f "@ =@ %a" (list constant_string) x.pval_prim - ) x - -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e - -and exception_declaration ctxt f x = - pp f "@[exception@ %a@]%a" - (extension_constructor ctxt) x.ptyexn_constructor - (item_attributes ctxt) x.ptyexn_attributes - -and class_type_field ctxt f x = - match x.pctf_desc with - | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" - mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]%a" - private_flag pf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]%a" - (core_type ctxt) ct1 (core_type ctxt) ct2 - (item_attributes ctxt) x.pctf_attributes - | Pctf_attribute a -> floating_attribute ctxt f a - | Pctf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pctf_attributes - -and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = - pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" - (fun f -> function - {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () - | ct -> pp f " (%a)" (core_type ctxt) ct) ct - (list (class_type_field ctxt) ~sep:"@;") l - -(* call [class_signature] called by [class_signature] *) -and class_type ctxt f x = - match x.pcty_desc with - | Pcty_signature cs -> - class_signature ctxt f cs; - attributes ctxt f x.pcty_attributes - | Pcty_constr (li, l) -> - pp f "%a%a%a" - (fun f l -> match l with - | [] -> () - | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li - (attributes ctxt) x.pcty_attributes - | Pcty_arrow (l, co, cl) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) - (class_type ctxt) cl - | Pcty_extension e -> - extension ctxt f e; - attributes ctxt f x.pcty_attributes - | Pcty_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) longident_loc o.popen_expr - (class_type ctxt) e - -(* [class type a = object end] *) -and class_type_declaration_list ctxt f l = - let class_type_declaration kwd f x = - let { pci_params=ls; pci_name={ txt; _ }; _ } = x in - pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in - match l with - | [] -> () - | [x] -> class_type_declaration "class type" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_type_declaration "class type") x - (list ~sep:"@," (class_type_declaration "and")) xs - -and class_field ctxt f x = - match x.pcf_desc with - | Pcf_inherit (ovf, ce, so) -> - pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) - (class_expr ctxt) ce - (fun f so -> match so with - | None -> (); - | Some (s) -> pp f "@ as %s" s.txt ) so - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) - mutable_flag mf s.txt - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]%a" - private_flag pf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]%a" - mutable_flag mf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let bind e = - binding ctxt f - {pvb_pat= - {ppat_desc=Ppat_var s; - ppat_loc=Location.none; - ppat_loc_stack=[]; - ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]; - pvb_loc=Location.none; - } - in - pp f "@[<2>method%s %a%a@]%a" - (override ovf) - private_flag pf - (fun f -> function - | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> - pp f "%s :@;%a=@;%a" - s.txt (core_type ctxt) ct (expression ctxt) e - | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> - bind e - | _ -> bind e) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]%a" - (core_type ctxt) ct1 - (core_type ctxt) ct2 - (item_attributes ctxt) x.pcf_attributes - | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]%a" - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_attribute a -> floating_attribute ctxt f a - | Pcf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pcf_attributes - -and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = - pp f "@[@[object%a@;%a@]@;end@]" - (fun f p -> match p.ppat_desc with - | Ppat_any -> () - | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p - | _ -> pp f " (%a)" (pattern ctxt) p) p - (list (class_field ctxt)) l - -and class_expr ctxt f x = - if x.pcl_attributes <> [] then begin - pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} - (attributes ctxt) x.pcl_attributes - end else - match x.pcl_desc with - | Pcl_structure (cs) -> class_structure ctxt f cs - | Pcl_fun (l, eo, p, e) -> - pp f "fun@ %a@ ->@ %a" - (label_exp ctxt) (l,eo,p) - (class_expr ctxt) e - | Pcl_let (rf, l, ce) -> - pp f "%a@ in@ %a" - (bindings ctxt) (rf,l) - (class_expr ctxt) ce - | Pcl_apply (ce, l) -> - pp f "((%a)@ %a)" (* Cf: #7200 *) - (class_expr ctxt) ce - (list (label_x_expression_param ctxt)) l - | Pcl_constr (li, l) -> - pp f "%a%a" - (fun f l-> if l <>[] then - pp f "[%a]@ " - (list (core_type ctxt) ~sep:",") l) l - longident_loc li - | Pcl_constraint (ce, ct) -> - pp f "(%a@ :@ %a)" - (class_expr ctxt) ce - (class_type ctxt) ct - | Pcl_extension e -> extension ctxt f e - | Pcl_open (o, e) -> - pp f "@[<2>let open%s %a in@;%a@]" - (override o.popen_override) longident_loc o.popen_expr - (class_expr ctxt) e - -and module_type ctxt f x = - if x.pmty_attributes <> [] then begin - pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} - (attributes ctxt) x.pmty_attributes - end else - match x.pmty_desc with - | Pmty_functor (Unit, mt2) -> - pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (Named (s, mt1), mt2) -> - begin match s.txt with - | None -> - pp f "@[%a@ ->@ %a@]" - (module_type1 ctxt) mt1 (module_type ctxt) mt2 - | Some name -> - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name - (module_type ctxt) mt1 (module_type ctxt) mt2 - end - | Pmty_with (mt, []) -> module_type ctxt f mt - | Pmty_with (mt, l) -> - pp f "@[%a@ with@ %a@]" - (module_type1 ctxt) mt - (list (with_constraint ctxt) ~sep:"@ and@ ") l - | _ -> module_type1 ctxt f x - -and with_constraint ctxt f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_modtype (li, mty) -> - pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 - | Pwith_modtypesubst (li, mty) -> - pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty; - - -and module_type1 ctxt f x = - if x.pmty_attributes <> [] then module_type ctxt f x - else match x.pmty_desc with - | Pmty_ident li -> - pp f "%a" longident_loc li; - | Pmty_alias li -> - pp f "(module %a)" longident_loc li; - | Pmty_signature (s) -> - pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_typeof me -> - pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me - | Pmty_extension e -> extension ctxt f e - | _ -> paren true (module_type ctxt) f x - -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x - -and signature_item ctxt f x : unit = - match x.psig_desc with - | Psig_type (rf, l) -> - type_def_list ctxt f (rf, true, l) - | Psig_typesubst l -> - (* Psig_typesubst is never recursive, but we specify [Recursive] here to - avoid printing a [nonrec] flag, which would be rejected by the parser. - *) - type_def_list ctxt f (Recursive, false, l) - | Psig_value vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "@[<2>%s@ %a@ :@ %a@]%a" intro - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Psig_typext te -> - type_extension ctxt f te - | Psig_exception ed -> - exception_declaration ctxt f ed - | Psig_class l -> - let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in begin - match l with - | [] -> () - | [x] -> class_description "class" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_description "class") x - (list ~sep:"@," (class_description "and")) xs - end - | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; - pmty_attributes=[]; _};_} as pmd) -> - pp f "@[module@ %s@ =@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - longident_loc alias - (item_attributes ctxt) pmd.pmd_attributes - | Psig_module pmd -> - pp f "@[module@ %s@ :@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - | Psig_modsubst pms -> - pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt - longident_loc pms.pms_manifest - (item_attributes ctxt) pms.pms_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[include@ %a@]%a" - (module_type ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - let md = match md with - | None -> assert false (* ast invariant *) - | Some mt -> mt in - pp f "@[module@ type@ %s@ :=@ %a@]%a" - s.txt (module_type ctxt) md - (item_attributes ctxt) attrs - | Psig_class_type (l) -> class_type_declaration_list ctxt f l - | Psig_recmodule decls -> - let rec string_x_module_type_list f ?(first=true) l = - match l with - | [] -> () ; - | pmd :: tl -> - if not first then - pp f "@ @[and@ %s:@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - (module_type1 ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - else - pp f "@[module@ rec@ %s:@ %a@]%a" - (Option.value pmd.pmd_name.txt ~default:"_") - (module_type1 ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes; - string_x_module_type_list f ~first:false tl - in - string_x_module_type_list f decls - | Psig_attribute a -> floating_attribute ctxt f a - | Psig_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and module_expr ctxt f x = - if x.pmod_attributes <> [] then - pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} - (attributes ctxt) x.pmod_attributes - else match x.pmod_desc with - | Pmod_structure (s) -> - pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%a@ :@ %a)@]" - (module_expr ctxt) me - (module_type ctxt) mt - | Pmod_ident (li) -> - pp f "%a" longident_loc li; - | Pmod_functor (Unit, me) -> - pp f "functor ()@;->@;%a" (module_expr ctxt) me - | Pmod_functor (Named (s, mt), me) -> - pp f "functor@ (%s@ :@ %a)@;->@;%a" - (Option.value s.txt ~default:"_") - (module_type ctxt) mt (module_expr ctxt) me - | Pmod_apply (me1, me2) -> - pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 - (* Cf: #7200 *) - | Pmod_unpack e -> - pp f "(val@ %a)" (expression ctxt) e - | Pmod_extension e -> extension ctxt f e - | Pmod_hole -> - pp f "_" - -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x - -and payload ctxt f = function - | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> - pp f "@[<2>%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | PStr x -> structure ctxt f x - | PTyp x -> pp f ":@ "; core_type ctxt f x - | PSig x -> pp f ":@ "; signature ctxt f x - | PPat (x, None) -> pp f "?"; pattern ctxt f x - | PPat (x, Some e) -> - pp f "?@ "; pattern ctxt f x; - pp f " when "; expression ctxt f e - -(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = - (* .pvb_attributes have already been printed by the caller, #bindings *) - let rec pp_print_pexp_function f x = - if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x - else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label=Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e - | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e - | _ -> pp f "=@;%a" (expression ctxt) x - in - let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in - let is_desugared_gadt p e = - let gadt_pattern = - match p with - | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, - {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); - ppat_attributes=[]}-> - Some (pat, args_tyvars, rt) - | _ -> None in - let rec gadt_exp tyvars e = - match e with - | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> - gadt_exp (tyvar :: tyvars) e - | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> - Some (List.rev tyvars, e, ct) - | _ -> None in - let gadt_exp = gadt_exp [] e in - match gadt_pattern, gadt_exp with - | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) - when tyvars_str pt_tyvars = tyvars_str e_tyvars -> - let ety = Typ.varify_constructors e_tyvars e_ct in - if ety = pt_ct then - Some (p, pt_tyvars, e_ct, e) else None - | _ -> None in - if x.pexp_attributes <> [] - then - match p with - | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _; _} as pat, - ({ptyp_desc=Ptyp_poly _; _} as typ)); - ppat_attributes=[]; _} -> - pp f "%a@;: %a@;=@;%a" - (simple_pattern ctxt) pat (core_type ctxt) typ (expression ctxt) x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - else - match is_desugared_gadt p x with - | Some (p, [], ct, e) -> - pp f "%a@;: %a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e - | Some (p, tyvars, ct, e) -> begin - pp f "%a@;: type@;%a.@;%a@;=@;%a" - (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") - (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e - end - | None -> begin - match p with - | {ppat_desc=Ppat_constraint(p ,ty); - ppat_attributes=[]} -> (* special case for the first*) - begin match ty with - | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> - pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - | _ -> - pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - end - | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - end - -(* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = - pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf - (binding ctxt) x (item_attributes ctxt) x.pvb_attributes - in - match l with - | [] -> () - | [x] -> binding "let" rf f x - | x::xs -> - pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs - -and binding_op ctxt f x = - match x.pbop_pat, x.pbop_exp with - | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _}, - {pexp_desc = Pexp_ident { txt=Lident evar; _}; pexp_attributes = []; _} - when pvar = evar -> - pp f "@[<2>%s %s@]" x.pbop_op.txt evar - | pat, exp -> - pp f "@[<2>%s %a@;=@;%a@]" - x.pbop_op.txt (pattern ctxt) pat (expression ctxt) exp - -and structure_item ctxt f x = - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - pp f "@[;;%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) - | Pstr_value (rf, l) -> - (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) - | Pstr_typext te -> type_extension ctxt f te - | Pstr_exception ed -> exception_declaration ctxt f ed - | Pstr_module x -> - let rec module_helper = function - | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} -> - begin match arg_opt with - | Unit -> pp f "()" - | Named (s, mt) -> - pp f "(%s:%a)" (Option.value s.txt ~default:"_") - (module_type ctxt) mt - end; - module_helper me' - | me -> me - in - pp f "@[module %s%a@]%a" - (Option.value x.pmb_name.txt ~default:"_") - (fun f me -> - let me = module_helper me in - match me with - | {pmod_desc= - Pmod_constraint - (me', - ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)); - pmod_attributes = []} -> - pp f " :@;%a@;=@;%a@;" - (module_type ctxt) mt (module_expr ctxt) me' - | _ -> pp f " =@ %a" (module_expr ctxt) me - ) x.pmb_expr - (item_attributes ctxt) x.pmb_attributes - | Pstr_open od -> - pp f "@[<2>open%s@;%a@]%a" - (override od.popen_override) - (module_expr ctxt) od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Pstr_class l -> - let extract_class_args cl = - let rec loop acc = function - | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} -> - loop ((l,eo,p) :: acc) cl' - | cl -> List.rev acc, cl - in - let args, cl = loop [] cl in - let constr, cl = - match cl with - | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} -> - Some ct, cl' - | _ -> None, cl - in - args, constr, cl - in - let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in - let class_declaration kwd f - ({pci_params=ls; pci_name={txt;_}; _} as x) = - let args, constr, cl = extract_class_args x.pci_expr in - pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (list (label_exp ctxt)) args - (option class_constraint) constr - (class_expr ctxt) cl - (item_attributes ctxt) x.pci_attributes - in begin - match l with - | [] -> () - | [x] -> class_declaration "class" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_declaration "class") x - (list ~sep:"@," (class_declaration "and")) xs - end - | Pstr_class_type l -> class_type_declaration_list ctxt f l - | Pstr_primitive vd -> - pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Pstr_include incl -> - pp f "@[include@ %a@]%a" - (module_expr ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Pstr_recmodule decls -> (* 3.07 *) - let aux f = function - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> - pp f "@[@ and@ %s:%a@ =@ %a@]%a" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - | pmb -> - pp f "@[@ and@ %s@ =@ %a@]%a" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_expr ctxt) pmb.pmb_expr - (item_attributes ctxt) pmb.pmb_attributes - in - begin match decls with - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> - pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | pmb :: l2 -> - pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" - (Option.value pmb.pmb_name.txt ~default:"_") - (module_expr ctxt) pmb.pmb_expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | _ -> assert false - end - | Pstr_attribute a -> floating_attribute ctxt f a - | Pstr_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and type_param ctxt f (ct, (a,b)) = - pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct - -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l - -and type_def_list ctxt f (rf, exported, l) = - let type_decl kwd rf f x = - let eq = - if (x.ptype_kind = Ptype_abstract) - && (x.ptype_manifest = None) then "" - else if exported then " =" - else " :=" - in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd - nonrec_flag rf - (type_params ctxt) x.ptype_params - x.ptype_name.txt eq - (type_declaration ctxt) x - (item_attributes ctxt) x.ptype_attributes - in - match l with - | [] -> assert false - | [x] -> type_decl "type" rf f x - | x :: xs -> pp f "@[%a@,%a@]" - (type_decl "type" rf) x - (list ~sep:"@," (type_decl "and" Recursive)) xs - -and record_declaration ctxt f lbls = - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" - mutable_flag pld.pld_mutable - pld.pld_name.txt - (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes - in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls - -and type_declaration ctxt f x = - (* type_declaration has an attribute field, - but it's been printed by the caller of this method *) - let priv f = - match x.ptype_private with - | Public -> () - | Private -> pp f "@;private" - in - let manifest f = - match x.ptype_manifest with - | None -> () - | Some y -> - if x.ptype_kind = Ptype_abstract then - pp f "%t@;%a" priv (core_type ctxt) y - else - pp f "@;%a" (core_type ctxt) y - in - let constructor_declaration f pcd = - pp f "|@;"; - constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_vars, - pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) - in - let repr f = - let intro f = - if x.ptype_manifest = None then () - else pp f "@;=" - in - match x.ptype_kind with - | Ptype_variant xs -> - let variants fmt xs = - if xs = [] then pp fmt " |" else - pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs - in pp f "%t%t%a" intro priv variants xs - | Ptype_abstract -> () - | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l - | Ptype_open -> pp f "%t%t@;.." intro priv - in - let constraints f = - List.iter - (fun (ct1,ct2,_) -> - pp f "@[@ constraint@ %a@ =@ %a@]" - (core_type ctxt) ct1 (core_type ctxt) ct2) - x.ptype_cstrs - in - pp f "%t%t%t" manifest repr constraints - -and type_extension ctxt f x = - let extension_constructor f x = - pp f "@\n|@;%a" (extension_constructor ctxt) x - in - pp f "@[<2>type %a%a += %a@ %a@]%a" - (fun f -> function - | [] -> () - | l -> - pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) - x.ptyext_params - longident_loc x.ptyext_path - private_flag x.ptyext_private (* Cf: #7200 *) - (list ~sep:"" extension_constructor) - x.ptyext_constructors - (item_attributes ctxt) x.ptyext_attributes - -and constructor_declaration ctxt f (name, vars, args, res, attrs) = - let name = - match name with - | "::" -> "(::)" - | s -> s in - let pp_vars f vs = - match vs with - | [] -> () - | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs in - match res with - | None -> - pp f "%s%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> - pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l - ) args - (attributes ctxt) attrs - | Some r -> - pp f "%s:@;%a%a@;%a" name - pp_vars vars - (fun f -> function - | Pcstr_tuple [] -> core_type1 ctxt f r - | Pcstr_tuple l -> pp f "%a@;->@;%a" - (list (core_type1 ctxt) ~sep:"@;*@;") l - (core_type1 ctxt) r - | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r - ) - args - (attributes ctxt) attrs - -and extension_constructor ctxt f x = - (* Cf: #7200 *) - match x.pext_kind with - | Pext_decl(v, l, r) -> - constructor_declaration ctxt f - (x.pext_name.txt, v, l, r, x.pext_attributes) - | Pext_rebind li -> - pp f "%s@;=@;%a%a" x.pext_name.txt - longident_loc li - (attributes ctxt) x.pext_attributes - -and case_list ctxt f l : unit = - let aux f {pc_lhs; pc_guard; pc_rhs} = - pp f "@;| @[<2>%a%a@;->@;%a@]" - (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") - pc_guard (expression (under_pipe ctxt)) pc_rhs - in - list aux f l ~sep:"" - -and label_x_expression_param ctxt f (l,e) = - let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l - | _ -> None - in match l with - | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> - if Some str = simple_name then - pp f "?%s" str - else - pp f "?%s:%a" str (simple_expr ctxt) e - | Labelled lbl -> - if Some lbl = simple_name then - pp f "~%s" lbl - else - pp f "~%s:%a" lbl (simple_expr ctxt) e - -and directive_argument f x = - match x.pdira_desc with - | Pdir_string (s) -> pp f "@ %S" s - | Pdir_int (n, None) -> pp f "@ %s" n - | Pdir_int (n, Some m) -> pp f "@ %s%c" n m - | Pdir_ident (li) -> pp f "@ %a" longident li - | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) - -let toplevel_phrase f x = - match x with - | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s - (* pp_open_hvbox f 0; *) - (* pp_print_list structure_item f s ; *) - (* pp_close_box f (); *) - | Ptop_dir {pdir_name; pdir_arg = None; _} -> - pp f "@[#%s@]" pdir_name.txt - | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> - pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg - -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x - -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () - -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () - -let top_phrase f x = - pp_print_newline f (); - toplevel_phrase f x; - pp f ";;"; - pp_print_newline f () - -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt -let module_expr = module_expr reset_ctxt -let module_type = module_type reset_ctxt -let class_field = class_field reset_ctxt -let class_type_field = class_type_field reset_ctxt -let class_expr = class_expr reset_ctxt -let class_type = class_type reset_ctxt -let structure_item = structure_item reset_ctxt -let signature_item = signature_item reset_ctxt -let binding = binding reset_ctxt -let payload = payload reset_ctxt -let case_list = case_list reset_ctxt - -let prepare_error err = - let source = Location.Parser in - let open Syntaxerr in - match err with - | Unclosed(opening_loc, opening, closing_loc, closing) -> - Location.errorf - ~source - ~loc:closing_loc - ~sub:[ - Location.msg ~loc:opening_loc - "This '%s' might be unmatched" opening - ] - "Syntax error: '%s' expected" closing - - | Expecting (loc, nonterm) -> - Location.errorf ~source ~loc "Syntax error: %s expected." nonterm - | Not_expecting (loc, nonterm) -> - Location.errorf ~source ~loc "Syntax error: %s not expected." nonterm - | Applicative_path loc -> - Location.errorf ~source ~loc - "Syntax error: applicative paths of the form F(X).t \ - are not supported when the option -no-app-func is set." - | Variable_in_scope (loc, var) -> - Location.errorf ~source ~loc - "In this scoped type, variable %a \ - is reserved for the local type %s." - tyvar var var - | Other loc -> - Location.errorf ~source ~loc "Syntax error" - | Ill_formed_ast (loc, s) -> - Location.errorf ~loc - "broken invariant in parsetree: %s" s - | Invalid_package_type (loc, s) -> - Location.errorf ~source ~loc "invalid package type: %s" s - -let () = - Location.register_error_of_exn - (function - | Syntaxerr.Error err -> Some (prepare_error err) - | _ -> None - ) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/pprintast.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/pprintast.mli deleted file mode 100644 index 47dbf6d5f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/pprintast.mli +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Hongbo Zhang (University of Pennsylvania) *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - - -(** Pretty-printers for {!Parsetree} - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -type space_formatter = (unit, Format.formatter, unit) format - -val longident : Format.formatter -> Longident.t -> unit -val expression : Format.formatter -> Parsetree.expression -> unit -val string_of_expression : Parsetree.expression -> string - -val pattern: Format.formatter -> Parsetree.pattern -> unit - -val core_type: Format.formatter -> Parsetree.core_type -> unit - -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string - -val module_expr: Format.formatter -> Parsetree.module_expr -> unit - -val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit -val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit - -val class_field: Format.formatter -> Parsetree.class_field -> unit -val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit -val class_expr: Format.formatter -> Parsetree.class_expr -> unit -val class_type: Format.formatter -> Parsetree.class_type -> unit -val module_type: Format.formatter -> Parsetree.module_type -> unit -val structure_item: Format.formatter -> Parsetree.structure_item -> unit -val signature_item: Format.formatter -> Parsetree.signature_item -> unit -val binding: Format.formatter -> Parsetree.value_binding -> unit -val payload: Format.formatter -> Parsetree.payload -> unit - -val tyvar: Format.formatter -> string -> unit - (** Print a type variable name, taking care of the special treatment - required for the single quote character in second position. *) - -(* merlin *) -val case_list : Format.formatter -> Parsetree.case list -> unit diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/printast.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/printast.ml deleted file mode 100644 index 490cfae93..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/printast.ml +++ /dev/null @@ -1,986 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Parsetree;; - -let fmt_position with_name f l = - let fname = if with_name then l.pos_fname else "" in - if l.pos_lnum = -1 - then fprintf f "%s[%d]" fname l.pos_cnum - else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol - (l.pos_cnum - l.pos_bol) -;; - -let fmt_location f loc = - if not !Clflags.locations then () - else begin - let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in - fprintf f "(%a..%a)" (fmt_position true) loc.loc_start - (fmt_position p_2nd_name) loc.loc_end; - if loc.loc_ghost then fprintf f " ghost"; - end -;; - -let rec fmt_longident_aux f x = - match x with - | Longident.Lident (s) -> fprintf f "%s" s; - | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; - | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; -;; - -let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;; - -let fmt_longident_loc f (x : Longident.t loc) = - fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc; -;; - -let fmt_string_loc f (x : string loc) = - fprintf f "\"%s\" %a" x.txt fmt_location x.loc; -;; - -let fmt_str_opt_loc f (x : string option loc) = - fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc; -;; - -let fmt_char_option f = function - | None -> fprintf f "None" - | Some c -> fprintf f "Some %c" c - -let fmt_constant f x = - match x with - | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); - | Pconst_string (s, strloc, None) -> - fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc ; - | Pconst_string (s, strloc, Some delim) -> - fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim; - | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; -;; - -let fmt_mutable_flag f x = - match x with - | Immutable -> fprintf f "Immutable"; - | Mutable -> fprintf f "Mutable"; -;; - -let fmt_virtual_flag f x = - match x with - | Virtual -> fprintf f "Virtual"; - | Concrete -> fprintf f "Concrete"; -;; - -let fmt_override_flag f x = - match x with - | Override -> fprintf f "Override"; - | Fresh -> fprintf f "Fresh"; -;; - -let fmt_closed_flag f x = - match x with - | Closed -> fprintf f "Closed" - | Open -> fprintf f "Open" - -let fmt_rec_flag f x = - match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; - -let fmt_direction_flag f x = - match x with - | Upto -> fprintf f "Up"; - | Downto -> fprintf f "Down"; -;; - -let fmt_private_flag f x = - match x with - | Public -> fprintf f "Public"; - | Private -> fprintf f "Private"; -;; - -let line i f s (*...*) = - fprintf f "%s" (String.make ((2*i) mod 72) ' '); - fprintf f s (*...*) -;; - -let list i f ppf l = - match l with - | [] -> line i ppf "[]\n"; - | _ :: _ -> - line i ppf "[\n"; - List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; - -let option i f ppf x = - match x with - | None -> line i ppf "None\n"; - | Some x -> - line i ppf "Some\n"; - f (i+1) ppf x; -;; - -let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;; -let string i ppf s = line i ppf "\"%s\"\n" s;; -let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; -let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;; -let arg_label i ppf = function - | Nolabel -> line i ppf "Nolabel\n" - | Optional s -> line i ppf "Optional \"%s\"\n" s - | Labelled s -> line i ppf "Labelled \"%s\"\n" s -;; - -let typevars ppf vs = - List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs - -let rec core_type i ppf x = - line i ppf "core_type %a\n" fmt_location x.ptyp_loc; - attributes i ppf x.ptyp_attributes; - let i = i+1 in - match x.ptyp_desc with - | Ptyp_any -> line i ppf "Ptyp_any\n"; - | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; - | Ptyp_arrow (l, ct1, ct2) -> - line i ppf "Ptyp_arrow\n"; - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2; - | Ptyp_tuple l -> - line i ppf "Ptyp_tuple\n"; - list i core_type ppf l; - | Ptyp_constr (li, l) -> - line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Ptyp_variant (l, closed, low) -> - line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; - list i label_x_bool_x_core_type_list ppf l; - option i (fun i -> list i string) ppf low - | Ptyp_object (l, c) -> - line i ppf "Ptyp_object %a\n" fmt_closed_flag c; - let i = i + 1 in - List.iter (fun field -> - match field.pof_desc with - | Otag (l, t) -> - line i ppf "method %s\n" l.txt; - attributes i ppf field.pof_attributes; - core_type (i + 1) ppf t - | Oinherit ct -> - line i ppf "Oinherit\n"; - core_type (i + 1) ppf ct - ) l - | Ptyp_class (li, l) -> - line i ppf "Ptyp_class %a\n" fmt_longident_loc li; - list i core_type ppf l - | Ptyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%s\"\n" s; - core_type i ppf ct; - | Ptyp_poly (sl, ct) -> - line i ppf "Ptyp_poly%a\n" typevars sl; - core_type i ppf ct; - | Ptyp_package (s, l) -> - line i ppf "Ptyp_package %a\n" fmt_longident_loc s; - list i package_with ppf l; - | Ptyp_extension (s, arg) -> - line i ppf "Ptyp_extension \"%s\"\n" s.txt; - payload i ppf arg - -and package_with i ppf (s, t) = - line i ppf "with type %a\n" fmt_longident_loc s; - core_type i ppf t - -and pattern i ppf x = - line i ppf "pattern %a\n" fmt_location x.ppat_loc; - attributes i ppf x.ppat_attributes; - let i = i+1 in - match x.ppat_desc with - | Ppat_any -> line i ppf "Ppat_any\n"; - | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; - | Ppat_alias (p, s) -> - line i ppf "Ppat_alias %a\n" fmt_string_loc s; - pattern i ppf p; - | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; - | Ppat_interval (c1, c2) -> - line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; - | Ppat_tuple (l) -> - line i ppf "Ppat_tuple\n"; - list i pattern ppf l; - | Ppat_construct (li, po) -> - line i ppf "Ppat_construct %a\n" fmt_longident_loc li; - option i - (fun i ppf (vl, p) -> - list i string_loc ppf vl; - pattern i ppf p) - ppf po - | Ppat_variant (l, po) -> - line i ppf "Ppat_variant \"%s\"\n" l; - option i pattern ppf po; - | Ppat_record (l, c) -> - line i ppf "Ppat_record %a\n" fmt_closed_flag c; - list i longident_x_pattern ppf l; - | Ppat_array (l) -> - line i ppf "Ppat_array\n"; - list i pattern ppf l; - | Ppat_or (p1, p2) -> - line i ppf "Ppat_or\n"; - pattern i ppf p1; - pattern i ppf p2; - | Ppat_lazy p -> - line i ppf "Ppat_lazy\n"; - pattern i ppf p; - | Ppat_constraint (p, ct) -> - line i ppf "Ppat_constraint\n"; - pattern i ppf p; - core_type i ppf ct; - | Ppat_type (li) -> - line i ppf "Ppat_type\n"; - longident_loc i ppf li - | Ppat_unpack s -> - line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s; - | Ppat_exception p -> - line i ppf "Ppat_exception\n"; - pattern i ppf p - | Ppat_open (m,p) -> - line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; - pattern i ppf p - | Ppat_extension (s, arg) -> - line i ppf "Ppat_extension \"%s\"\n" s.txt; - payload i ppf arg - -and expression i ppf x = - line i ppf "expression %a\n" fmt_location x.pexp_loc; - attributes i ppf x.pexp_attributes; - let i = i+1 in - match x.pexp_desc with - | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; - | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; - | Pexp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - expression i ppf e; - | Pexp_function l -> - line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; - | Pexp_apply (e, l) -> - line i ppf "Pexp_apply\n"; - expression i ppf e; - list i label_x_expression ppf l; - | Pexp_match (e, l) -> - line i ppf "Pexp_match\n"; - expression i ppf e; - list i case ppf l; - | Pexp_try (e, l) -> - line i ppf "Pexp_try\n"; - expression i ppf e; - list i case ppf l; - | Pexp_tuple (l) -> - line i ppf "Pexp_tuple\n"; - list i expression ppf l; - | Pexp_construct (li, eo) -> - line i ppf "Pexp_construct %a\n" fmt_longident_loc li; - option i expression ppf eo; - | Pexp_variant (l, eo) -> - line i ppf "Pexp_variant \"%s\"\n" l; - option i expression ppf eo; - | Pexp_record (l, eo) -> - line i ppf "Pexp_record\n"; - list i longident_x_expression ppf l; - option i expression ppf eo; - | Pexp_field (e, li) -> - line i ppf "Pexp_field\n"; - expression i ppf e; - longident_loc i ppf li; - | Pexp_setfield (e1, li, e2) -> - line i ppf "Pexp_setfield\n"; - expression i ppf e1; - longident_loc i ppf li; - expression i ppf e2; - | Pexp_array (l) -> - line i ppf "Pexp_array\n"; - list i expression ppf l; - | Pexp_ifthenelse (e1, e2, eo) -> - line i ppf "Pexp_ifthenelse\n"; - expression i ppf e1; - expression i ppf e2; - option i expression ppf eo; - | Pexp_sequence (e1, e2) -> - line i ppf "Pexp_sequence\n"; - expression i ppf e1; - expression i ppf e2; - | Pexp_while (e1, e2) -> - line i ppf "Pexp_while\n"; - expression i ppf e1; - expression i ppf e2; - | Pexp_for (p, e1, e2, df, e3) -> - line i ppf "Pexp_for %a\n" fmt_direction_flag df; - pattern i ppf p; - expression i ppf e1; - expression i ppf e2; - expression i ppf e3; - | Pexp_constraint (e, ct) -> - line i ppf "Pexp_constraint\n"; - expression i ppf e; - core_type i ppf ct; - | Pexp_coerce (e, cto1, cto2) -> - line i ppf "Pexp_coerce\n"; - expression i ppf e; - option i core_type ppf cto1; - core_type i ppf cto2; - | Pexp_send (e, s) -> - line i ppf "Pexp_send \"%s\"\n" s.txt; - expression i ppf e; - | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; - | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; - expression i ppf e; - | Pexp_override (l) -> - line i ppf "Pexp_override\n"; - list i string_x_expression ppf l; - | Pexp_letmodule (s, me, e) -> - line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s; - module_expr i ppf me; - expression i ppf e; - | Pexp_letexception (cd, e) -> - line i ppf "Pexp_letexception\n"; - extension_constructor i ppf cd; - expression i ppf e; - | Pexp_assert (e) -> - line i ppf "Pexp_assert\n"; - expression i ppf e; - | Pexp_lazy (e) -> - line i ppf "Pexp_lazy\n"; - expression i ppf e; - | Pexp_poly (e, cto) -> - line i ppf "Pexp_poly\n"; - expression i ppf e; - option i core_type ppf cto; - | Pexp_object s -> - line i ppf "Pexp_object\n"; - class_structure i ppf s - | Pexp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s.txt; - expression i ppf e - | Pexp_pack me -> - line i ppf "Pexp_pack\n"; - module_expr i ppf me - | Pexp_open (o, e) -> - line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override; - module_expr i ppf o.popen_expr; - expression i ppf e - | Pexp_letop {let_; ands; body} -> - line i ppf "Pexp_letop\n"; - binding_op i ppf let_; - list i binding_op ppf ands; - expression i ppf body - | Pexp_extension (s, arg) -> - line i ppf "Pexp_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pexp_unreachable -> - line i ppf "Pexp_unreachable" - | Pexp_hole -> - line i ppf "Pexp_hole" - -and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc - x.pval_name fmt_location x.pval_loc; - attributes i ppf x.pval_attributes; - core_type (i+1) ppf x.pval_type; - list (i+1) string ppf x.pval_prim - -and type_parameter i ppf (x, _variance) = core_type i ppf x - -and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name - fmt_location x.ptype_loc; - attributes i ppf x.ptype_attributes; - let i = i+1 in - line i ppf "ptype_params =\n"; - list (i+1) type_parameter ppf x.ptype_params; - line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; - line i ppf "ptype_kind =\n"; - type_kind (i+1) ppf x.ptype_kind; - line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; - line i ppf "ptype_manifest =\n"; - option (i+1) core_type ppf x.ptype_manifest - -and attribute i ppf k a = - line i ppf "%s \"%s\"\n" k a.attr_name.txt; - payload i ppf a.attr_payload; - -and attributes i ppf l = - let i = i + 1 in - List.iter (fun a -> - line i ppf "attribute \"%s\"\n" a.attr_name.txt; - payload (i + 1) ppf a.attr_payload; - ) l; - -and payload i ppf = function - | PStr x -> structure i ppf x - | PSig x -> signature i ppf x - | PTyp x -> core_type i ppf x - | PPat (x, None) -> pattern i ppf x - | PPat (x, Some g) -> - pattern i ppf x; - line i ppf "\n"; - expression (i + 1) ppf g - - -and type_kind i ppf x = - match x with - | Ptype_abstract -> - line i ppf "Ptype_abstract\n" - | Ptype_variant l -> - line i ppf "Ptype_variant\n"; - list (i+1) constructor_decl ppf l; - | Ptype_record l -> - line i ppf "Ptype_record\n"; - list (i+1) label_decl ppf l; - | Ptype_open -> - line i ppf "Ptype_open\n"; - -and type_extension i ppf x = - line i ppf "type_extension\n"; - attributes i ppf x.ptyext_attributes; - let i = i+1 in - line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; - line i ppf "ptyext_params =\n"; - list (i+1) type_parameter ppf x.ptyext_params; - line i ppf "ptyext_constructors =\n"; - list (i+1) extension_constructor ppf x.ptyext_constructors; - line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; - -and type_exception i ppf x = - line i ppf "type_exception\n"; - attributes i ppf x.ptyexn_attributes; - let i = i+1 in - line i ppf "ptyext_constructor =\n"; - let i = i+1 in - extension_constructor i ppf x.ptyexn_constructor - -and extension_constructor i ppf x = - line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; - attributes i ppf x.pext_attributes; - let i = i + 1 in - line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; - line i ppf "pext_kind =\n"; - extension_constructor_kind (i + 1) ppf x.pext_kind; - -and extension_constructor_kind i ppf x = - match x with - Pext_decl(v, a, r) -> - line i ppf "Pext_decl\n"; - if v <> [] then line (i+1) ppf "vars%a\n" typevars v; - constructor_arguments (i+1) ppf a; - option (i+1) core_type ppf r; - | Pext_rebind li -> - line i ppf "Pext_rebind\n"; - line (i+1) ppf "%a\n" fmt_longident_loc li; - -and class_type i ppf x = - line i ppf "class_type %a\n" fmt_location x.pcty_loc; - attributes i ppf x.pcty_attributes; - let i = i+1 in - match x.pcty_desc with - | Pcty_constr (li, l) -> - line i ppf "Pcty_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Pcty_signature (cs) -> - line i ppf "Pcty_signature\n"; - class_signature i ppf cs; - | Pcty_arrow (l, co, cl) -> - line i ppf "Pcty_arrow\n"; - arg_label i ppf l; - core_type i ppf co; - class_type i ppf cl; - | Pcty_extension (s, arg) -> - line i ppf "Pcty_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pcty_open (o, e) -> - line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override - fmt_longident_loc o.popen_expr; - class_type i ppf e - -and class_signature i ppf cs = - line i ppf "class_signature\n"; - core_type (i+1) ppf cs.pcsig_self; - list (i+1) class_type_field ppf cs.pcsig_fields; - -and class_type_field i ppf x = - line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; - let i = i+1 in - attributes i ppf x.pctf_attributes; - match x.pctf_desc with - | Pctf_inherit (ct) -> - line i ppf "Pctf_inherit\n"; - class_type i ppf ct; - | Pctf_val (s, mf, vf, ct) -> - line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Pctf_method (s, pf, vf, ct) -> - line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Pctf_constraint (ct1, ct2) -> - line i ppf "Pctf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pctf_attribute a -> - attribute i ppf "Pctf_attribute" a - | Pctf_extension (s, arg) -> - line i ppf "Pctf_extension \"%s\"\n" s.txt; - payload i ppf arg - -and class_description i ppf x = - line i ppf "class_description %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.pci_expr; - -and class_type_declaration i ppf x = - line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.pci_expr; - -and class_expr i ppf x = - line i ppf "class_expr %a\n" fmt_location x.pcl_loc; - attributes i ppf x.pcl_attributes; - let i = i+1 in - match x.pcl_desc with - | Pcl_constr (li, l) -> - line i ppf "Pcl_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Pcl_structure (cs) -> - line i ppf "Pcl_structure\n"; - class_structure i ppf cs; - | Pcl_fun (l, eo, p, e) -> - line i ppf "Pcl_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - class_expr i ppf e; - | Pcl_apply (ce, l) -> - line i ppf "Pcl_apply\n"; - class_expr i ppf ce; - list i label_x_expression ppf l; - | Pcl_let (rf, l, ce) -> - line i ppf "Pcl_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - class_expr i ppf ce; - | Pcl_constraint (ce, ct) -> - line i ppf "Pcl_constraint\n"; - class_expr i ppf ce; - class_type i ppf ct; - | Pcl_extension (s, arg) -> - line i ppf "Pcl_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pcl_open (o, e) -> - line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override - fmt_longident_loc o.popen_expr; - class_expr i ppf e - -and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = - line i ppf "class_structure\n"; - pattern (i+1) ppf p; - list (i+1) class_field ppf l; - -and class_field i ppf x = - line i ppf "class_field %a\n" fmt_location x.pcf_loc; - let i = i + 1 in - attributes i ppf x.pcf_attributes; - match x.pcf_desc with - | Pcf_inherit (ovf, ce, so) -> - line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; - class_expr (i+1) ppf ce; - option (i+1) string_loc ppf so; - | Pcf_val (s, mf, k) -> - line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k - | Pcf_method (s, pf, k) -> - line i ppf "Pcf_method %a\n" fmt_private_flag pf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k - | Pcf_constraint (ct1, ct2) -> - line i ppf "Pcf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pcf_initializer (e) -> - line i ppf "Pcf_initializer\n"; - expression (i+1) ppf e; - | Pcf_attribute a -> - attribute i ppf "Pcf_attribute" a - | Pcf_extension (s, arg) -> - line i ppf "Pcf_extension \"%s\"\n" s.txt; - payload i ppf arg - -and class_field_kind i ppf = function - | Cfk_concrete (o, e) -> - line i ppf "Concrete %a\n" fmt_override_flag o; - expression i ppf e - | Cfk_virtual t -> - line i ppf "Virtual\n"; - core_type i ppf t - -and class_declaration i ppf x = - line i ppf "class_declaration %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_expr (i+1) ppf x.pci_expr; - -and module_type i ppf x = - line i ppf "module_type %a\n" fmt_location x.pmty_loc; - attributes i ppf x.pmty_attributes; - let i = i+1 in - match x.pmty_desc with - | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; - | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; - | Pmty_signature (s) -> - line i ppf "Pmty_signature\n"; - signature i ppf s; - | Pmty_functor (Unit, mt2) -> - line i ppf "Pmty_functor ()\n"; - module_type i ppf mt2; - | Pmty_functor (Named (s, mt1), mt2) -> - line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s; - module_type i ppf mt1; - module_type i ppf mt2; - | Pmty_with (mt, l) -> - line i ppf "Pmty_with\n"; - module_type i ppf mt; - list i with_constraint ppf l; - | Pmty_typeof m -> - line i ppf "Pmty_typeof\n"; - module_expr i ppf m; - | Pmty_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg - -and signature i ppf x = list i signature_item ppf x - -and signature_item i ppf x = - line i ppf "signature_item %a\n" fmt_location x.psig_loc; - let i = i+1 in - match x.psig_desc with - | Psig_value vd -> - line i ppf "Psig_value\n"; - value_description i ppf vd; - | Psig_type (rf, l) -> - line i ppf "Psig_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Psig_typesubst l -> - line i ppf "Psig_typesubst\n"; - list i type_declaration ppf l; - | Psig_typext te -> - line i ppf "Psig_typext\n"; - type_extension i ppf te - | Psig_exception te -> - line i ppf "Psig_exception\n"; - type_exception i ppf te - | Psig_module pmd -> - line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type i ppf pmd.pmd_type - | Psig_modsubst pms -> - line i ppf "Psig_modsubst %a = %a\n" - fmt_string_loc pms.pms_name - fmt_longident_loc pms.pms_manifest; - attributes i ppf pms.pms_attributes; - | Psig_recmodule decls -> - line i ppf "Psig_recmodule\n"; - list i module_declaration ppf decls; - | Psig_modtype x -> - line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Psig_modtypesubst x -> - line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Psig_open od -> - line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override - fmt_longident_loc od.popen_expr; - attributes i ppf od.popen_attributes - | Psig_include incl -> - line i ppf "Psig_include\n"; - module_type i ppf incl.pincl_mod; - attributes i ppf incl.pincl_attributes - | Psig_class (l) -> - line i ppf "Psig_class\n"; - list i class_description ppf l; - | Psig_class_type (l) -> - line i ppf "Psig_class_type\n"; - list i class_type_declaration ppf l; - | Psig_extension ((s, arg), attrs) -> - line i ppf "Psig_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg - | Psig_attribute a -> - attribute i ppf "Psig_attribute" a - -and modtype_declaration i ppf = function - | None -> line i ppf "#abstract" - | Some mt -> module_type (i+1) ppf mt - -and with_constraint i ppf x = - match x with - | Pwith_type (lid, td) -> - line i ppf "Pwith_type %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; - | Pwith_typesubst (lid, td) -> - line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; - | Pwith_module (lid1, lid2) -> - line i ppf "Pwith_module %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; - | Pwith_modsubst (lid1, lid2) -> - line i ppf "Pwith_modsubst %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; - | Pwith_modtype (lid1, mty) -> - line i ppf "Pwith_modtype %a\n" - fmt_longident_loc lid1; - module_type (i+1) ppf mty - | Pwith_modtypesubst (lid1, mty) -> - line i ppf "Pwith_modtypesubst %a\n" - fmt_longident_loc lid1; - module_type (i+1) ppf mty - -and module_expr i ppf x = - line i ppf "module_expr %a\n" fmt_location x.pmod_loc; - attributes i ppf x.pmod_attributes; - let i = i+1 in - match x.pmod_desc with - | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; - | Pmod_structure (s) -> - line i ppf "Pmod_structure\n"; - structure i ppf s; - | Pmod_functor (Unit, me) -> - line i ppf "Pmod_functor ()\n"; - module_expr i ppf me; - | Pmod_functor (Named (s, mt), me) -> - line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s; - module_type i ppf mt; - module_expr i ppf me; - | Pmod_apply (me1, me2) -> - line i ppf "Pmod_apply\n"; - module_expr i ppf me1; - module_expr i ppf me2; - | Pmod_constraint (me, mt) -> - line i ppf "Pmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; - | Pmod_unpack (e) -> - line i ppf "Pmod_unpack\n"; - expression i ppf e; - | Pmod_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pmod_hole -> - line i ppf "Pmod_hole" - -and structure i ppf x = list i structure_item ppf x - -and structure_item i ppf x = - line i ppf "structure_item %a\n" fmt_location x.pstr_loc; - let i = i+1 in - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - line i ppf "Pstr_eval\n"; - attributes i ppf attrs; - expression i ppf e; - | Pstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - | Pstr_primitive vd -> - line i ppf "Pstr_primitive\n"; - value_description i ppf vd; - | Pstr_type (rf, l) -> - line i ppf "Pstr_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Pstr_typext te -> - line i ppf "Pstr_typext\n"; - type_extension i ppf te - | Pstr_exception te -> - line i ppf "Pstr_exception\n"; - type_exception i ppf te - | Pstr_module x -> - line i ppf "Pstr_module\n"; - module_binding i ppf x - | Pstr_recmodule bindings -> - line i ppf "Pstr_recmodule\n"; - list i module_binding ppf bindings; - | Pstr_modtype x -> - line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Pstr_open od -> - line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override; - module_expr i ppf od.popen_expr; - attributes i ppf od.popen_attributes - | Pstr_class (l) -> - line i ppf "Pstr_class\n"; - list i class_declaration ppf l; - | Pstr_class_type (l) -> - line i ppf "Pstr_class_type\n"; - list i class_type_declaration ppf l; - | Pstr_include incl -> - line i ppf "Pstr_include"; - attributes i ppf incl.pincl_attributes; - module_expr i ppf incl.pincl_mod - | Pstr_extension ((s, arg), attrs) -> - line i ppf "Pstr_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg - | Pstr_attribute a -> - attribute i ppf "Pstr_attribute" a - -and module_declaration i ppf pmd = - str_opt_loc i ppf pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type (i+1) ppf pmd.pmd_type; - -and module_binding i ppf x = - str_opt_loc i ppf x.pmb_name; - attributes i ppf x.pmb_attributes; - module_expr (i+1) ppf x.pmb_expr - -and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = - line i ppf " %a\n" fmt_location l; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - -and constructor_decl i ppf - {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = - line i ppf "%a\n" fmt_location pcd_loc; - line (i+1) ppf "%a\n" fmt_string_loc pcd_name; - if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; - attributes i ppf pcd_attributes; - constructor_arguments (i+1) ppf pcd_args; - option (i+1) core_type ppf pcd_res - -and constructor_arguments i ppf = function - | Pcstr_tuple l -> list i core_type ppf l - | Pcstr_record l -> list i label_decl ppf l - -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= - line i ppf "%a\n" fmt_location pld_loc; - attributes i ppf pld_attributes; - line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; - line (i+1) ppf "%a" fmt_string_loc pld_name; - core_type (i+1) ppf pld_type - -and longident_x_pattern i ppf (li, p) = - line i ppf "%a\n" fmt_longident_loc li; - pattern (i+1) ppf p; - -and case i ppf {pc_lhs; pc_guard; pc_rhs} = - line i ppf "\n"; - pattern (i+1) ppf pc_lhs; - begin match pc_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf pc_rhs; - -and value_binding i ppf x = - line i ppf "\n"; - attributes (i+1) ppf x.pvb_attributes; - pattern (i+1) ppf x.pvb_pat; - expression (i+1) ppf x.pvb_expr - -and binding_op i ppf x = - line i ppf " %a %a" - fmt_string_loc x.pbop_op fmt_location x.pbop_loc; - pattern (i+1) ppf x.pbop_pat; - expression (i+1) ppf x.pbop_exp; - -and string_x_expression i ppf (s, e) = - line i ppf " %a\n" fmt_string_loc s; - expression (i+1) ppf e; - -and longident_x_expression i ppf (li, e) = - line i ppf "%a\n" fmt_longident_loc li; - expression (i+1) ppf e; - -and label_x_expression i ppf (l,e) = - line i ppf "\n"; - arg_label i ppf l; - expression (i+1) ppf e; - -and label_x_bool_x_core_type_list i ppf x = - match x.prf_desc with - Rtag (l, b, ctl) -> - line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); - attributes (i+1) ppf x.prf_attributes; - list (i+1) core_type ppf ctl - | Rinherit (ct) -> - line i ppf "Rinherit\n"; - core_type (i+1) ppf ct -;; - -let rec toplevel_phrase i ppf x = - match x with - | Ptop_def (s) -> - line i ppf "Ptop_def\n"; - structure (i+1) ppf s; - | Ptop_dir {pdir_name; pdir_arg; _} -> - line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt; - match pdir_arg with - | None -> () - | Some da -> directive_argument i ppf da; - -and directive_argument i ppf x = - match x.pdira_desc with - | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; - | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n; - | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m; - | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; - | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); -;; - -let interface ppf x = list 0 signature_item ppf x;; - -let implementation ppf x = list 0 structure_item ppf x;; - -let top_phrase ppf x = toplevel_phrase 0 ppf x;; diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/printast.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/printast.mli deleted file mode 100644 index 821565482..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/printast.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Raw printer for {!Parsetree} - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Parsetree;; -open Format;; - -val interface : formatter -> signature_item list -> unit;; -val implementation : formatter -> structure_item list -> unit;; -val top_phrase : formatter -> toplevel_phrase -> unit;; - -val expression: int -> formatter -> expression -> unit -val structure: int -> formatter -> structure -> unit -val payload: int -> formatter -> payload -> unit diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/syntaxerr.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/syntaxerr.ml deleted file mode 100644 index 49372b9ed..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/syntaxerr.ml +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Auxiliary type for reporting syntax errors *) - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - -exception Error of error -exception Escape_error - -let location_of_error = function - | Unclosed(l,_,_,_) - | Applicative_path l - | Variable_in_scope(l,_) - | Other l - | Not_expecting (l, _) - | Ill_formed_ast (l, _) - | Invalid_package_type (l, _) - | Expecting (l, _) -> l - - -let ill_formed_ast loc s = - raise (Error (Ill_formed_ast (loc, s))) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/syntaxerr.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/syntaxerr.mli deleted file mode 100644 index 26ba71267..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/parsing/syntaxerr.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Auxiliary type for reporting syntax errors - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - -exception Error of error -exception Escape_error - -val location_of_error: error -> Location.t -val ill_formed_ast: Location.t -> string -> 'a diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/dune b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/dune deleted file mode 100644 index 96bd66551..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/dune +++ /dev/null @@ -1,49 +0,0 @@ -(ocamllex lexer_ident lexer_raw) - -(library - (name ocaml_preprocess) - (public_name merlin-lib.ocaml_preprocess) - (flags :standard -open Ocaml_parsing -open Ocaml_utils -open Merlin_utils) - (libraries ocaml_parsing ocaml_utils merlin_utils)) - -(menhir - (modules parser_raw) - (enabled_if false) - (mode promote) - (flags :standard --inspection --table --cmly)) - -(rule - (targets parser_recover.ml) - (enabled_if false) - (deps parser_raw.cmly) - (mode promote) - (action - (with-stdout-to %{targets} - (run %{exe:./recover/gen_recover.exe} %{deps})))) - -(rule - (targets parser_explain.ml) - (enabled_if false) - (deps parser_raw.cmly) - (mode promote) - (action - (with-stdout-to %{targets} - (run %{exe:./explain/gen_explain.exe} %{deps})))) - -(rule - (targets parser_printer.ml) - (enabled_if false) - (deps parser_raw.cmly) - (mode promote) - (action - (with-stdout-to %{targets} - (run %{exe:./printer/gen_printer.exe} %{deps})))) - -(rule - (targets menhirLib.ml menhirLib.mli) - (enabled_if false) - (mode promote) - (action - (progn - (copy %{lib:menhirLib:menhirLib.ml} menhirLib.ml) - (copy %{lib:menhirLib:menhirLib.mli} menhirLib.mli)))) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/explain/dune b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/explain/dune deleted file mode 100644 index 86650a6d5..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/explain/dune +++ /dev/null @@ -1,3 +0,0 @@ -(executable - (name gen_explain) - (libraries unix menhirSdk)) diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/explain/gen_explain.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/explain/gen_explain.ml deleted file mode 100644 index a71f295a3..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/explain/gen_explain.ml +++ /dev/null @@ -1,51 +0,0 @@ -open MenhirSdk -open Printf - -module G = Cmly_read.Read(struct let filename = Sys.argv.(1) end) - -open G - -let print_header () = - let name = Filename.chop_extension (Filename.basename Sys.argv.(1)) in - printf "open %s\n" (String.capitalize_ascii name) - -let attributes_at st = - List.fold_left - (fun attrs (prod, pos) -> - if pos > 0 then - let _, _, attrs' = (G.Production.rhs prod).(pos - 1) in - attrs' @ attrs - else - attrs) - [] (Lr0.items (Lr1.lr0 st)) - -let print_named_items () = - let print_item st = - match List.filter (Attribute.has_label "item") (attributes_at st) with - | [] -> () - | (x :: _) as xs -> - let xs = List.map Attribute.payload xs |> List.sort_uniq compare in - if List.length xs > 1 then - eprintf "Warning: state %d has multiple items, %s.\n" - (Lr1.to_int st) (String.concat " " xs); - printf " | %d -> %s\n" - (Lr1.to_int st) (Attribute.payload x) - in - printf "let named_item_at = function\n"; - Lr1.iter print_item; - printf " | _ -> raise Not_found\n\n" - -let print_nullable () = - let print_n n = - if Nonterminal.nullable n then - printf " | N_%s -> true\n" (Nonterminal.mangled_name n) - in - printf "let nullable (type a) : a MenhirInterpreter.nonterminal -> bool =\n\ - \ let open MenhirInterpreter in function\n"; - Nonterminal.iter print_n; - printf " | _ -> false\n" - -let () = - print_header (); - print_named_items (); - print_nullable () diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_ident.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_ident.mli deleted file mode 100644 index c95e9c80c..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_ident.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -val token: Lexing.lexbuf -> Parser_raw.token diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_ident.mll b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_ident.mll deleted file mode 100644 index e9690dbd2..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_ident.mll +++ /dev/null @@ -1,186 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* The lexer definition *) - -{ -open Std -open Lexing -open Parser_raw - -(* Update the current location with file name and line number. *) - -let update_loc lexbuf file line absolute chars = - let pos = lexbuf.lex_curr_p in - let new_file = match file with - | None -> pos.pos_fname - | Some s -> s - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } -} - -let newline = ('\013'* '\010') -let blank = [' ' '\009' '\012'] -let lowercase = ['a'-'z' '_'] -let uppercase = ['A'-'Z'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] -let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar_latin1 = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] -let symbolchar = - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let symbolcharnopercent = - ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* -let hex_literal = - '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* -let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* -let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* -let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal -let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? -let dotsymbolchar = - ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|'] -let kwdopchar = - ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] - -rule token = parse - | "_" { EOL } - | newline - { update_loc lexbuf None 1 false 0; - token lexbuf } - | blank + - { token lexbuf } - | "~" (lowercase identchar *) as label ':' - { LABEL label } - | "~" (lowercase_latin1 identchar_latin1 *) as label ':' - { LABEL label } - | "?" - { QUESTION } - | "?" (lowercase identchar *) as label ':' - { OPTLABEL label } - | "?" (lowercase_latin1 identchar_latin1 *) as label ':' - { OPTLABEL label } - | ("let" kwdopchar dotsymbolchar *) as op { LETOP op } - | ("and" kwdopchar dotsymbolchar *) as op { ANDOP op } - | (lowercase identchar *) as ident - { LIDENT ident } - | (lowercase_latin1 identchar_latin1 *) as ident - { LIDENT ident } - | (uppercase identchar *) as ident - { UIDENT ident } - | "`" { BACKQUOTE } - | "'" { QUOTE } - | "(" { LPAREN } - | ")" { RPAREN } - | "." { DOT } - | "!" symbolchar + - { PREFIXOP(Lexing.lexeme lexbuf) } - | ['~' '?'] symbolchar + - { PREFIXOP(Lexing.lexeme lexbuf) } - | ['=' '<' '|' '&' '$' '>'] symbolchar * - { INFIXOP0(Lexing.lexeme lexbuf) } - | ['@' '^'] symbolchar * - { INFIXOP1(Lexing.lexeme lexbuf) } - | ['+' '-'] symbolchar * - { INFIXOP2(Lexing.lexeme lexbuf) } - | "**" symbolchar * - { INFIXOP4(Lexing.lexeme lexbuf) } - | '%' { PERCENT } - | ['*' '/' '%'] symbolchar * - { INFIXOP3(Lexing.lexeme lexbuf) } - | '#' (symbolchar | '#') + - { let s = Lexing.lexeme lexbuf in - HASHOP s } - | eof { EOF } - | "'" newline "'" - { update_loc lexbuf None 1 false 1; - EOL } - | "'\\" newline - { update_loc lexbuf None 1 false 0; - EOL } - | int_literal - | float_literal - | int_literal "l" - | int_literal "L" - | int_literal "n" - | ".<" - | ">." - | ".~" - | "~" - | "\"" - | "{" lowercase* "|" - | "'" [^ '\\' '\'' '\010' '\013'] "'" - | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] "'" - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" - | "'\\" _ - | "(*" - | "(*)" - | "*)" - | "#" - | "&" - | "&&" - | "*" - | "," - | "->" - | ".." - | ":" - | "::" - | ":=" - | ":>" - | ";" - | ";;" - | "<" - | "<-" - | "=" - | "[" - | "[|" - | "[<" - | "[>" - | "]" - | "{" - | "{<" - | "|" - | "||" - | "|]" - | ">" - | ">]" - | "}" - | ">}" - | "[@" - | "[%" - | "[%%" - | "[@@" - | "[@@@" - | "!" - - | "!=" - | "+" - | "+." - | "+=" - | "-" - | "-." - { EOL } - | _ { EOL } - diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_raw.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_raw.mli deleted file mode 100644 index 67965e90a..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_raw.mli +++ /dev/null @@ -1,65 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Std - -(* Possible errors *) -type error = - | Illegal_character of char - | Illegal_escape of string * string option - | Reserved_sequence of string * string option - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Empty_character_literal - | Keyword_as_label of string - | Invalid_literal of string -exception Error of error * Location.t - -(* Keywords, manipulated by extensions *) -type keywords -val keywords: (string * Parser_raw.token) list -> keywords - -val list_keywords : keywords -> string list -(* [list_keywords kws] not only lists the keys of [kw], but also OCaml's - keywords. *) - -(* Monad in which the lexer evaluates *) -type 'a result = - | Return of 'a - | Refill of (unit -> 'a result) - | Fail of error * Location.t - -type preprocessor = (Lexing.lexbuf -> Parser_raw.token) -> Lexing.lexbuf -> Parser_raw.token - -type state = { - keywords: keywords; - mutable buffer: Buffer.t; - mutable string_start_loc: Location.t; - mutable comment_start_loc: Location.t list; - mutable preprocessor: preprocessor option; -} - -val make: ?preprocessor:preprocessor -> keywords -> state - -(* The lexical analyzer *) - -val skip_sharp_bang: state -> Lexing.lexbuf -> Parser_raw.token result -val token: state -> Lexing.lexbuf -> Parser_raw.token result - -(* Comments are filtered out from the token rule and stored in a global - variable. *) -type comment = string * Location.t - -(* If you want to get the raw output, including comments, from the lexer, use - the [token_with_comments] entry point. *) -val token_without_comments : state -> Lexing.lexbuf -> Parser_raw.token result diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_raw.mll b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_raw.mll deleted file mode 100644 index 89fd89761..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/lexer_raw.mll +++ /dev/null @@ -1,813 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* The lexer definition *) - -{ -open Misc -open Std -open Lexing -open Parser_raw - -type keywords = (string, Parser_raw.token) Hashtbl.t - -type error = - | Illegal_character of char - | Illegal_escape of string * string option - | Reserved_sequence of string * string option - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Empty_character_literal - | Keyword_as_label of string - | Invalid_literal of string - -exception Error of error * Location.t - -(* Monad in which the lexer evaluates *) -type 'a result = - | Return of 'a - | Refill of (unit -> 'a result) - | Fail of error * Location.t - -let return a = Return a - -let fail lexbuf e = Fail (e, Location.curr lexbuf) -let fail_loc e l = Fail (e,l) - -let rec (>>=) (m : 'a result) (f : 'a -> 'b result) : 'b result = - match m with - | Return a -> f a - | Refill u -> - Refill (fun () -> u () >>= f) - | Fail _ as e -> e - -type preprocessor = (Lexing.lexbuf -> Parser_raw.token) -> Lexing.lexbuf -> Parser_raw.token - -type state = { - keywords: keywords; - mutable buffer: Buffer.t; - mutable string_start_loc: Location.t; - mutable comment_start_loc: Location.t list; - mutable preprocessor: preprocessor option; -} - -let make ?preprocessor keywords = { - keywords; - buffer = Buffer.create 17; - string_start_loc = Location.none; - comment_start_loc = []; - preprocessor; -} - -let lABEL m = m >>= fun v -> return (LABEL v) -let oPTLABEL m = m >>= fun v -> return (OPTLABEL v) - -let rec catch m f = match m with - | Fail (e,l) -> f e l - | Refill next -> Refill (fun () -> catch (next ()) f) - | Return _ -> m - -(* The table of keywords *) - -let keyword_table : keywords = - create_hashtable 149 [ - "and", AND; - "as", AS; - "assert", ASSERT; - "begin", BEGIN; - "class", CLASS; - "constraint", CONSTRAINT; - "do", DO; - "done", DONE; - "downto", DOWNTO; - "else", ELSE; - "end", END; - "exception", EXCEPTION; - "external", EXTERNAL; - "false", FALSE; - "for", FOR; - "fun", FUN; - "function", FUNCTION; - "functor", FUNCTOR; - "if", IF; - "in", IN; - "include", INCLUDE; - "inherit", INHERIT; - "initializer", INITIALIZER; - "lazy", LAZY; - "let", LET; - "match", MATCH; - "method", METHOD; - "module", MODULE; - "mutable", MUTABLE; - "new", NEW; - "nonrec", NONREC; - "object", OBJECT; - "of", OF; - "open", OPEN; - "or", OR; -(* "parser", PARSER; *) - "private", PRIVATE; - "rec", REC; - "sig", SIG; - "struct", STRUCT; - "then", THEN; - "to", TO; - "true", TRUE; - "try", TRY; - "type", TYPE; - "val", VAL; - "virtual", VIRTUAL; - "when", WHEN; - "while", WHILE; - "with", WITH; - - "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) - "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) - "mod", INFIXOP3("mod"); - "land", INFIXOP3("land"); - "lsl", INFIXOP4("lsl"); - "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr"); -] - -let keywords l = create_hashtable 11 l - -let list_keywords = - let add_kw str _tok kws = str :: kws in - let init = Hashtbl.fold add_kw keyword_table [] in - fun keywords -> - Hashtbl.fold add_kw keywords init - -(* To store the position of the beginning of a string and comment *) -let in_comment state = state.comment_start_loc <> [] - -(* Escaped chars are interpreted in strings unless they are in comments. *) -let store_escaped_uchar state lexbuf u = - if in_comment state - then Buffer.add_string state.buffer (Lexing.lexeme lexbuf) - else Buffer.add_utf_8_uchar state.buffer u - - -let compute_quoted_string_idloc {Location.loc_start = orig_loc; _ } shift id = - let id_start_pos = orig_loc.Lexing.pos_cnum + shift in - let loc_start = - Lexing.{orig_loc with pos_cnum = id_start_pos } - in - let loc_end = - Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id } - in - {Location. loc_start ; loc_end ; loc_ghost = false } - -let wrap_string_lexer f state lexbuf = - Buffer.reset state.buffer; - state.string_start_loc <- Location.curr lexbuf; - f state lexbuf >>= fun loc_end -> - lexbuf.lex_start_p <- state.string_start_loc.Location.loc_start; - state.string_start_loc <- Location.none; - let loc = - Location.{ - loc_ghost = false; - loc_start = state.string_start_loc.Location.loc_start; - loc_end; - } - in - return (Buffer.contents state.buffer, loc) - -(* to translate escape sequences *) - -let digit_value c = - match c with - | 'a' .. 'f' -> 10 + Char.code c - Char.code 'a' - | 'A' .. 'F' -> 10 + Char.code c - Char.code 'A' - | '0' .. '9' -> Char.code c - Char.code '0' - | _ -> assert false - -let num_value lexbuf ~base ~first ~last = - let c = ref 0 in - for i = first to last do - let v = digit_value (Lexing.lexeme_char lexbuf i) in - assert(v < base); - c := (base * !c) + v - done; - !c - -let char_for_backslash = function - | 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let illegal_escape lexbuf reason = - let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in - fail lexbuf error - -let char_for_decimal_code state lexbuf i = - let c = num_value lexbuf ~base:10 ~first:i ~last:(i+2) in - if (c < 0 || c > 255) then - if in_comment state - then return 'x' - else - illegal_escape lexbuf - (Printf.sprintf - "%d is outside the range of legal characters (0-255)." c) - else return (Char.chr c) - -let char_for_octal_code state lexbuf i = - let c = num_value lexbuf ~base:8 ~first:i ~last:(i+2) in - if (c < 0 || c > 255) then - if in_comment state - then return 'x' - else - illegal_escape lexbuf - (Printf.sprintf - "o%o (=%d) is outside the range of legal characters (0-255)." c c) - else return (Char.chr c) - -let char_for_hexadecimal_code lexbuf i = - Char.chr (num_value lexbuf ~base:16 ~first:i ~last:(i+1)) - -let uchar_for_uchar_escape lexbuf = - let illegal_escape lexbuf reason = - let error = Illegal_escape (Lexing.lexeme lexbuf, Some reason) in - raise (Error (error, Location.curr lexbuf)) - in - let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in - let first = 3 (* skip opening \u{ *) in - let last = len - 2 (* skip closing } *) in - let digit_count = last - first + 1 in - match digit_count > 6 with - | true -> - illegal_escape lexbuf - "too many digits, expected 1 to 6 hexadecimal digits" - | false -> - let cp = num_value lexbuf ~base:16 ~first ~last in - if Uchar.is_valid cp then Uchar.unsafe_of_int cp else - illegal_escape lexbuf - (Printf.sprintf "%X is not a Unicode scalar value" cp) - -let keyword_or state s default = - try Hashtbl.find state.keywords s - with Not_found -> try Hashtbl.find keyword_table s - with Not_found -> default - -let is_keyword name = Hashtbl.mem keyword_table name - -let check_label_name lexbuf name = - if is_keyword name - then fail lexbuf (Keyword_as_label name) - else return name - -(* Update the current location with file name and line number. *) - -let update_loc lexbuf _file line absolute chars = - let pos = lexbuf.lex_curr_p in - let new_file = pos.pos_fname - (*match file with - | None -> pos.pos_fname - | Some s -> s*) - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } -;; - -(* Warn about Latin-1 characters used in idents *) - -let warn_latin1 lexbuf = - Location.deprecated (Location.curr lexbuf) - "ISO-Latin1 characters in identifiers" -;; - -(* Error report *) - -open Format - -let prepare_error loc = function - | Illegal_character c -> - Location.errorf ~loc "Illegal character (%s)" (Char.escaped c) - | Illegal_escape (s, explanation) -> - Location.errorf ~loc - "Illegal backslash escape in string or character (%s)%t" s - (fun ppf -> match explanation with - | None -> () - | Some expl -> fprintf ppf ": %s" expl) - | Reserved_sequence (s, explanation) -> - Location.errorf ~loc - "Reserved character sequence: %s%t" s - (fun ppf -> match explanation with - | None -> () - | Some expl -> fprintf ppf " %s" expl) - | Unterminated_comment _ -> - Location.errorf ~loc "Comment not terminated" - | Unterminated_string -> - Location.errorf ~loc "String literal not terminated" - | Unterminated_string_in_comment (_, literal_loc) -> - Location.errorf ~loc - "This comment contains an unterminated string literal" - ~sub:[Location.msg ~loc:literal_loc "String literal begins here"] - | Empty_character_literal -> - let msg = "Illegal empty character literal ''" in - let sub = - [Location.msg - "Hint: Did you mean ' ' or a type variable 'a?"] in - Location.error ~loc ~sub msg - | Keyword_as_label kwd -> - Location.errorf ~loc - "`%s' is a keyword, it cannot be used as label name" kwd - | Invalid_literal s -> - Location.errorf ~loc "Invalid literal %s" s -(* FIXME: Invalid_directive? *) - -let () = - Location.register_error_of_exn - (function - | Error (err, loc) -> - Some (prepare_error loc err) - | _ -> - None - ) - -} - -let newline = ('\013'* '\010') -let blank = [' ' '\009' '\012'] -let lowercase = ['a'-'z' '_'] -let uppercase = ['A'-'Z'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9' '\128'-'\255'] -let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] -let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar_latin1 = identchar - (*['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']*) -let symbolchar = - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let symbolcharnopercent = - ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let dotsymbolchar = - ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|'] -let symbolchar_or_hash = - symbolchar | '#' -let kwdopchar = - ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|'] - -let ident = (lowercase | uppercase) identchar* -let extattrident = ident ('.' ident)* - -let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* -let hex_digit = - ['0'-'9' 'A'-'F' 'a'-'f'] -let hex_literal = - '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* -let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* -let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* -let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal -let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*) ? -let hex_float_literal = - '0' ['x' 'X'] - ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* - ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? - (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? -let literal_modifier = ['G'-'Z' 'g'-'z'] - - -refill {fun k lexbuf -> Refill (fun () -> k lexbuf)} - -rule token state = parse - | ("\\" as bs) newline { - match state.preprocessor with - | None -> fail lexbuf (Illegal_character bs) - | Some _ -> - update_loc lexbuf None 1 false 0; - token state lexbuf } - | newline - { update_loc lexbuf None 1 false 0; - match state.preprocessor with - | None -> token state lexbuf - | Some _ -> return EOL - } - | blank + - { token state lexbuf } - | ".<" - { return DOTLESS } - | ">." - { return (keyword_or state (Lexing.lexeme lexbuf) (INFIXOP0 ">.")) } - | ".~" - { return (keyword_or state (Lexing.lexeme lexbuf) DOTTILDE) } - | "_" - { return UNDERSCORE } - | "~" - { return TILDE } - (* - | ".~" - { fail lexbuf - (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } - *) - | "~" (lowercase identchar * as name) ':' - { lABEL (check_label_name lexbuf name) } - | "~" (lowercase_latin1 identchar_latin1 * as name) ':' - { warn_latin1 lexbuf; - return (LABEL name) } - | "?" - { return QUESTION } - | "??" - { return QUESTIONQUESTION } - | "?" (lowercase identchar * as name) ':' - { oPTLABEL (check_label_name lexbuf name) } - | "?" (lowercase_latin1 identchar_latin1 * as name) ':' - { warn_latin1 lexbuf; return (OPTLABEL name) } - | lowercase identchar * as name - { return (try Hashtbl.find state.keywords name - with Not_found -> - try Hashtbl.find keyword_table name - with Not_found -> - LIDENT name) } - | lowercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; return (LIDENT name) } - | uppercase identchar * as name - { (* Capitalized keywords for OUnit *) - return (try Hashtbl.find state.keywords name - with Not_found -> - try Hashtbl.find keyword_table name - with Not_found -> - UIDENT name) } - | uppercase_latin1 identchar_latin1 * as name - { warn_latin1 lexbuf; return (UIDENT name) } - | int_literal as lit { return (INT (lit, None)) } - | (int_literal as lit) (literal_modifier as modif) - { return (INT (lit, Some modif)) } - | float_literal | hex_float_literal as lit - { return (FLOAT (lit, None)) } - | (float_literal | hex_float_literal as lit) (literal_modifier as modif) - { return (FLOAT (lit, Some modif)) } - | (float_literal | hex_float_literal | int_literal) identchar+ as invalid - { fail lexbuf (Invalid_literal invalid) } - | "\"" - { wrap_string_lexer string state lexbuf >>= fun (str, loc) -> - return (STRING (str, loc, None)) } - | "\'\'" - { wrap_string_lexer string state lexbuf >>= fun (str, loc) -> - return (STRING (str, loc, None)) } - | "{" (lowercase* as delim) "|" - { wrap_string_lexer (quoted_string delim) state lexbuf - >>= fun (str, loc) -> - return (STRING (str, loc, Some delim)) } - | "{%" (extattrident as id) "|" - { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string "") state lexbuf - >>= fun (str, loc) -> - let idloc = compute_quoted_string_idloc orig_loc 2 id in - return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some "")) } - | "{%" (extattrident as id) blank+ (lowercase* as delim) "|" - { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string delim) state lexbuf - >>= fun (str, loc) -> - let idloc = compute_quoted_string_idloc orig_loc 2 id in - return (QUOTED_STRING_EXPR (id, idloc, str, loc, Some delim)) } - | "{%%" (extattrident as id) "|" - { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string "") state lexbuf - >>= fun (str, loc) -> - let idloc = compute_quoted_string_idloc orig_loc 3 id in - return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some "")) } - | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|" - { let orig_loc = Location.curr lexbuf in - wrap_string_lexer (quoted_string delim) state lexbuf - >>= fun (str, loc) -> - let idloc = compute_quoted_string_idloc orig_loc 3 id in - return (QUOTED_STRING_ITEM (id, idloc, str, loc, Some delim)) } - | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - (* newline is ('\013'* '\010') *) - return (CHAR '\n') } - | "\'" ([^ '\\' '\'' '\010' '\013'] as c) "\'" - { return (CHAR c) } - | "\'\\" (['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] as c) "\'" - { return (CHAR (char_for_backslash c)) } - | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { char_for_octal_code state lexbuf 3 >>= fun c -> return (CHAR c) } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { char_for_decimal_code state lexbuf 2 >>= fun c -> return (CHAR c) } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { return (CHAR (char_for_hexadecimal_code lexbuf 3)) } - | "\'" ("\\" _ as esc) - { fail lexbuf (Illegal_escape (esc, None)) } - | "(*" - { let start_loc = Location.curr lexbuf in - state.comment_start_loc <- [start_loc]; - Buffer.reset state.buffer; - comment state lexbuf >>= fun end_loc -> - let s = Buffer.contents state.buffer in - Buffer.reset state.buffer; - return (COMMENT (s, { start_loc with - Location.loc_end = end_loc.Location.loc_end })) - } - | "(*)" - { let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Comment_start; - state.comment_start_loc <- [loc]; - Buffer.reset state.buffer; - comment state lexbuf >>= fun end_loc -> - let s = Buffer.contents state.buffer in - Buffer.reset state.buffer; - return (COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end })) - } - | "*)" - { let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Comment_not_end; - lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; - let curpos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; - return STAR - } - | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")? - [^ '\010' '\013'] * newline - { update_loc lexbuf name (int_of_string num) true 0; - token state lexbuf - } - | "#" { return HASH } - | "&" { return AMPERSAND } - | "&&" { return AMPERAMPER } - | "`" { return BACKQUOTE } - | "\'" { return QUOTE } - | "(" { return LPAREN } - | ")" { return RPAREN } - | "*" { return STAR } - | "," { return COMMA } - | "->" { return MINUSGREATER } - | "." { return DOT } - | "." (dotsymbolchar symbolchar* as op) { return (DOTOP op) } - | ".." { return DOTDOT } - | ":" { return COLON } - | "::" { return COLONCOLON } - | ":=" { return COLONEQUAL } - | ":>" { return COLONGREATER } - | ";" { return SEMI } - | ";;" { return SEMISEMI } - | "<" { return LESS } - | "<-" { return LESSMINUS } - | "=" { return EQUAL } - | "[" { return LBRACKET } - | "[|" { return LBRACKETBAR } - | "[<" { return LBRACKETLESS } - | "[>" { return LBRACKETGREATER } - | "]" { return RBRACKET } - | "{" { return LBRACE } - | "{<" { return LBRACELESS } - | "|" { return BAR } - | "||" { return BARBAR } - | "|]" { return BARRBRACKET } - | ">" { return GREATER } - | ">]" { return GREATERRBRACKET } - | "}" { return RBRACE } - | ">}" { return GREATERRBRACE } - | "[@" { return LBRACKETAT } - | "[@@" { return LBRACKETATAT } - | "[@@@" { return LBRACKETATATAT } - | "[%" { return LBRACKETPERCENT } - | "[%%" { return LBRACKETPERCENTPERCENT } - | "!" { return BANG } - | "!=" { return (INFIXOP0 "!=") } - | "+" { return PLUS } - | "+." { return PLUSDOT } - | "+=" { return PLUSEQ } - | "-" { return MINUS } - | "-." { return MINUSDOT } - - | "!" symbolchar_or_hash + as op - { return (PREFIXOP op) } - | ['~' '?'] symbolchar_or_hash + as op - { return (PREFIXOP op) } - | ['=' '<' '|' '&' '$' '>'] symbolchar * as op - { return (keyword_or state op - (INFIXOP0 op)) } - | ['@' '^'] symbolchar * as op - { return (INFIXOP1 op) } - | ['+' '-'] symbolchar * as op - { return (INFIXOP2 op) } - | "**" symbolchar * as op - { return (INFIXOP4 op) } - | '%' { return PERCENT } - | ['*' '/' '%'] symbolchar * as op - { return (INFIXOP3 op) } - (* Old style js_of_ocaml support is implemented by generating a custom token *) - | '#' symbolchar_or_hash + as op - { return (try Hashtbl.find state.keywords op - with Not_found -> HASHOP op) } - | "let" kwdopchar dotsymbolchar * as op - { return (LETOP op) } - | "and" kwdopchar dotsymbolchar * as op - { return (ANDOP op) } - | eof { return EOF } - - | _ as illegal_char - { fail lexbuf (Illegal_character illegal_char) } - -and comment state = parse - "(*" - { state.comment_start_loc <- (Location.curr lexbuf) :: state.comment_start_loc; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - comment state lexbuf - } - | "*)" - { match state.comment_start_loc with - | [] -> assert false - | [_] -> state.comment_start_loc <- []; return (Location.curr lexbuf) - | _ :: l -> state.comment_start_loc <- l; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - comment state lexbuf - } - | "\"" - { - state.string_start_loc <- Location.curr lexbuf; - Buffer.add_char state.buffer '\"'; - let buffer = state.buffer in - state.buffer <- Buffer.create 15; - (catch (string state lexbuf) (fun e l -> match e with - | Unterminated_string -> - begin match state.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev state.comment_start_loc) in - state.comment_start_loc <- []; - fail_loc (Unterminated_string_in_comment (start, l)) loc - end - | e -> fail_loc e l - ) - ) >>= fun _loc -> - state.string_start_loc <- Location.none; - Buffer.add_string buffer (String.escaped (Buffer.contents state.buffer)); - state.buffer <- buffer; - Buffer.add_char state.buffer '\"'; - comment state lexbuf } - | "{" ('%' '%'? extattrident blank*)? lowercase* "|" - { - let delim = Lexing.lexeme lexbuf in - let delim = String.sub delim ~pos:1 ~len:(String.length delim - 2) in - state.string_start_loc <- Location.curr lexbuf; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - (catch (quoted_string delim state lexbuf) (fun e l -> match e with - | Unterminated_string -> - begin match state.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev state.comment_start_loc) in - state.comment_start_loc <- []; - fail_loc (Unterminated_string_in_comment (start, l)) loc - end - | e -> fail_loc e l - ) - ) >>= fun _loc -> - state.string_start_loc <- Location.none; - Buffer.add_char state.buffer '|'; - Buffer.add_string state.buffer delim; - Buffer.add_char state.buffer '}'; - comment state lexbuf } - - | "''" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'" newline "'" - { update_loc lexbuf None 1 false 1; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - comment state lexbuf - } - | "'" [^ '\\' '\'' '\010' '\013' ] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | eof - { match state.comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev state.comment_start_loc) in - state.comment_start_loc <- []; - fail_loc (Unterminated_comment start) loc - } - | newline - { update_loc lexbuf None 1 false 0; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - comment state lexbuf - } - | (lowercase | uppercase) identchar * - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | _ - { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - -and string state = parse - '\"' - { return lexbuf.lex_start_p } - | '\\' newline ([' ' '\t'] * as space) - { update_loc lexbuf None 1 false (String.length space); - string state lexbuf - } - | '\\' ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] - { Buffer.add_char state.buffer - (char_for_backslash (Lexing.lexeme_char lexbuf 1)); - string state lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { char_for_decimal_code state lexbuf 1 >>= fun c -> - Buffer.add_char state.buffer c; - string state lexbuf } - | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] - { Buffer.add_char state.buffer (char_for_hexadecimal_code lexbuf 2); - string state lexbuf } - | '\\' 'u' '{' hex_digit+ '}' - { store_escaped_uchar state lexbuf (uchar_for_uchar_escape lexbuf); - string state lexbuf } - | '\\' _ - { if in_comment state - then string state lexbuf - else begin -(* Should be an error, but we are very lax. - fail (Illegal_escape (Lexing.lexeme lexbuf), - (Location.curr lexbuf) -*) - let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Illegal_backslash; - Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); - Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 1); - string state lexbuf - end - } - | newline - { if not (in_comment state) then - Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; - update_loc lexbuf None 1 false 0; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - string state lexbuf - } - | eof - { let loc = state.string_start_loc in - state.string_start_loc <- Location.none; - fail_loc Unterminated_string loc } - | _ - { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); - string state lexbuf } - -and quoted_string delim state = parse - | newline - { update_loc lexbuf None 1 false 0; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - quoted_string delim state lexbuf - } - | eof - { let loc = state.string_start_loc in - state.string_start_loc <- Location.none; - fail_loc Unterminated_string loc } - | "|" lowercase* "}" - { - let edelim = Lexing.lexeme lexbuf in - let edelim = String.sub edelim ~pos:1 ~len:(String.length edelim - 2) in - if delim = edelim then return lexbuf.lex_start_p - else (Buffer.add_string state.buffer (Lexing.lexeme lexbuf); - quoted_string delim state lexbuf) - } - | _ - { Buffer.add_char state.buffer (Lexing.lexeme_char lexbuf 0); - quoted_string delim state lexbuf } - -and skip_sharp_bang state = parse - | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" - { update_loc lexbuf None 3 false 0; token state lexbuf } - | "#!" [^ '\n']* '\n' - { update_loc lexbuf None 1 false 0; token state lexbuf } - | "" { token state lexbuf } - -{ - type comment = string * Location.t - - (* preprocessor support not implemented, not compatible with monadic - interface *) - - let rec token_without_comments state lexbuf = - token state lexbuf >>= function - | COMMENT _ -> - token_without_comments state lexbuf - | tok -> return tok -} diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/menhirLib.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/menhirLib.ml deleted file mode 100644 index f1782933f..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/menhirLib.ml +++ /dev/null @@ -1,3789 +0,0 @@ -module General = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* --------------------------------------------------------------------------- *) - -(* Lists. *) - -let rec take n xs = - match n, xs with - | 0, _ - | _, [] -> - [] - | _, (x :: xs as input) -> - let xs' = take (n - 1) xs in - if xs == xs' then - input - else - x :: xs' - -let rec drop n xs = - match n, xs with - | 0, _ -> - xs - | _, [] -> - [] - | _, _ :: xs -> - drop (n - 1) xs - -let rec uniq1 cmp x ys = - match ys with - | [] -> - [] - | y :: ys -> - if cmp x y = 0 then - uniq1 cmp x ys - else - y :: uniq1 cmp y ys - -let uniq cmp xs = - match xs with - | [] -> - [] - | x :: xs -> - x :: uniq1 cmp x xs - -let weed cmp xs = - uniq cmp (List.sort cmp xs) - -(* --------------------------------------------------------------------------- *) - -(* Streams. *) - -type 'a stream = - 'a head Lazy.t - -and 'a head = - | Nil - | Cons of 'a * 'a stream - -(* The length of a stream. *) - -let rec length xs = - match Lazy.force xs with - | Nil -> - 0 - | Cons (_, xs) -> - 1 + length xs - -(* Folding over a stream. *) - -let rec foldr f xs accu = - match Lazy.force xs with - | Nil -> - accu - | Cons (x, xs) -> - f x (foldr f xs accu) -end -module Convert = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* An ocamlyacc-style, or Menhir-style, parser requires access to - the lexer, which must be parameterized with a lexing buffer, and - to the lexing buffer itself, where it reads position information. *) - -(* This traditional API is convenient when used with ocamllex, but - inelegant when used with other lexer generators. *) - -type ('token, 'semantic_value) traditional = - (Lexing.lexbuf -> 'token) -> Lexing.lexbuf -> 'semantic_value - -(* This revised API is independent of any lexer generator. Here, the - parser only requires access to the lexer, and the lexer takes no - parameters. The tokens returned by the lexer may contain position - information. *) - -type ('token, 'semantic_value) revised = - (unit -> 'token) -> 'semantic_value - -(* --------------------------------------------------------------------------- *) - -(* Converting a traditional parser, produced by ocamlyacc or Menhir, - into a revised parser. *) - -(* A token of the revised lexer is essentially a triple of a token - of the traditional lexer (or raw token), a start position, and - and end position. The three [get] functions are accessors. *) - -(* We do not require the type ['token] to actually be a triple type. - This enables complex applications where it is a record type with - more than three fields. It also enables simple applications where - positions are of no interest, so ['token] is just ['raw_token] - and [get_startp] and [get_endp] return dummy positions. *) - -let traditional2revised - (get_raw_token : 'token -> 'raw_token) - (get_startp : 'token -> Lexing.position) - (get_endp : 'token -> Lexing.position) - (parser : ('raw_token, 'semantic_value) traditional) -: ('token, 'semantic_value) revised = - - (* Accept a revised lexer. *) - - fun (lexer : unit -> 'token) -> - - (* Create a dummy lexing buffer. *) - - let lexbuf : Lexing.lexbuf = - Lexing.from_string "" - in - - (* Wrap the revised lexer as a traditional lexer. A traditional - lexer returns a raw token and updates the fields of the lexing - buffer with new positions, which will be read by the parser. *) - - let lexer (lexbuf : Lexing.lexbuf) : 'raw_token = - let token : 'token = lexer() in - lexbuf.Lexing.lex_start_p <- get_startp token; - lexbuf.Lexing.lex_curr_p <- get_endp token; - get_raw_token token - in - - (* Invoke the traditional parser. *) - - parser lexer lexbuf - -(* --------------------------------------------------------------------------- *) - -(* Converting a revised parser back to a traditional parser. *) - -let revised2traditional - (make_token : 'raw_token -> Lexing.position -> Lexing.position -> 'token) - (parser : ('token, 'semantic_value) revised) -: ('raw_token, 'semantic_value) traditional = - - (* Accept a traditional lexer and a lexing buffer. *) - - fun (lexer : Lexing.lexbuf -> 'raw_token) (lexbuf : Lexing.lexbuf) -> - - (* Wrap the traditional lexer as a revised lexer. *) - - let lexer () : 'token = - let token : 'raw_token = lexer lexbuf in - make_token token lexbuf.Lexing.lex_start_p lexbuf.Lexing.lex_curr_p - in - - (* Invoke the revised parser. *) - - parser lexer - -(* --------------------------------------------------------------------------- *) - -(* Simplified versions of the above, where concrete triples are used. *) - -module Simplified = struct - - let traditional2revised parser = - traditional2revised - (fun (token, _, _) -> token) - (fun (_, startp, _) -> startp) - (fun (_, _, endp) -> endp) - parser - - let revised2traditional parser = - revised2traditional - (fun token startp endp -> (token, startp, endp)) - parser - -end -end -module IncrementalEngine = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -type position = Lexing.position - -open General - -(* This signature describes the incremental LR engine. *) - -(* In this mode, the user controls the lexer, and the parser suspends - itself when it needs to read a new token. *) - -module type INCREMENTAL_ENGINE = sig - - type token - - (* A value of type [production] is (an index for) a production. The start - productions (which do not exist in an \mly file, but are constructed by - Menhir internally) are not part of this type. *) - - type production - - (* The type ['a checkpoint] represents an intermediate or final state of the - parser. An intermediate checkpoint is a suspension: it records the parser's - current state, and allows parsing to be resumed. The parameter ['a] is - the type of the semantic value that will eventually be produced if the - parser succeeds. *) - - (* [Accepted] and [Rejected] are final checkpoints. [Accepted] carries a - semantic value. *) - - (* [InputNeeded] is an intermediate checkpoint. It means that the parser wishes - to read one token before continuing. *) - - (* [Shifting] is an intermediate checkpoint. It means that the parser is taking - a shift transition. It exposes the state of the parser before and after - the transition. The Boolean parameter tells whether the parser intends to - request a new token after this transition. (It always does, except when - it is about to accept.) *) - - (* [AboutToReduce] is an intermediate checkpoint. It means that the parser is - about to perform a reduction step. It exposes the parser's current - state as well as the production that is about to be reduced. *) - - (* [HandlingError] is an intermediate checkpoint. It means that the parser has - detected an error and is currently handling it, in several steps. *) - - (* A value of type ['a env] represents a configuration of the automaton: - current state, stack, lookahead token, etc. The parameter ['a] is the - type of the semantic value that will eventually be produced if the parser - succeeds. *) - - (* In normal operation, the parser works with checkpoints: see the functions - [offer] and [resume]. However, it is also possible to work directly with - environments (see the functions [pop], [force_reduction], and [feed]) and - to reconstruct a checkpoint out of an environment (see [input_needed]). - This is considered advanced functionality; its purpose is to allow error - recovery strategies to be programmed by the user. *) - - type 'a env - - type 'a checkpoint = private - | InputNeeded of 'a env - | Shifting of 'a env * 'a env * bool - | AboutToReduce of 'a env * production - | HandlingError of 'a env - | Accepted of 'a - | Rejected - - (* [offer] allows the user to resume the parser after it has suspended - itself with a checkpoint of the form [InputNeeded env]. [offer] expects - the old checkpoint as well as a new token and produces a new checkpoint. - It does not raise any exception. *) - - val offer: - 'a checkpoint -> - token * position * position -> - 'a checkpoint - - (* [resume] allows the user to resume the parser after it has suspended - itself with a checkpoint of the form [AboutToReduce (env, prod)] or - [HandlingError env]. [resume] expects the old checkpoint and produces a - new checkpoint. It does not raise any exception. *) - - (* The optional argument [strategy] influences the manner in which [resume] - deals with checkpoints of the form [ErrorHandling _]. Its default value - is [`Legacy]. It can be briefly described as follows: - - - If the [error] token is used only to report errors (that is, if the - [error] token appears only at the end of a production, whose semantic - action raises an exception) then the simplified strategy should be - preferred. (This includes the case where the [error] token does not - appear at all in the grammar.) - - - If the [error] token is used to recover after an error, or if - perfect backward compatibility is required, the legacy strategy - should be selected. - - More details on these strategies appear in the file [Engine.ml]. *) - - type strategy = - [ `Legacy | `Simplified ] - - val resume: - ?strategy:strategy -> - 'a checkpoint -> - 'a checkpoint - - (* A token supplier is a function of no arguments which delivers a new token - (together with its start and end positions) every time it is called. *) - - type supplier = - unit -> token * position * position - - (* A pair of a lexer and a lexing buffer can be easily turned into a - supplier. *) - - val lexer_lexbuf_to_supplier: - (Lexing.lexbuf -> token) -> - Lexing.lexbuf -> - supplier - - (* The functions [offer] and [resume] are sufficient to write a parser loop. - One can imagine many variations (which is why we expose these functions - in the first place!). Here, we expose a few variations of the main loop, - ready for use. *) - - (* [loop supplier checkpoint] begins parsing from [checkpoint], reading - tokens from [supplier]. It continues parsing until it reaches a - checkpoint of the form [Accepted v] or [Rejected]. In the former case, it - returns [v]. In the latter case, it raises the exception [Error]. - The optional argument [strategy], whose default value is [Legacy], - is passed to [resume] and influences the error-handling strategy. *) - - val loop: ?strategy:strategy -> supplier -> 'a checkpoint -> 'a - - (* [loop_handle succeed fail supplier checkpoint] begins parsing from - [checkpoint], reading tokens from [supplier]. It continues parsing until - it reaches a checkpoint of the form [Accepted v] or [HandlingError env] - (or [Rejected], but that should not happen, as [HandlingError _] will be - observed first). In the former case, it calls [succeed v]. In the latter - case, it calls [fail] with this checkpoint. It cannot raise [Error]. - - This means that Menhir's error-handling procedure does not get a chance - to run. For this reason, there is no [strategy] parameter. Instead, the - user can implement her own error handling code, in the [fail] - continuation. *) - - val loop_handle: - ('a -> 'answer) -> - ('a checkpoint -> 'answer) -> - supplier -> 'a checkpoint -> 'answer - - (* [loop_handle_undo] is analogous to [loop_handle], except it passes a pair - of checkpoints to the failure continuation. - - The first (and oldest) checkpoint is the last [InputNeeded] checkpoint that - was encountered before the error was detected. The second (and newest) - checkpoint is where the error was detected, as in [loop_handle]. Going back - to the first checkpoint can be thought of as undoing any reductions that - were performed after seeing the problematic token. (These reductions must - be default reductions or spurious reductions.) - - [loop_handle_undo] must initially be applied to an [InputNeeded] checkpoint. - The parser's initial checkpoints satisfy this constraint. *) - - val loop_handle_undo: - ('a -> 'answer) -> - ('a checkpoint -> 'a checkpoint -> 'answer) -> - supplier -> 'a checkpoint -> 'answer - - (* [shifts checkpoint] assumes that [checkpoint] has been obtained by - submitting a token to the parser. It runs the parser from [checkpoint], - through an arbitrary number of reductions, until the parser either - accepts this token (i.e., shifts) or rejects it (i.e., signals an error). - If the parser decides to shift, then [Some env] is returned, where [env] - is the parser's state just before shifting. Otherwise, [None] is - returned. *) - - (* It is desirable that the semantic actions be side-effect free, or that - their side-effects be harmless (replayable). *) - - val shifts: 'a checkpoint -> 'a env option - - (* The function [acceptable] allows testing, after an error has been - detected, which tokens would have been accepted at this point. It is - implemented using [shifts]. Its argument should be an [InputNeeded] - checkpoint. *) - - (* For completeness, one must undo any spurious reductions before carrying out - this test -- that is, one must apply [acceptable] to the FIRST checkpoint - that is passed by [loop_handle_undo] to its failure continuation. *) - - (* This test causes some semantic actions to be run! The semantic actions - should be side-effect free, or their side-effects should be harmless. *) - - (* The position [pos] is used as the start and end positions of the - hypothetical token, and may be picked up by the semantic actions. We - suggest using the position where the error was detected. *) - - val acceptable: 'a checkpoint -> token -> position -> bool - - (* The abstract type ['a lr1state] describes the non-initial states of the - LR(1) automaton. The index ['a] represents the type of the semantic value - associated with this state's incoming symbol. *) - - type 'a lr1state - - (* The states of the LR(1) automaton are numbered (from 0 and up). *) - - val number: _ lr1state -> int - - (* Productions are numbered. *) - - (* [find_production i] requires the index [i] to be valid. Use with care. *) - - val production_index: production -> int - val find_production: int -> production - - (* An element is a pair of a non-initial state [s] and a semantic value [v] - associated with the incoming symbol of this state. The idea is, the value - [v] was pushed onto the stack just before the state [s] was entered. Thus, - for some type ['a], the state [s] has type ['a lr1state] and the value [v] - has type ['a]. In other words, the type [element] is an existential type. *) - - type element = - | Element: 'a lr1state * 'a * position * position -> element - - (* The parser's stack is (or, more precisely, can be viewed as) a stream of - elements. The type [stream] is defined by the module [General]. *) - - (* As of 2017/03/31, the types [stream] and [stack] and the function [stack] - are DEPRECATED. They might be removed in the future. An alternative way - of inspecting the stack is via the functions [top] and [pop]. *) - - type stack = (* DEPRECATED *) - element stream - - (* This is the parser's stack, a stream of elements. This stream is empty if - the parser is in an initial state; otherwise, it is non-empty. The LR(1) - automaton's current state is the one found in the top element of the - stack. *) - - val stack: 'a env -> stack (* DEPRECATED *) - - (* [top env] returns the parser's top stack element. The state contained in - this stack element is the current state of the automaton. If the stack is - empty, [None] is returned. In that case, the current state of the - automaton must be an initial state. *) - - val top: 'a env -> element option - - (* [pop_many i env] pops [i] cells off the automaton's stack. This is done - via [i] successive invocations of [pop]. Thus, [pop_many 1] is [pop]. The - index [i] must be nonnegative. The time complexity is O(i). *) - - val pop_many: int -> 'a env -> 'a env option - - (* [get i env] returns the parser's [i]-th stack element. The index [i] is - 0-based: thus, [get 0] is [top]. If [i] is greater than or equal to the - number of elements in the stack, [None] is returned. The time complexity - is O(i). *) - - val get: int -> 'a env -> element option - - (* [current_state_number env] is (the integer number of) the automaton's - current state. This works even if the automaton's stack is empty, in - which case the current state is an initial state. This number can be - passed as an argument to a [message] function generated by [menhir - --compile-errors]. *) - - val current_state_number: 'a env -> int - - (* [equal env1 env2] tells whether the parser configurations [env1] and - [env2] are equal in the sense that the automaton's current state is the - same in [env1] and [env2] and the stack is *physically* the same in - [env1] and [env2]. If [equal env1 env2] is [true], then the sequence of - the stack elements, as observed via [pop] and [top], must be the same in - [env1] and [env2]. Also, if [equal env1 env2] holds, then the checkpoints - [input_needed env1] and [input_needed env2] must be equivalent. The - function [equal] has time complexity O(1). *) - - val equal: 'a env -> 'a env -> bool - - (* These are the start and end positions of the current lookahead token. If - invoked in an initial state, this function returns a pair of twice the - initial position. *) - - val positions: 'a env -> position * position - - (* When applied to an environment taken from a checkpoint of the form - [AboutToReduce (env, prod)], the function [env_has_default_reduction] - tells whether the reduction that is about to take place is a default - reduction. *) - - val env_has_default_reduction: 'a env -> bool - - (* [state_has_default_reduction s] tells whether the state [s] has a default - reduction. This includes the case where [s] is an accepting state. *) - - val state_has_default_reduction: _ lr1state -> bool - - (* [pop env] returns a new environment, where the parser's top stack cell - has been popped off. (If the stack is empty, [None] is returned.) This - amounts to pretending that the (terminal or nonterminal) symbol that - corresponds to this stack cell has not been read. *) - - val pop: 'a env -> 'a env option - - (* [force_reduction prod env] should be called only if in the state [env] - the parser is capable of reducing the production [prod]. If this - condition is satisfied, then this production is reduced, which means that - its semantic action is executed (this can have side effects!) and the - automaton makes a goto (nonterminal) transition. If this condition is not - satisfied, [Invalid_argument _] is raised. *) - - val force_reduction: production -> 'a env -> 'a env - - (* [input_needed env] returns [InputNeeded env]. That is, out of an [env] - that might have been obtained via a series of calls to the functions - [pop], [force_reduction], [feed], etc., it produces a checkpoint, which - can be used to resume normal parsing, by supplying this checkpoint as an - argument to [offer]. *) - - (* This function should be used with some care. It could "mess up the - lookahead" in the sense that it allows parsing to resume in an arbitrary - state [s] with an arbitrary lookahead symbol [t], even though Menhir's - reachability analysis (menhir --list-errors) might well think that it is - impossible to reach this particular configuration. If one is using - Menhir's new error reporting facility, this could cause the parser to - reach an error state for which no error message has been prepared. *) - - val input_needed: 'a env -> 'a checkpoint - -end - -(* This signature is a fragment of the inspection API that is made available - to the user when [--inspection] is used. This fragment contains type - definitions for symbols. *) - -module type SYMBOLS = sig - - (* The type ['a terminal] represents a terminal symbol. The type ['a - nonterminal] represents a nonterminal symbol. In both cases, the index - ['a] represents the type of the semantic values associated with this - symbol. The concrete definitions of these types are generated. *) - - type 'a terminal - type 'a nonterminal - - (* The type ['a symbol] represents a terminal or nonterminal symbol. It is - the disjoint union of the types ['a terminal] and ['a nonterminal]. *) - - type 'a symbol = - | T : 'a terminal -> 'a symbol - | N : 'a nonterminal -> 'a symbol - - (* The type [xsymbol] is an existentially quantified version of the type - ['a symbol]. This type is useful in situations where the index ['a] - is not statically known. *) - - type xsymbol = - | X : 'a symbol -> xsymbol - -end - -(* This signature describes the inspection API that is made available to the - user when [--inspection] is used. *) - -module type INSPECTION = sig - - (* The types of symbols are described above. *) - - include SYMBOLS - - (* The type ['a lr1state] is meant to be the same as in [INCREMENTAL_ENGINE]. *) - - type 'a lr1state - - (* The type [production] is meant to be the same as in [INCREMENTAL_ENGINE]. - It represents a production of the grammar. A production can be examined - via the functions [lhs] and [rhs] below. *) - - type production - - (* An LR(0) item is a pair of a production [prod] and a valid index [i] into - this production. That is, if the length of [rhs prod] is [n], then [i] is - comprised between 0 and [n], inclusive. *) - - type item = - production * int - - (* Ordering functions. *) - - val compare_terminals: _ terminal -> _ terminal -> int - val compare_nonterminals: _ nonterminal -> _ nonterminal -> int - val compare_symbols: xsymbol -> xsymbol -> int - val compare_productions: production -> production -> int - val compare_items: item -> item -> int - - (* [incoming_symbol s] is the incoming symbol of the state [s], that is, - the symbol that the parser must recognize before (has recognized when) - it enters the state [s]. This function gives access to the semantic - value [v] stored in a stack element [Element (s, v, _, _)]. Indeed, - by case analysis on the symbol [incoming_symbol s], one discovers the - type ['a] of the value [v]. *) - - val incoming_symbol: 'a lr1state -> 'a symbol - - (* [items s] is the set of the LR(0) items in the LR(0) core of the LR(1) - state [s]. This set is not epsilon-closed. This set is presented as a - list, in an arbitrary order. *) - - val items: _ lr1state -> item list - - (* [lhs prod] is the left-hand side of the production [prod]. This is - always a non-terminal symbol. *) - - val lhs: production -> xsymbol - - (* [rhs prod] is the right-hand side of the production [prod]. This is - a (possibly empty) sequence of (terminal or nonterminal) symbols. *) - - val rhs: production -> xsymbol list - - (* [nullable nt] tells whether the non-terminal symbol [nt] is nullable. - That is, it is true if and only if this symbol produces the empty - word [epsilon]. *) - - val nullable: _ nonterminal -> bool - - (* [first nt t] tells whether the FIRST set of the nonterminal symbol [nt] - contains the terminal symbol [t]. That is, it is true if and only if - [nt] produces a word that begins with [t]. *) - - val first: _ nonterminal -> _ terminal -> bool - - (* [xfirst] is analogous to [first], but expects a first argument of type - [xsymbol] instead of [_ terminal]. *) - - val xfirst: xsymbol -> _ terminal -> bool - - (* [foreach_terminal] enumerates the terminal symbols, including [error]. - [foreach_terminal_but_error] enumerates the terminal symbols, excluding - [error]. *) - - val foreach_terminal: (xsymbol -> 'a -> 'a) -> 'a -> 'a - val foreach_terminal_but_error: (xsymbol -> 'a -> 'a) -> 'a -> 'a - - (* The type [env] is meant to be the same as in [INCREMENTAL_ENGINE]. *) - - type 'a env - - (* [feed symbol startp semv endp env] causes the parser to consume the - (terminal or nonterminal) symbol [symbol], accompanied with the semantic - value [semv] and with the start and end positions [startp] and [endp]. - Thus, the automaton makes a transition, and reaches a new state. The - stack grows by one cell. This operation is permitted only if the current - state (as determined by [env]) has an outgoing transition labeled with - [symbol]. Otherwise, [Invalid_argument _] is raised. *) - - val feed: 'a symbol -> position -> 'a -> position -> 'b env -> 'b env - -end - -(* This signature combines the incremental API and the inspection API. *) - -module type EVERYTHING = sig - - include INCREMENTAL_ENGINE - - include INSPECTION - with type 'a lr1state := 'a lr1state - with type production := production - with type 'a env := 'a env - -end -end -module EngineTypes = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This file defines several types and module types that are used in the - specification of module [Engine]. *) - -(* --------------------------------------------------------------------------- *) - -(* It would be nice if we could keep the structure of stacks and environments - hidden. However, stacks and environments must be accessible to semantic - actions, so the following data structure definitions must be public. *) - -(* --------------------------------------------------------------------------- *) - -(* A stack is a linked list of cells. A sentinel cell -- which is its own - successor -- is used to mark the bottom of the stack. The sentinel cell - itself is not significant -- it contains dummy values. *) - -type ('state, 'semantic_value) stack = { - - (* The state that we should go back to if we pop this stack cell. *) - - (* This convention means that the state contained in the top stack cell is - not the current state [env.current]. It also means that the state found - within the sentinel is a dummy -- it is never consulted. This convention - is the same as that adopted by the code-based back-end. *) - - state: 'state; - - (* The semantic value associated with the chunk of input that this cell - represents. *) - - semv: 'semantic_value; - - (* The start and end positions of the chunk of input that this cell - represents. *) - - startp: Lexing.position; - endp: Lexing.position; - - (* The next cell down in the stack. If this is a self-pointer, then this - cell is the sentinel, and the stack is conceptually empty. *) - - next: ('state, 'semantic_value) stack; - -} - -(* --------------------------------------------------------------------------- *) - -(* A parsing environment contains all of the parser's state (except for the - current program point). *) - -type ('state, 'semantic_value, 'token) env = { - - (* If this flag is true, then the first component of [env.triple] should - be ignored, as it has been logically overwritten with the [error] - pseudo-token. *) - - error: bool; - - (* The last token that was obtained from the lexer, together with its start - and end positions. Warning: before the first call to the lexer has taken - place, a dummy (and possibly invalid) token is stored here. *) - - triple: 'token * Lexing.position * Lexing.position; - - (* The stack. In [CodeBackend], it is passed around on its own, - whereas, here, it is accessed via the environment. *) - - stack: ('state, 'semantic_value) stack; - - (* The current state. In [CodeBackend], it is passed around on its - own, whereas, here, it is accessed via the environment. *) - - current: 'state; - -} - -(* --------------------------------------------------------------------------- *) - -(* This signature describes the parameters that must be supplied to the LR - engine. *) - -module type TABLE = sig - - (* The type of automaton states. *) - - type state - - (* States are numbered. *) - - val number: state -> int - - (* The type of tokens. These can be thought of as real tokens, that is, - tokens returned by the lexer. They carry a semantic value. This type - does not include the [error] pseudo-token. *) - - type token - - (* The type of terminal symbols. These can be thought of as integer codes. - They do not carry a semantic value. This type does include the [error] - pseudo-token. *) - - type terminal - - (* The type of nonterminal symbols. *) - - type nonterminal - - (* The type of semantic values. *) - - type semantic_value - - (* A token is conceptually a pair of a (non-[error]) terminal symbol and - a semantic value. The following two functions are the pair projections. *) - - val token2terminal: token -> terminal - val token2value: token -> semantic_value - - (* Even though the [error] pseudo-token is not a real token, it is a - terminal symbol. Furthermore, for regularity, it must have a semantic - value. *) - - val error_terminal: terminal - val error_value: semantic_value - - (* [foreach_terminal] allows iterating over all terminal symbols. *) - - val foreach_terminal: (terminal -> 'a -> 'a) -> 'a -> 'a - - (* The type of productions. *) - - type production - - val production_index: production -> int - val find_production: int -> production - - (* If a state [s] has a default reduction on production [prod], then, upon - entering [s], the automaton should reduce [prod] without consulting the - lookahead token. The following function allows determining which states - have default reductions. *) - - (* Instead of returning a value of a sum type -- either [DefRed prod], or - [NoDefRed] -- it accepts two continuations, and invokes just one of - them. This mechanism allows avoiding a memory allocation. *) - - val default_reduction: - state -> - ('env -> production -> 'answer) -> - ('env -> 'answer) -> - 'env -> 'answer - - (* An LR automaton can normally take three kinds of actions: shift, reduce, - or fail. (Acceptance is a particular case of reduction: it consists in - reducing a start production.) *) - - (* There are two variants of the shift action. [shift/discard s] instructs - the automaton to discard the current token, request a new one from the - lexer, and move to state [s]. [shift/nodiscard s] instructs it to move to - state [s] without requesting a new token. This instruction should be used - when [s] has a default reduction on [#]. See [CodeBackend.gettoken] for - details. *) - - (* This is the automaton's action table. It maps a pair of a state and a - terminal symbol to an action. *) - - (* Instead of returning a value of a sum type -- one of shift/discard, - shift/nodiscard, reduce, or fail -- this function accepts three - continuations, and invokes just one them. This mechanism allows avoiding - a memory allocation. *) - - (* In summary, the parameters to [action] are as follows: - - - the first two parameters, a state and a terminal symbol, are used to - look up the action table; - - - the next parameter is the semantic value associated with the above - terminal symbol; it is not used, only passed along to the shift - continuation, as explained below; - - - the shift continuation expects an environment; a flag that tells - whether to discard the current token; the terminal symbol that - is being shifted; its semantic value; and the target state of - the transition; - - - the reduce continuation expects an environment and a production; - - - the fail continuation expects an environment; - - - the last parameter is the environment; it is not used, only passed - along to the selected continuation. *) - - val action: - state -> - terminal -> - semantic_value -> - ('env -> bool -> terminal -> semantic_value -> state -> 'answer) -> - ('env -> production -> 'answer) -> - ('env -> 'answer) -> - 'env -> 'answer - - (* This is the automaton's goto table. This table maps a pair of a state - and a nonterminal symbol to a new state. By extension, it also maps a - pair of a state and a production to a new state. *) - - (* The function [goto_nt] can be applied to [s] and [nt] ONLY if the state - [s] has an outgoing transition labeled [nt]. Otherwise, its result is - undefined. Similarly, the call [goto_prod prod s] is permitted ONLY if - the state [s] has an outgoing transition labeled with the nonterminal - symbol [lhs prod]. The function [maybe_goto_nt] involves an additional - dynamic check and CAN be called even if there is no outgoing transition. *) - - val goto_nt : state -> nonterminal -> state - val goto_prod: state -> production -> state - val maybe_goto_nt: state -> nonterminal -> state option - - (* [is_start prod] tells whether the production [prod] is a start production. *) - - val is_start: production -> bool - - (* By convention, a semantic action is responsible for: - - 1. fetching whatever semantic values and positions it needs off the stack; - - 2. popping an appropriate number of cells off the stack, as dictated - by the length of the right-hand side of the production; - - 3. computing a new semantic value, as well as new start and end positions; - - 4. pushing a new stack cell, which contains the three values - computed in step 3; - - 5. returning the new stack computed in steps 2 and 4. - - Point 1 is essentially forced upon us: if semantic values were fetched - off the stack by this interpreter, then the calling convention for - semantic actions would be variadic: not all semantic actions would have - the same number of arguments. The rest follows rather naturally. *) - - (* Semantic actions are allowed to raise [Error]. *) - - exception Error - - type semantic_action = - (state, semantic_value, token) env -> (state, semantic_value) stack - - val semantic_action: production -> semantic_action - - (* [may_reduce state prod] tests whether the state [state] is capable of - reducing the production [prod]. This function is currently costly and - is not used by the core LR engine. It is used in the implementation - of certain functions, such as [force_reduction], which allow the engine - to be driven programmatically. *) - - val may_reduce: state -> production -> bool - - (* The LR engine requires a number of hooks, which are used for logging. *) - - (* The comments below indicate the conventional messages that correspond - to these hooks in the code-based back-end; see [CodeBackend]. *) - - (* If the flag [log] is false, then the logging functions are not called. - If it is [true], then they are called. *) - - val log : bool - - module Log : sig - - (* State %d: *) - - val state: state -> unit - - (* Shifting () to state *) - - val shift: terminal -> state -> unit - - (* Reducing a production should be logged either as a reduction - event (for regular productions) or as an acceptance event (for - start productions). *) - - (* Reducing production / Accepting *) - - val reduce_or_accept: production -> unit - - (* Lookahead token is now (-) *) - - val lookahead_token: terminal -> Lexing.position -> Lexing.position -> unit - - (* Initiating error handling *) - - val initiating_error_handling: unit -> unit - - (* Resuming error handling *) - - val resuming_error_handling: unit -> unit - - (* Handling error in state *) - - val handling_error: state -> unit - - end - -end - -(* --------------------------------------------------------------------------- *) - -(* This signature describes the monolithic (traditional) LR engine. *) - -(* In this interface, the parser controls the lexer. *) - -module type MONOLITHIC_ENGINE = sig - - type state - - type token - - type semantic_value - - (* An entry point to the engine requires a start state, a lexer, and a lexing - buffer. It either succeeds and produces a semantic value, or fails and - raises [Error]. *) - - exception Error - - val entry: - (* strategy: *) [ `Legacy | `Simplified ] -> (* see [IncrementalEngine] *) - state -> - (Lexing.lexbuf -> token) -> - Lexing.lexbuf -> - semantic_value - -end - -(* --------------------------------------------------------------------------- *) - -(* The following signatures describe the incremental LR engine. *) - -(* First, see [INCREMENTAL_ENGINE] in the file [IncrementalEngine.ml]. *) - -(* The [start] function is set apart because we do not wish to publish - it as part of the generated [parser.mli] file. Instead, the table - back-end will publish specialized versions of it, with a suitable - type cast. *) - -module type INCREMENTAL_ENGINE_START = sig - - (* [start] is an entry point. It requires a start state and a start position - and begins the parsing process. If the lexer is based on an OCaml lexing - buffer, the start position should be [lexbuf.lex_curr_p]. [start] produces - a checkpoint, which usually will be an [InputNeeded] checkpoint. (It could - be [Accepted] if this starting state accepts only the empty word. It could - be [Rejected] if this starting state accepts no word at all.) It does not - raise any exception. *) - - (* [start s pos] should really produce a checkpoint of type ['a checkpoint], - for a fixed ['a] that depends on the state [s]. We cannot express this, so - we use [semantic_value checkpoint], which is safe. The table back-end uses - [Obj.magic] to produce safe specialized versions of [start]. *) - - type state - type semantic_value - type 'a checkpoint - - val start: - state -> - Lexing.position -> - semantic_value checkpoint - -end - -(* --------------------------------------------------------------------------- *) - -(* This signature describes the LR engine, which combines the monolithic - and incremental interfaces. *) - -module type ENGINE = sig - - include MONOLITHIC_ENGINE - - include IncrementalEngine.INCREMENTAL_ENGINE - with type token := token - and type 'a lr1state = state (* useful for us; hidden from the end user *) - - include INCREMENTAL_ENGINE_START - with type state := state - and type semantic_value := semantic_value - and type 'a checkpoint := 'a checkpoint - -end -end -module Engine = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -type position = Lexing.position -open EngineTypes - -(* The LR parsing engine. *) - -(* This module is used: - - - at compile time, if so requested by the user, via the --interpret options; - - at run time, in the table-based back-end. *) - -module Make (T : TABLE) = struct - - (* This propagates type and exception definitions. The functions [number], - [production_index], [find_production], too, are defined by this [include] - declaration. *) - - include T - - type 'a env = - (state, semantic_value, token) EngineTypes.env - - (* ------------------------------------------------------------------------ *) - - (* The type [checkpoint] represents an intermediate or final result of the - parser. See [EngineTypes]. *) - - (* The type [checkpoint] is presented to the user as a private type (see - [IncrementalEngine]). This prevents the user from manufacturing - checkpoints (i.e., continuations) that do not make sense. (Such - continuations could potentially violate the LR invariant and lead to - crashes.) *) - - (* 2017/03/29 Although [checkpoint] is a private type, we now expose a - constructor function, [input_needed]. This function allows manufacturing - a checkpoint out of an environment. For this reason, the type [env] must - also be parameterized with ['a]. *) - - type 'a checkpoint = - | InputNeeded of 'a env - | Shifting of 'a env * 'a env * bool - | AboutToReduce of 'a env * production - | HandlingError of 'a env - | Accepted of 'a - | Rejected - - (* ------------------------------------------------------------------------ *) - - (* As of 2020/12/16, we introduce a choice between multiple error handling - strategies. *) - - (* Regardless of the strategy, when a syntax error is encountered, the - function [initiate] is called, a [HandlingError] checkpoint is produced, - and (after resuming) the function [error] is called. This function checks - whether the current state allows shifting, reducing, or neither, when the - lookahead token is [error]. Its behavior, then, depends on the strategy, - as follows. *) - - (* In the legacy strategy, which until now was the only strategy, - - - If shifting is possible, then a [Shifting] checkpoint is produced, - whose field [please_discard] is [true], so (after resuming) an - [InputNeeded] checkpoint is produced, and (after a new token - has been provided) the parser leaves error-handling mode and - returns to normal mode. - - - If reducing is possible, then one or more reductions are performed. - Default reductions are announced via [AboutToReduce] checkpoints, - whereas ordinary reductions are performed silently. (It is unclear - why this is so.) The parser remains in error-handling mode, so - another [HandlingError] checkpoint is produced, and the function - [error] is called again. - - - If neither action is possible and if the stack is nonempty, then a - cell is popped off the stack, then a [HandlingError] checkpoint is - produced, and the function [error] is called again. - - - If neither action is possible and if the stack is empty, then the - parse dies with a [Reject] checkpoint. *) - - (* The simplified strategy differs from the legacy strategy as follows: - - - When shifting, a [Shifting] checkpoint is produced, whose field - [please_discard] is [false], so the parser does not request another - token, and the parser remains in error-handling mode. (If the - destination state of this shift transition has a default reduction, - then the parser will perform this reduction as its next step.) - - - When reducing, all reductions are announced by [AboutToReduce] - checkpoints. - - - If neither shifting [error] nor reducing on [error] is possible, - then the parser dies with a [Reject] checkpoint. (The parser does - not attempt to pop cells off the stack one by one.) - - This simplified strategy is appropriate when the grammar uses the [error] - token in a limited way, where the [error] token always appears at the end - of a production whose semantic action raises an exception (whose purpose - is to signal a syntax error and perhaps produce a custom message). Then, - the parser must not request one token past the syntax error. (In a REPL, - that would be undesirable.) It must perform as many reductions on [error] - as possible, then (if possible) shift the [error] token and move to a new - state where a default reduction will be possible. (Because the [error] - token always appears at the end of a production, no other action can - exist in that state, so a default reduction must exist.) The semantic - action raises an exception, and that is it. *) - - (* Let us note that it is also possible to perform no error handling at - all, or to perform customized error handling, by stopping as soon as - the first [ErrorHandling] checkpoint appears. *) - - type strategy = - [ `Legacy | `Simplified ] - - (* ------------------------------------------------------------------------ *) - - (* In the code-based back-end, the [run] function is sometimes responsible - for pushing a new cell on the stack. This is motivated by code sharing - concerns. In this interpreter, there is no such concern; [run]'s caller - is always responsible for updating the stack. *) - - (* In the code-based back-end, there is a [run] function for each state - [s]. This function can behave in two slightly different ways, depending - on when it is invoked, or (equivalently) depending on [s]. - - If [run] is invoked after shifting a terminal symbol (or, equivalently, - if [s] has a terminal incoming symbol), then [run] discards a token, - unless [s] has a default reduction on [#]. (Indeed, in that case, - requesting the next token might drive the lexer off the end of the input - stream.) - - If, on the other hand, [run] is invoked after performing a goto - transition, or invoked directly by an entry point, then there is nothing - to discard. - - These two cases are reflected in [CodeBackend.gettoken]. - - Here, the code is structured in a slightly different way. It is up to the - caller of [run] to indicate whether to discard a token, via the parameter - [please_discard]. This flag is set when [s] is being entered by shifting - a terminal symbol and [s] does not have a default reduction on [#]. *) - - (* The following recursive group of functions are tail recursive, produce a - checkpoint of type [semantic_value checkpoint], and cannot raise an - exception. A semantic action can raise [Error], but this exception is - immediately caught within [reduce]. *) - - let rec run env please_discard : semantic_value checkpoint = - - (* Log the fact that we just entered this state. *) - - if log then - Log.state env.current; - - (* If [please_discard] is set, we discard the current lookahead token and - fetch the next one. In order to request a token from the user, we - return an [InputNeeded] continuation, which, when invoked by the user, - will take us to [discard]. If [please_discard] is not set, we skip this - step and jump directly to [check_for_default_reduction]. *) - - if please_discard then - InputNeeded env - else - check_for_default_reduction env - - (* [discard env triple] stores [triple] into [env], overwriting the previous - token. It is invoked by [offer], which itself is invoked by the user in - response to an [InputNeeded] checkpoint. *) - - and discard env triple = - if log then begin - let (token, startp, endp) = triple in - Log.lookahead_token (T.token2terminal token) startp endp - end; - let env = { env with error = false; triple } in - check_for_default_reduction env - - and check_for_default_reduction env = - - (* Examine what situation we are in. This case analysis is analogous to - that performed in [CodeBackend.gettoken], in the sub-case where we do - not have a terminal incoming symbol. *) - - T.default_reduction - env.current - announce_reduce (* there is a default reduction; perform it *) - check_for_error_token (* there is none; continue below *) - env - - and check_for_error_token env = - - (* There is no default reduction. Consult the current lookahead token - so as to determine which action should be taken. *) - - (* Peeking at the first input token, without taking it off the input - stream, is done by reading [env.triple]. We are careful to first - check [env.error]. *) - - (* Note that, if [please_discard] was true, then we have just called - [discard], so the lookahead token cannot be [error]. *) - - (* Returning [HandlingError env] is like calling [error ~strategy env] - directly, except it allows the user to regain control and choose an - error-handling strategy. *) - - if env.error then begin - if log then - Log.resuming_error_handling(); - HandlingError env - end - else - let (token, _, _) = env.triple in - - (* We consult the two-dimensional action table, indexed by the - current state and the current lookahead token, in order to - determine which action should be taken. *) - - T.action - env.current (* determines a row *) - (T.token2terminal token) (* determines a column *) - (T.token2value token) - shift (* shift continuation *) - announce_reduce (* reduce continuation *) - initiate (* failure continuation *) - env - - (* ------------------------------------------------------------------------ *) - - (* This function takes care of shift transitions along a terminal symbol. - (Goto transitions are taken care of within [reduce] below.) The symbol - can be either an actual token or the [error] pseudo-token. *) - - (* Here, the lookahead token CAN be [error]. *) - - and shift env - (please_discard : bool) - (terminal : terminal) - (value : semantic_value) - (s' : state) = - - (* Log the transition. *) - - if log then - Log.shift terminal s'; - - (* Push a new cell onto the stack, containing the identity of the - state that we are leaving. *) - - let (_, startp, endp) = env.triple in - let stack = { - state = env.current; - semv = value; - startp; - endp; - next = env.stack; - } in - - (* Switch to state [s']. *) - - let new_env = { env with stack; current = s' } in - - (* Expose the transition to the user. (In principle, we have a choice - between exposing the transition before we take it, after we take - it, or at some point in between. This affects the number and type - of the parameters carried by [Shifting]. Here, we choose to expose - the transition after we take it; this allows [Shifting] to carry - only three parameters, whose meaning is simple.) *) - - Shifting (env, new_env, please_discard) - - (* ------------------------------------------------------------------------ *) - - (* The function [announce_reduce] stops the parser and returns a checkpoint - which allows the parser to be resumed by calling [reduce]. *) - - (* Only ordinary productions are exposed to the user. Start productions - are not exposed to the user. Reducing a start production simply leads - to the successful termination of the parser. *) - - and announce_reduce env (prod : production) = - if T.is_start prod then - accept env prod - else - AboutToReduce (env, prod) - - (* The function [reduce] takes care of reductions. It is invoked by - [resume] after an [AboutToReduce] event has been produced. *) - - (* Here, the lookahead token CAN be [error]. *) - - (* The production [prod] CANNOT be a start production. *) - - and reduce env (prod : production) = - - (* Log a reduction event. *) - - if log then - Log.reduce_or_accept prod; - - (* Invoke the semantic action. The semantic action is responsible for - truncating the stack and pushing a new cell onto the stack, which - contains a new semantic value. It can raise [Error]. *) - - (* If the semantic action terminates normally, it returns a new stack, - which becomes the current stack. *) - - (* If the semantic action raises [Error], we catch it and initiate error - handling. *) - - (* This [match/with/exception] construct requires OCaml 4.02. *) - - match T.semantic_action prod env with - | stack -> - - (* By our convention, the semantic action has produced an updated - stack. The state now found in the top stack cell is the return - state. *) - - (* Perform a goto transition. The target state is determined - by consulting the goto table at the return state and at - production [prod]. *) - - let current = T.goto_prod stack.state prod in - let env = { env with stack; current } in - run env false - - | exception Error -> - initiate env - - and accept env prod = - (* Log an accept event. *) - if log then - Log.reduce_or_accept prod; - (* Extract the semantic value out of the stack. *) - let v = env.stack.semv in - (* Finish. *) - Accepted v - - (* ------------------------------------------------------------------------ *) - - (* The following functions deal with errors. *) - - (* [initiate] initiates or resumes error handling. *) - - (* Here, the lookahead token CAN be [error]. *) - - and initiate env = - if log then - Log.initiating_error_handling(); - let env = { env with error = true } in - HandlingError env - - (* [error] handles errors. *) - - and error ~strategy env = - assert env.error; - - (* Consult the column associated with the [error] pseudo-token in the - action table. *) - - T.action - env.current (* determines a row *) - T.error_terminal (* determines a column *) - T.error_value - (error_shift ~strategy) (* shift continuation *) - (error_reduce ~strategy) (* reduce continuation *) - (error_fail ~strategy) (* failure continuation *) - env - - and error_shift ~strategy env please_discard terminal value s' = - assert (terminal = T.error_terminal && value = T.error_value); - - (* This state is capable of shifting the [error] token. *) - - if log then - Log.handling_error env.current; - - (* In the simplified strategy, we change [please_discard] to [false], - which means that we won't request the next token and (therefore) - we will remain in error-handling mode after shifting the [error] - token. *) - - let please_discard = - match strategy with `Legacy -> please_discard | `Simplified -> false - in - - shift env please_discard terminal value s' - - and error_reduce ~strategy env prod = - - (* This state is capable of performing a reduction on [error]. *) - - if log then - Log.handling_error env.current; - - (* In the legacy strategy, we call [reduce] instead of [announce_reduce], - apparently in an attempt to hide the reduction steps performed during - error handling. This seems inconsistent, as the default reduction steps - are still announced. In the simplified strategy, all reductions are - announced. *) - - match strategy with - | `Legacy -> - reduce env prod - | `Simplified -> - announce_reduce env prod - - and error_fail ~strategy env = - - (* This state is unable to handle errors. In the simplified strategy, we - die immediately. In the legacy strategy, we attempt to pop a stack - cell. (This amounts to forgetting part of what we have just read, in - the hope of reaching a state where we can shift the [error] token and - resume parsing in normal mode. Forgetting past input is not appropriate - when the goal is merely to produce a good syntax error message.) *) - - match strategy with - | `Simplified -> - Rejected - | `Legacy -> - - (* Attempt to pop a stack cell. *) - - let cell = env.stack in - let next = cell.next in - if next == cell then - - (* The stack is empty. Die. *) - - Rejected - - else begin - - (* The stack is nonempty. Pop a cell, updating the current state - with that found in the popped cell, and try again. *) - - let env = { env with - stack = next; - current = cell.state - } in - HandlingError env - - end - - (* End of the nest of tail recursive functions. *) - - (* ------------------------------------------------------------------------ *) - (* ------------------------------------------------------------------------ *) - - (* The incremental interface. See [EngineTypes]. *) - - (* [start s] begins the parsing process. *) - - let start (s : state) (initial : position) : semantic_value checkpoint = - - (* Build an empty stack. This is a dummy cell, which is its own successor. - Its [next] field WILL be accessed by [error_fail] if an error occurs and - is propagated all the way until the stack is empty. Its [endp] field WILL - be accessed (by a semantic action) if an epsilon production is reduced - when the stack is empty. *) - - let rec empty = { - state = s; (* dummy *) - semv = T.error_value; (* dummy *) - startp = initial; (* dummy *) - endp = initial; - next = empty; - } in - - (* Build an initial environment. *) - - (* Unfortunately, there is no type-safe way of constructing a - dummy token. Tokens carry semantic values, which in general - we cannot manufacture. This instance of [Obj.magic] could - be avoided by adopting a different representation (e.g., no - [env.error] field, and an option in the first component of - [env.triple]), but I like this representation better. *) - - let dummy_token = Obj.magic () in - let env = { - error = false; - triple = (dummy_token, initial, initial); (* dummy *) - stack = empty; - current = s; - } in - - (* Begin parsing. *) - - (* The parameter [please_discard] here is [true], which means we know - that we must read at least one token. This claim relies on the fact - that we have ruled out the two special cases where a start symbol - recognizes the empty language or the singleton language {epsilon}. *) - - run env true - - (* [offer checkpoint triple] is invoked by the user in response to a - checkpoint of the form [InputNeeded env]. It checks that [checkpoint] is - indeed of this form, and invokes [discard]. *) - - (* [resume checkpoint] is invoked by the user in response to a checkpoint of - the form [AboutToReduce (env, prod)] or [HandlingError env]. It checks - that [checkpoint] is indeed of this form, and invokes [reduce] or - [error], as appropriate. *) - - (* In reality, [offer] and [resume] accept an argument of type - [semantic_value checkpoint] and produce a checkpoint of the same type. - The choice of [semantic_value] is forced by the fact that this is the - parameter of the checkpoint [Accepted]. *) - - (* We change this as follows. *) - - (* We change the argument and result type of [offer] and [resume] from - [semantic_value checkpoint] to ['a checkpoint]. This is safe, in this - case, because we give the user access to values of type [t checkpoint] - only if [t] is indeed the type of the eventual semantic value for this - run. (More precisely, by examining the signatures [INCREMENTAL_ENGINE] - and [INCREMENTAL_ENGINE_START], one finds that the user can build a value - of type ['a checkpoint] only if ['a] is [semantic_value]. The table - back-end goes further than this and produces versions of [start] composed - with a suitable cast, which give the user access to a value of type - [t checkpoint] where [t] is the type of the start symbol.) *) - - let offer : 'a . 'a checkpoint -> - token * position * position -> - 'a checkpoint - = function - | InputNeeded env -> - Obj.magic discard env - | _ -> - invalid_arg "offer expects InputNeeded" - - let resume : 'a . ?strategy:strategy -> 'a checkpoint -> 'a checkpoint = - fun ?(strategy=`Legacy) checkpoint -> - match checkpoint with - | HandlingError env -> - Obj.magic error ~strategy env - | Shifting (_, env, please_discard) -> - Obj.magic run env please_discard - | AboutToReduce (env, prod) -> - Obj.magic reduce env prod - | _ -> - invalid_arg "resume expects HandlingError | Shifting | AboutToReduce" - - (* ------------------------------------------------------------------------ *) - (* ------------------------------------------------------------------------ *) - - (* The traditional interface. See [EngineTypes]. *) - - (* ------------------------------------------------------------------------ *) - - (* Wrapping a lexer and lexbuf as a token supplier. *) - - type supplier = - unit -> token * position * position - - let lexer_lexbuf_to_supplier - (lexer : Lexing.lexbuf -> token) - (lexbuf : Lexing.lexbuf) - : supplier = - fun () -> - let token = lexer lexbuf in - let startp = lexbuf.Lexing.lex_start_p - and endp = lexbuf.Lexing.lex_curr_p in - token, startp, endp - - (* ------------------------------------------------------------------------ *) - - (* The main loop repeatedly handles intermediate checkpoints, until a final - checkpoint is obtained. This allows implementing the monolithic interface - ([entry]) in terms of the incremental interface ([start], [offer], - [handle], [reduce]). *) - - (* By convention, acceptance is reported by returning a semantic value, - whereas rejection is reported by raising [Error]. *) - - (* [loop] is polymorphic in ['a]. No cheating is involved in achieving this. - All of the cheating resides in the types assigned to [offer] and [handle] - above. *) - - let rec loop : 'a . ?strategy:strategy -> supplier -> 'a checkpoint -> 'a = - fun ?(strategy=`Legacy) read checkpoint -> - match checkpoint with - | InputNeeded _ -> - (* The parser needs a token. Request one from the lexer, - and offer it to the parser, which will produce a new - checkpoint. Then, repeat. *) - let triple = read() in - let checkpoint = offer checkpoint triple in - loop ~strategy read checkpoint - | Shifting _ - | AboutToReduce _ - | HandlingError _ -> - (* The parser has suspended itself, but does not need - new input. Just resume the parser. Then, repeat. *) - let checkpoint = resume ~strategy checkpoint in - loop ~strategy read checkpoint - | Accepted v -> - (* The parser has succeeded and produced a semantic value. - Return this semantic value to the user. *) - v - | Rejected -> - (* The parser rejects this input. Raise an exception. *) - raise Error - - let entry strategy (s : state) lexer lexbuf : semantic_value = - let initial = lexbuf.Lexing.lex_curr_p in - loop ~strategy (lexer_lexbuf_to_supplier lexer lexbuf) (start s initial) - - (* ------------------------------------------------------------------------ *) - - (* [loop_handle] stops if it encounters an error, and at this point, invokes - its failure continuation, without letting Menhir do its own traditional - error-handling (which involves popping the stack, etc.). *) - - let rec loop_handle succeed fail read checkpoint = - match checkpoint with - | InputNeeded _ -> - let triple = read() in - let checkpoint = offer checkpoint triple in - loop_handle succeed fail read checkpoint - | Shifting _ - | AboutToReduce _ -> - (* Which strategy is passed to [resume] here is irrelevant, - since this checkpoint is not [HandlingError _]. *) - let checkpoint = resume checkpoint in - loop_handle succeed fail read checkpoint - | HandlingError _ - | Rejected -> - (* The parser has detected an error. Invoke the failure continuation. *) - fail checkpoint - | Accepted v -> - (* The parser has succeeded and produced a semantic value. Invoke the - success continuation. *) - succeed v - - (* ------------------------------------------------------------------------ *) - - (* [loop_handle_undo] is analogous to [loop_handle], except it passes a pair - of checkpoints to the failure continuation. - - The first (and oldest) checkpoint is the last [InputNeeded] checkpoint - that was encountered before the error was detected. The second (and - newest) checkpoint is where the error was detected, as in [loop_handle]. - Going back to the first checkpoint can be thought of as undoing any - reductions that were performed after seeing the problematic token. (These - reductions must be default reductions or spurious reductions.) *) - - let rec loop_handle_undo succeed fail read (inputneeded, checkpoint) = - match checkpoint with - | InputNeeded _ -> - (* Update the last recorded [InputNeeded] checkpoint. *) - let inputneeded = checkpoint in - let triple = read() in - let checkpoint = offer checkpoint triple in - loop_handle_undo succeed fail read (inputneeded, checkpoint) - | Shifting _ - | AboutToReduce _ -> - (* Which strategy is passed to [resume] here is irrelevant, - since this checkpoint is not [HandlingError _]. *) - let checkpoint = resume checkpoint in - loop_handle_undo succeed fail read (inputneeded, checkpoint) - | HandlingError _ - | Rejected -> - fail inputneeded checkpoint - | Accepted v -> - succeed v - - (* For simplicity, we publish a version of [loop_handle_undo] that takes a - single checkpoint as an argument, instead of a pair of checkpoints. We - check that the argument is [InputNeeded _], and duplicate it. *) - - (* The parser cannot accept or reject before it asks for the very first - character of input. (Indeed, we statically reject a symbol that - generates the empty language or the singleton language {epsilon}.) - So, the [start] checkpoint must match [InputNeeded _]. Hence, it is - permitted to call [loop_handle_undo] with a [start] checkpoint. *) - - let loop_handle_undo succeed fail read checkpoint = - assert (match checkpoint with InputNeeded _ -> true | _ -> false); - loop_handle_undo succeed fail read (checkpoint, checkpoint) - - (* ------------------------------------------------------------------------ *) - - let rec shifts checkpoint = - match checkpoint with - | Shifting (env, _, _) -> - (* The parser is about to shift, which means it is willing to - consume the terminal symbol that we have fed it. Return the - state just before this transition. *) - Some env - | AboutToReduce _ -> - (* The parser wishes to reduce. Just follow. *) - (* Which strategy is passed to [resume] here is irrelevant, - since this checkpoint is not [HandlingError _]. *) - shifts (resume checkpoint) - | HandlingError _ -> - (* The parser fails, which means it rejects the terminal symbol - that we have fed it. *) - None - | InputNeeded _ - | Accepted _ - | Rejected -> - (* None of these cases can arise. Indeed, after a token is submitted - to it, the parser must shift, reduce, or signal an error, before - it can request another token or terminate. *) - assert false - - let acceptable checkpoint token pos = - let triple = (token, pos, pos) in - let checkpoint = offer checkpoint triple in - match shifts checkpoint with - | None -> false - | Some _env -> true - - (* ------------------------------------------------------------------------ *) - - (* The type ['a lr1state] describes the (non-initial) states of the LR(1) - automaton. The index ['a] represents the type of the semantic value - associated with the state's incoming symbol. *) - - (* The type ['a lr1state] is defined as an alias for [state], which itself - is usually defined as [int] (see [TableInterpreter]). So, ['a lr1state] - is technically a phantom type, but should really be thought of as a GADT - whose data constructors happen to be represented as integers. It is - presented to the user as an abstract type (see [IncrementalEngine]). *) - - type 'a lr1state = - state - - (* ------------------------------------------------------------------------ *) - - (* Stack inspection. *) - - (* We offer a read-only view of the parser's state as a stream of elements. - Each element contains a pair of a (non-initial) state and a semantic - value associated with (the incoming symbol of) this state. Note that the - type [element] is an existential type. *) - - (* As of 2017/03/31, the type [stack] and the function [stack] are DEPRECATED. - If desired, they could now be implemented outside Menhir, by relying on - the functions [top] and [pop]. *) - - type element = - | Element: 'a lr1state * 'a * position * position -> element - - open General - - type stack = - element stream - - (* If [current] is the current state and [cell] is the top stack cell, - then [stack cell current] is a view of the parser's state as a stream - of elements. *) - - let rec stack cell current : element stream = - lazy ( - (* The stack is empty iff the top stack cell is its own successor. In - that case, the current state [current] should be an initial state - (which has no incoming symbol). - We do not allow the user to inspect this state. *) - let next = cell.next in - if next == cell then - Nil - else - (* Construct an element containing the current state [current] as well - as the semantic value contained in the top stack cell. This semantic - value is associated with the incoming symbol of this state, so it - makes sense to pair them together. The state has type ['a state] and - the semantic value has type ['a], for some type ['a]. Here, the OCaml - type-checker thinks ['a] is [semantic_value] and considers this code - well-typed. Outside, we will use magic to provide the user with a way - of inspecting states and recovering the value of ['a]. *) - let element = Element ( - current, - cell.semv, - cell.startp, - cell.endp - ) in - Cons (element, stack next cell.state) - ) - - let stack env : element stream = - stack env.stack env.current - - (* As explained above, the function [top] allows access to the top stack - element only if the stack is nonempty, i.e., only if the current state - is not an initial state. *) - - let top env : element option = - let cell = env.stack in - let next = cell.next in - if next == cell then - None - else - Some (Element (env.current, cell.semv, cell.startp, cell.endp)) - - (* [equal] compares the stacks for physical equality, and compares the - current states via their numbers (this seems cleaner than using OCaml's - polymorphic equality). *) - - (* The two fields that are not compared by [equal], namely [error] and - [triple], are overwritten by the function [discard], which handles - [InputNeeded] checkpoints. Thus, if [equal env1 env2] holds, then the - checkpoints [input_needed env1] and [input_needed env2] are - equivalent: they lead the parser to behave in the same way. *) - - let equal env1 env2 = - env1.stack == env2.stack && - number env1.current = number env2.current - - let current_state_number env = - number env.current - - (* ------------------------------------------------------------------------ *) - - (* Access to the position of the lookahead token. *) - - let positions { triple = (_, startp, endp); _ } = - startp, endp - - (* ------------------------------------------------------------------------ *) - - (* Access to information about default reductions. *) - - (* This can be a function of states, or a function of environments. - We offer both. *) - - (* Instead of a Boolean result, we could return a [production option]. - However, we would have to explicitly test whether [prod] is a start - production, and in that case, return [None], I suppose. Indeed, we - have decided not to expose the start productions. *) - - let state_has_default_reduction (state : _ lr1state) : bool = - T.default_reduction state - (fun _env _prod -> true) - (fun _env -> false) - () - - let env_has_default_reduction env = - state_has_default_reduction env.current - - (* ------------------------------------------------------------------------ *) - - (* The following functions work at the level of environments (as opposed to - checkpoints). The function [pop] causes the automaton to go back into the - past, pretending that the last input symbol has never been read. The - function [force_reduction] causes the automaton to re-interpret the past, - by recognizing the right-hand side of a production and reducing this - production. The function [feed] causes the automaton to progress into the - future by pretending that a (terminal or nonterminal) symbol has been - read. *) - - (* The function [feed] would ideally be defined here. However, for this - function to be type-safe, the GADT ['a symbol] is needed. For this - reason, we move its definition to [InspectionTableInterpreter], where - the inspection API is available. *) - - (* [pop] pops one stack cell. It cannot go wrong. *) - - let pop (env : 'a env) : 'a env option = - let cell = env.stack in - let next = cell.next in - if next == cell then - (* The stack is empty. *) - None - else - (* The stack is nonempty. Pop off one cell. *) - Some { env with stack = next; current = cell.state } - - (* [force_reduction] is analogous to [reduce], except that it does not - continue by calling [run env] or [initiate env]. Instead, it returns - [env] to the user. *) - - (* [force_reduction] is dangerous insofar as it executes a semantic action. - This semantic action could have side effects: nontermination, state, - exceptions, input/output, etc. *) - - let force_reduction prod (env : 'a env) : 'a env = - (* Check if this reduction is permitted. This check is REALLY important. - The stack must have the correct shape: that is, it must be sufficiently - high, and must contain semantic values of appropriate types, otherwise - the semantic action will crash and burn. *) - (* We currently check whether the current state is WILLING to reduce this - production (i.e., there is a reduction action in the action table row - associated with this state), whereas it would be more liberal to check - whether this state is CAPABLE of reducing this production (i.e., the - stack has an appropriate shape). We currently have no means of - performing such a check. *) - if not (T.may_reduce env.current prod) then - invalid_arg "force_reduction: this reduction is not permitted in this state" - else begin - (* We do not expose the start productions to the user, so this cannot be - a start production. Hence, it has a semantic action. *) - assert (not (T.is_start prod)); - (* Invoke the semantic action. *) - let stack = T.semantic_action prod env in - (* Perform a goto transition. *) - let current = T.goto_prod stack.state prod in - { env with stack; current } - end - - (* The environment manipulation functions -- [pop] and [force_reduction] - above, plus [feed] -- manipulate the automaton's stack and current state, - but do not affect the automaton's lookahead symbol. When the function - [input_needed] is used to go back from an environment to a checkpoint - (and therefore, resume normal parsing), the lookahead symbol is clobbered - anyway, since the only action that the user can take is to call [offer]. - So far, so good. One problem, though, is that this call to [offer] may - well place the automaton in a configuration of a state [s] and a - lookahead symbol [t] that is normally unreachable. Also, perhaps the - state [s] is a state where an input symbol normally is never demanded, so - this [InputNeeded] checkpoint is fishy. There does not seem to be a deep - problem here, but, when programming an error recovery strategy, one - should pay some attention to this issue. Ideally, perhaps, one should use - [input_needed] only in a state [s] where an input symbol is normally - demanded, that is, a state [s] whose incoming symbol is a terminal symbol - and which does not have a default reduction on [#]. *) - - let input_needed (env : 'a env) : 'a checkpoint = - InputNeeded env - - (* The following functions are compositions of [top] and [pop]. *) - - let rec pop_many i env = - if i = 0 then - Some env - else match pop env with - | None -> - None - | Some env -> - pop_many (i - 1) env - - let get i env = - match pop_many i env with - | None -> - None - | Some env -> - top env - -end -end -module ErrorReports = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* -------------------------------------------------------------------------- *) - -(* A two-place buffer stores zero, one, or two elements. *) - -type 'a content = -| Zero -| One of 'a -| Two of 'a * (* most recent: *) 'a - -type 'a buffer = - 'a content ref - -(* [update buffer x] pushes [x] into [buffer], causing the buffer to slide. *) - -let update buffer x = - buffer := - match !buffer, x with - | Zero, _ -> - One x - | One x1, x2 - | Two (_, x1), x2 -> - Two (x1, x2) - -let show f buffer : string = - match !buffer with - | Zero -> - (* The buffer cannot be empty. If we have read no tokens, - we cannot have detected a syntax error. *) - assert false - | One invalid -> - (* It is unlikely, but possible, that we have read just one token. *) - Printf.sprintf "before '%s'" (f invalid) - | Two (valid, invalid) -> - (* In the most likely case, we have read two tokens. *) - Printf.sprintf "after '%s' and before '%s'" (f valid) (f invalid) - -let last buffer = - match !buffer with - | Zero -> - (* The buffer cannot be empty. If we have read no tokens, - we cannot have detected a syntax error. *) - assert false - | One invalid - | Two (_, invalid) -> - invalid - -open Lexing - -let wrap lexer = - let buffer = ref Zero in - buffer, - fun lexbuf -> - let token = lexer lexbuf in - update buffer (lexbuf.lex_start_p, lexbuf.lex_curr_p); - token - -let wrap_supplier supplier = - let buffer = ref Zero in - buffer, - fun () -> - let (_token, pos1, pos2) as triple = supplier() in - update buffer (pos1, pos2); - triple - -(* -------------------------------------------------------------------------- *) - -let extract text (pos1, pos2) : string = - let ofs1 = pos1.pos_cnum - and ofs2 = pos2.pos_cnum in - let len = ofs2 - ofs1 in - try - String.sub text ofs1 len - with Invalid_argument _ -> - (* In principle, this should not happen, but if it does, let's make this - a non-fatal error. *) - "???" - -let sanitize text = - String.map (fun c -> - if Char.code c < 32 then ' ' else c - ) text - -(* If we were willing to depend on [Str], we could implement [compress] as - follows: - - let compress text = - Str.global_replace (Str.regexp "[ \t\n\r]+") " " text - - *) - -let rec compress n b i j skipping = - if j < n then - let c, j = Bytes.get b j, j + 1 in - match c with - | ' ' | '\t' | '\n' | '\r' -> - let i = if not skipping then (Bytes.set b i ' '; i + 1) else i in - let skipping = true in - compress n b i j skipping - | _ -> - let i = Bytes.set b i c; i + 1 in - let skipping = false in - compress n b i j skipping - else - Bytes.sub_string b 0 i - -let compress text = - let b = Bytes.of_string text in - let n = Bytes.length b in - compress n b 0 0 false - -let shorten k text = - let n = String.length text in - if n <= 2 * k + 3 then - text - else - String.sub text 0 k ^ - "..." ^ - String.sub text (n - k) k - -let is_digit c = - let c = Char.code c in - Char.code '0' <= c && c <= Char.code '9' - -exception Copy - -let expand f text = - let n = String.length text in - let b = Buffer.create n in - let rec loop i = - if i < n then begin - let c, i = text.[i], i + 1 in - loop ( - try - if c <> '$' then raise Copy; - let j = ref i in - while !j < n && is_digit text.[!j] do incr j done; - if i = !j then raise Copy; - let k = int_of_string (String.sub text i (!j - i)) in - Buffer.add_string b (f k); - !j - with Copy -> - (* We reach this point if either [c] is not '$' or [c] is '$' - but is not followed by an integer literal. *) - Buffer.add_char b c; - i - ) - end - else - Buffer.contents b - in - loop 0 -end -module LexerUtil = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -open Lexing -open Printf - -let init filename lexbuf = - lexbuf.lex_curr_p <- { - pos_fname = filename; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0 - }; - lexbuf - -let read filename = - let c = open_in filename in - let text = really_input_string c (in_channel_length c) in - close_in c; - let lexbuf = Lexing.from_string text in - text, init filename lexbuf - -let newline lexbuf = - let pos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { pos with - pos_lnum = pos.pos_lnum + 1; - pos_bol = pos.pos_cnum; - } - -let is_dummy (pos1, pos2) = - pos1 == dummy_pos || pos2 == dummy_pos - -let range ((pos1, pos2) as range) = - if is_dummy range then - sprintf "At an unknown location:\n" - else - let file = pos1.pos_fname in - let line = pos1.pos_lnum in - let char1 = pos1.pos_cnum - pos1.pos_bol in - let char2 = pos2.pos_cnum - pos1.pos_bol in (* yes, [pos1.pos_bol] *) - sprintf "File \"%s\", line %d, characters %d-%d:\n" - file line char1 char2 - (* use [char1 + 1] and [char2 + 1] if *not* using Caml mode *) -end -module Printers = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -module Make - (I : IncrementalEngine.EVERYTHING) - (User : sig - val print: string -> unit - val print_symbol: I.xsymbol -> unit - val print_element: (I.element -> unit) option - end) -= struct - - let arrow = " -> " - let dot = "." - let space = " " - let newline = "\n" - - open User - open I - - (* Printing a list of symbols. An optional dot is printed at offset - [i] into the list [symbols], if this offset lies between [0] and - the length of the list (included). *) - - let rec print_symbols i symbols = - if i = 0 then begin - print dot; - print space; - print_symbols (-1) symbols - end - else begin - match symbols with - | [] -> - () - | symbol :: symbols -> - print_symbol symbol; - print space; - print_symbols (i - 1) symbols - end - - (* Printing an element as a symbol. *) - - let print_element_as_symbol element = - match element with - | Element (s, _, _, _) -> - print_symbol (X (incoming_symbol s)) - - (* Some of the functions that follow need an element printer. They use - [print_element] if provided by the user; otherwise they use - [print_element_as_symbol]. *) - - let print_element = - match print_element with - | Some print_element -> - print_element - | None -> - print_element_as_symbol - - (* Printing a stack as a list of symbols. Stack bottom on the left, - stack top on the right. *) - - let rec print_stack env = - match top env, pop env with - | Some element, Some env -> - print_stack env; - print space; - print_element element - | _, _ -> - () - - let print_stack env = - print_stack env; - print newline - - (* Printing an item. *) - - let print_item (prod, i) = - print_symbol (lhs prod); - print arrow; - print_symbols i (rhs prod); - print newline - - (* Printing a list of symbols (public version). *) - - let print_symbols symbols = - print_symbols (-1) symbols - - (* Printing a production (without a dot). *) - - let print_production prod = - print_item (prod, -1) - - (* Printing the current LR(1) state. *) - - let print_current_state env = - print "Current LR(1) state: "; - match top env with - | None -> - print ""; (* TEMPORARY unsatisfactory *) - print newline - | Some (Element (current, _, _, _)) -> - print (string_of_int (number current)); - print newline; - List.iter print_item (items current) - - let print_env env = - print_stack env; - print_current_state env; - print newline - -end -end -module InfiniteArray = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(** This module implements infinite arrays, that is, arrays that grow - transparently upon demand. *) - -type 'a t = { - default: 'a; - mutable table: 'a array; - mutable extent: int; (* the index of the greatest [set] ever, plus one *) - } - -let default_size = - 16384 (* must be non-zero *) - -let make x = { - default = x; - table = Array.make default_size x; - extent = 0; -} - -let rec new_length length i = - if i < length then - length - else - new_length (2 * length) i - -let ensure a i = - assert (0 <= i); - let table = a.table in - let length = Array.length table in - if i >= length then begin - let table' = Array.make (new_length (2 * length) i) a.default in - Array.blit table 0 table' 0 length; - a.table <- table' - end - -let get a i = - ensure a i; - Array.unsafe_get a.table (i) - -let set a i x = - ensure a i; - Array.unsafe_set a.table (i) x; - if a.extent <= i then - a.extent <- i + 1 - -let extent a = - a.extent - -let domain a = - Array.sub a.table 0 a.extent - -end -module PackedIntArray = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* A packed integer array is represented as a pair of an integer [k] and - a string [s]. The integer [k] is the number of bits per integer that we - use. The string [s] is just an array of bits, which is read in 8-bit - chunks. *) - -(* The ocaml programming language treats string literals and array literals - in slightly different ways: the former are statically allocated, while - the latter are dynamically allocated. (This is rather arbitrary.) In the - context of Menhir's table-based back-end, where compact, immutable - integer arrays are needed, ocaml strings are preferable to ocaml arrays. *) - -type t = - int * string - -(* The magnitude [k] of an integer [v] is the number of bits required - to represent [v]. It is rounded up to the nearest power of two, so - that [k] divides [Sys.word_size]. *) - -let magnitude (v : int) = - if v < 0 then - Sys.word_size - else - let rec check k max = (* [max] equals [2^k] *) - if (max <= 0) || (v < max) then - k - (* if [max] just overflew, then [v] requires a full ocaml - integer, and [k] is the number of bits in an ocaml integer - plus one, that is, [Sys.word_size]. *) - else - check (2 * k) (max * max) - in - check 1 2 - -(* [pack a] turns an array of integers into a packed integer array. *) - -(* Because the sign bit is the most significant bit, the magnitude of - any negative number is the word size. In other words, [pack] does - not achieve any space savings as soon as [a] contains any negative - numbers, even if they are ``small''. *) - -let pack (a : int array) : t = - - let m = Array.length a in - - (* Compute the maximum magnitude of the array elements. This tells - us how many bits per element we are going to use. *) - - let k = - Array.fold_left (fun k v -> - max k (magnitude v) - ) 1 a - in - - (* Because access to ocaml strings is performed on an 8-bit basis, - two cases arise. If [k] is less than 8, then we can pack multiple - array entries into a single character. If [k] is greater than 8, - then we must use multiple characters to represent a single array - entry. *) - - if k <= 8 then begin - - (* [w] is the number of array entries that we pack in a character. *) - - assert (8 mod k = 0); - let w = 8 / k in - - (* [n] is the length of the string that we allocate. *) - - let n = - if m mod w = 0 then - m / w - else - m / w + 1 - in - - let s = - Bytes.create n - in - - (* Define a reader for the source array. The reader might run off - the end if [w] does not divide [m]. *) - - let i = ref 0 in - let next () = - let ii = !i in - if ii = m then - 0 (* ran off the end, pad with zeroes *) - else - let v = a.(ii) in - i := ii + 1; - v - in - - (* Fill up the string. *) - - for j = 0 to n - 1 do - let c = ref 0 in - for _x = 1 to w do - c := (!c lsl k) lor next() - done; - Bytes.set s j (Char.chr !c) - done; - - (* Done. *) - - k, Bytes.unsafe_to_string s - - end - else begin (* k > 8 *) - - (* [w] is the number of characters that we use to encode an array entry. *) - - assert (k mod 8 = 0); - let w = k / 8 in - - (* [n] is the length of the string that we allocate. *) - - let n = - m * w - in - - let s = - Bytes.create n - in - - (* Fill up the string. *) - - for i = 0 to m - 1 do - let v = ref a.(i) in - for x = 1 to w do - Bytes.set s ((i + 1) * w - x) (Char.chr (!v land 255)); - v := !v lsr 8 - done - done; - - (* Done. *) - - k, Bytes.unsafe_to_string s - - end - -(* Access to a string. *) - -let read (s : string) (i : int) : int = - Char.code (String.unsafe_get s i) - -(* [get1 t i] returns the integer stored in the packed array [t] at index [i]. - It assumes (and does not check) that the array's bit width is [1]. The - parameter [t] is just a string. *) - -let get1 (s : string) (i : int) : int = - let c = read s (i lsr 3) in - let c = c lsr ((lnot i) land 0b111) in - let c = c land 0b1 in - c - -(* [get t i] returns the integer stored in the packed array [t] at index [i]. *) - -(* Together, [pack] and [get] satisfy the following property: if the index [i] - is within bounds, then [get (pack a) i] equals [a.(i)]. *) - -let get ((k, s) : t) (i : int) : int = - match k with - | 1 -> - get1 s i - | 2 -> - let c = read s (i lsr 2) in - let c = c lsr (2 * ((lnot i) land 0b11)) in - let c = c land 0b11 in - c - | 4 -> - let c = read s (i lsr 1) in - let c = c lsr (4 * ((lnot i) land 0b1)) in - let c = c land 0b1111 in - c - | 8 -> - read s i - | 16 -> - let j = 2 * i in - (read s j) lsl 8 + read s (j + 1) - | _ -> - assert (k = 32); (* 64 bits unlikely, not supported *) - let j = 4 * i in - (((read s j lsl 8) + read s (j + 1)) lsl 8 + read s (j + 2)) lsl 8 + read s (j + 3) - -(* [unflatten1 (n, data) i j] accesses the two-dimensional bitmap - represented by [(n, data)] at indices [i] and [j]. The integer - [n] is the width of the bitmap; the string [data] is the second - component of the packed array obtained by encoding the table as - a one-dimensional array. *) - -let unflatten1 (n, data) i j = - get1 data (n * i + j) - -end -module RowDisplacement = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This module compresses a two-dimensional table, where some values - are considered insignificant, via row displacement. *) - -(* This idea reportedly appears in Aho and Ullman's ``Principles - of Compiler Design'' (1977). It is evaluated in Tarjan and Yao's - ``Storing a Sparse Table'' (1979) and in Dencker, Dürre, and Heuft's - ``Optimization of Parser Tables for Portable Compilers'' (1984). *) - -(* A compressed table is represented as a pair of arrays. The - displacement array is an array of offsets into the data array. *) - -type 'a table = - int array * (* displacement *) - 'a array (* data *) - -(* In a natural version of this algorithm, displacements would be greater - than (or equal to) [-n]. However, in the particular setting of Menhir, - both arrays are intended to be compressed with [PackedIntArray], which - does not efficiently support negative numbers. For this reason, we are - careful not to produce negative displacements. *) - -(* In order to avoid producing negative displacements, we simply use the - least significant bit as the sign bit. This is implemented by [encode] - and [decode] below. *) - -(* One could also think, say, of adding [n] to every displacement, so as - to ensure that all displacements are nonnegative. This would work, but - would require [n] to be published, for use by the decoder. *) - -let encode (displacement : int) : int = - if displacement >= 0 then - displacement lsl 1 - else - (-displacement) lsl 1 + 1 - -let decode (displacement : int) : int = - if displacement land 1 = 0 then - displacement lsr 1 - else - -(displacement lsr 1) - -(* It is reasonable to assume that, as matrices grow large, their - density becomes low, i.e., they have many insignificant entries. - As a result, it is important to work with a sparse data structure - for rows. We internally represent a row as a list of its - significant entries, where each entry is a pair of a [j] index and - an element. *) - -type 'a row = - (int * 'a) list - -(* [compress equal insignificant dummy m n t] turns the two-dimensional table - [t] into a compressed table. The parameter [equal] is equality of data - values. The parameter [wildcard] tells which data values are insignificant, - and can thus be overwritten with other values. The parameter [dummy] is - used to fill holes in the data array. [m] and [n] are the integer - dimensions of the table [t]. *) - -let compress - (equal : 'a -> 'a -> bool) - (insignificant : 'a -> bool) - (dummy : 'a) - (m : int) (n : int) - (t : 'a array array) - : 'a table = - - (* Be defensive. *) - - assert (Array.length t = m); - assert begin - for i = 0 to m - 1 do - assert (Array.length t.(i) = n) - done; - true - end; - - (* This turns a row-as-array into a row-as-sparse-list. The row is - accompanied by its index [i] and by its rank (the number of its - significant entries, that is, the length of the row-as-a-list. *) - - let sparse (i : int) (line : 'a array) : int * int * 'a row (* index, rank, row *) = - - let rec loop (j : int) (rank : int) (row : 'a row) = - if j < 0 then - i, rank, row - else - let x = line.(j) in - if insignificant x then - loop (j - 1) rank row - else - loop (j - 1) (1 + rank) ((j, x) :: row) - in - - loop (n - 1) 0 [] - - in - - (* Construct an array of all rows, together with their index and rank. *) - - let rows : (int * int * 'a row) array = (* index, rank, row *) - Array.mapi sparse t - in - - (* Sort this array by decreasing rank. This does not have any impact - on correctness, but reportedly improves compression. The - intuitive idea is that rows with few significant elements are - easy to fit, so they should be inserted last, after the problem - has become quite constrained by fitting the heavier rows. This - heuristic is attributed to Ziegler. *) - - Array.fast_sort (fun (_, rank1, _) (_, rank2, _) -> - compare rank2 rank1 - ) rows; - - (* Allocate a one-dimensional array of displacements. *) - - let displacement : int array = - Array.make m 0 - in - - (* Allocate a one-dimensional, infinite array of values. Indices - into this array are written [k]. *) - - let data : 'a InfiniteArray.t = - InfiniteArray.make dummy - in - - (* Determine whether [row] fits at offset [k] within the current [data] - array, up to extension of this array. *) - - (* Note that this check always succeeds when [k] equals the length of - the [data] array. Indeed, the loop is then skipped. This property - guarantees the termination of the recursive function [fit] below. *) - - let fits k (row : 'a row) : bool = - - let d = InfiniteArray.extent data in - - let rec loop = function - | [] -> - true - | (j, x) :: row -> - - (* [x] is a significant element. *) - - (* By hypothesis, [k + j] is nonnegative. If it is greater than or - equal to the current length of the data array, stop -- the row - fits. *) - - assert (k + j >= 0); - - if k + j >= d then - true - - (* We now know that [k + j] is within bounds of the data - array. Check whether it is compatible with the element [y] found - there. If it is, continue. If it isn't, stop -- the row does not - fit. *) - - else - let y = InfiniteArray.get data (k + j) in - if insignificant y || equal x y then - loop row - else - false - - in - loop row - - in - - (* Find the leftmost position where a row fits. *) - - (* If the leftmost significant element in this row is at offset [j], - then we can hope to fit as far left as [-j] -- so this element - lands at offset [0] in the data array. *) - - (* Note that displacements may be negative. This means that, for - insignificant elements, accesses to the data array could fail: they could - be out of bounds, either towards the left or towards the right. This is - not a problem, as long as [get] is invoked only at significant - elements. *) - - let rec fit k row : int = - if fits k row then - k - else - fit (k + 1) row - in - - let fit row = - match row with - | [] -> - 0 (* irrelevant *) - | (j, _) :: _ -> - fit (-j) row - in - - (* Write [row] at (compatible) offset [k]. *) - - let rec write k = function - | [] -> - () - | (j, x) :: row -> - InfiniteArray.set data (k + j) x; - write k row - in - - (* Iterate over the sorted array of rows. Fit and write each row at - the leftmost compatible offset. Update the displacement table. *) - - Array.iter (fun (i, _, row) -> - let k = fit row in (* if [row] has leading insignificant elements, then [k] can be negative *) - write k row; - displacement.(i) <- encode k - ) rows; - - (* Return the compressed tables. *) - - displacement, InfiniteArray.domain data - -(* [get ct i j] returns the value found at indices [i] and [j] in the - compressed table [ct]. This function call is permitted only if the - value found at indices [i] and [j] in the original table is - significant -- otherwise, it could fail abruptly. *) - -(* Together, [compress] and [get] have the property that, if the value - found at indices [i] and [j] in an uncompressed table [t] is - significant, then [get (compress t) i j] is equal to that value. *) - -let get (displacement, data) i j = - assert (0 <= i && i < Array.length displacement); - let k = decode displacement.(i) in - assert (0 <= k + j && k + j < Array.length data); - (* failure of this assertion indicates an attempt to access an - insignificant element that happens to be mapped out of the bounds - of the [data] array. *) - data.(k + j) - -(* [getget] is a variant of [get] which only requires read access, - via accessors, to the two components of the table. *) - -let getget get_displacement get_data (displacement, data) i j = - let k = decode (get_displacement displacement i) in - get_data data (k + j) -end -module LinearizedArray = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* The [entry] array contains offsets into the [data] array. It has [n+1] - elements if the original (unencoded) array has [n] elements. The value - of [entry.(n)] is the length of the [data] array. This convention is - natural and allows avoiding a special case. *) - -type 'a t = - (* data: *) 'a array * - (* entry: *) int array - -let make (a : 'a array array) : 'a t = - let n = Array.length a in - (* Build the entry array. *) - let size = ref 0 in - let entry = Array.init (n + 1) (fun i -> - let s = !size in - if i < n then - size := s + Array.length a.(i); - s - ) in - assert (entry.(n) = !size); - (* Build the data array. *) - let i = ref 0 - and j = ref 0 in - let data = Array.init !size (fun _ -> - while !j = Array.length a.(!i) do - i := !i + 1; - j := 0; - done; - let x = a.(!i).(!j) in - j := !j + 1; - x - ) in - data, entry - -let length ((_, entry) : 'a t) : int = - Array.length entry - -let row_length ((_, entry) : 'a t) i : int = - entry.(i + 1) - entry.(i) - -let row_length_via get_entry i = - get_entry (i + 1) - get_entry i - -let read ((data, entry) as la : 'a t) i j : 'a = - assert (0 <= j && j < row_length la i); - data.(entry.(i) + j) - -let read_via get_data get_entry i j = - assert (0 <= j && j < row_length_via get_entry i); - get_data (get_entry i + j) - -let write ((data, entry) as la : 'a t) i j (v : 'a) : unit = - assert (0 <= j && j < row_length la i); - data.(entry.(i) + j) <- v - -let rec read_interval_via get_data i j = - if i = j then - [] - else - get_data i :: read_interval_via get_data (i + 1) j - -let read_row_via get_data get_entry i = - read_interval_via get_data (get_entry i) (get_entry (i + 1)) - -let read_row ((data, entry) : 'a t) i : 'a list = - read_row_via (Array.get data) (Array.get entry) i - -end -module TableFormat = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This signature defines the format of the parse tables. It is used as - an argument to [TableInterpreter.Make]. *) - -module type TABLES = sig - - (* This is the parser's type of tokens. *) - - type token - - (* This maps a token to its internal (generation-time) integer code. *) - - val token2terminal: token -> int - - (* This is the integer code for the error pseudo-token. *) - - val error_terminal: int - - (* This maps a token to its semantic value. *) - - val token2value: token -> Obj.t - - (* Traditionally, an LR automaton is described by two tables, namely, an - action table and a goto table. See, for instance, the Dragon book. - - The action table is a two-dimensional matrix that maps a state and a - lookahead token to an action. An action is one of: shift to a certain - state, reduce a certain production, accept, or fail. - - The goto table is a two-dimensional matrix that maps a state and a - non-terminal symbol to either a state or undefined. By construction, this - table is sparse: its undefined entries are never looked up. A compression - technique is free to overlap them with other entries. - - In Menhir, things are slightly different. If a state has a default - reduction on token [#], then that reduction must be performed without - consulting the lookahead token. As a result, we must first determine - whether that is the case, before we can obtain a lookahead token and use it - as an index in the action table. - - Thus, Menhir's tables are as follows. - - A one-dimensional default reduction table maps a state to either ``no - default reduction'' (encoded as: 0) or ``by default, reduce prod'' - (encoded as: 1 + prod). The action table is looked up only when there - is no default reduction. *) - - val default_reduction: PackedIntArray.t - - (* Menhir follows Dencker, Dürre and Heuft, who point out that, although the - action table is not sparse by nature (i.e., the error entries are - significant), it can be made sparse by first factoring out a binary error - matrix, then replacing the error entries in the action table with undefined - entries. Thus: - - A two-dimensional error bitmap maps a state and a terminal to either - ``fail'' (encoded as: 0) or ``do not fail'' (encoded as: 1). The action - table, which is now sparse, is looked up only in the latter case. *) - - (* The error bitmap is flattened into a one-dimensional table; its width is - recorded so as to allow indexing. The table is then compressed via - [PackedIntArray]. The bit width of the resulting packed array must be - [1], so it is not explicitly recorded. *) - - (* The error bitmap does not contain a column for the [#] pseudo-terminal. - Thus, its width is [Terminal.n - 1]. We exploit the fact that the integer - code assigned to [#] is greatest: the fact that the right-most column - in the bitmap is missing does not affect the code for accessing it. *) - - val error: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *) - - (* A two-dimensional action table maps a state and a terminal to one of - ``shift to state s and discard the current token'' (encoded as: s | 10), - ``shift to state s without discarding the current token'' (encoded as: s | - 11), or ``reduce prod'' (encoded as: prod | 01). *) - - (* The action table is first compressed via [RowDisplacement], then packed - via [PackedIntArray]. *) - - (* Like the error bitmap, the action table does not contain a column for the - [#] pseudo-terminal. *) - - val action: PackedIntArray.t * PackedIntArray.t - - (* A one-dimensional lhs table maps a production to its left-hand side (a - non-terminal symbol). *) - - val lhs: PackedIntArray.t - - (* A two-dimensional goto table maps a state and a non-terminal symbol to - either undefined (encoded as: 0) or a new state s (encoded as: 1 + s). *) - - (* The goto table is first compressed via [RowDisplacement], then packed - via [PackedIntArray]. *) - - val goto: PackedIntArray.t * PackedIntArray.t - - (* The number of start productions. A production [prod] is a start - production if and only if [prod < start] holds. This is also the - number of start symbols. A nonterminal symbol [nt] is a start - symbol if and only if [nt < start] holds. *) - - val start: int - - (* A one-dimensional semantic action table maps productions to semantic - actions. The calling convention for semantic actions is described in - [EngineTypes]. This table contains ONLY NON-START PRODUCTIONS, so the - indexing is off by [start]. Be careful. *) - - val semantic_action: ((int, Obj.t, token) EngineTypes.env -> - (int, Obj.t) EngineTypes.stack) array - - (* The parser defines its own [Error] exception. This exception can be - raised by semantic actions and caught by the engine, and raised by the - engine towards the final user. *) - - exception Error - - (* The parser indicates whether to generate a trace. Generating a - trace requires two extra tables, which respectively map a - terminal symbol and a production to a string. *) - - val trace: (string array * string array) option - -end -end -module InspectionTableFormat = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This signature defines the format of the tables that are produced (in - addition to the tables described in [TableFormat]) when the command line - switch [--inspection] is enabled. It is used as an argument to - [InspectionTableInterpreter.Make]. *) - -module type TABLES = sig - - (* The types of symbols. *) - - include IncrementalEngine.SYMBOLS - - (* The type ['a lr1state] describes an LR(1) state. The generated parser defines - it internally as [int]. *) - - type 'a lr1state - - (* Some of the tables that follow use encodings of (terminal and - nonterminal) symbols as integers. So, we need functions that - map the integer encoding of a symbol to its algebraic encoding. *) - - val terminal: int -> xsymbol - val nonterminal: int -> xsymbol - - (* The left-hand side of every production already appears in the - signature [TableFormat.TABLES], so we need not repeat it here. *) - - (* The right-hand side of every production. This a linearized array - of arrays of integers, whose [data] and [entry] components have - been packed. The encoding of symbols as integers in described in - [TableBackend]. *) - - val rhs: PackedIntArray.t * PackedIntArray.t - - (* A mapping of every (non-initial) state to its LR(0) core. *) - - val lr0_core: PackedIntArray.t - - (* A mapping of every LR(0) state to its set of LR(0) items. Each item is - represented in its packed form (see [Item]) as an integer. Thus the - mapping is an array of arrays of integers, which is linearized and - packed, like [rhs]. *) - - val lr0_items: PackedIntArray.t * PackedIntArray.t - - (* A mapping of every LR(0) state to its incoming symbol, if it has one. *) - - val lr0_incoming: PackedIntArray.t - - (* A table that tells which non-terminal symbols are nullable. *) - - val nullable: string - (* This is a packed int array of bit width 1. It can be read - using [PackedIntArray.get1]. *) - - (* A two-table dimensional table, indexed by a nonterminal symbol and - by a terminal symbol (other than [#]), encodes the FIRST sets. *) - - val first: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *) - -end - -end -module InspectionTableInterpreter = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* -------------------------------------------------------------------------- *) - -(* The type functor. *) - -module Symbols (T : sig - - type 'a terminal - type 'a nonterminal - -end) = struct - - open T - - (* This should be the only place in the whole library (and generator!) - where these types are defined. *) - - type 'a symbol = - | T : 'a terminal -> 'a symbol - | N : 'a nonterminal -> 'a symbol - - type xsymbol = - | X : 'a symbol -> xsymbol - -end - -(* -------------------------------------------------------------------------- *) - -(* The code functor. *) - -module Make - (TT : TableFormat.TABLES) - (IT : InspectionTableFormat.TABLES - with type 'a lr1state = int) - (ET : EngineTypes.TABLE - with type terminal = int - and type nonterminal = int - and type semantic_value = Obj.t) - (E : sig - type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env - end) -= struct - - (* Including [IT] is an easy way of inheriting the definitions of the types - [symbol] and [xsymbol]. *) - - include IT - - (* This auxiliary function decodes a packed linearized array, as created by - [TableBackend.linearize_and_marshal1]. Here, we read a row all at once. *) - - let read_packed_linearized - (data, entry : PackedIntArray.t * PackedIntArray.t) (i : int) : int list - = - LinearizedArray.read_row_via - (PackedIntArray.get data) - (PackedIntArray.get entry) - i - - (* This auxiliary function decodes a symbol. The encoding was done by - [encode_symbol] or [encode_symbol_option] in the table back-end. *) - - let decode_symbol (symbol : int) : IT.xsymbol = - (* If [symbol] is 0, then we have no symbol. This could mean e.g. - that the function [incoming_symbol] has been applied to an - initial state. In principle, this cannot happen. *) - assert (symbol > 0); - (* The low-order bit distinguishes terminal and nonterminal symbols. *) - let kind = symbol land 1 in - let symbol = symbol lsr 1 in - if kind = 0 then - IT.terminal (symbol - 1) - else - IT.nonterminal symbol - - (* These auxiliary functions convert a symbol to its integer code. For speed - and for convenience, we use an unsafe type cast. This relies on the fact - that the data constructors of the [terminal] and [nonterminal] GADTs are - declared in an order that reflects their internal code. In the case of - nonterminal symbols, we add [start] to account for the presence of the - start symbols. *) - - let n2i (nt : 'a IT.nonterminal) : int = - let answer = TT.start + Obj.magic nt in - (* For safety, check that the above cast produced a correct result. *) - assert (IT.nonterminal answer = X (N nt)); - answer - - let t2i (t : 'a IT.terminal) : int = - let answer = Obj.magic t in - (* For safety, check that the above cast produced a correct result. *) - assert (IT.terminal answer = X (T t)); - answer - - (* Ordering functions. *) - - let compare_terminals t1 t2 = - (* Subtraction is safe because overflow is impossible. *) - t2i t1 - t2i t2 - - let compare_nonterminals nt1 nt2 = - (* Subtraction is safe because overflow is impossible. *) - n2i nt1 - n2i nt2 - - let compare_symbols symbol1 symbol2 = - match symbol1, symbol2 with - | X (T _), X (N _) -> - -1 - | X (N _), X (T _) -> - 1 - | X (T t1), X (T t2) -> - compare_terminals t1 t2 - | X (N nt1), X (N nt2) -> - compare_nonterminals nt1 nt2 - - let compare_productions prod1 prod2 = - (* Subtraction is safe because overflow is impossible. *) - prod1 - prod2 - - let compare_items (prod1, index1) (prod2, index2) = - let c = compare_productions prod1 prod2 in - (* Subtraction is safe because overflow is impossible. *) - if c <> 0 then c else index1 - index2 - - (* The function [incoming_symbol] goes through the tables [IT.lr0_core] and - [IT.lr0_incoming]. This yields a representation of type [xsymbol], out of - which we strip the [X] quantifier, so as to get a naked symbol. This last - step is ill-typed and potentially dangerous. It is safe only because this - function is used at type ['a lr1state -> 'a symbol], which forces an - appropriate choice of ['a]. *) - - let incoming_symbol (s : 'a IT.lr1state) : 'a IT.symbol = - let core = PackedIntArray.get IT.lr0_core s in - let symbol = decode_symbol (PackedIntArray.get IT.lr0_incoming core) in - match symbol with - | IT.X symbol -> - Obj.magic symbol - - (* The function [lhs] reads the table [TT.lhs] and uses [IT.nonterminal] - to decode the symbol. *) - - let lhs prod = - IT.nonterminal (PackedIntArray.get TT.lhs prod) - - (* The function [rhs] reads the table [IT.rhs] and uses [decode_symbol] - to decode the symbol. *) - - let rhs prod = - List.map decode_symbol (read_packed_linearized IT.rhs prod) - - (* The function [items] maps the LR(1) state [s] to its LR(0) core, - then uses [core] as an index into the table [IT.lr0_items]. The - items are then decoded by the function [export] below, which is - essentially a copy of [Item.export]. *) - - type item = - int * int - - let low_bits = - 10 - - let low_limit = - 1 lsl low_bits - - let export t : item = - (t lsr low_bits, t mod low_limit) - - let items s = - (* Map [s] to its LR(0) core. *) - let core = PackedIntArray.get IT.lr0_core s in - (* Now use [core] to look up the table [IT.lr0_items]. *) - List.map export (read_packed_linearized IT.lr0_items core) - - (* The function [nullable] maps the nonterminal symbol [nt] to its - integer code, which it uses to look up the array [IT.nullable]. - This yields 0 or 1, which we map back to a Boolean result. *) - - let decode_bool i = - assert (i = 0 || i = 1); - i = 1 - - let nullable nt = - decode_bool (PackedIntArray.get1 IT.nullable (n2i nt)) - - (* The function [first] maps the symbols [nt] and [t] to their integer - codes, which it uses to look up the matrix [IT.first]. *) - - let first nt t = - decode_bool (PackedIntArray.unflatten1 IT.first (n2i nt) (t2i t)) - - let xfirst symbol t = - match symbol with - | X (T t') -> - compare_terminals t t' = 0 - | X (N nt) -> - first nt t - - (* The function [foreach_terminal] exploits the fact that the - first component of [TT.error] is [Terminal.n - 1], i.e., the - number of terminal symbols, including [error] but not [#]. *) - - let rec foldij i j f accu = - if i = j then - accu - else - foldij (i + 1) j f (f i accu) - - let foreach_terminal f accu = - let n, _ = TT.error in - foldij 0 n (fun i accu -> - f (IT.terminal i) accu - ) accu - - let foreach_terminal_but_error f accu = - let n, _ = TT.error in - foldij 0 n (fun i accu -> - if i = TT.error_terminal then - accu - else - f (IT.terminal i) accu - ) accu - - (* ------------------------------------------------------------------------ *) - - (* The following is the implementation of the function [feed]. This function - is logically part of the LR engine, so it would be nice if it were placed - in the module [Engine], but it must be placed here because, to ensure - type safety, its arguments must be a symbol of type ['a symbol] and a - semantic value of type ['a]. The type ['a symbol] is not available in - [Engine]. It is available here. *) - - open EngineTypes - open ET - open E - - (* [feed] fails if the current state does not have an outgoing transition - labeled with the desired symbol. This check is carried out at runtime. *) - - let feed_failure () = - invalid_arg "feed: outgoing transition does not exist" - - (* Feeding a nonterminal symbol [nt]. Here, [nt] has type [nonterminal], - which is a synonym for [int], and [semv] has type [semantic_value], - which is a synonym for [Obj.t]. This type is unsafe, because pushing - a semantic value of arbitrary type into the stack can later cause a - semantic action to crash and burn. The function [feed] is given a safe - type below. *) - - let feed_nonterminal - (nt : nonterminal) startp (semv : semantic_value) endp (env : 'b env) - : 'b env - = - (* Check if the source state has an outgoing transition labeled [nt]. - This is done by consulting the [goto] table. *) - let source = env.current in - match ET.maybe_goto_nt source nt with - | None -> - feed_failure() - | Some target -> - (* Push a new cell onto the stack, containing the identity of the state - that we are leaving. The semantic value [semv] and positions [startp] - and [endp] contained in the new cell are provided by the caller. *) - let stack = { state = source; semv; startp; endp; next = env.stack } in - (* Move to the target state. *) - { env with stack; current = target } - - let reduce _env _prod = feed_failure() - let initiate _env = feed_failure() - - let feed_terminal - (terminal : terminal) startp (semv : semantic_value) endp (env : 'b env) - : 'b env - = - (* Check if the source state has an outgoing transition labeled [terminal]. - This is done by consulting the [action] table. *) - let source = env.current in - ET.action source terminal semv - (fun env _please_discard _terminal semv target -> - (* There is indeed a transition toward the state [target]. - Push a new cell onto the stack and move to the target state. *) - let stack = { state = source; semv; startp; endp; next = env.stack } in - { env with stack; current = target } - ) reduce initiate env - - (* The type assigned to [feed] ensures that the type of the semantic value - [semv] is appropriate: it must be the semantic-value type of the symbol - [symbol]. *) - - let feed (symbol : 'a symbol) startp (semv : 'a) endp env = - let semv : semantic_value = Obj.repr semv in - match symbol with - | N nt -> - feed_nonterminal (n2i nt) startp semv endp env - | T terminal -> - feed_terminal (t2i terminal) startp semv endp env - -end -end -module TableInterpreter = struct -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -module MakeEngineTable (T : TableFormat.TABLES) = struct - - type state = - int - - let number s = s - - type token = - T.token - - type terminal = - int - - type nonterminal = - int - - type semantic_value = - Obj.t - - let token2terminal = - T.token2terminal - - let token2value = - T.token2value - - let error_terminal = - T.error_terminal - - let error_value = - Obj.repr () - - (* The function [foreach_terminal] exploits the fact that the - first component of [T.error] is [Terminal.n - 1], i.e., the - number of terminal symbols, including [error] but not [#]. *) - - (* There is similar code in [InspectionTableInterpreter]. The - code there contains an additional conversion of the type - [terminal] to the type [xsymbol]. *) - - let rec foldij i j f accu = - if i = j then - accu - else - foldij (i + 1) j f (f i accu) - - let foreach_terminal f accu = - let n, _ = T.error in - foldij 0 n (fun i accu -> - f i accu - ) accu - - type production = - int - - (* In principle, only non-start productions are exposed to the user, - at type [production] or at type [int]. This is checked dynamically. *) - let non_start_production i = - assert (T.start <= i && i - T.start < Array.length T.semantic_action) - - let production_index i = - non_start_production i; - i - - let find_production i = - non_start_production i; - i - - let default_reduction state defred nodefred env = - let code = PackedIntArray.get T.default_reduction state in - if code = 0 then - nodefred env - else - defred env (code - 1) - - let is_start prod = - prod < T.start - - (* This auxiliary function helps access a compressed, two-dimensional - matrix, like the action and goto tables. *) - - let unmarshal2 table i j = - RowDisplacement.getget - PackedIntArray.get - PackedIntArray.get - table - i j - - let action state terminal value shift reduce fail env = - match PackedIntArray.unflatten1 T.error state terminal with - | 1 -> - let action = unmarshal2 T.action state terminal in - let opcode = action land 0b11 - and param = action lsr 2 in - if opcode >= 0b10 then - (* 0b10 : shift/discard *) - (* 0b11 : shift/nodiscard *) - let please_discard = (opcode = 0b10) in - shift env please_discard terminal value param - else - (* 0b01 : reduce *) - (* 0b00 : cannot happen *) - reduce env param - | c -> - assert (c = 0); - fail env - - let goto_nt state nt = - let code = unmarshal2 T.goto state nt in - (* code = 1 + state *) - code - 1 - - let goto_prod state prod = - goto_nt state (PackedIntArray.get T.lhs prod) - - let maybe_goto_nt state nt = - let code = unmarshal2 T.goto state nt in - (* If [code] is 0, there is no outgoing transition. - If [code] is [1 + state], there is a transition towards [state]. *) - assert (0 <= code); - if code = 0 then None else Some (code - 1) - - exception Error = - T.Error - - type semantic_action = - (state, semantic_value, token) EngineTypes.env -> - (state, semantic_value) EngineTypes.stack - - let semantic_action prod = - (* Indexing into the array [T.semantic_action] is off by [T.start], - because the start productions do not have entries in this array. *) - T.semantic_action.(prod - T.start) - - (* [may_reduce state prod] tests whether the state [state] is capable of - reducing the production [prod]. This information could be determined - in constant time if we were willing to create a bitmap for it, but - that would take up a lot of space. Instead, we obtain this information - by iterating over a line in the action table. This is costly, but this - function is not normally used by the LR engine anyway; it is supposed - to be used only by programmers who wish to develop error recovery - strategies. *) - - (* In the future, if desired, we could memoize this function, so as - to pay the cost in (memory) space only if and where this function - is actually used. We could also replace [foreach_terminal] with a - function [exists_terminal] which stops as soon as the accumulator - is [true]. *) - - let may_reduce state prod = - (* Test if there is a default reduction of [prod]. *) - default_reduction state - (fun () prod' -> prod = prod') - (fun () -> - (* If not, then for each terminal [t], ... *) - foreach_terminal (fun t accu -> - accu || - (* ... test if there is a reduction of [prod] on [t]. *) - action state t () - (* shift: *) (fun () _ _ () _ -> false) - (* reduce: *) (fun () prod' -> prod = prod') - (* fail: *) (fun () -> false) - () - ) false - ) - () - - (* If [T.trace] is [None], then the logging functions do nothing. *) - - let log = - match T.trace with Some _ -> true | None -> false - - module Log = struct - - open Printf - - let state state = - match T.trace with - | Some _ -> - fprintf stderr "State %d:\n%!" state - | None -> - () - - let shift terminal state = - match T.trace with - | Some (terminals, _) -> - fprintf stderr "Shifting (%s) to state %d\n%!" terminals.(terminal) state - | None -> - () - - let reduce_or_accept prod = - match T.trace with - | Some (_, productions) -> - fprintf stderr "%s\n%!" productions.(prod) - | None -> - () - - let lookahead_token token startp endp = - match T.trace with - | Some (terminals, _) -> - fprintf stderr "Lookahead token is now %s (%d-%d)\n%!" - terminals.(token) - startp.Lexing.pos_cnum - endp.Lexing.pos_cnum - | None -> - () - - let initiating_error_handling () = - match T.trace with - | Some _ -> - fprintf stderr "Initiating error handling\n%!" - | None -> - () - - let resuming_error_handling () = - match T.trace with - | Some _ -> - fprintf stderr "Resuming error handling\n%!" - | None -> - () - - let handling_error state = - match T.trace with - | Some _ -> - fprintf stderr "Handling error in state %d\n%!" state - | None -> - () - - end - -end -end -module StaticVersion = struct -let require_20201216 = () -end diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/menhirLib.mli b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/menhirLib.mli deleted file mode 100644 index 98db99e62..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/menhirLib.mli +++ /dev/null @@ -1,1807 +0,0 @@ -module General : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This module offers general-purpose functions on lists and streams. *) - -(* As of 2017/03/31, this module is DEPRECATED. It might be removed in - the future. *) - -(* --------------------------------------------------------------------------- *) - -(* Lists. *) - -(* [take n xs] returns the [n] first elements of the list [xs]. It is - acceptable for the list [xs] to have length less than [n], in - which case [xs] itself is returned. *) - -val take: int -> 'a list -> 'a list - -(* [drop n xs] returns the list [xs], deprived of its [n] first elements. - It is acceptable for the list [xs] to have length less than [n], in - which case an empty list is returned. *) - -val drop: int -> 'a list -> 'a list - -(* [uniq cmp xs] assumes that the list [xs] is sorted according to the - ordering [cmp] and returns the list [xs] deprived of any duplicate - elements. *) - -val uniq: ('a -> 'a -> int) -> 'a list -> 'a list - -(* [weed cmp xs] returns the list [xs] deprived of any duplicate elements. *) - -val weed: ('a -> 'a -> int) -> 'a list -> 'a list - -(* --------------------------------------------------------------------------- *) - -(* A stream is a list whose elements are produced on demand. *) - -type 'a stream = - 'a head Lazy.t - -and 'a head = - | Nil - | Cons of 'a * 'a stream - -(* The length of a stream. *) - -val length: 'a stream -> int - -(* Folding over a stream. *) - -val foldr: ('a -> 'b -> 'b) -> 'a stream -> 'b -> 'b -end -module Convert : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* An ocamlyacc-style, or Menhir-style, parser requires access to - the lexer, which must be parameterized with a lexing buffer, and - to the lexing buffer itself, where it reads position information. *) - -(* This traditional API is convenient when used with ocamllex, but - inelegant when used with other lexer generators. *) - -type ('token, 'semantic_value) traditional = - (Lexing.lexbuf -> 'token) -> Lexing.lexbuf -> 'semantic_value - -(* This revised API is independent of any lexer generator. Here, the - parser only requires access to the lexer, and the lexer takes no - parameters. The tokens returned by the lexer may contain position - information. *) - -type ('token, 'semantic_value) revised = - (unit -> 'token) -> 'semantic_value - -(* --------------------------------------------------------------------------- *) - -(* Converting a traditional parser, produced by ocamlyacc or Menhir, - into a revised parser. *) - -(* A token of the revised lexer is essentially a triple of a token - of the traditional lexer (or raw token), a start position, and - and end position. The three [get] functions are accessors. *) - -(* We do not require the type ['token] to actually be a triple type. - This enables complex applications where it is a record type with - more than three fields. It also enables simple applications where - positions are of no interest, so ['token] is just ['raw_token] - and [get_startp] and [get_endp] return dummy positions. *) - -val traditional2revised: - ('token -> 'raw_token) -> - ('token -> Lexing.position) -> - ('token -> Lexing.position) -> - ('raw_token, 'semantic_value) traditional -> - ('token, 'semantic_value) revised - -(* --------------------------------------------------------------------------- *) - -(* Converting a revised parser back to a traditional parser. *) - -val revised2traditional: - ('raw_token -> Lexing.position -> Lexing.position -> 'token) -> - ('token, 'semantic_value) revised -> - ('raw_token, 'semantic_value) traditional - -(* --------------------------------------------------------------------------- *) - -(* Simplified versions of the above, where concrete triples are used. *) - -module Simplified : sig - - val traditional2revised: - ('token, 'semantic_value) traditional -> - ('token * Lexing.position * Lexing.position, 'semantic_value) revised - - val revised2traditional: - ('token * Lexing.position * Lexing.position, 'semantic_value) revised -> - ('token, 'semantic_value) traditional - -end -end -module IncrementalEngine : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -type position = Lexing.position - -open General - -(* This signature describes the incremental LR engine. *) - -(* In this mode, the user controls the lexer, and the parser suspends - itself when it needs to read a new token. *) - -module type INCREMENTAL_ENGINE = sig - - type token - - (* A value of type [production] is (an index for) a production. The start - productions (which do not exist in an \mly file, but are constructed by - Menhir internally) are not part of this type. *) - - type production - - (* The type ['a checkpoint] represents an intermediate or final state of the - parser. An intermediate checkpoint is a suspension: it records the parser's - current state, and allows parsing to be resumed. The parameter ['a] is - the type of the semantic value that will eventually be produced if the - parser succeeds. *) - - (* [Accepted] and [Rejected] are final checkpoints. [Accepted] carries a - semantic value. *) - - (* [InputNeeded] is an intermediate checkpoint. It means that the parser wishes - to read one token before continuing. *) - - (* [Shifting] is an intermediate checkpoint. It means that the parser is taking - a shift transition. It exposes the state of the parser before and after - the transition. The Boolean parameter tells whether the parser intends to - request a new token after this transition. (It always does, except when - it is about to accept.) *) - - (* [AboutToReduce] is an intermediate checkpoint. It means that the parser is - about to perform a reduction step. It exposes the parser's current - state as well as the production that is about to be reduced. *) - - (* [HandlingError] is an intermediate checkpoint. It means that the parser has - detected an error and is currently handling it, in several steps. *) - - (* A value of type ['a env] represents a configuration of the automaton: - current state, stack, lookahead token, etc. The parameter ['a] is the - type of the semantic value that will eventually be produced if the parser - succeeds. *) - - (* In normal operation, the parser works with checkpoints: see the functions - [offer] and [resume]. However, it is also possible to work directly with - environments (see the functions [pop], [force_reduction], and [feed]) and - to reconstruct a checkpoint out of an environment (see [input_needed]). - This is considered advanced functionality; its purpose is to allow error - recovery strategies to be programmed by the user. *) - - type 'a env - - type 'a checkpoint = private - | InputNeeded of 'a env - | Shifting of 'a env * 'a env * bool - | AboutToReduce of 'a env * production - | HandlingError of 'a env - | Accepted of 'a - | Rejected - - (* [offer] allows the user to resume the parser after it has suspended - itself with a checkpoint of the form [InputNeeded env]. [offer] expects - the old checkpoint as well as a new token and produces a new checkpoint. - It does not raise any exception. *) - - val offer: - 'a checkpoint -> - token * position * position -> - 'a checkpoint - - (* [resume] allows the user to resume the parser after it has suspended - itself with a checkpoint of the form [AboutToReduce (env, prod)] or - [HandlingError env]. [resume] expects the old checkpoint and produces a - new checkpoint. It does not raise any exception. *) - - (* The optional argument [strategy] influences the manner in which [resume] - deals with checkpoints of the form [ErrorHandling _]. Its default value - is [`Legacy]. It can be briefly described as follows: - - - If the [error] token is used only to report errors (that is, if the - [error] token appears only at the end of a production, whose semantic - action raises an exception) then the simplified strategy should be - preferred. (This includes the case where the [error] token does not - appear at all in the grammar.) - - - If the [error] token is used to recover after an error, or if - perfect backward compatibility is required, the legacy strategy - should be selected. - - More details on these strategies appear in the file [Engine.ml]. *) - - type strategy = - [ `Legacy | `Simplified ] - - val resume: - ?strategy:strategy -> - 'a checkpoint -> - 'a checkpoint - - (* A token supplier is a function of no arguments which delivers a new token - (together with its start and end positions) every time it is called. *) - - type supplier = - unit -> token * position * position - - (* A pair of a lexer and a lexing buffer can be easily turned into a - supplier. *) - - val lexer_lexbuf_to_supplier: - (Lexing.lexbuf -> token) -> - Lexing.lexbuf -> - supplier - - (* The functions [offer] and [resume] are sufficient to write a parser loop. - One can imagine many variations (which is why we expose these functions - in the first place!). Here, we expose a few variations of the main loop, - ready for use. *) - - (* [loop supplier checkpoint] begins parsing from [checkpoint], reading - tokens from [supplier]. It continues parsing until it reaches a - checkpoint of the form [Accepted v] or [Rejected]. In the former case, it - returns [v]. In the latter case, it raises the exception [Error]. - The optional argument [strategy], whose default value is [Legacy], - is passed to [resume] and influences the error-handling strategy. *) - - val loop: ?strategy:strategy -> supplier -> 'a checkpoint -> 'a - - (* [loop_handle succeed fail supplier checkpoint] begins parsing from - [checkpoint], reading tokens from [supplier]. It continues parsing until - it reaches a checkpoint of the form [Accepted v] or [HandlingError env] - (or [Rejected], but that should not happen, as [HandlingError _] will be - observed first). In the former case, it calls [succeed v]. In the latter - case, it calls [fail] with this checkpoint. It cannot raise [Error]. - - This means that Menhir's error-handling procedure does not get a chance - to run. For this reason, there is no [strategy] parameter. Instead, the - user can implement her own error handling code, in the [fail] - continuation. *) - - val loop_handle: - ('a -> 'answer) -> - ('a checkpoint -> 'answer) -> - supplier -> 'a checkpoint -> 'answer - - (* [loop_handle_undo] is analogous to [loop_handle], except it passes a pair - of checkpoints to the failure continuation. - - The first (and oldest) checkpoint is the last [InputNeeded] checkpoint that - was encountered before the error was detected. The second (and newest) - checkpoint is where the error was detected, as in [loop_handle]. Going back - to the first checkpoint can be thought of as undoing any reductions that - were performed after seeing the problematic token. (These reductions must - be default reductions or spurious reductions.) - - [loop_handle_undo] must initially be applied to an [InputNeeded] checkpoint. - The parser's initial checkpoints satisfy this constraint. *) - - val loop_handle_undo: - ('a -> 'answer) -> - ('a checkpoint -> 'a checkpoint -> 'answer) -> - supplier -> 'a checkpoint -> 'answer - - (* [shifts checkpoint] assumes that [checkpoint] has been obtained by - submitting a token to the parser. It runs the parser from [checkpoint], - through an arbitrary number of reductions, until the parser either - accepts this token (i.e., shifts) or rejects it (i.e., signals an error). - If the parser decides to shift, then [Some env] is returned, where [env] - is the parser's state just before shifting. Otherwise, [None] is - returned. *) - - (* It is desirable that the semantic actions be side-effect free, or that - their side-effects be harmless (replayable). *) - - val shifts: 'a checkpoint -> 'a env option - - (* The function [acceptable] allows testing, after an error has been - detected, which tokens would have been accepted at this point. It is - implemented using [shifts]. Its argument should be an [InputNeeded] - checkpoint. *) - - (* For completeness, one must undo any spurious reductions before carrying out - this test -- that is, one must apply [acceptable] to the FIRST checkpoint - that is passed by [loop_handle_undo] to its failure continuation. *) - - (* This test causes some semantic actions to be run! The semantic actions - should be side-effect free, or their side-effects should be harmless. *) - - (* The position [pos] is used as the start and end positions of the - hypothetical token, and may be picked up by the semantic actions. We - suggest using the position where the error was detected. *) - - val acceptable: 'a checkpoint -> token -> position -> bool - - (* The abstract type ['a lr1state] describes the non-initial states of the - LR(1) automaton. The index ['a] represents the type of the semantic value - associated with this state's incoming symbol. *) - - type 'a lr1state - - (* The states of the LR(1) automaton are numbered (from 0 and up). *) - - val number: _ lr1state -> int - - (* Productions are numbered. *) - - (* [find_production i] requires the index [i] to be valid. Use with care. *) - - val production_index: production -> int - val find_production: int -> production - - (* An element is a pair of a non-initial state [s] and a semantic value [v] - associated with the incoming symbol of this state. The idea is, the value - [v] was pushed onto the stack just before the state [s] was entered. Thus, - for some type ['a], the state [s] has type ['a lr1state] and the value [v] - has type ['a]. In other words, the type [element] is an existential type. *) - - type element = - | Element: 'a lr1state * 'a * position * position -> element - - (* The parser's stack is (or, more precisely, can be viewed as) a stream of - elements. The type [stream] is defined by the module [General]. *) - - (* As of 2017/03/31, the types [stream] and [stack] and the function [stack] - are DEPRECATED. They might be removed in the future. An alternative way - of inspecting the stack is via the functions [top] and [pop]. *) - - type stack = (* DEPRECATED *) - element stream - - (* This is the parser's stack, a stream of elements. This stream is empty if - the parser is in an initial state; otherwise, it is non-empty. The LR(1) - automaton's current state is the one found in the top element of the - stack. *) - - val stack: 'a env -> stack (* DEPRECATED *) - - (* [top env] returns the parser's top stack element. The state contained in - this stack element is the current state of the automaton. If the stack is - empty, [None] is returned. In that case, the current state of the - automaton must be an initial state. *) - - val top: 'a env -> element option - - (* [pop_many i env] pops [i] cells off the automaton's stack. This is done - via [i] successive invocations of [pop]. Thus, [pop_many 1] is [pop]. The - index [i] must be nonnegative. The time complexity is O(i). *) - - val pop_many: int -> 'a env -> 'a env option - - (* [get i env] returns the parser's [i]-th stack element. The index [i] is - 0-based: thus, [get 0] is [top]. If [i] is greater than or equal to the - number of elements in the stack, [None] is returned. The time complexity - is O(i). *) - - val get: int -> 'a env -> element option - - (* [current_state_number env] is (the integer number of) the automaton's - current state. This works even if the automaton's stack is empty, in - which case the current state is an initial state. This number can be - passed as an argument to a [message] function generated by [menhir - --compile-errors]. *) - - val current_state_number: 'a env -> int - - (* [equal env1 env2] tells whether the parser configurations [env1] and - [env2] are equal in the sense that the automaton's current state is the - same in [env1] and [env2] and the stack is *physically* the same in - [env1] and [env2]. If [equal env1 env2] is [true], then the sequence of - the stack elements, as observed via [pop] and [top], must be the same in - [env1] and [env2]. Also, if [equal env1 env2] holds, then the checkpoints - [input_needed env1] and [input_needed env2] must be equivalent. The - function [equal] has time complexity O(1). *) - - val equal: 'a env -> 'a env -> bool - - (* These are the start and end positions of the current lookahead token. If - invoked in an initial state, this function returns a pair of twice the - initial position. *) - - val positions: 'a env -> position * position - - (* When applied to an environment taken from a checkpoint of the form - [AboutToReduce (env, prod)], the function [env_has_default_reduction] - tells whether the reduction that is about to take place is a default - reduction. *) - - val env_has_default_reduction: 'a env -> bool - - (* [state_has_default_reduction s] tells whether the state [s] has a default - reduction. This includes the case where [s] is an accepting state. *) - - val state_has_default_reduction: _ lr1state -> bool - - (* [pop env] returns a new environment, where the parser's top stack cell - has been popped off. (If the stack is empty, [None] is returned.) This - amounts to pretending that the (terminal or nonterminal) symbol that - corresponds to this stack cell has not been read. *) - - val pop: 'a env -> 'a env option - - (* [force_reduction prod env] should be called only if in the state [env] - the parser is capable of reducing the production [prod]. If this - condition is satisfied, then this production is reduced, which means that - its semantic action is executed (this can have side effects!) and the - automaton makes a goto (nonterminal) transition. If this condition is not - satisfied, [Invalid_argument _] is raised. *) - - val force_reduction: production -> 'a env -> 'a env - - (* [input_needed env] returns [InputNeeded env]. That is, out of an [env] - that might have been obtained via a series of calls to the functions - [pop], [force_reduction], [feed], etc., it produces a checkpoint, which - can be used to resume normal parsing, by supplying this checkpoint as an - argument to [offer]. *) - - (* This function should be used with some care. It could "mess up the - lookahead" in the sense that it allows parsing to resume in an arbitrary - state [s] with an arbitrary lookahead symbol [t], even though Menhir's - reachability analysis (menhir --list-errors) might well think that it is - impossible to reach this particular configuration. If one is using - Menhir's new error reporting facility, this could cause the parser to - reach an error state for which no error message has been prepared. *) - - val input_needed: 'a env -> 'a checkpoint - -end - -(* This signature is a fragment of the inspection API that is made available - to the user when [--inspection] is used. This fragment contains type - definitions for symbols. *) - -module type SYMBOLS = sig - - (* The type ['a terminal] represents a terminal symbol. The type ['a - nonterminal] represents a nonterminal symbol. In both cases, the index - ['a] represents the type of the semantic values associated with this - symbol. The concrete definitions of these types are generated. *) - - type 'a terminal - type 'a nonterminal - - (* The type ['a symbol] represents a terminal or nonterminal symbol. It is - the disjoint union of the types ['a terminal] and ['a nonterminal]. *) - - type 'a symbol = - | T : 'a terminal -> 'a symbol - | N : 'a nonterminal -> 'a symbol - - (* The type [xsymbol] is an existentially quantified version of the type - ['a symbol]. This type is useful in situations where the index ['a] - is not statically known. *) - - type xsymbol = - | X : 'a symbol -> xsymbol - -end - -(* This signature describes the inspection API that is made available to the - user when [--inspection] is used. *) - -module type INSPECTION = sig - - (* The types of symbols are described above. *) - - include SYMBOLS - - (* The type ['a lr1state] is meant to be the same as in [INCREMENTAL_ENGINE]. *) - - type 'a lr1state - - (* The type [production] is meant to be the same as in [INCREMENTAL_ENGINE]. - It represents a production of the grammar. A production can be examined - via the functions [lhs] and [rhs] below. *) - - type production - - (* An LR(0) item is a pair of a production [prod] and a valid index [i] into - this production. That is, if the length of [rhs prod] is [n], then [i] is - comprised between 0 and [n], inclusive. *) - - type item = - production * int - - (* Ordering functions. *) - - val compare_terminals: _ terminal -> _ terminal -> int - val compare_nonterminals: _ nonterminal -> _ nonterminal -> int - val compare_symbols: xsymbol -> xsymbol -> int - val compare_productions: production -> production -> int - val compare_items: item -> item -> int - - (* [incoming_symbol s] is the incoming symbol of the state [s], that is, - the symbol that the parser must recognize before (has recognized when) - it enters the state [s]. This function gives access to the semantic - value [v] stored in a stack element [Element (s, v, _, _)]. Indeed, - by case analysis on the symbol [incoming_symbol s], one discovers the - type ['a] of the value [v]. *) - - val incoming_symbol: 'a lr1state -> 'a symbol - - (* [items s] is the set of the LR(0) items in the LR(0) core of the LR(1) - state [s]. This set is not epsilon-closed. This set is presented as a - list, in an arbitrary order. *) - - val items: _ lr1state -> item list - - (* [lhs prod] is the left-hand side of the production [prod]. This is - always a non-terminal symbol. *) - - val lhs: production -> xsymbol - - (* [rhs prod] is the right-hand side of the production [prod]. This is - a (possibly empty) sequence of (terminal or nonterminal) symbols. *) - - val rhs: production -> xsymbol list - - (* [nullable nt] tells whether the non-terminal symbol [nt] is nullable. - That is, it is true if and only if this symbol produces the empty - word [epsilon]. *) - - val nullable: _ nonterminal -> bool - - (* [first nt t] tells whether the FIRST set of the nonterminal symbol [nt] - contains the terminal symbol [t]. That is, it is true if and only if - [nt] produces a word that begins with [t]. *) - - val first: _ nonterminal -> _ terminal -> bool - - (* [xfirst] is analogous to [first], but expects a first argument of type - [xsymbol] instead of [_ terminal]. *) - - val xfirst: xsymbol -> _ terminal -> bool - - (* [foreach_terminal] enumerates the terminal symbols, including [error]. - [foreach_terminal_but_error] enumerates the terminal symbols, excluding - [error]. *) - - val foreach_terminal: (xsymbol -> 'a -> 'a) -> 'a -> 'a - val foreach_terminal_but_error: (xsymbol -> 'a -> 'a) -> 'a -> 'a - - (* The type [env] is meant to be the same as in [INCREMENTAL_ENGINE]. *) - - type 'a env - - (* [feed symbol startp semv endp env] causes the parser to consume the - (terminal or nonterminal) symbol [symbol], accompanied with the semantic - value [semv] and with the start and end positions [startp] and [endp]. - Thus, the automaton makes a transition, and reaches a new state. The - stack grows by one cell. This operation is permitted only if the current - state (as determined by [env]) has an outgoing transition labeled with - [symbol]. Otherwise, [Invalid_argument _] is raised. *) - - val feed: 'a symbol -> position -> 'a -> position -> 'b env -> 'b env - -end - -(* This signature combines the incremental API and the inspection API. *) - -module type EVERYTHING = sig - - include INCREMENTAL_ENGINE - - include INSPECTION - with type 'a lr1state := 'a lr1state - with type production := production - with type 'a env := 'a env - -end -end -module EngineTypes : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This file defines several types and module types that are used in the - specification of module [Engine]. *) - -(* --------------------------------------------------------------------------- *) - -(* It would be nice if we could keep the structure of stacks and environments - hidden. However, stacks and environments must be accessible to semantic - actions, so the following data structure definitions must be public. *) - -(* --------------------------------------------------------------------------- *) - -(* A stack is a linked list of cells. A sentinel cell -- which is its own - successor -- is used to mark the bottom of the stack. The sentinel cell - itself is not significant -- it contains dummy values. *) - -type ('state, 'semantic_value) stack = { - - (* The state that we should go back to if we pop this stack cell. *) - - (* This convention means that the state contained in the top stack cell is - not the current state [env.current]. It also means that the state found - within the sentinel is a dummy -- it is never consulted. This convention - is the same as that adopted by the code-based back-end. *) - - state: 'state; - - (* The semantic value associated with the chunk of input that this cell - represents. *) - - semv: 'semantic_value; - - (* The start and end positions of the chunk of input that this cell - represents. *) - - startp: Lexing.position; - endp: Lexing.position; - - (* The next cell down in the stack. If this is a self-pointer, then this - cell is the sentinel, and the stack is conceptually empty. *) - - next: ('state, 'semantic_value) stack; - -} - -(* --------------------------------------------------------------------------- *) - -(* A parsing environment contains all of the parser's state (except for the - current program point). *) - -type ('state, 'semantic_value, 'token) env = { - - (* If this flag is true, then the first component of [env.triple] should - be ignored, as it has been logically overwritten with the [error] - pseudo-token. *) - - error: bool; - - (* The last token that was obtained from the lexer, together with its start - and end positions. Warning: before the first call to the lexer has taken - place, a dummy (and possibly invalid) token is stored here. *) - - triple: 'token * Lexing.position * Lexing.position; - - (* The stack. In [CodeBackend], it is passed around on its own, - whereas, here, it is accessed via the environment. *) - - stack: ('state, 'semantic_value) stack; - - (* The current state. In [CodeBackend], it is passed around on its - own, whereas, here, it is accessed via the environment. *) - - current: 'state; - -} - -(* --------------------------------------------------------------------------- *) - -(* This signature describes the parameters that must be supplied to the LR - engine. *) - -module type TABLE = sig - - (* The type of automaton states. *) - - type state - - (* States are numbered. *) - - val number: state -> int - - (* The type of tokens. These can be thought of as real tokens, that is, - tokens returned by the lexer. They carry a semantic value. This type - does not include the [error] pseudo-token. *) - - type token - - (* The type of terminal symbols. These can be thought of as integer codes. - They do not carry a semantic value. This type does include the [error] - pseudo-token. *) - - type terminal - - (* The type of nonterminal symbols. *) - - type nonterminal - - (* The type of semantic values. *) - - type semantic_value - - (* A token is conceptually a pair of a (non-[error]) terminal symbol and - a semantic value. The following two functions are the pair projections. *) - - val token2terminal: token -> terminal - val token2value: token -> semantic_value - - (* Even though the [error] pseudo-token is not a real token, it is a - terminal symbol. Furthermore, for regularity, it must have a semantic - value. *) - - val error_terminal: terminal - val error_value: semantic_value - - (* [foreach_terminal] allows iterating over all terminal symbols. *) - - val foreach_terminal: (terminal -> 'a -> 'a) -> 'a -> 'a - - (* The type of productions. *) - - type production - - val production_index: production -> int - val find_production: int -> production - - (* If a state [s] has a default reduction on production [prod], then, upon - entering [s], the automaton should reduce [prod] without consulting the - lookahead token. The following function allows determining which states - have default reductions. *) - - (* Instead of returning a value of a sum type -- either [DefRed prod], or - [NoDefRed] -- it accepts two continuations, and invokes just one of - them. This mechanism allows avoiding a memory allocation. *) - - val default_reduction: - state -> - ('env -> production -> 'answer) -> - ('env -> 'answer) -> - 'env -> 'answer - - (* An LR automaton can normally take three kinds of actions: shift, reduce, - or fail. (Acceptance is a particular case of reduction: it consists in - reducing a start production.) *) - - (* There are two variants of the shift action. [shift/discard s] instructs - the automaton to discard the current token, request a new one from the - lexer, and move to state [s]. [shift/nodiscard s] instructs it to move to - state [s] without requesting a new token. This instruction should be used - when [s] has a default reduction on [#]. See [CodeBackend.gettoken] for - details. *) - - (* This is the automaton's action table. It maps a pair of a state and a - terminal symbol to an action. *) - - (* Instead of returning a value of a sum type -- one of shift/discard, - shift/nodiscard, reduce, or fail -- this function accepts three - continuations, and invokes just one them. This mechanism allows avoiding - a memory allocation. *) - - (* In summary, the parameters to [action] are as follows: - - - the first two parameters, a state and a terminal symbol, are used to - look up the action table; - - - the next parameter is the semantic value associated with the above - terminal symbol; it is not used, only passed along to the shift - continuation, as explained below; - - - the shift continuation expects an environment; a flag that tells - whether to discard the current token; the terminal symbol that - is being shifted; its semantic value; and the target state of - the transition; - - - the reduce continuation expects an environment and a production; - - - the fail continuation expects an environment; - - - the last parameter is the environment; it is not used, only passed - along to the selected continuation. *) - - val action: - state -> - terminal -> - semantic_value -> - ('env -> bool -> terminal -> semantic_value -> state -> 'answer) -> - ('env -> production -> 'answer) -> - ('env -> 'answer) -> - 'env -> 'answer - - (* This is the automaton's goto table. This table maps a pair of a state - and a nonterminal symbol to a new state. By extension, it also maps a - pair of a state and a production to a new state. *) - - (* The function [goto_nt] can be applied to [s] and [nt] ONLY if the state - [s] has an outgoing transition labeled [nt]. Otherwise, its result is - undefined. Similarly, the call [goto_prod prod s] is permitted ONLY if - the state [s] has an outgoing transition labeled with the nonterminal - symbol [lhs prod]. The function [maybe_goto_nt] involves an additional - dynamic check and CAN be called even if there is no outgoing transition. *) - - val goto_nt : state -> nonterminal -> state - val goto_prod: state -> production -> state - val maybe_goto_nt: state -> nonterminal -> state option - - (* [is_start prod] tells whether the production [prod] is a start production. *) - - val is_start: production -> bool - - (* By convention, a semantic action is responsible for: - - 1. fetching whatever semantic values and positions it needs off the stack; - - 2. popping an appropriate number of cells off the stack, as dictated - by the length of the right-hand side of the production; - - 3. computing a new semantic value, as well as new start and end positions; - - 4. pushing a new stack cell, which contains the three values - computed in step 3; - - 5. returning the new stack computed in steps 2 and 4. - - Point 1 is essentially forced upon us: if semantic values were fetched - off the stack by this interpreter, then the calling convention for - semantic actions would be variadic: not all semantic actions would have - the same number of arguments. The rest follows rather naturally. *) - - (* Semantic actions are allowed to raise [Error]. *) - - exception Error - - type semantic_action = - (state, semantic_value, token) env -> (state, semantic_value) stack - - val semantic_action: production -> semantic_action - - (* [may_reduce state prod] tests whether the state [state] is capable of - reducing the production [prod]. This function is currently costly and - is not used by the core LR engine. It is used in the implementation - of certain functions, such as [force_reduction], which allow the engine - to be driven programmatically. *) - - val may_reduce: state -> production -> bool - - (* The LR engine requires a number of hooks, which are used for logging. *) - - (* The comments below indicate the conventional messages that correspond - to these hooks in the code-based back-end; see [CodeBackend]. *) - - (* If the flag [log] is false, then the logging functions are not called. - If it is [true], then they are called. *) - - val log : bool - - module Log : sig - - (* State %d: *) - - val state: state -> unit - - (* Shifting () to state *) - - val shift: terminal -> state -> unit - - (* Reducing a production should be logged either as a reduction - event (for regular productions) or as an acceptance event (for - start productions). *) - - (* Reducing production / Accepting *) - - val reduce_or_accept: production -> unit - - (* Lookahead token is now (-) *) - - val lookahead_token: terminal -> Lexing.position -> Lexing.position -> unit - - (* Initiating error handling *) - - val initiating_error_handling: unit -> unit - - (* Resuming error handling *) - - val resuming_error_handling: unit -> unit - - (* Handling error in state *) - - val handling_error: state -> unit - - end - -end - -(* --------------------------------------------------------------------------- *) - -(* This signature describes the monolithic (traditional) LR engine. *) - -(* In this interface, the parser controls the lexer. *) - -module type MONOLITHIC_ENGINE = sig - - type state - - type token - - type semantic_value - - (* An entry point to the engine requires a start state, a lexer, and a lexing - buffer. It either succeeds and produces a semantic value, or fails and - raises [Error]. *) - - exception Error - - val entry: - (* strategy: *) [ `Legacy | `Simplified ] -> (* see [IncrementalEngine] *) - state -> - (Lexing.lexbuf -> token) -> - Lexing.lexbuf -> - semantic_value - -end - -(* --------------------------------------------------------------------------- *) - -(* The following signatures describe the incremental LR engine. *) - -(* First, see [INCREMENTAL_ENGINE] in the file [IncrementalEngine.ml]. *) - -(* The [start] function is set apart because we do not wish to publish - it as part of the generated [parser.mli] file. Instead, the table - back-end will publish specialized versions of it, with a suitable - type cast. *) - -module type INCREMENTAL_ENGINE_START = sig - - (* [start] is an entry point. It requires a start state and a start position - and begins the parsing process. If the lexer is based on an OCaml lexing - buffer, the start position should be [lexbuf.lex_curr_p]. [start] produces - a checkpoint, which usually will be an [InputNeeded] checkpoint. (It could - be [Accepted] if this starting state accepts only the empty word. It could - be [Rejected] if this starting state accepts no word at all.) It does not - raise any exception. *) - - (* [start s pos] should really produce a checkpoint of type ['a checkpoint], - for a fixed ['a] that depends on the state [s]. We cannot express this, so - we use [semantic_value checkpoint], which is safe. The table back-end uses - [Obj.magic] to produce safe specialized versions of [start]. *) - - type state - type semantic_value - type 'a checkpoint - - val start: - state -> - Lexing.position -> - semantic_value checkpoint - -end - -(* --------------------------------------------------------------------------- *) - -(* This signature describes the LR engine, which combines the monolithic - and incremental interfaces. *) - -module type ENGINE = sig - - include MONOLITHIC_ENGINE - - include IncrementalEngine.INCREMENTAL_ENGINE - with type token := token - and type 'a lr1state = state (* useful for us; hidden from the end user *) - - include INCREMENTAL_ENGINE_START - with type state := state - and type semantic_value := semantic_value - and type 'a checkpoint := 'a checkpoint - -end -end -module Engine : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -open EngineTypes - -(* The LR parsing engine. *) - -module Make (T : TABLE) -: ENGINE - with type state = T.state - and type token = T.token - and type semantic_value = T.semantic_value - and type production = T.production - and type 'a env = (T.state, T.semantic_value, T.token) EngineTypes.env - -(* We would prefer not to expose the definition of the type [env]. - However, it must be exposed because some of the code in the - inspection API needs access to the engine's internals; see - [InspectionTableInterpreter]. Everything would be simpler if - --inspection was always ON, but that would lead to bigger parse - tables for everybody. *) -end -module ErrorReports : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* -------------------------------------------------------------------------- *) - -(* The following functions help keep track of the start and end positions of - the last two tokens in a two-place buffer. This is used to nicely display - where a syntax error took place. *) - -type 'a buffer - -(* [wrap lexer] returns a pair of a new (initially empty) buffer and a lexer - which internally relies on [lexer] and updates [buffer] on the fly whenever - a token is demanded. *) - -(* The type of the buffer is [(position * position) buffer], which means that - it stores two pairs of positions, which are the start and end positions of - the last two tokens. *) - -open Lexing - -val wrap: - (lexbuf -> 'token) -> - (position * position) buffer * (lexbuf -> 'token) - -val wrap_supplier: - (unit -> 'token * position * position) -> - (position * position) buffer * (unit -> 'token * position * position) - -(* [show f buffer] prints the contents of the buffer, producing a string that - is typically of the form "after '%s' and before '%s'". The function [f] is - used to print an element. The buffer MUST be nonempty. *) - -val show: ('a -> string) -> 'a buffer -> string - -(* [last buffer] returns the last element of the buffer. The buffer MUST be - nonempty. *) - -val last: 'a buffer -> 'a - -(* -------------------------------------------------------------------------- *) - -(* [extract text (pos1, pos2)] extracts the sub-string of [text] delimited - by the positions [pos1] and [pos2]. *) - -val extract: string -> position * position -> string - -(* [sanitize text] eliminates any special characters from the text [text]. - A special character is a character whose ASCII code is less than 32. - Every special character is replaced with a single space character. *) - -val sanitize: string -> string - -(* [compress text] replaces every run of at least one whitespace character - with exactly one space character. *) - -val compress: string -> string - -(* [shorten k text] limits the length of [text] to [2k+3] characters. If the - text is too long, a fragment in the middle is replaced with an ellipsis. *) - -val shorten: int -> string -> string - -(* [expand f text] searches [text] for occurrences of [$k], where [k] - is a nonnegative integer literal, and replaces each such occurrence - with the string [f k]. *) - -val expand: (int -> string) -> string -> string -end -module LexerUtil : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -open Lexing - -(* [init filename lexbuf] initializes the lexing buffer [lexbuf] so - that the positions that are subsequently read from it refer to the - file [filename]. It returns [lexbuf]. *) - -val init: string -> lexbuf -> lexbuf - -(* [read filename] reads the entire contents of the file [filename] and - returns a pair of this content (a string) and a lexing buffer that - has been initialized, based on this string. *) - -val read: string -> string * lexbuf - -(* [newline lexbuf] increments the line counter stored within [lexbuf]. It - should be invoked by the lexer itself every time a newline character is - consumed. This allows maintaining a current the line number in [lexbuf]. *) - -val newline: lexbuf -> unit - -(* [range (startpos, endpos)] prints a textual description of the range - delimited by the start and end positions [startpos] and [endpos]. - This description is one line long and ends in a newline character. - This description mentions the file name, the line number, and a range - of characters on this line. The line number is correct only if [newline] - has been correctly used, as described dabove. *) - -val range: position * position -> string -end -module Printers : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This module is part of MenhirLib. *) - -module Make - - (I : IncrementalEngine.EVERYTHING) - - (User : sig - - (* [print s] is supposed to send the string [s] to some output channel. *) - - val print: string -> unit - - (* [print_symbol s] is supposed to print a representation of the symbol [s]. *) - - val print_symbol: I.xsymbol -> unit - - (* [print_element e] is supposed to print a representation of the element [e]. - This function is optional; if it is not provided, [print_element_as_symbol] - (defined below) is used instead. *) - - val print_element: (I.element -> unit) option - - end) - -: sig - - open I - - (* Printing a list of symbols. *) - - val print_symbols: xsymbol list -> unit - - (* Printing an element as a symbol. This prints just the symbol - that this element represents; nothing more. *) - - val print_element_as_symbol: element -> unit - - (* Printing a stack as a list of elements. This function needs an element - printer. It uses [print_element] if provided by the user; otherwise - it uses [print_element_as_symbol]. (Ending with a newline.) *) - - val print_stack: 'a env -> unit - - (* Printing an item. (Ending with a newline.) *) - - val print_item: item -> unit - - (* Printing a production. (Ending with a newline.) *) - - val print_production: production -> unit - - (* Printing the current LR(1) state. The current state is first displayed - as a number; then the list of its LR(0) items is printed. (Ending with - a newline.) *) - - val print_current_state: 'a env -> unit - - (* Printing a summary of the stack and current state. This function just - calls [print_stack] and [print_current_state] in succession. *) - - val print_env: 'a env -> unit - -end -end -module InfiniteArray : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(** This module implements infinite arrays. **) -type 'a t - -(** [make x] creates an infinite array, where every slot contains [x]. **) -val make: 'a -> 'a t - -(** [get a i] returns the element contained at offset [i] in the array [a]. - Slots are numbered 0 and up. **) -val get: 'a t -> int -> 'a - -(** [set a i x] sets the element contained at offset [i] in the array - [a] to [x]. Slots are numbered 0 and up. **) -val set: 'a t -> int -> 'a -> unit - -(** [extent a] is the length of an initial segment of the array [a] - that is sufficiently large to contain all [set] operations ever - performed. In other words, all elements beyond that segment have - the default value. *) -val extent: 'a t -> int - -(** [domain a] is a fresh copy of an initial segment of the array [a] - whose length is [extent a]. *) -val domain: 'a t -> 'a array -end -module PackedIntArray : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* A packed integer array is represented as a pair of an integer [k] and - a string [s]. The integer [k] is the number of bits per integer that we - use. The string [s] is just an array of bits, which is read in 8-bit - chunks. *) - -(* The ocaml programming language treats string literals and array literals - in slightly different ways: the former are statically allocated, while - the latter are dynamically allocated. (This is rather arbitrary.) In the - context of Menhir's table-based back-end, where compact, immutable - integer arrays are needed, ocaml strings are preferable to ocaml arrays. *) - -type t = - int * string - -(* [pack a] turns an array of integers into a packed integer array. *) - -(* Because the sign bit is the most significant bit, the magnitude of - any negative number is the word size. In other words, [pack] does - not achieve any space savings as soon as [a] contains any negative - numbers, even if they are ``small''. *) - -val pack: int array -> t - -(* [get t i] returns the integer stored in the packed array [t] at index [i]. *) - -(* Together, [pack] and [get] satisfy the following property: if the index [i] - is within bounds, then [get (pack a) i] equals [a.(i)]. *) - -val get: t -> int -> int - -(* [get1 t i] returns the integer stored in the packed array [t] at index [i]. - It assumes (and does not check) that the array's bit width is [1]. The - parameter [t] is just a string. *) - -val get1: string -> int -> int - -(* [unflatten1 (n, data) i j] accesses the two-dimensional bitmap - represented by [(n, data)] at indices [i] and [j]. The integer - [n] is the width of the bitmap; the string [data] is the second - component of the packed array obtained by encoding the table as - a one-dimensional array. *) - -val unflatten1: int * string -> int -> int -> int - -end -module RowDisplacement : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This module compresses a two-dimensional table, where some values - are considered insignificant, via row displacement. *) - -(* A compressed table is represented as a pair of arrays. The - displacement array is an array of offsets into the data array. *) - -type 'a table = - int array * (* displacement *) - 'a array (* data *) - -(* [compress equal insignificant dummy m n t] turns the two-dimensional table - [t] into a compressed table. The parameter [equal] is equality of data - values. The parameter [wildcard] tells which data values are insignificant, - and can thus be overwritten with other values. The parameter [dummy] is - used to fill holes in the data array. [m] and [n] are the integer - dimensions of the table [t]. *) - -val compress: - ('a -> 'a -> bool) -> - ('a -> bool) -> - 'a -> - int -> int -> - 'a array array -> - 'a table - -(* [get ct i j] returns the value found at indices [i] and [j] in the - compressed table [ct]. This function call is permitted only if the - value found at indices [i] and [j] in the original table is - significant -- otherwise, it could fail abruptly. *) - -(* Together, [compress] and [get] have the property that, if the value - found at indices [i] and [j] in an uncompressed table [t] is - significant, then [get (compress t) i j] is equal to that value. *) - -val get: - 'a table -> - int -> int -> - 'a - -(* [getget] is a variant of [get] which only requires read access, - via accessors, to the two components of the table. *) - -val getget: - ('displacement -> int -> int) -> - ('data -> int -> 'a) -> - 'displacement * 'data -> - int -> int -> - 'a - -end -module LinearizedArray : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* An array of arrays (of possibly different lengths!) can be ``linearized'', - i.e., encoded as a data array (by concatenating all of the little arrays) - and an entry array (which contains offsets into the data array). *) - -type 'a t = - (* data: *) 'a array * - (* entry: *) int array - -(* [make a] turns the array of arrays [a] into a linearized array. *) - -val make: 'a array array -> 'a t - -(* [read la i j] reads the linearized array [la] at indices [i] and [j]. - Thus, [read (make a) i j] is equivalent to [a.(i).(j)]. *) - -val read: 'a t -> int -> int -> 'a - -(* [write la i j v] writes the value [v] into the linearized array [la] - at indices [i] and [j]. *) - -val write: 'a t -> int -> int -> 'a -> unit - -(* [length la] is the number of rows of the array [la]. Thus, [length (make - a)] is equivalent to [Array.length a]. *) - -val length: 'a t -> int - -(* [row_length la i] is the length of the row at index [i] in the linearized - array [la]. Thus, [row_length (make a) i] is equivalent to [Array.length - a.(i)]. *) - -val row_length: 'a t -> int -> int - -(* [read_row la i] reads the row at index [i], producing a list. Thus, - [read_row (make a) i] is equivalent to [Array.to_list a.(i)]. *) - -val read_row: 'a t -> int -> 'a list - -(* The following variants read the linearized array via accessors - [get_data : int -> 'a] and [get_entry : int -> int]. *) - -val row_length_via: - (* get_entry: *) (int -> int) -> - (* i: *) int -> - int - -val read_via: - (* get_data: *) (int -> 'a) -> - (* get_entry: *) (int -> int) -> - (* i: *) int -> - (* j: *) int -> - 'a - -val read_row_via: - (* get_data: *) (int -> 'a) -> - (* get_entry: *) (int -> int) -> - (* i: *) int -> - 'a list - -end -module TableFormat : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This signature defines the format of the parse tables. It is used as - an argument to [TableInterpreter.Make]. *) - -module type TABLES = sig - - (* This is the parser's type of tokens. *) - - type token - - (* This maps a token to its internal (generation-time) integer code. *) - - val token2terminal: token -> int - - (* This is the integer code for the error pseudo-token. *) - - val error_terminal: int - - (* This maps a token to its semantic value. *) - - val token2value: token -> Obj.t - - (* Traditionally, an LR automaton is described by two tables, namely, an - action table and a goto table. See, for instance, the Dragon book. - - The action table is a two-dimensional matrix that maps a state and a - lookahead token to an action. An action is one of: shift to a certain - state, reduce a certain production, accept, or fail. - - The goto table is a two-dimensional matrix that maps a state and a - non-terminal symbol to either a state or undefined. By construction, this - table is sparse: its undefined entries are never looked up. A compression - technique is free to overlap them with other entries. - - In Menhir, things are slightly different. If a state has a default - reduction on token [#], then that reduction must be performed without - consulting the lookahead token. As a result, we must first determine - whether that is the case, before we can obtain a lookahead token and use it - as an index in the action table. - - Thus, Menhir's tables are as follows. - - A one-dimensional default reduction table maps a state to either ``no - default reduction'' (encoded as: 0) or ``by default, reduce prod'' - (encoded as: 1 + prod). The action table is looked up only when there - is no default reduction. *) - - val default_reduction: PackedIntArray.t - - (* Menhir follows Dencker, Dürre and Heuft, who point out that, although the - action table is not sparse by nature (i.e., the error entries are - significant), it can be made sparse by first factoring out a binary error - matrix, then replacing the error entries in the action table with undefined - entries. Thus: - - A two-dimensional error bitmap maps a state and a terminal to either - ``fail'' (encoded as: 0) or ``do not fail'' (encoded as: 1). The action - table, which is now sparse, is looked up only in the latter case. *) - - (* The error bitmap is flattened into a one-dimensional table; its width is - recorded so as to allow indexing. The table is then compressed via - [PackedIntArray]. The bit width of the resulting packed array must be - [1], so it is not explicitly recorded. *) - - (* The error bitmap does not contain a column for the [#] pseudo-terminal. - Thus, its width is [Terminal.n - 1]. We exploit the fact that the integer - code assigned to [#] is greatest: the fact that the right-most column - in the bitmap is missing does not affect the code for accessing it. *) - - val error: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *) - - (* A two-dimensional action table maps a state and a terminal to one of - ``shift to state s and discard the current token'' (encoded as: s | 10), - ``shift to state s without discarding the current token'' (encoded as: s | - 11), or ``reduce prod'' (encoded as: prod | 01). *) - - (* The action table is first compressed via [RowDisplacement], then packed - via [PackedIntArray]. *) - - (* Like the error bitmap, the action table does not contain a column for the - [#] pseudo-terminal. *) - - val action: PackedIntArray.t * PackedIntArray.t - - (* A one-dimensional lhs table maps a production to its left-hand side (a - non-terminal symbol). *) - - val lhs: PackedIntArray.t - - (* A two-dimensional goto table maps a state and a non-terminal symbol to - either undefined (encoded as: 0) or a new state s (encoded as: 1 + s). *) - - (* The goto table is first compressed via [RowDisplacement], then packed - via [PackedIntArray]. *) - - val goto: PackedIntArray.t * PackedIntArray.t - - (* The number of start productions. A production [prod] is a start - production if and only if [prod < start] holds. This is also the - number of start symbols. A nonterminal symbol [nt] is a start - symbol if and only if [nt < start] holds. *) - - val start: int - - (* A one-dimensional semantic action table maps productions to semantic - actions. The calling convention for semantic actions is described in - [EngineTypes]. This table contains ONLY NON-START PRODUCTIONS, so the - indexing is off by [start]. Be careful. *) - - val semantic_action: ((int, Obj.t, token) EngineTypes.env -> - (int, Obj.t) EngineTypes.stack) array - - (* The parser defines its own [Error] exception. This exception can be - raised by semantic actions and caught by the engine, and raised by the - engine towards the final user. *) - - exception Error - - (* The parser indicates whether to generate a trace. Generating a - trace requires two extra tables, which respectively map a - terminal symbol and a production to a string. *) - - val trace: (string array * string array) option - -end -end -module InspectionTableFormat : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This signature defines the format of the tables that are produced (in - addition to the tables described in [TableFormat]) when the command line - switch [--inspection] is enabled. It is used as an argument to - [InspectionTableInterpreter.Make]. *) - -module type TABLES = sig - - (* The types of symbols. *) - - include IncrementalEngine.SYMBOLS - - (* The type ['a lr1state] describes an LR(1) state. The generated parser defines - it internally as [int]. *) - - type 'a lr1state - - (* Some of the tables that follow use encodings of (terminal and - nonterminal) symbols as integers. So, we need functions that - map the integer encoding of a symbol to its algebraic encoding. *) - - val terminal: int -> xsymbol - val nonterminal: int -> xsymbol - - (* The left-hand side of every production already appears in the - signature [TableFormat.TABLES], so we need not repeat it here. *) - - (* The right-hand side of every production. This a linearized array - of arrays of integers, whose [data] and [entry] components have - been packed. The encoding of symbols as integers in described in - [TableBackend]. *) - - val rhs: PackedIntArray.t * PackedIntArray.t - - (* A mapping of every (non-initial) state to its LR(0) core. *) - - val lr0_core: PackedIntArray.t - - (* A mapping of every LR(0) state to its set of LR(0) items. Each item is - represented in its packed form (see [Item]) as an integer. Thus the - mapping is an array of arrays of integers, which is linearized and - packed, like [rhs]. *) - - val lr0_items: PackedIntArray.t * PackedIntArray.t - - (* A mapping of every LR(0) state to its incoming symbol, if it has one. *) - - val lr0_incoming: PackedIntArray.t - - (* A table that tells which non-terminal symbols are nullable. *) - - val nullable: string - (* This is a packed int array of bit width 1. It can be read - using [PackedIntArray.get1]. *) - - (* A two-table dimensional table, indexed by a nonterminal symbol and - by a terminal symbol (other than [#]), encodes the FIRST sets. *) - - val first: int (* width of the bitmap *) * string (* second component of [PackedIntArray.t] *) - -end - -end -module InspectionTableInterpreter : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This functor is invoked inside the generated parser, in [--table] mode. It - produces no code! It simply constructs the types [symbol] and [xsymbol] on - top of the generated types [terminal] and [nonterminal]. *) - -module Symbols (T : sig - - type 'a terminal - type 'a nonterminal - -end) - -: IncrementalEngine.SYMBOLS - with type 'a terminal := 'a T.terminal - and type 'a nonterminal := 'a T.nonterminal - -(* This functor is invoked inside the generated parser, in [--table] mode. It - constructs the inspection API on top of the inspection tables described in - [InspectionTableFormat]. *) - -module Make - (TT : TableFormat.TABLES) - (IT : InspectionTableFormat.TABLES - with type 'a lr1state = int) - (ET : EngineTypes.TABLE - with type terminal = int - and type nonterminal = int - and type semantic_value = Obj.t) - (E : sig - type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env - end) - -: IncrementalEngine.INSPECTION - with type 'a terminal := 'a IT.terminal - and type 'a nonterminal := 'a IT.nonterminal - and type 'a lr1state := 'a IT.lr1state - and type production := int - and type 'a env := 'a E.env -end -module TableInterpreter : sig -(******************************************************************************) -(* *) -(* Menhir *) -(* *) -(* François Pottier, Inria Paris *) -(* Yann Régis-Gianas, PPS, Université Paris Diderot *) -(* *) -(* Copyright Inria. All rights reserved. This file is distributed under the *) -(* terms of the GNU Library General Public License version 2, with a *) -(* special exception on linking, as described in the file LICENSE. *) -(* *) -(******************************************************************************) - -(* This module provides a thin decoding layer for the generated tables, thus - providing an API that is suitable for use by [Engine.Make]. It is part of - [MenhirLib]. *) - -(* The exception [Error] is declared within the generated parser. This is - preferable to pre-declaring it here, as it ensures that each parser gets - its own, distinct [Error] exception. This is consistent with the code-based - back-end. *) - -(* This functor is invoked by the generated parser. *) - -module MakeEngineTable - (T : TableFormat.TABLES) -: EngineTypes.TABLE - with type state = int - and type token = T.token - and type semantic_value = Obj.t - and type production = int - and type terminal = int - and type nonterminal = int -end -module StaticVersion : sig -val require_20201216: unit -end diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/parser_explain.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/parser_explain.ml deleted file mode 100644 index ef02f7096..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/parser_explain.ml +++ /dev/null @@ -1,51 +0,0 @@ -open Parser_raw -let named_item_at = function - | _ -> raise Not_found - -let nullable (type a) : a MenhirInterpreter.nonterminal -> bool = - let open MenhirInterpreter in function - | N_virtual_flag -> true - | N_type_variance -> true - | N_type_parameters -> true - | N_type_kind -> true - | N_structure -> true - | N_signature -> true - | N_reversed_llist_preceded_CONSTRAINT_constrain__ -> true - | N_rec_flag -> true - | N_private_virtual_flags -> true - | N_private_flag -> true - | N_payload -> true - | N_option_type_constraint_ -> true - | N_option_preceded_EQUAL_seq_expr__ -> true - | N_option_preceded_EQUAL_pattern__ -> true - | N_option_preceded_EQUAL_module_type__ -> true - | N_option_preceded_EQUAL_expr__ -> true - | N_option_preceded_COLON_core_type__ -> true - | N_option_preceded_AS_mkrhs_LIDENT___ -> true - | N_option_SEMI_ -> true - | N_option_BAR_ -> true - | N_opt_ampersand -> true - | N_mutable_virtual_flags -> true - | N_mutable_flag -> true - | N_list_use_file_element_ -> true - | N_list_text_str_structure_item__ -> true - | N_list_text_cstr_class_field__ -> true - | N_list_text_csig_class_sig_field__ -> true - | N_list_structure_element_ -> true - | N_list_signature_element_ -> true - | N_list_post_item_attribute_ -> true - | N_list_generic_and_type_declaration_type_subst_kind__ -> true - | N_list_generic_and_type_declaration_type_kind__ -> true - | N_list_attribute_ -> true - | N_list_and_module_declaration_ -> true - | N_list_and_module_binding_ -> true - | N_list_and_class_type_declaration_ -> true - | N_list_and_class_description_ -> true - | N_list_and_class_declaration_ -> true - | N_index_mod -> true - | N_generalized_constructor_arguments -> true - | N_formal_class_parameters -> true - | N_ext -> true - | N_class_self_type -> true - | N_class_self_pattern -> true - | _ -> false diff --git a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/parser_printer.ml b/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/parser_printer.ml deleted file mode 100644 index 2526b98d1..000000000 --- a/ocaml-lsp-server/vendor/merlin/src/ocaml/preprocess/parser_printer.ml +++ /dev/null @@ -1,984 +0,0 @@ -open Parser_raw - - let string_of_INT = function - | (s, None) -> Printf.sprintf "INT(%s)" s - | (s, Some c) -> Printf.sprintf "INT(%s%c)" s c - - let string_of_FLOAT = function - | (s, None) -> Printf.sprintf "FLOAT(%s)" s - | (s, Some c) -> Printf.sprintf "FLOAT(%s%c)" s c - - let string_of_STRING = function - | s, _, Some s' -> Printf.sprintf "STRING(%S,%S)" s s' - | s, _, None -> Printf.sprintf "STRING(%S)" s - - let string_of_quoted_STRING = function - | _, _, s, _, Some s' -> Printf.sprintf "QUOTED_STRING(%S,%S)" s s' - | _, _, s, _, None -> Printf.sprintf "QUOTED_STRING(%S)" s - - -let print_symbol = function - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_error) -> "error" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WITH) -> "with" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WHILE_LWT) -> "while_lwt" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WHILE) -> "while" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_WHEN) -> "when" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_VIRTUAL) -> "virtual" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_VAL) -> "val" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_UNDERSCORE) -> "_" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_UIDENT) -> "UIDENT" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TYPE) -> "type" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TRY_LWT) -> "try_lwt" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TRY) -> "try" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TRUE) -> "true" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TO) -> "to" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_TILDE) -> "~" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_THEN) -> "then" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_STRUCT) -> "struct" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_STRING) -> "STRING" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_STAR) -> "*" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_SIG) -> "sig" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_SEMISEMI) -> ";;" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_SEMI) -> ";" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_RPAREN) -> ")" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_REC) -> "rec" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_RBRACKET) -> "]" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_RBRACE) -> "}" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_ITEM) -> "QUOTED_STRING_ITEM" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUOTED_STRING_EXPR) -> "QUOTED_STRING_EXPR" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUOTE) -> "'" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUESTIONQUESTION) -> "??" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_QUESTION) -> "?" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PRIVATE) -> "private" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PREFIXOP) -> "!+" (* chosen with care; see above *) - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PLUSEQ) -> "+=" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PLUSDOT) -> "+." - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PLUS) -> "+" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_PERCENT) -> "%" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OR) -> "or" - | MenhirInterpreter.X (MenhirInterpreter.T MenhirInterpreter.T_OPTLABEL) -> "?