From 9be57bf93bc661eef8484b4dbafc102827198154 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 31 May 2024 14:08:42 +0200 Subject: [PATCH 01/42] Prepare for release 4.15-414 --- CHANGES.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index ea217dc137..96b8a73405 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,6 @@ -merlin NEXT_VERSION -================== +merlin 4.15 +=========== +Fri May 31 14:02:42 CEST 2024 + merlin binary - destruct: Removal of residual patterns (#1737, fixes #1560) From 89e00d232c6e4d05cf1c18e24317d7f9fb12f379 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 10 Jun 2024 16:14:17 +0200 Subject: [PATCH 02/42] [B] Merge pull request #1758 from xvw/tunneling-merlin-lsp-p1-split-protocol Extract commands from new protocol inside a dedicated library --- CHANGES.md | 12 ++++++ src/commands/dune | 14 +++++++ .../new => commands}/new_commands.ml | 29 ++++++++++++++ src/commands/new_commands.mli | 38 +++++++++++++++++++ .../ocamlmerlin => commands}/query_json.ml | 0 src/frontend/ocamlmerlin/dune | 5 ++- src/frontend/ocamlmerlin/new/new_commands.mli | 9 ----- 7 files changed, 96 insertions(+), 11 deletions(-) create mode 100644 src/commands/dune rename src/{frontend/ocamlmerlin/new => commands}/new_commands.ml (94%) create mode 100644 src/commands/new_commands.mli rename src/{frontend/ocamlmerlin => commands}/query_json.ml (100%) delete mode 100644 src/frontend/ocamlmerlin/new/new_commands.mli diff --git a/CHANGES.md b/CHANGES.md index 96b8a73405..260aa1eed5 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,12 @@ +merlin 4.16 +=========== +unreleased + + + merlin binary + - Addition of a `merlin-lib.commands` library which disassociates the + execution of commands from the `new_protocol`, from the binary, allowing + it to be invoked from other projects (#1758) + merlin 4.15 =========== Fri May 31 14:02:42 CEST 2024 @@ -9,6 +18,9 @@ Fri May 31 14:02:42 CEST 2024 - Ignore SIGPIPE in the Merlin server process (#1746) - Fix lexing of quoted strings in comments (#1754, fixes #1753) - Improve cursor position detection in longidents (#1756) + - Addition of a `merlin-lib.commands` library which disassociates the + execution of commands from the `new_protocol`, from the binary, allowing + it to be invoked from other projects (#1758) merlin 4.14 =========== diff --git a/src/commands/dune b/src/commands/dune new file mode 100644 index 0000000000..016727ba05 --- /dev/null +++ b/src/commands/dune @@ -0,0 +1,14 @@ +(library + (name merlin_commands) + (public_name merlin-lib.commands) + (flags + :standard + -open Ocaml_parsing + -open Merlin_utils + -open Merlin_kernel) + (libraries + merlin-lib.ocaml_parsing + merlin-lib.utils + merlin-lib.kernel + merlin-lib.query_protocol + merlin-lib.query_commands)) diff --git a/src/frontend/ocamlmerlin/new/new_commands.ml b/src/commands/new_commands.ml similarity index 94% rename from src/frontend/ocamlmerlin/new/new_commands.ml rename to src/commands/new_commands.ml index a1b753dd7d..81e5ff1bc5 100644 --- a/src/frontend/ocamlmerlin/new/new_commands.ml +++ b/src/commands/new_commands.ml @@ -1,3 +1,32 @@ +(* {{{ 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 type command = diff --git a/src/commands/new_commands.mli b/src/commands/new_commands.mli new file mode 100644 index 0000000000..e8f766f822 --- /dev/null +++ b/src/commands/new_commands.mli @@ -0,0 +1,38 @@ +(* {{{ 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 + +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/src/frontend/ocamlmerlin/query_json.ml b/src/commands/query_json.ml similarity index 100% rename from src/frontend/ocamlmerlin/query_json.ml rename to src/commands/query_json.ml diff --git a/src/frontend/ocamlmerlin/dune b/src/frontend/ocamlmerlin/dune index e8ab3eccdd..409c71c0c2 100644 --- a/src/frontend/ocamlmerlin/dune +++ b/src/frontend/ocamlmerlin/dune @@ -12,12 +12,13 @@ -open Merlin_kernel -open Merlin_utils -open Merlin_analysis - -open Merlin_kernel) + -open Merlin_kernel + -open Merlin_commands) (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)) + merlin-lib.ocaml_typing merlin-lib.ocaml_utils merlin-lib.commands)) (executable (name gen_ccflags) diff --git a/src/frontend/ocamlmerlin/new/new_commands.mli b/src/frontend/ocamlmerlin/new/new_commands.mli deleted file mode 100644 index 2c6498aa25..0000000000 --- a/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 From 060404c957f5fe3092226b7360d83f8b693912a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 10 Jun 2024 16:14:56 +0200 Subject: [PATCH 03/42] [B] Merge pull request #1778 from voodoos/find-command-opt Add a `find_command_opt` alternative to `find_command` that does not raise --- CHANGES.md | 2 ++ src/commands/new_commands.ml | 15 +++++++-------- src/commands/new_commands.mli | 6 ++++++ 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 260aa1eed5..3c86229c59 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,8 @@ unreleased - Addition of a `merlin-lib.commands` library which disassociates the execution of commands from the `new_protocol`, from the binary, allowing it to be invoked from other projects (#1758) + - `merlin-lib.commands`: Add a `find_command_opt` alternative to + `find_command` that does not raise (#1778) merlin 4.15 =========== diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 81e5ff1bc5..4491ae9f25 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -81,12 +81,11 @@ let marg_completion_kind f = Marg.param "completion-kind" 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 command_is ~name (Command (name', _, _, _, _)) = String.equal name name' + +let find_command name = List.find ~f:(command_is ~name) + +let find_command_opt name = List.find_opt ~f:(command_is ~name) let run pipeline query = Logger.log ~section:"New_commands" ~title:"run(query)" @@ -236,9 +235,9 @@ Otherwise, Merlin looks for the documentation for the entity under the cursor (a ] ~default: `None begin fun buffer pos -> - match pos with + match pos with | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> + | #Msource.position as pos -> run buffer (Query_protocol.Syntax_document pos) end ; diff --git a/src/commands/new_commands.mli b/src/commands/new_commands.mli index e8f766f822..7c62b49d8f 100644 --- a/src/commands/new_commands.mli +++ b/src/commands/new_commands.mli @@ -35,4 +35,10 @@ type command = val all_commands : command list +(** [find_command name cmds] returns the command with name [name] in the list + [cmds] if it exists. Raises [Not_found] if it does not. *) val find_command : string -> command list -> command + +(** [find_command name cmds] optionaly returns the command with name [name] if + it is in the list [cmds]. *) +val find_command_opt : string -> command list -> command option From d129d7edb3927ebd8e2d03976400dcad0e205f3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 10 Jun 2024 17:32:11 +0200 Subject: [PATCH 04/42] Prepare for release v4.16-414 --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 3c86229c59..dff06f5c86 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,6 @@ merlin 4.16 =========== -unreleased +Mon Jun 10 17:35:42 CEST 2024 + merlin binary - Addition of a `merlin-lib.commands` library which disassociates the From 5a98d886ca3c9334fd89655f64b3912ccf5d0620 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 10 Jun 2024 17:36:48 +0200 Subject: [PATCH 05/42] Remove duplicate entry in changelog --- CHANGES.md | 3 --- 1 file changed, 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index dff06f5c86..e28de7653d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -20,9 +20,6 @@ Fri May 31 14:02:42 CEST 2024 - Ignore SIGPIPE in the Merlin server process (#1746) - Fix lexing of quoted strings in comments (#1754, fixes #1753) - Improve cursor position detection in longidents (#1756) - - Addition of a `merlin-lib.commands` library which disassociates the - execution of commands from the `new_protocol`, from the binary, allowing - it to be invoked from other projects (#1758) merlin 4.14 =========== From a9037595ece8ea8be23adecc02874e9db4bc4b66 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 11 Sep 2024 14:54:34 +0200 Subject: [PATCH 06/42] Backport changes from issue #1798 --- vim/merlin/autoload/merlin.py | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/vim/merlin/autoload/merlin.py b/vim/merlin/autoload/merlin.py index 41c1aab9e3..2e9528a024 100644 --- a/vim/merlin/autoload/merlin.py +++ b/vim/merlin/autoload/merlin.py @@ -760,19 +760,19 @@ def easy_matcher_wide(start, stop): startl = "" startc = "" if start['line'] > 0: - startl = "\%{0}l".format(start['line']) + startl = "\\%{0}l".format(start['line']) if start['col'] > 0: - startc = "\%{0}c".format(start['col'] + 1) - return '{0}{1}.*\%{2}l\%{3}c'.format(startl, startc, stop['line'], stop['col'] + 1) + startc = "\\%{0}c".format(start['col'] + 1) + return '{0}{1}.*\\%{2}l\\%{3}c'.format(startl, startc, stop['line'], stop['col'] + 1) def easy_matcher(start, stop): startl = "" startc = "" if start['line'] > 0: - startl = "\%>{0}l".format(start['line'] - 1) + startl = "\\%>{0}l".format(start['line'] - 1) if start['col'] > 0: - startc = "\%>{0}c".format(start['col']) - return '{0}{1}\%<{2}l\%<{3}c'.format(startl, startc, stop['line'] + 1, stop['col'] + 1) + startc = "\\%>{0}c".format(start['col']) + return '{0}{1}\\%<{2}l\\%<{3}c'.format(startl, startc, stop['line'] + 1, stop['col'] + 1) def hard_matcher(start, stop): first_start = {'line' : start['line'], 'col' : start['col']} @@ -784,7 +784,7 @@ def hard_matcher(start, stop): last_start = {'line' : stop['line'], 'col' : 0} last_stop = {'line' : stop['line'], 'col' : stop['col']} last_line = easy_matcher(last_start, last_stop) - return "{0}\|{1}\|{2}".format(first_line, middle, last_line) + return "{0}\\|{1}\\|{2}".format(first_line, middle, last_line) def make_matcher(start, stop): if start['line'] == stop['line']: From 10d36598c49d61f119848be27a3012c01487c4db Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 11 Sep 2024 18:36:05 +0200 Subject: [PATCH 07/42] Backported Changes entry. --- CHANGES.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index e28de7653d..9bcf35db64 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +unreleased +========== + + editor modes + - vim: fix python-3.12 syntax warnings in merlin.py (#1798) + merlin 4.16 =========== Mon Jun 10 17:35:42 CEST 2024 From c3b78f8af70c14a13bdf13d44cc11e739f7038fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:28:14 +0200 Subject: [PATCH 08/42] [B] SOURCE_ROOT, UNIT_NAME and WRAPPING_PREFIX --- CHANGES.md | 4 ++ src/dot-merlin/dot_merlin_reader.ml | 17 ++++- src/dot-protocol/merlin_dot_protocol.ml | 10 +++ src/dot-protocol/merlin_dot_protocol.mli | 3 + src/kernel/mconfig.ml | 27 +++++++- src/kernel/mconfig.mli | 5 +- src/kernel/mconfig_dot.ml | 15 +++++ src/kernel/mconfig_dot.mli | 3 + .../config/dot-merlin-reader/load-config.t | 63 +++++++++++++++++++ .../config/dot-merlin-reader/quoting.t | 3 + 10 files changed, 147 insertions(+), 3 deletions(-) create mode 100644 tests/test-dirs/config/dot-merlin-reader/load-config.t diff --git a/CHANGES.md b/CHANGES.md index 9bcf35db64..9b0b5063de 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,9 @@ unreleased ========== + + + merlin binary + - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin + what to append to the current unit name in the presence of wrapping (#1788) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e3a1aaba00..349bd81476 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -92,6 +92,12 @@ module Cache = File_cache.Make (struct 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:"SOURCE_ROOT " line then + tell (`SOURCE_ROOT (String.drop 12 line)) + else if String.is_prefixed ~by:"UNIT_NAME " line then + tell (`UNIT_NAME (String.drop 10 line)) + else if String.is_prefixed ~by:"WRAPPING_PREFIX " line then + tell (`WRAPPING_PREFIX (String.drop 16 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 @@ -305,6 +311,7 @@ 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; + source_root : string option; packages_to_load : string list; findlib : string option; findlib_path : string list; @@ -315,6 +322,7 @@ let empty_config = { pass_forward = []; to_canonicalize = []; stdlib = None; + source_root = None; packages_to_load = []; findlib = None; findlib_path = []; @@ -327,7 +335,11 @@ let prepend_config ~cwd ~cfg = | `B _ | `S _ | `CMI _ | `CMT _ as directive -> { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ - | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive -> + | (`EXCLUDE_QUERY_DIR + | `USE_PPX_CACHE + | `UNIT_NAME _ + | `WRAPPING_PREFIX _ + | `UNKNOWN_TAG _) as directive -> { cfg with pass_forward = directive :: cfg.pass_forward } | `PKG ps -> { cfg with packages_to_load = ps @ cfg.packages_to_load } @@ -339,6 +351,9 @@ let prepend_config ~cwd ~cfg = log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path end; { cfg with stdlib = Some canon_path } + | `SOURCE_ROOT path -> + let canon_path = canonicalize_filename ~cwd path in + { cfg with source_root = Some canon_path } | `FINDLIB path -> let canon_path = canonicalize_filename ~cwd path in begin match cfg.stdlib with diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 97648d9317..181175cca7 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -37,6 +37,9 @@ module Directive = struct [ `EXT of string list | `FLG of string list | `STDLIB of string + | `SOURCE_ROOT of string + | `UNIT_NAME of string + | `WRAPPING_PREFIX of string | `SUFFIX of string | `READER of string list | `EXCLUDE_QUERY_DIR @@ -85,6 +88,9 @@ module Sexp = struct | "CMI" -> `CMI value | "CMT" -> `CMT value | "STDLIB" -> `STDLIB value + | "SOURCE_ROOT" -> `SOURCE_ROOT value + | "UNIT_NAME" -> `UNIT_NAME value + | "WRAPPING_PREFIX" -> `WRAPPING_PREFIX value | "SUFFIX" -> `SUFFIX value | "ERROR" -> `ERROR_MSG value | "FLG" -> @@ -114,6 +120,10 @@ module Sexp = struct | `S s -> ("S", single s) | `CMI s -> ("CMI", single s) | `CMT s -> ("CMT", single s) + | `INDEX s -> ("INDEX", single s) + | `SOURCE_ROOT s -> ("SOURCE_ROOT", single s) + | `UNIT_NAME s -> ("UNIT_NAME", single s) + | `WRAPPING_PREFIX s -> ("WRAPPING_PREFIX", single s) | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ]) | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ]) | `STDLIB s -> ("STDLIB", single s) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index c238b813ae..1b96bf2f2c 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -49,6 +49,9 @@ module Directive : sig [ `EXT of string list | `FLG of string list | `STDLIB of string + | `SOURCE_ROOT of string + | `UNIT_NAME of string + | `WRAPPING_PREFIX of string | `SUFFIX of string | `READER of string list | `EXCLUDE_QUERY_DIR diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index e050014f92..90448f9714 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -77,6 +77,9 @@ type merlin = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; reader : string list; protocol : [`Json | `Sexp]; log_file : string option; @@ -115,6 +118,9 @@ let dump_merlin x = ]) x.suffixes ); "stdlib" , Json.option Json.string x.stdlib; + "source_root" , Json.option Json.string x.source_root; + "unit_name" , Json.option Json.string x.unit_name; + "wrapping_prefix" , Json.option Json.string x.wrapping_prefix; "reader" , `List (List.map ~f:Json.string x.reader); "protocol" , (match x.protocol with | `Json -> `String "json" @@ -243,6 +249,14 @@ let merge_merlin_config dot merlin ~failures ~config_path = extensions = dot.extensions @ merlin.extensions; suffixes = dot.suffixes @ merlin.suffixes; stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib); + source_root = + (if dot.source_root = None then merlin.source_root else dot.source_root); + unit_name = + (if dot.unit_name = None then merlin.unit_name else dot.unit_name); + wrapping_prefix = + if dot.wrapping_prefix = None + then merlin.wrapping_prefix + else dot.wrapping_prefix; reader = if dot.reader = [] then merlin.reader @@ -624,6 +638,9 @@ let initial = { extensions = []; suffixes = [(".ml", ".mli"); (".re", ".rei")]; stdlib = None; + source_root = None; + unit_name = None; + wrapping_prefix = None; reader = []; protocol = `Json; log_file = None; @@ -796,4 +813,12 @@ let global_modules ?(include_current=false) config = ( let filename t = t.query.filename -let unitname t = Misc.unitname t.query.filename +let unitname t = + match t.merlin.unit_name with + | Some name -> Misc.unitname name + | None -> + let basename = Misc.unitname t.query.filename in + begin match t.merlin.wrapping_prefix with + | Some prefix -> prefix ^ basename + | None -> basename + end diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 05d3197f23..3b1215b28f 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -35,6 +35,9 @@ type merlin = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; reader : string list; protocol : [`Json | `Sexp]; log_file : string option; @@ -57,7 +60,7 @@ val dump_merlin : merlin -> json (** {1 Some flags affecting queries} *) -module Verbosity : sig +module Verbosity : sig type t = Smart | Lvl of int (** the default value for verbosity, i.e., [Lvl 0] *) diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index 13ad8eba99..0a17f4671c 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -41,6 +41,9 @@ type config = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; reader : string list; exclude_query_dir : bool; use_ppx_cache : bool; @@ -55,6 +58,9 @@ let empty_config = { suffixes = []; flags = []; stdlib = None; + source_root = None; + unit_name = None; + wrapping_prefix = None; reader = []; exclude_query_dir = false; use_ppx_cache = false; @@ -246,6 +252,12 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config = {config with flags = flags :: config.flags}, errors | `STDLIB path -> {config with stdlib = Some path}, errors + | `SOURCE_ROOT path -> + {config with source_root = Some path}, errors + | `UNIT_NAME name -> + {config with unit_name = Some name}, errors + | `WRAPPING_PREFIX prefix -> + {config with wrapping_prefix = Some prefix}, errors | `READER reader -> {config with reader}, errors | `EXCLUDE_QUERY_DIR -> @@ -274,6 +286,9 @@ let postprocess_config config = suffixes = clean config.suffixes; flags = clean config.flags; stdlib = config.stdlib; + source_root = config.source_root; + unit_name = config.unit_name; + wrapping_prefix = config.wrapping_prefix; reader = config.reader; exclude_query_dir = config.exclude_query_dir; use_ppx_cache = config.use_ppx_cache; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 926fb928a8..1cb93ebac7 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -43,6 +43,9 @@ type config = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; reader : string list; exclude_query_dir : bool; use_ppx_cache : bool; diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t new file mode 100644 index 0000000000..ee9af398bf --- /dev/null +++ b/tests/test-dirs/config/dot-merlin-reader/load-config.t @@ -0,0 +1,63 @@ +This test comes from: https://github.com/janestreet/merlin-jst/pull/59 + + $ cat > .merlin < B build/dir + > S source/dir + > BH build-hidden/dir + > SH source-hidden/dir + > EOF + + $ FILE=$(pwd)/test.ml; dot-merlin-reader < (4:File${#FILE}:$FILE) + > EOF + ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:ERROR?:Unknown tag in .merlin?: BH)(?:ERROR?:Unknown tag in .merlin?: SH)) + + $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin' + { + "build_path": [ + "$TESTCASE_ROOT/build/dir" + ], + "source_path": [ + "$TESTCASE_ROOT/source/dir" + ], + "cmi_path": [], + "cmt_path": [], + "flags_applied": [], + "extensions": [], + "suffixes": [ + { + "impl": ".ml", + "intf": ".mli" + }, + { + "impl": ".re", + "intf": ".rei" + } + ], + "stdlib": null, + "source_root": null, + "unit_name": null, + "wrapping_prefix": null, + "reader": [], + "protocol": "json", + "log_file": null, + "log_sections": [], + "flags_to_apply": [], + "failures": [ + "Unknown tag in .merlin: SH", + "Unknown tag in .merlin: BH" + ], + "assoc_suffixes": [ + { + "extension": ".re", + "reader": "reason" + }, + { + "extension": ".rei", + "reader": "reason" + } + ], + "cache_lifespan": "5" + } + + $ rm .merlin diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index b9ae8c7eee..9458ffd34f 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -51,6 +51,9 @@ } ], "stdlib": null, + "source_root": null, + "unit_name": null, + "wrapping_prefix": null, "reader": [], "protocol": "json", "log_file": null, From 570cd57022399e2080ab232b4f004b005860fff7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:30:09 +0200 Subject: [PATCH 09/42] [B] #1795: Fix #1794: Add `-unboxed-types` and `-no-unboxed-types` to ignored flags --- CHANGES.md | 1 + src/kernel/mconfig.ml | 8 ++++---- tests/test-dirs/errors/issue1794.t | 13 +++++++++++++ 3 files changed, 18 insertions(+), 4 deletions(-) create mode 100644 tests/test-dirs/errors/issue1794.t diff --git a/CHANGES.md b/CHANGES.md index 9b0b5063de..a413733ac9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,7 @@ unreleased + merlin binary - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin what to append to the current unit name in the presence of wrapping (#1788) + - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 90448f9714..ef8e8f6208 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -430,10 +430,10 @@ let ocaml_ignored_flags = [ "-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"; + "-no-unbox-specialised-args"; "-no-unboxed-types"; "-O2"; "-O3"; + "-Oclassic"; "-opaque"; "-output-complete-obj"; "-output-obj"; "-p"; "-pack"; + "-remove-unused-arguments"; "-S"; "-shared"; "-unbox-closures"; + "-unboxed-types"; "-v"; "-verbose"; "-where"; ] let ocaml_ignored_parametrized_flags = [ diff --git a/tests/test-dirs/errors/issue1794.t b/tests/test-dirs/errors/issue1794.t new file mode 100644 index 0000000000..b5ee24a474 --- /dev/null +++ b/tests/test-dirs/errors/issue1794.t @@ -0,0 +1,13 @@ + $ $MERLIN single errors -filename main.ml -unboxed-types + { + "class": "return", + "value": [], + "notifications": [] + } + + $ $MERLIN single errors -filename main.ml -no-unboxed-types + { + "class": "return", + "value": [], + "notifications": [] + } From 9d76cd6ea2524c9f5d53dbd2f8e99b424cc27673 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:34:06 +0200 Subject: [PATCH 10/42] [B] #1804 vim: remove references to MerlinPhrase --- CHANGES.md | 1 + vim/merlin/autoload/merlin.vim | 22 ---------------------- vim/merlin/doc/merlin.txt | 6 ------ 3 files changed, 1 insertion(+), 28 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index a413733ac9..4893aee899 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,6 +7,7 @@ unreleased - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) + - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) merlin 4.16 =========== diff --git a/vim/merlin/autoload/merlin.vim b/vim/merlin/autoload/merlin.vim index f78424cdd1..df33b3bdb0 100644 --- a/vim/merlin/autoload/merlin.vim +++ b/vim/merlin/autoload/merlin.vim @@ -662,20 +662,6 @@ function! merlin#setVisualSelection(a, b) call setpos("'b", markBSave) endfunction -let s:phrase_counter = 0 - -function! merlin#Phrase() - if s:phrase_counter - let s:phrase_counter = s:phrase_counter - 1 - else - let [l1, c1] = getpos("'<")[1:2] - let [l2, c2] = getpos("'>")[1:2] - let s:phrase_counter = l2 - l1 - MerlinPy merlin.vim_selectphrase("l1","c1","l2","c2") - call merlin#setVisualSelection([l1,c1],[l2,c2]) - endif -endfunction - function! merlin#Register() if @% == ":merlin-type-history:" return @@ -807,10 +793,6 @@ function! merlin#Register() command! -buffer -nargs=0 MerlinGotoDotMerlin call merlin#GotoDotMerlin() command! -buffer -nargs=0 MerlinEchoDotMerlin call merlin#EchoDotMerlin() - """ 'semantic movement' ----------------------------------------------------- - " TODO: bind (,),{,} ? - command! -buffer -nargs=0 MerlinPhrase call merlin#Phrase() - """ Polarity search command! -buffer -complete=customlist,merlin#ExpandTypePrefix -nargs=+ MerlinSearch call merlin#PolaritySearch(0,) @@ -819,10 +801,6 @@ function! merlin#Register() command! -buffer -nargs=0 MerlinDebugDisable call merlin#DebugDisable() command! -buffer -nargs=0 MerlinDebugEnable call merlin#DebugEnable() - if !exists('g:merlin_disable_default_keybindings') || !g:merlin_disable_default_keybindings - vmap :MerlinPhrase - endif - call merlin#LoadProject() endfunction diff --git a/vim/merlin/doc/merlin.txt b/vim/merlin/doc/merlin.txt index b741bc926a..b1c571d5d7 100644 --- a/vim/merlin/doc/merlin.txt +++ b/vim/merlin/doc/merlin.txt @@ -147,12 +147,6 @@ environment which name matches the user input. Hitting enter will move you to the definition of the selected element. -:MerlinPhrase *:MerlinPhrase* -Selects the current phrase. - - -Bound to by default in visual mode. - :MerlinErrorCheck *:MerlinErrorCheck* Perform a fast type check of the current file, displaying the error From 9ac5dea6a133e5353cf606bb10a544420d117ecc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:34:58 +0200 Subject: [PATCH 11/42] [B] #1806 Ignore new Menhir deprecations --- src/ocaml/preprocess/recover/gen_recover.ml | 2 +- src/ocaml/preprocess/recover/synthesis.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ocaml/preprocess/recover/gen_recover.ml b/src/ocaml/preprocess/recover/gen_recover.ml index 2d0f14f86b..c2046b5a83 100644 --- a/src/ocaml/preprocess/recover/gen_recover.ml +++ b/src/ocaml/preprocess/recover/gen_recover.ml @@ -23,7 +23,7 @@ let () = module G = Cmly_read.Read (struct let filename = !name end) module A = Recover_attrib.Make(G) -let () = +let[@alert "-deprecated"] () = let open Format in let ppf = Format.err_formatter in if !verbose then begin diff --git a/src/ocaml/preprocess/recover/synthesis.ml b/src/ocaml/preprocess/recover/synthesis.ml index 70f6f6d571..fcf34c4327 100644 --- a/src/ocaml/preprocess/recover/synthesis.ml +++ b/src/ocaml/preprocess/recover/synthesis.ml @@ -104,7 +104,7 @@ struct | _ -> false) *) - let cost_of = function + let[@alert "-deprecated"] cost_of = function | Head (st, n) -> let acc = List.fold_left (fun acc (_sym, st') -> @@ -184,7 +184,7 @@ struct let cost_of_actions actions = List.fold_left (fun cost act -> cost +. cost_of_action act) 0.0 actions - let solution = function + let[@alert "-deprecated"] solution = function | Head (st, n) -> let acc = Abort in let acc = List.fold_left From 7eed27aacaff37d57715acd1bdf2026588e9ce4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:38:09 +0200 Subject: [PATCH 12/42] [B] #1800 Refinement in the presence of optional arguments --- CHANGES.md | 1 + src/analysis/destruct.ml | 37 +++++- tests/test-dirs/destruct/issue1770.t | 162 +++++++++++++++++++++++++++ 3 files changed, 199 insertions(+), 1 deletion(-) create mode 100644 tests/test-dirs/destruct/issue1770.t diff --git a/CHANGES.md b/CHANGES.md index 4893aee899..492ef53027 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,7 @@ unreleased - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin what to append to the current unit name in the presence of wrapping (#1788) - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794) + - destruct: Refinement in the presence of optional arguments (#1800 fixes #1770) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 740e281a8e..e2d17fd62f 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -500,9 +500,44 @@ let print_pretty ?punned_field config source subject = | Some label -> label.Types.lbl_name ^ " = " ^ result +let need_recover_labeled_args = function + | Parsetree.Pexp_construct ({loc; txt = Longident.Lident ctor}, Some e) -> + (* If the internal construction is ghosted, then the expression must be + re-labelled. *) + if String.equal "Some" ctor && loc.loc_ghost then Some e else None + | _ -> None + +let remove_non_applied_optional_args (Parsetree.{ pexp_desc; _} as base_expr) = + (* Fix the behaviour described here + https://github.com/ocaml/merlin/issues/1770 *) + match pexp_desc with + | Parsetree.Pexp_apply (expr, args) -> + let args = List.concat_map ~f:(fun (label, expr) -> + match label with + | Asttypes.Optional str -> + (* If an optional parameter is not applied, its location is assumed to + be ghost, and the parameter should not be generated. *) + let loc = expr.Parsetree.pexp_loc in + if loc.loc_ghost + then [] + else begin + match need_recover_labeled_args expr.pexp_desc with + | Some e -> [(Asttypes.Labelled str, e)] + | None -> [(label, expr)] + end + | _ -> [(label, expr)] + ) args + in + let pexp_desc = Parsetree.Pexp_apply (expr, args) in + { base_expr with pexp_desc } + | _ -> base_expr + let destruct_expression loc config source parents expr = let ty = expr.Typedtree.exp_type in - let pexp = filter_expr_attr (Untypeast.untype_expression expr) in + let pexp = + filter_expr_attr (Untypeast.untype_expression expr) + |> remove_non_applied_optional_args + in let () = log ~title:"node_expression" "%a" Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp) diff --git a/tests/test-dirs/destruct/issue1770.t b/tests/test-dirs/destruct/issue1770.t new file mode 100644 index 0000000000..97c63bd802 --- /dev/null +++ b/tests/test-dirs/destruct/issue1770.t @@ -0,0 +1,162 @@ + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?bar x = x + > let () = foo () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 15 + } + }, + "match foo () with | () -> _" + ], + "notifications": [] + } + +$ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?bar x = x + > let () = foo ~bar:10 () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 23 + } + }, + "match foo ~bar:10 () with | () -> _" + ], + "notifications": [] + } + + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?bar x = x + > let () = foo ?bar:(Some 10) () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 30 + } + }, + "match foo ?bar:(Some 10) () with | () -> _" + ], + "notifications": [] + } + + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?(bar = 10) x = x + > let () = foo () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 15 + } + }, + "match foo () with | () -> _" + ], + "notifications": [] + } + + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?(bar = 10) x = x + > let () = foo ~bar:15 () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 23 + } + }, + "match foo ~bar:15 () with | () -> _" + ], + "notifications": [] + } + + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?(bar = 10) x = x + > let () = foo ?bar:None () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 25 + } + }, + "match foo ?bar:None () with | () -> _" + ], + "notifications": [] + } + + $ $MERLIN single case-analysis -start 2:10 -end 2:15 \ + > -filename main.ml < let foo ?(bar = 10) x = x + > let () = foo ?bar:(Some 15) () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 30 + } + }, + "match foo ?bar:(Some 15) () with | () -> _" + ], + "notifications": [] + } From b8d97d58780e76022839b8b30348829769da2be1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:39:22 +0200 Subject: [PATCH 13/42] [B] #1807 Check always that default args are option --- CHANGES.md | 2 +- src/analysis/destruct.ml | 19 ++++++++----------- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 492ef53027..5be955e6a1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,7 +5,7 @@ unreleased - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin what to append to the current unit name in the presence of wrapping (#1788) - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794) - - destruct: Refinement in the presence of optional arguments (#1800 fixes #1770) + - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index e2d17fd62f..d7e34f60f5 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -512,19 +512,16 @@ let remove_non_applied_optional_args (Parsetree.{ pexp_desc; _} as base_expr) = https://github.com/ocaml/merlin/issues/1770 *) match pexp_desc with | Parsetree.Pexp_apply (expr, args) -> - let args = List.concat_map ~f:(fun (label, expr) -> - match label with - | Asttypes.Optional str -> - (* If an optional parameter is not applied, its location is assumed to - be ghost, and the parameter should not be generated. *) - let loc = expr.Parsetree.pexp_loc in - if loc.loc_ghost - then [] - else begin - match need_recover_labeled_args expr.pexp_desc with + let args = List.concat_map ~f:(fun (label, (expr : Parsetree.expression)) -> + match label, expr.pexp_loc.loc_ghost, expr.pexp_desc with + | Asttypes.Optional _, true, + Pexp_construct ({ txt = Longident.Lident "None"; _ }, _) -> + [] + | Asttypes.Optional str, false, exp_desc -> + (match need_recover_labeled_args exp_desc with | Some e -> [(Asttypes.Labelled str, e)] | None -> [(label, expr)] - end + ) | _ -> [(label, expr)] ) args in From f9901b16f53f33a2d582e5fa9c3f85e2e4f1586f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:41:29 +0200 Subject: [PATCH 14/42] [B] #1803 Fix ignorance of STDLIB in .merlin --- src/dot-merlin/dot_merlin_reader.ml | 1 + .../config/dot-merlin-reader/load-config.t | 5 +++-- .../config/dot-merlin-reader/stdlib-config.t | 21 +++++++++++++++++++ 3 files changed, 25 insertions(+), 2 deletions(-) create mode 100644 tests/test-dirs/config/dot-merlin-reader/stdlib-config.t diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index 349bd81476..d5c3e26c1d 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -474,6 +474,7 @@ let postprocess cfg = (dirs :> Merlin_dot_protocol.directive list) ) ; (cfg.pass_forward :> Merlin_dot_protocol.directive list) + ; cfg.stdlib |> Option.map ~f:(fun stdlib -> `STDLIB stdlib) |> Option.to_list ; List.concat_map pkg_paths ~f:(fun p -> [ `B p; `S p ]) ; ppx ; List.map failures ~f:(fun s -> `ERROR_MSG s) diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t index ee9af398bf..cd3b50f634 100644 --- a/tests/test-dirs/config/dot-merlin-reader/load-config.t +++ b/tests/test-dirs/config/dot-merlin-reader/load-config.t @@ -5,12 +5,13 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59 > S source/dir > BH build-hidden/dir > SH source-hidden/dir + > STDLIB /stdlib > EOF $ FILE=$(pwd)/test.ml; dot-merlin-reader < (4:File${#FILE}:$FILE) > EOF - ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:ERROR?:Unknown tag in .merlin?: BH)(?:ERROR?:Unknown tag in .merlin?: SH)) + ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:ERROR?:Unknown tag in .merlin?: BH)(?:ERROR?:Unknown tag in .merlin?: SH)(?:STDLIB?:/stdlib)) $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin' { @@ -34,7 +35,7 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59 "intf": ".rei" } ], - "stdlib": null, + "stdlib": "/stdlib", "source_root": null, "unit_name": null, "wrapping_prefix": null, diff --git a/tests/test-dirs/config/dot-merlin-reader/stdlib-config.t b/tests/test-dirs/config/dot-merlin-reader/stdlib-config.t new file mode 100644 index 0000000000..33ae58c061 --- /dev/null +++ b/tests/test-dirs/config/dot-merlin-reader/stdlib-config.t @@ -0,0 +1,21 @@ +The STDLIB directive in .merlin is respected + $ cat > .merlin < STDLIB /stdlib1 + > EOF + + $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin.stdlib' + "/stdlib1" + + $ rm .merlin + +The -ocamlib-path flag is respected + $ echo | $MERLIN single dump-configuration -ocamllib-path /stdlib2 -filename test.ml 2> /dev/null | jq '.value.merlin.stdlib' + "/stdlib2" + +The STDLIB directive in .merlin takes priority over -ocamllib-path + $ cat > .merlin < STDLIB /stdlib-from-.merlin + > EOF + + $ echo | $MERLIN single dump-configuration -ocamllib-path /stdlib-from-flag -filename test.ml 2> /dev/null | jq '.value.merlin.stdlib' + "/stdlib-from-.merlin" From cfa3683ccd0de8e8be9da616025cabe2b847bff8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:43:49 +0200 Subject: [PATCH 15/42] [B] #1745 Expand PPX nodes --- CHANGES.md | 1 + src/analysis/ppx_expand.ml | 159 +++++ src/analysis/ppx_expand.mli | 19 + src/commands/new_commands.ml | 15 + src/commands/query_json.ml | 15 + src/frontend/query_commands.ml | 12 + src/frontend/query_protocol.ml | 12 + src/ocaml/parsing/location_aux.ml | 4 + src/ocaml/parsing/location_aux.mli | 4 + .../expand_node/ppx-tests.t/c_ppx/c_ppx.ml | 163 +++++ .../expand_node/ppx-tests.t/c_ppx/dune | 4 + .../expand_node/ppx-tests.t/rewriter/dune | 4 + .../ppx-tests.t/rewriter/my_ppx.ml | 14 + tests/test-dirs/expand_node/ppx-tests.t/run.t | 587 ++++++++++++++++++ 14 files changed, 1013 insertions(+) create mode 100644 src/analysis/ppx_expand.ml create mode 100644 src/analysis/ppx_expand.mli create mode 100644 tests/test-dirs/expand_node/ppx-tests.t/c_ppx/c_ppx.ml create mode 100644 tests/test-dirs/expand_node/ppx-tests.t/c_ppx/dune create mode 100644 tests/test-dirs/expand_node/ppx-tests.t/rewriter/dune create mode 100644 tests/test-dirs/expand_node/ppx-tests.t/rewriter/my_ppx.ml create mode 100644 tests/test-dirs/expand_node/ppx-tests.t/run.t diff --git a/CHANGES.md b/CHANGES.md index 5be955e6a1..b04b06a4f1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,7 @@ unreleased what to append to the current unit name in the presence of wrapping (#1788) - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794) - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770) + - Implement new expand-node command for expanding PPX annotations (#1745) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) diff --git a/src/analysis/ppx_expand.ml b/src/analysis/ppx_expand.ml new file mode 100644 index 0000000000..2982ea78d5 --- /dev/null +++ b/src/analysis/ppx_expand.ml @@ -0,0 +1,159 @@ +type ppx_kind = + | Expr of Parsetree.expression + | Sig_item of Parsetree.signature_item + | Str_item of Parsetree.structure_item + +let check_at_pos pos loc = Location_aux.compare_pos pos loc = 0 + +let check_extension_node pos (expression : Parsetree.expression) = + match expression.pexp_desc with + | Pexp_extension (loc, _) -> + if check_at_pos pos loc.loc then Some expression.pexp_loc else None + | _ -> None + +let check_deriving_attr pos (attrs : Parsetree.attributes) = + let found_attr = + List.find_opt + (fun (attribute : Parsetree.attribute) -> + attribute.attr_name.txt = "deriving" + && check_at_pos pos attribute.attr_loc) + attrs + in + match found_attr with + | Some attribute -> Some attribute.attr_loc + | None -> None + +let check_structures pos (item : Parsetree.structure_item_desc) = + match item with + | Pstr_type (_, ty) -> + List.find_map + (fun (t : Parsetree.type_declaration) -> + check_deriving_attr pos t.ptype_attributes) + ty + | Pstr_exception tc -> check_deriving_attr pos tc.ptyexn_attributes + | Pstr_modtype mt -> check_deriving_attr pos mt.pmtd_attributes + | Pstr_typext tex -> check_deriving_attr pos tex.ptyext_attributes + | _ -> None + +let check_signatures pos (item : Parsetree.signature_item_desc) = + match item with + | Psig_type (_, ty) -> + List.find_map + (fun (t : Parsetree.type_declaration) -> + check_deriving_attr pos t.ptype_attributes) + ty + | Psig_exception tc -> check_deriving_attr pos tc.ptyexn_attributes + | Psig_modtype mt -> check_deriving_attr pos mt.pmtd_attributes + | Psig_typext tex -> check_deriving_attr pos tex.ptyext_attributes + | _ -> None + +let check_extension ~parsetree ~pos = + let kind = ref None in + let expr (self : Ast_iterator.iterator) (expr : Parsetree.expression) = + match check_extension_node pos expr with + | Some ext_loc -> kind := Some (Expr expr, ext_loc) + | None -> Ast_iterator.default_iterator.expr self expr + in + let signature_item (self : Ast_iterator.iterator) + (original_sg : Parsetree.signature_item) = + match check_signatures pos original_sg.psig_desc with + | Some attr_loc -> kind := Some (Sig_item original_sg, attr_loc) + | None -> Ast_iterator.default_iterator.signature_item self original_sg + in + let structure_item (self : Ast_iterator.iterator) + (original_str : Parsetree.structure_item) = + match check_structures pos original_str.pstr_desc with + | Some attr_loc -> kind := Some (Str_item original_str, attr_loc) + | None -> Ast_iterator.default_iterator.structure_item self original_str + in + let iterator = + { Ast_iterator.default_iterator with signature_item; structure_item; expr } + in + let () = + match parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str + in + !kind + +let get_ppxed_source ~ppxed_parsetree ~pos ppx_kind_with_attr : + Query_protocol.ppxed_source = + let expression = ref None in + let signature = ref [] in + let structure = ref [] in + let () = + match ppx_kind_with_attr with + | Expr original_expr, _ -> ( + let expr (self : Ast_iterator.iterator) + (new_expr : Parsetree.expression) = + match + Location_aux.included ~into:original_expr.pexp_loc new_expr.pexp_loc + with + | true -> expression := Some new_expr + | false -> Ast_iterator.default_iterator.expr self new_expr + in + let iterator = { Ast_iterator.default_iterator with expr } in + match ppxed_parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str) + | Sig_item original_sg, _ -> ( + let signature_item (self : Ast_iterator.iterator) + (new_sg : Parsetree.signature_item) = + let included = + Location_aux.included new_sg.psig_loc ~into:original_sg.psig_loc + in + match included && original_sg <> new_sg, new_sg.psig_loc.loc_ghost with + | true, _ -> signature := new_sg :: !signature + | false, false -> Ast_iterator.default_iterator.signature_item self new_sg + | false, true -> () (* We don't enter nested ppxes *) + in + let iterator = { Ast_iterator.default_iterator with signature_item } in + match ppxed_parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str) + | Str_item original_str, _ -> ( + let structure_item (self : Ast_iterator.iterator) + (new_str : Parsetree.structure_item) = + let included = + Location_aux.included new_str.pstr_loc ~into:original_str.pstr_loc + in + match included, new_str.pstr_loc.loc_ghost with + | true, _ -> + (match check_structures pos new_str.pstr_desc with + | None -> structure := new_str :: !structure + | Some _ -> ()) + | false, false -> Ast_iterator.default_iterator.structure_item self new_str + | false, true -> () + in + let iterator = { Ast_iterator.default_iterator with structure_item } in + match ppxed_parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str) + in + match (ppx_kind_with_attr : ppx_kind * Warnings.loc) with + | Expr _, ext_loc -> + { + code = Pprintast.string_of_expression (Option.get !expression); + attr_start = ext_loc.loc_start; + attr_end = ext_loc.loc_end; + } + | Sig_item _, attr_loc -> + let exp = + Pprintast.signature Format.str_formatter (List.rev !signature); + Format.flush_str_formatter () + in + { + code = exp; + attr_start = attr_loc.loc_start; + attr_end = attr_loc.loc_end; + } + | Str_item _, attr_loc -> + let exp = + Pprintast.structure Format.str_formatter (List.rev !structure); + Format.flush_str_formatter () + in + { + code = exp; + attr_start = attr_loc.loc_start; + attr_end = attr_loc.loc_end; + } diff --git a/src/analysis/ppx_expand.mli b/src/analysis/ppx_expand.mli new file mode 100644 index 0000000000..2ba75c84ed --- /dev/null +++ b/src/analysis/ppx_expand.mli @@ -0,0 +1,19 @@ +type ppx_kind = + | Expr of Parsetree.expression + | Sig_item of Parsetree.signature_item + | Str_item of Parsetree.structure_item + +val check_extension : + parsetree: + [ `Implementation of Parsetree.structure + | `Interface of Parsetree.signature ] -> + pos:Lexing.position -> + (ppx_kind * Warnings.loc) option + +val get_ppxed_source : + ppxed_parsetree: + [ `Implementation of Parsetree.structure + | `Interface of Parsetree.signature ] -> + pos:Lexing.position -> + ppx_kind * Warnings.loc -> + Query_protocol.ppxed_source diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 4491ae9f25..1ce6ad57c1 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -242,6 +242,21 @@ Otherwise, Merlin looks for the documentation for the entity under the cursor (a end ; + command "expand-ppx" + ~doc: "Returns the generated code of a PPX." + ~spec: [ + arg "-position" " Position to expand" + (marg_position (fun pos _pos -> pos)); + ] + ~default: `None + begin fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Expand_ppx pos) + end + ; + command "enclosing" ~spec: [ arg "-position" " Position to complete" diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 69515bc1f5..5b277a4b1f 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -114,6 +114,8 @@ let dump (type a) : a t -> json = ] | Syntax_document pos -> mk "syntax-document" [ ("position", mk_position pos) ] + | Expand_ppx pos -> + mk "ppx-expand" [ ("position", mk_position pos) ] | Locate (prefix, look_for, pos) -> mk "locate" [ "prefix", (match prefix with @@ -392,6 +394,19 @@ let json_of_response (type a) (query : a t) (response : a) : json = ("url", `String info.documentation); ] | `No_documentation -> `String "No documentation found") + | Expand_ppx _, resp -> + let str = match resp with + | `Found ppx_info -> + `Assoc + [ + ("code", `String ppx_info.code); + ("deriver", `Assoc [ + ("start", Lexing.json_of_position ppx_info.attr_start); + ("end", Lexing.json_of_position ppx_info.attr_end); + ]) + ] + | `No_ppx -> `String "No PPX deriver/extension node found on this position" + in str | Locate_type _, resp -> json_of_locate resp | Locate _, resp -> json_of_locate resp | Jump _, resp -> diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 350d3e7586..c45e691852 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -512,6 +512,18 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Some res -> `Found res | None -> `No_documentation) + | Expand_ppx pos -> ( + let pos = Mpipeline.get_lexing_pos pipeline pos in + let parsetree = Mpipeline.reader_parsetree pipeline in + let ppxed_parsetree = Mpipeline.ppx_parsetree pipeline in + let ppx_kind_with_attr = Ppx_expand.check_extension ~parsetree ~pos in + match ppx_kind_with_attr with + | Some _ -> + `Found + (Ppx_expand.get_ppxed_source ~ppxed_parsetree ~pos + (Option.get ppx_kind_with_attr)) + | None -> `No_ppx) + | Locate (patho, ml_or_mli, pos) -> let typer = Mpipeline.typer_result pipeline in let local_defs = Mtyper.get_typedtree typer in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index cd8871e476..73dfe96009 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -103,6 +103,13 @@ type syntax_doc_result = documentation : string } +type ppxed_source = +{ + code : string; + attr_start : Lexing.position; + attr_end : Lexing.position; +} + type is_tail_position = [`No | `Tail_position | `Tail_call] type _ _bool = bool @@ -145,6 +152,11 @@ type _ t = -> [ `Found of syntax_doc_result | `No_documentation ] t + | Expand_ppx + : Msource.position + -> [ `Found of ppxed_source + | `No_ppx + ] t | Locate_type : Msource.position -> [ `Found of string option * Lexing.position diff --git a/src/ocaml/parsing/location_aux.ml b/src/ocaml/parsing/location_aux.ml index 966ebdd3f7..5a9ec92d87 100644 --- a/src/ocaml/parsing/location_aux.ml +++ b/src/ocaml/parsing/location_aux.ml @@ -46,6 +46,10 @@ let compare_pos pos loc = else 0 +let included ~into:parent_loc child_loc = +Lexing.compare_pos child_loc.loc_start parent_loc.loc_start >= 0 && + Lexing.compare_pos parent_loc.loc_end child_loc.loc_end >= 0 + let union l1 l2 = if l1 = Location.none then l2 else if l2 = Location.none then l1 diff --git a/src/ocaml/parsing/location_aux.mli b/src/ocaml/parsing/location_aux.mli index 7d99d36a05..d6164b2cd7 100644 --- a/src/ocaml/parsing/location_aux.mli +++ b/src/ocaml/parsing/location_aux.mli @@ -42,6 +42,10 @@ val union : t -> t -> t (** Like location_union, but keep loc_ghost'ness of first argument *) val extend : t -> t -> t +(** [included ~into:parent child] returns [true] if [child] is included + in [parent]. Otherwise returns [false]. *) +val included : into:t -> t -> bool + (** Filter valid errors, log invalid ones *) val prepare_errors : exn list -> Location.error list diff --git a/tests/test-dirs/expand_node/ppx-tests.t/c_ppx/c_ppx.ml b/tests/test-dirs/expand_node/ppx-tests.t/c_ppx/c_ppx.ml new file mode 100644 index 0000000000..8c0ec0b0fc --- /dev/null +++ b/tests/test-dirs/expand_node/ppx-tests.t/c_ppx/c_ppx.ml @@ -0,0 +1,163 @@ +open Ppxlib +open Ast_builder.Default + +(* Type declarations in structure *) +let generate_impl ~ctxt (rec_flag, type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + List.map (fun ty -> + pstr_type ~loc rec_flag + [{ + ptype_loc = {loc with loc_ghost = true}; + ptype_params = ty.ptype_params; + ptype_cstrs = ty.ptype_cstrs; + ptype_kind = ty.ptype_kind; + ptype_manifest = ty.ptype_manifest; + ptype_private = ty.ptype_private; + ptype_attributes = []; + ptype_name = {txt = ty.ptype_name.txt ^ "_renamed"; loc = {loc with loc_ghost = true}} + }] + ) type_declarations + +(* Type declarations in signature *) +let generate_intf ~ctxt (rec_flag, type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + List.map (fun ty -> + psig_type ~loc rec_flag + [{ + ptype_loc = {loc with loc_ghost = true}; + ptype_params = ty.ptype_params; + ptype_cstrs = ty.ptype_cstrs; + ptype_kind = ty.ptype_kind; + ptype_manifest = ty.ptype_manifest; + ptype_private = ty.ptype_private; + ptype_attributes = []; + ptype_name = {txt = ty.ptype_name.txt ^ "_renamed"; loc = {loc with loc_ghost = true}} + }] + ) type_declarations + +(* Type_extensions in structure *) +let generate_ext_impl ~ctxt type_extension = + let new_path = Longident.parse ((Longident.name type_extension.ptyext_path.txt) ^ "_renamed") in + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ + pstr_typext ~loc + { + ptyext_path = {txt = new_path; loc = ({loc with loc_ghost = true})}; + ptyext_params = type_extension.ptyext_params; + ptyext_constructors = type_extension.ptyext_constructors; + ptyext_private = type_extension.ptyext_private; + ptyext_loc = {type_extension.ptyext_loc with loc_ghost = true}; + ptyext_attributes = []; + } + ] + +(* Type_extensions in signature *) +let generate_ext_intf ~ctxt type_extension = + let new_path = Longident.parse ((Longident.name type_extension.ptyext_path.txt) ^ "_renamed") in + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ + psig_typext ~loc + { + ptyext_path = {txt = new_path; loc = ({loc with loc_ghost = true})}; + ptyext_params = type_extension.ptyext_params; + ptyext_constructors = type_extension.ptyext_constructors; + ptyext_private = type_extension.ptyext_private; + ptyext_loc = {type_extension.ptyext_loc with loc_ghost = true}; + ptyext_attributes = []; + } + ] + +(* Type_exceptions in structure *) +let generate_exn_impl ~ctxt type_exception = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ + pstr_exception ~loc + { + ptyexn_constructor = { + pext_name = {txt = type_exception.ptyexn_constructor.pext_name.txt ^ "_renamed"; loc = {loc with loc_ghost = true}}; + pext_kind = type_exception.ptyexn_constructor.pext_kind; + pext_loc = {loc with loc_ghost = true}; + pext_attributes = []; + }; + ptyexn_loc = {loc with loc_ghost = true}; + ptyexn_attributes = []; + } + ] + +(* Type_exceptions in signature *) +let generate_exn_intf ~ctxt type_exception = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ + psig_exception ~loc + { + ptyexn_constructor = { + pext_name = {txt = type_exception.ptyexn_constructor.pext_name.txt ^ "_renamed"; loc = {loc with loc_ghost = true}}; + pext_kind = type_exception.ptyexn_constructor.pext_kind; + pext_loc = {loc with loc_ghost = true}; + pext_attributes = []; + }; + ptyexn_loc = {loc with loc_ghost = true}; + ptyexn_attributes = []; + } + ] + +(* Module_type_declarations in structure *) +let generate_mt_impl ~ctxt module_type_declaration = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ + pstr_modtype ~loc + { + pmtd_name = {txt = module_type_declaration.pmtd_name.txt ^ "_renamed"; loc = {loc with loc_ghost = true};}; + pmtd_type = module_type_declaration.pmtd_type; + pmtd_attributes = []; + pmtd_loc = {loc with loc_ghost = true}; + } + ] + +let generate_mt_intf ~ctxt module_type_declaration = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ + psig_modtype ~loc + { + pmtd_name = {txt = module_type_declaration.pmtd_name.txt ^ "_renamed"; loc = {loc with loc_ghost = true};}; + pmtd_type = module_type_declaration.pmtd_type; + pmtd_attributes = []; + pmtd_loc = {loc with loc_ghost = true}; + } + ] + + +(* Driver for type declarations in structures*) +let ty_impl_generator = Deriving.Generator.V2.make_noarg generate_impl + +(* Driver for type declarations in signatures*) +let ty_intf_generator = Deriving.Generator.V2.make_noarg generate_intf + +(* Driver for type_extensions in structures*) +let ext_impl_generator = Deriving.Generator.V2.make_noarg generate_ext_impl + +(* Driver for type_extensions in signatures*) +let ext_intf_generator = Deriving.Generator.V2.make_noarg generate_ext_intf + +(* Driver for type_exceptions in structures*) +let exn_impl_generator = Deriving.Generator.V2.make_noarg generate_exn_impl + +(* Driver for type_exceptions in signatures*) +let exn_intf_generator = Deriving.Generator.V2.make_noarg generate_exn_intf + +(* Driver for module_type_declarations in structures*) +let mdt_impl_generator = Deriving.Generator.V2.make_noarg generate_mt_impl + +(* Driver for module_type_declarations in signatures*) +let mdt_intf_generator = Deriving.Generator.V2.make_noarg generate_mt_intf +let my_deriver = + Deriving.add "rename" + ~str_type_decl:ty_impl_generator + ~sig_type_decl:ty_intf_generator + ~str_type_ext:ext_impl_generator + ~sig_type_ext:ext_intf_generator + ~str_exception:exn_impl_generator + ~sig_exception:exn_intf_generator + ~str_module_type_decl:mdt_impl_generator + ~sig_module_type_decl:mdt_intf_generator + |> Deriving.ignore diff --git a/tests/test-dirs/expand_node/ppx-tests.t/c_ppx/dune b/tests/test-dirs/expand_node/ppx-tests.t/c_ppx/dune new file mode 100644 index 0000000000..c6fb4575a2 --- /dev/null +++ b/tests/test-dirs/expand_node/ppx-tests.t/c_ppx/dune @@ -0,0 +1,4 @@ +(library + (name c_ppx) + (kind ppx_deriver) + (libraries ppxlib)) diff --git a/tests/test-dirs/expand_node/ppx-tests.t/rewriter/dune b/tests/test-dirs/expand_node/ppx-tests.t/rewriter/dune new file mode 100644 index 0000000000..fcbdc1e39c --- /dev/null +++ b/tests/test-dirs/expand_node/ppx-tests.t/rewriter/dune @@ -0,0 +1,4 @@ +(library + (name my_ppx) + (kind ppx_rewriter) + (libraries ppxlib)) diff --git a/tests/test-dirs/expand_node/ppx-tests.t/rewriter/my_ppx.ml b/tests/test-dirs/expand_node/ppx-tests.t/rewriter/my_ppx.ml new file mode 100644 index 0000000000..797578f42e --- /dev/null +++ b/tests/test-dirs/expand_node/ppx-tests.t/rewriter/my_ppx.ml @@ -0,0 +1,14 @@ +open Ppxlib + +let expand ~ctxt payload = + let _p = payload in + let loc = Expansion_context.Extension.extension_point_loc ctxt in + Ast_builder.Default.estring ~loc "OCaml is so cool" + +let my_extension = + Extension.V3.declare "tell_me" Extension.Context.expression + Ast_pattern.(__) + expand + +let rule = Ppxlib.Context_free.Rule.extension my_extension +let () = Driver.register_transformation ~rules:[ rule ] "tell_me" diff --git a/tests/test-dirs/expand_node/ppx-tests.t/run.t b/tests/test-dirs/expand_node/ppx-tests.t/run.t new file mode 100644 index 0000000000..848f9a8c1e --- /dev/null +++ b/tests/test-dirs/expand_node/ppx-tests.t/run.t @@ -0,0 +1,587 @@ +Dune setup + $ cat > dune-project << EOF + > (lang dune 2.9) + > EOF + + $ cat > dune << EOF + > (executable + > (name apt) + > (preprocess (pps c_ppx my_ppx))) + > EOF + +Type declaration in structure + $ cat > apt.ml << EOF + > module MyModule = struct + > type point = {x:int; y:int} [@@deriving rename] + > end + > EOF + + $ dune build + +on module name "MyModule" + $ $MERLIN single expand-ppx -position 1:11 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": "No PPX deriver/extension node found on this position", + "notifications": [] + } + +on keyword type + $ $MERLIN single expand-ppx -position 2:3 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": "No PPX deriver/extension node found on this position", + "notifications": [] + } + +on attribute name "deriving" + $ $MERLIN single expand-ppx -position 2:36 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": { + "code": "include + struct + let _ = fun (_ : point) -> () + type point_renamed = { + x: int ; + y: int } + end[@@ocaml.doc \"@inline\"][@@merlin.hide ]", + "deriver": { + "start": { + "line": 2, + "col": 29 + }, + "end": { + "line": 2, + "col": 48 + } + } + }, + "notifications": [] + } + +on attribute payload name "rename" + $ $MERLIN single expand-ppx -position 2:46 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": { + "code": "include + struct + let _ = fun (_ : point) -> () + type point_renamed = { + x: int ; + y: int } + end[@@ocaml.doc \"@inline\"][@@merlin.hide ]", + "deriver": { + "start": { + "line": 2, + "col": 29 + }, + "end": { + "line": 2, + "col": 48 + } + } + }, + "notifications": [] + } + +Type declaration in signature + $ cat > apt.ml << EOF + > module type MyModuleSig = sig + > type tttt = Red | Green [@@deriving rename] + > end + > EOF + + $ dune build + +on attribute name "deriving" + $ $MERLIN single expand-ppx -position 2:36 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] type tttt_renamed = + | Red + | Green end[@@ocaml.doc \"@inline\"] + [@@merlin.hide ]", + "deriver": { + "start": { + "line": 2, + "col": 26 + }, + "end": { + "line": 2, + "col": 45 + } + } + }, + "notifications": [] + } + +on attribute payload name "rename" + $ $MERLIN single expand-ppx -position 2:42 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] type tttt_renamed = + | Red + | Green end[@@ocaml.doc \"@inline\"] + [@@merlin.hide ]", + "deriver": { + "start": { + "line": 2, + "col": 26 + }, + "end": { + "line": 2, + "col": 45 + } + } + }, + "notifications": [] + } + +Type declaration in structure + $ cat > apt.ml << EOF + > type yyyy = int [@@deriving rename] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:23 -filename ./apt.ml < ./apt.ml + { + "class": "return", + "value": { + "code": "include struct let _ = fun (_ : yyyy) -> () + type yyyy_renamed = int end[@@ocaml.doc \"@inline\"][@@merlin.hide + ]", + "deriver": { + "start": { + "line": 1, + "col": 16 + }, + "end": { + "line": 1, + "col": 35 + } + } + }, + "notifications": [] + } + +Type declaration in signature + $ cat > apt.mli << EOF + > type yyyy = int [@@deriving rename] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:23 -filename ./apt.mli < ./apt.mli + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] type yyyy_renamed = int end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ]", + "deriver": { + "start": { + "line": 1, + "col": 16 + }, + "end": { + "line": 1, + "col": 35 + } + } + }, + "notifications": [] + } + +Type extension in structure + $ cat > apy.ml << EOF + > type pppp = .. [@@deriving rename] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:22 -filename ./apy.ml < ./apy.ml + { + "class": "return", + "value": { + "code": "include struct let _ = fun (_ : pppp) -> () + type pppp_renamed = .. end[@@ocaml.doc \"@inline\"][@@merlin.hide + ]", + "deriver": { + "start": { + "line": 1, + "col": 15 + }, + "end": { + "line": 1, + "col": 34 + } + } + }, + "notifications": [] + } + +Type extension in signature + $ cat > apy.mli << EOF + > type pppp = .. [@@deriving rename] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:22 -filename ./apy.mli < ./apy.mli + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] type pppp_renamed = .. end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ]", + "deriver": { + "start": { + "line": 1, + "col": 15 + }, + "end": { + "line": 1, + "col": 34 + } + } + }, + "notifications": [] + } + +Exception in structure + $ cat > apr.ml << EOF + > exception Foo of string [@@deriving rename] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:30 -filename ./apr.ml < ./apr.ml + { + "class": "return", + "value": { + "code": "include struct exception Foo_renamed of string end[@@ocaml.doc \"@inline\"] + [@@merlin.hide ]", + "deriver": { + "start": { + "line": 1, + "col": 24 + }, + "end": { + "line": 1, + "col": 43 + } + } + }, + "notifications": [] + } + +Exception in signature + $ cat > apr.mli << EOF + > exception Foo of string [@@deriving rename] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:30 -filename ./apr.mli < ./apr.mli + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] exception Foo_renamed of string end + [@@ocaml.doc \"@inline\"][@@merlin.hide ]", + "deriver": { + "start": { + "line": 1, + "col": 24 + }, + "end": { + "line": 1, + "col": 43 + } + } + }, + "notifications": [] + } + +Module type declaration in structure + $ cat > apc.ml << EOF + > module type Stack = sig + > type t [@@deriving rename] + > type stack + > val empty : stack + > val is_empty : stack -> bool + > val push : t -> stack -> stack + > val pop : stack -> stack + > val peek : stack -> t + > end [@@deriving rename] + > EOF + + $ dune build + +a cursor here should only output the derived t + +(* Type t_renamed is duplicated multiple times because the same type is derived twice, first by it's own ppx and secondly +when the parent ppx on the module type declaration is evaluated. *) + $ $MERLIN single expand-ppx -position 2:14 -filename ./apc.ml < ./apc.ml + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"][@@merlin.hide + ] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"][@@merlin.hide + ] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"][@@merlin.hide + ]", + "deriver": { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 28 + } + } + }, + "notifications": [] + } + +(* Type t_renamed is duplicated multiple times because the same type is derived twice, first by it's own ppx and secondly +when the parent ppx on the module type declaration is evaluated. *) + + $ $MERLIN single expand-ppx -position 9:8 -filename ./apc.ml < ./apc.ml + { + "class": "return", + "value": { + "code": "include + struct + module type Stack_renamed = + sig + type t[@@deriving rename] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ] + type stack + val empty : stack + val is_empty : stack -> bool + val push : t -> stack -> stack + val pop : stack -> stack + val peek : stack -> t + end + end[@@ocaml.doc \"@inline\"][@@merlin.hide ]", + "deriver": { + "start": { + "line": 9, + "col": 4 + }, + "end": { + "line": 9, + "col": 23 + } + } + }, + "notifications": [] + } + +Module type declaration in signature + $ cat > apc.mli << EOF + > module type Stack = sig + > type t [@@deriving rename] + > type stack + > val empty : stack + > val is_empty : stack -> bool + > val push : t -> stack -> stack + > val pop : stack -> stack + > val peek : stack -> t + > end [@@deriving rename] + > EOF + + $ dune build + +on attribute name deriving of type t +a cursor here should only output the derived t + $ $MERLIN single expand-ppx -position 2:14 -filename ./apc.mli < ./apc.mli + { + "class": "return", + "value": { + "code": "include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"][@@merlin.hide + ]", + "deriver": { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 28 + } + } + }, + "notifications": [] + } + +on attribute name deriving of module Stack +(* Type t_renamed is duplicated multiple times because the same type is derived twice, first by it's own ppx and secondly +when the parent ppx on the module type declaration is evaluated. *) + $ $MERLIN single expand-ppx -position 9:8 -filename ./apc.mli < ./apc.mli + { + "class": "return", + "value": { + "code": "module type Stack = + sig + type t[@@deriving rename] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ] + type stack + val empty : stack + val is_empty : stack -> bool + val push : t -> stack -> stack + val pop : stack -> stack + val peek : stack -> t + end[@@deriving rename] + include + sig + [@@@ocaml.warning \"-32\"] + module type Stack_renamed = + sig + type t[@@deriving rename] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ] + include sig [@@@ocaml.warning \"-32\"] type t_renamed end[@@ocaml.doc + \"@inline\"] + [@@merlin.hide ] + type stack + val empty : stack + val is_empty : stack -> bool + val push : t -> stack -> stack + val pop : stack -> stack + val peek : stack -> t + end + end[@@ocaml.doc \"@inline\"][@@merlin.hide ]", + "deriver": { + "start": { + "line": 9, + "col": 4 + }, + "end": { + "line": 9, + "col": 23 + } + } + }, + "notifications": [] + } + +Test for an attribute that's not deriving + $ cat > apf.ml << EOF + > type y = int * float [@@merlin.hide] + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:27 -filename ./apf.ml < ./apf.ml + { + "class": "return", + "value": "No PPX deriver/extension node found on this position", + "notifications": [] + } + +PPx extension + $ cat > apttt.ml << EOF + > let phrase = print_string ([%tell_me] ^ ":-)!") + > EOF + + $ dune build + + $ $MERLIN single expand-ppx -position 1:30 -filename ./apttt.ml < ./apttt.ml + { + "class": "return", + "value": { + "code": "\"OCaml is so cool\"", + "deriver": { + "start": { + "line": 1, + "col": 27 + }, + "end": { + "line": 1, + "col": 37 + } + } + }, + "notifications": [] + } + + $ $MERLIN single expand-ppx -position 1:41 -filename ./apttt.ml < ./apttt.ml + { + "class": "return", + "value": "No PPX deriver/extension node found on this position", + "notifications": [] + } + +Show only an output for the hover and not all extensions + $ cat > aptxc.ml << EOF + > let phrase = [%tell_me] ^ [%tell_me] + > EOF + + $ dune build +on the first [%tell_me] + $ $MERLIN single expand-ppx -position 1:16 -filename ./apttt.ml < ./aptxc.ml + { + "class": "return", + "value": { + "code": "\"OCaml is so cool\"", + "deriver": { + "start": { + "line": 1, + "col": 13 + }, + "end": { + "line": 1, + "col": 23 + } + } + }, + "notifications": [] + } + +on the concatenator + $ $MERLIN single expand-ppx -position 1:24 -filename ./apttt.ml < ./aptxc.ml + { + "class": "return", + "value": "No PPX deriver/extension node found on this position", + "notifications": [] + } + +on the second [%tell_me] + $ $MERLIN single expand-ppx -position 1:28 -filename ./apttt.ml < ./aptxc.ml + { + "class": "return", + "value": { + "code": "\"OCaml is so cool\"", + "deriver": { + "start": { + "line": 1, + "col": 26 + }, + "end": { + "line": 1, + "col": 36 + } + } + }, + "notifications": [] + } From c4efe5c47c331241cd53bed6eb5bb7bbdda32775 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:45:14 +0200 Subject: [PATCH 16/42] [B] #1810 Produce a better error message when a flag spec appears multiple times --- src/kernel/mconfig.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index ef8e8f6208..f2b4ddfbc5 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -710,7 +710,8 @@ let () = args, (upd a b) in let add prj upd (name,flag,_doc) = - assert (not (Hashtbl.mem arguments_table name)); + if Hashtbl.mem arguments_table name then + failwith ("Duplicate flag spec: " ^ name); Hashtbl.add arguments_table name (lens prj upd flag) in List.iter From a2105f4b956d96b3d57bf912703f4bfc82cdfe25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:50:08 +0200 Subject: [PATCH 17/42] [B] #1812 Inlay hint upstreaming --- CHANGES.md | 1 + src/analysis/inlay_hints.ml | 179 +++++++++++++++++++++++++++ src/analysis/inlay_hints.mli | 12 ++ src/commands/new_commands.ml | 46 +++++++ src/commands/query_json.ml | 18 +++ src/frontend/query_commands.ml | 23 ++++ src/frontend/query_protocol.ml | 3 + src/ocaml/parsing/location_aux.ml | 5 + src/ocaml/parsing/location_aux.mli | 4 + src/ocaml/typing/printtyped.ml | 2 + src/ocaml/typing/printtyped.mli | 1 + src/utils/std.ml | 1 + tests/test-dirs/inlay-hint/samples.t | 169 +++++++++++++++++++++++++ tests/test-dirs/inlay-hint/spec.t | 26 ++++ 14 files changed, 490 insertions(+) create mode 100644 src/analysis/inlay_hints.ml create mode 100644 src/analysis/inlay_hints.mli create mode 100644 tests/test-dirs/inlay-hint/samples.t create mode 100644 tests/test-dirs/inlay-hint/spec.t diff --git a/CHANGES.md b/CHANGES.md index b04b06a4f1..8d1415a62e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,6 +7,7 @@ unreleased - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794) - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770) - Implement new expand-node command for expanding PPX annotations (#1745) + - Implement new inlay-hints command for adding hints on a sourcetree (#1812) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) diff --git a/src/analysis/inlay_hints.ml b/src/analysis/inlay_hints.ml new file mode 100644 index 0000000000..e07287f9b5 --- /dev/null +++ b/src/analysis/inlay_hints.ml @@ -0,0 +1,179 @@ +open Std + +let {Logger.log} = Logger.for_section "inlay-hints" + +module Iterator = Ocaml_typing.Tast_iterator + +let is_ghost_location avoid_ghost loc = + loc.Location.loc_ghost && avoid_ghost + +let pattern_has_constraint (type a) (pattern: a Typedtree.general_pattern) = + List.exists ~f:(fun (extra, _, _) -> + match extra with + | Typedtree.Tpat_constraint _ -> true + | Typedtree.Tpat_type (_, _) + | Typedtree.Tpat_open (_, _, _) + | Typedtree.Tpat_unpack -> false + ) pattern.pat_extra + +let structure_iterator + hint_let_binding + hint_pattern_binding + avoid_ghost_location + typedtree + range + callback = + + let case_iterator hint_lhs (iterator : Iterator.iterator) case = + let () = log ~title:"case" "on case" in + let () = + if hint_lhs then + iterator.pat iterator case.Typedtree.c_lhs + in + let () = Option.iter ~f:(iterator.expr iterator) case.c_guard in + iterator.expr iterator case.c_rhs + in + + let value_binding_iterator hint_lhs (iterator : Iterator.iterator) vb = + let () = log ~title:"value_binding" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "On value binding %a" + (Printtyped.pattern 0) vb.Typedtree.vb_pat + ) + in + if Location_aux.overlap_with_range range vb.Typedtree.vb_loc then + if hint_lhs then + let () = log ~title:"value_binding" "overlap" in + match vb.vb_expr.exp_desc with + | Texp_function _ -> iterator.expr iterator vb.vb_expr + | _ -> Iterator.default_iterator.value_binding iterator vb + else iterator.expr iterator vb.vb_expr + in + + let expr_iterator (iterator : Iterator.iterator) expr = + let () = log ~title:"expression" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "On expression %a" + Printtyped.expression expr + ) + in + if Location_aux.overlap_with_range range expr.Typedtree.exp_loc then + let () = log ~title:"expression" "overlap" in + match expr.exp_desc with + | Texp_let (_, bindings, body) -> + let () = log ~title:"expression" "on let" in + let () = + List.iter + ~f:(value_binding_iterator hint_let_binding iterator) + bindings + in iterator.expr iterator body + | Texp_letop { body; _ } -> + let () = log ~title:"expression" "on let-op" in + case_iterator hint_let_binding iterator body + | Texp_match (expr, cases, _) -> + let () = log ~title:"expression" "on match" in + let () = iterator.expr iterator expr in + List.iter ~f:(case_iterator hint_pattern_binding iterator) cases + | Texp_function + { arg_label = Optional _ + ; cases = + [ { c_rhs = + { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ } + ; _ + } + ] + ; _ + } -> + iterator.pat iterator vb_pat; + iterator.expr iterator body + | _ when is_ghost_location avoid_ghost_location expr.exp_loc -> + (* Stop iterating when we see a ghost location to avoid + annotating generated code *) + log ~title:"ghost" "ghost-location found" + | _ -> Iterator.default_iterator.expr iterator expr + in + + let structure_item_iterator (iterator : Iterator.iterator) item = + if Location_aux.overlap_with_range range item.Typedtree.str_loc then + let () = log ~title:"structure_item" "overlap" in + match item.str_desc with + | Tstr_value (_, bindings) -> + List.iter ~f:(fun binding -> + expr_iterator iterator binding.Typedtree.vb_expr) + bindings + | _ when is_ghost_location avoid_ghost_location item.str_loc -> + (* Stop iterating when we see a ghost location to avoid + annotating generated code *) + log ~title:"ghost" "ghost-location found" + | _ -> Iterator.default_iterator.structure_item iterator item + in + + let pattern_iterator + (type a) iterator (pattern : a Typedtree.general_pattern) = + let () = log ~title:"pattern" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "On pattern %a" + (Printtyped.pattern 0) pattern + ) + in + if Location_aux.overlap_with_range range pattern.pat_loc + && not (pattern_has_constraint pattern) + then + let () = log ~title:"pattern" "overlap" in + let () = Iterator.default_iterator.pat iterator pattern in + match pattern.pat_desc with + | Tpat_var _ when not pattern.pat_loc.loc_ghost -> + let () = log ~title:"pattern" "found" in + callback pattern.pat_env pattern.pat_type pattern.pat_loc + | _ -> log ~title:"pattern" "not a var" + in + + let iterator = { + Ocaml_typing.Tast_iterator.default_iterator with + expr = expr_iterator; + structure_item = structure_item_iterator; + pat = pattern_iterator; + value_binding = value_binding_iterator true + } + in iterator.structure iterator typedtree + +type hint = Lexing.position * string + +let create_hint env typ loc = + let label = Printtyp.wrap_printing_env env (fun () -> + Format.asprintf "%a" Printtyp.type_scheme typ) + in + let position = loc.Location.loc_end in + (position, label) + +let of_structure + ~hint_let_binding + ~hint_pattern_binding + ~avoid_ghost_location + ~start + ~stop + structure = + let () = log ~title:"start" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "Start on %s to %s with : let: %b, pat: %b, ghost: %b" + (Lexing.print_position () start) + (Lexing.print_position () stop) + hint_let_binding + hint_pattern_binding + avoid_ghost_location) + in + let range = (start, stop) in + let hints = ref [] in + let () = + structure_iterator + hint_let_binding + hint_pattern_binding + avoid_ghost_location + structure + range + (fun env typ loc -> + let () = log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt -> + Format.fprintf fmt "%s - %a" + (Location_aux.print () loc) + (Printtyp.type_expr) typ) + in + let hint = create_hint env typ loc in + hints := hint :: !hints) + in + !hints diff --git a/src/analysis/inlay_hints.mli b/src/analysis/inlay_hints.mli new file mode 100644 index 0000000000..2bf52c9536 --- /dev/null +++ b/src/analysis/inlay_hints.mli @@ -0,0 +1,12 @@ +(** Builds the list of inlay hints to be displayed on a document. *) + +type hint = Lexing.position * string + +val of_structure : + hint_let_binding:bool + -> hint_pattern_binding:bool + -> avoid_ghost_location:bool + -> start:Lexing.position + -> stop:Lexing.position + -> Typedtree.structure + -> hint list diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 1ce6ad57c1..7e2535743b 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -572,6 +572,52 @@ of the buffer." end ; + command "inlay-hints" + ~doc:"return a list of inly-hints for additional client (like LSP)" + ~spec: [ + arg "-start" " Where inlay-hints generation start" + (marg_position + (fun start + (_start, stop, let_binding, pattern_binding, ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + arg "-end" " Where inlay-hints generation stop" + (marg_position + (fun stop + (start, _stop, let_binding, pattern_binding, ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + optional "-let-binding" " Hint let-binding (default is false)" + (Marg.bool + (fun let_binding + (start, stop, _let_binding, pattern_binding, ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + optional + "-pattern-binding" " Hint pattern-binding (default is false)" + (Marg.bool + (fun pattern_binding + (start, stop, let_binding, _pattern_binding, ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + optional + "-avoid-ghost-location" + " Avoid hinting ghost location (default is true)" + (Marg.bool + (fun ghost + (start, stop, let_binding, pattern_binding, _ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + ] + ~default:(`None, `None, false, false, true) + begin fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) -> + match (start, stop) with + | (`None, `None) -> failwith "-start and -end are mandatory" + | (`None, _) -> failwith "-start is mandatory" + | (_, `None) -> failwith "-end is mandatory" + | (#Msource.position, #Msource.position) as position -> + let (start, stop) = position in + run buffer + (Query_protocol.Inlay_hints + (start, stop, let_binding, pattern_binding, avoid_ghost)) + 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. diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 5b277a4b1f..f3ae5c8767 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -154,6 +154,14 @@ let dump (type a) : a t -> json = ); "depth", `Int depth ] + | Inlay_hints (start, stop, hint_let_binding, hint_pattern_var, ghost) -> + mk "inlay-hints" [ + "start", mk_position start; + "stop", mk_position stop; + "hint-let-binding", `Bool hint_let_binding; + "hint-pattern-variable", `Bool hint_pattern_var; + "avoid-ghost-location", `Bool ghost + ] | Outline -> mk "outline" [] | Errors { lexing; parsing; typing } -> let args = @@ -351,6 +359,14 @@ let json_of_locate resp = | `Found (Some file,pos) -> `Assoc ["file",`String file; "pos", Lexing.json_of_position pos] +let json_of_inlay_hints hints = + let json_of_hint (position, label) = + `Assoc [ + "pos", Lexing.json_of_position position; + "label", `String label + ] + in `List (List.map ~f:json_of_hint hints) + let json_of_response (type a) (query : a t) (response : a) : json = match query, response with | Type_expr _, str -> `String str @@ -441,6 +457,8 @@ let json_of_response (type a) (query : a t) (response : a) : json = `List (json_of_outline outlines) | Shape _, shapes -> `List (List.map ~f:json_of_shape shapes) + | Inlay_hints _, result -> + json_of_inlay_hints result | Errors _, errors -> `List (List.map ~f:json_of_error errors) | Dump _, json -> json diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index c45e691852..db5e57b01b 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -860,6 +860,29 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in List.sort ~cmp locs + | Inlay_hints ( + start, + stop, + hint_let_binding, + hint_pattern_binding, + avoid_ghost_location + ) -> + let start = Mpipeline.get_lexing_pos pipeline start + and stop = Mpipeline.get_lexing_pos pipeline stop in + let typer_result = Mpipeline.typer_result pipeline in + begin match Mtyper.get_typedtree typer_result with + | `Interface _ -> [] + | `Implementation structure -> + Inlay_hints.of_structure + ~hint_let_binding + ~hint_pattern_binding + ~avoid_ghost_location + ~start + ~stop + structure + end + | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" Merlin_config.version Sys.ocaml_version; + diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 73dfe96009..364ecfc331 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -192,6 +192,9 @@ type _ t = | Construct : Msource.position * [`None | `Local] option * int option -> (Location.t * string list) t + | Inlay_hints + : Msource.position * Msource.position * bool * bool * bool + -> (Lexing.position * string) list t | Outline(* *) : outline t | Shape(* *) diff --git a/src/ocaml/parsing/location_aux.ml b/src/ocaml/parsing/location_aux.ml index 5a9ec92d87..e7e215bce2 100644 --- a/src/ocaml/parsing/location_aux.ml +++ b/src/ocaml/parsing/location_aux.ml @@ -50,6 +50,11 @@ let included ~into:parent_loc child_loc = Lexing.compare_pos child_loc.loc_start parent_loc.loc_start >= 0 && Lexing.compare_pos parent_loc.loc_end child_loc.loc_end >= 0 +let overlap_with_range (start, stop) loc = + let a = Lexing.compare_pos start loc.loc_end + and b = Lexing.compare_pos stop loc.loc_start in + a <= 0 && b >= 0 || a >= 0 && b <= 0 + let union l1 l2 = if l1 = Location.none then l2 else if l2 = Location.none then l1 diff --git a/src/ocaml/parsing/location_aux.mli b/src/ocaml/parsing/location_aux.mli index d6164b2cd7..b3804d1afb 100644 --- a/src/ocaml/parsing/location_aux.mli +++ b/src/ocaml/parsing/location_aux.mli @@ -46,6 +46,10 @@ val extend : t -> t -> t in [parent]. Otherwise returns [false]. *) val included : into:t -> t -> bool +(** [overlap_with_range (pos_start, pos_end) loc] returns [true] if + [loc] overlap with the range defined by [pos_start] and [pos_end]. *) +val overlap_with_range : (Lexing.position * Lexing.position) -> t -> bool + (** Filter valid errors, log invalid ones *) val prepare_errors : exn list -> Location.error list diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index c3480379d2..f9009931d5 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -975,3 +975,5 @@ let implementation ppf x = list 0 structure_item ppf x.str_items;; let implementation_with_coercion ppf Typedtree.{structure; _} = implementation ppf structure + +let expression ppf x = expression 0 ppf x diff --git a/src/ocaml/typing/printtyped.mli b/src/ocaml/typing/printtyped.mli index 7002986d4a..96184c9961 100644 --- a/src/ocaml/typing/printtyped.mli +++ b/src/ocaml/typing/printtyped.mli @@ -24,3 +24,4 @@ val implementation_with_coercion : (* Added by merlin for debugging purposes *) val pattern : int -> formatter -> _ general_pattern -> unit +val expression : formatter -> expression -> unit diff --git a/src/utils/std.ml b/src/utils/std.ml index 433e1b9527..586087b65e 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -392,6 +392,7 @@ module String = struct (* Drop characters from beginning of string *) let drop n s = sub s ~pos:n ~len:(length s - n) + module Set = struct include MoreLabels.Set.Make (struct type t = string let compare = compare end) diff --git a/tests/test-dirs/inlay-hint/samples.t b/tests/test-dirs/inlay-hint/samples.t new file mode 100644 index 0000000000..de3be2b4ba --- /dev/null +++ b/tests/test-dirs/inlay-hint/samples.t @@ -0,0 +1,169 @@ +Optional argument + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -filename inlay.ml < let f ?x () = x () + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 8 + }, + "label": "'a option" + } + ], + "notifications": [] + } + +Optional argument with value + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -filename inlay.ml < let f ?(x = 1) () = x + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 9 + }, + "label": "int" + } + ], + "notifications": [] + } + +Labeled argument + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -filename inlay.ml < let f ~x = x + 1 + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 8 + }, + "label": "int" + } + ], + "notifications": [] + } + +Case argument + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -filename inlay.ml < let f (Some x) = x + 1 + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 13 + }, + "label": "int" + } + ], + "notifications": [] + } + +Pattern variables without pattern-binding hint + + $ $MERLIN single inlay-hints -start 1:0 -end 4:26 -avoid-ghost-location false \ + > -filename inlay.ml < let f x = + > match x with + > | Some x -> x + > | None -> 0 + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 7 + }, + "label": "int option" + } + ], + "notifications": [] + } + +Pattern variables with pattern-binding hint + + $ $MERLIN single inlay-hints -start 1:0 -end 4:26 -avoid-ghost-location false \ + > -pattern-binding true \ + > -filename inlay.ml < let f x = + > match x with + > | Some x -> x + > | None -> 0 + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 3, + "col": 10 + }, + "label": "int" + }, + { + "pos": { + "line": 1, + "col": 7 + }, + "label": "int option" + } + ], + "notifications": [] + } + + +Let bindings without let hinting + + $ $MERLIN single inlay-hints -start 1:0 -end 4:26 -avoid-ghost-location false \ + > -let-binding false \ + > -filename inlay.ml < let f () = let y = 0 in y + > EOF + { + "class": "return", + "value": [], + "notifications": [] + } + + +Let bindings with let hinting + + $ $MERLIN single inlay-hints -start 1:0 -end 4:26 -avoid-ghost-location false \ + > -let-binding true \ + > -filename inlay.ml < let f () = let y = 0 in y + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 16 + }, + "label": "int" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/inlay-hint/spec.t b/tests/test-dirs/inlay-hint/spec.t new file mode 100644 index 0000000000..b4d2ee6243 --- /dev/null +++ b/tests/test-dirs/inlay-hint/spec.t @@ -0,0 +1,26 @@ +Start and end should be mandatory + + $ $MERLIN single inlay-hints + { + "class": "failure", + "value": "-start and -end are mandatory", + "notifications": [] + } + +Start should be mandatory + + $ $MERLIN single inlay-hints -end 1 + { + "class": "failure", + "value": "-start is mandatory", + "notifications": [] + } + +Stop should be mandatory + + $ $MERLIN single inlay-hints -start 1 + { + "class": "failure", + "value": "-end is mandatory", + "notifications": [] + } From 797e2a9cf389f26757d82554fbdd3492d0354150 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:50:48 +0200 Subject: [PATCH 18/42] [B] #1814 Some UI improvement for `emacs/merlin-search` --- CHANGES.md | 1 + emacs/merlin.el | 43 ++++++++++++++++++++++++++++++++++++------- 2 files changed, 37 insertions(+), 7 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 8d1415a62e..88a8e99634 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -11,6 +11,7 @@ unreleased + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) + - emacs: Improve the way that result of polarity search is displayed (#1814) merlin 4.16 =========== diff --git a/emacs/merlin.el b/emacs/merlin.el index 9100dfa360..cf5dd0089e 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -137,6 +137,10 @@ a call to `merlin-occurrences'." See `merlin-debug'." :group 'merlin :type 'string) +(defcustom merlin-polarity-search-buffer-name "*merlin-polarity-search-result*" + "The name of the buffer displaying result of polarity search." + :group 'merlin :type 'string) + (defcustom merlin-favourite-caml-mode nil "The OCaml mode to use for the *merlin-types* buffer." :group 'merlin :type 'symbol) @@ -1099,17 +1103,42 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." "-query" query "-position" (merlin-unmake-point (point)))) +(defun merlin--get-polarity-buff () + (get-buffer-create merlin-polarity-search-buffer-name)) + +(defun merlin--render-polarity-result (name type) + (let ((plain-name (string-remove-prefix "Stdlib__" name))) + (concat + (propertize "val " 'face (intern "font-lock-keyword-face")) + (propertize plain-name 'face (intern "font-lock-function-name-face")) + " : " + (propertize type 'face (intern "font-lock-doc-face"))))) + +(defun merlin--polarity-result-to-list (entry) + (let ((function-name (merlin-completion-entry-text "" entry)) + (function-type (merlin-completion-entry-short-description entry))) + (list function-name + (vector (merlin--render-polarity-result function-name function-type))))) + (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))))) + (previous-buff (current-buffer))) + (let ((pol-buff (merlin--get-polarity-buff)) + (inhibit-read-only t)) + (with-current-buffer pol-buff + (switch-to-buffer-other-window pol-buff) + (goto-char 1) + (tabulated-list-mode) + (setq tabulated-list-format [("Polarity Search Result" 100 t)]) + (setq tabulated-list-entries (mapcar 'merlin--polarity-result-to-list entries)) + (setq tabulated-list-padding 2) + (face-spec-set 'header-line '((t :weight bold :height 1.2))) + (tabulated-list-init-header) + (tabulated-list-print t) + (setq buffer-read-only t) + (switch-to-buffer-other-window previous-buff))))) ;;;;;;;;;;;;;;;;; ;; TYPE BUFFER ;; From 55182d37261b5d618f7860c555d370ccf518f6b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:54:44 +0200 Subject: [PATCH 19/42] [B] #1811 Exposes some helper for reducing direct typedtree usage in Lsp --- src/analysis/misc_utils.ml | 20 ++++++------- src/analysis/misc_utils.mli | 12 +++----- src/analysis/type_utils.ml | 1 + src/analysis/typedtree_utils.ml | 51 ++++++++++++++++++++++++++++++++ src/analysis/typedtree_utils.mli | 23 ++++++++++++++ 5 files changed, 89 insertions(+), 18 deletions(-) create mode 100644 src/analysis/typedtree_utils.ml create mode 100644 src/analysis/typedtree_utils.mli diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 5312a2b16d..9d3b705e66 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -58,13 +58,13 @@ let parenthesize_name name = "(" ^ name ^ ")" ) -module Compat = struct - open Typedtree - let pat_var_id_and_loc = function - | { pat_desc = Tpat_var (id, loc); _ } -> Some (id, loc) - | _ -> None - - let pat_alias_pat_id_and_loc = function - | { pat_desc = Tpat_alias (pat, id, loc); _ } -> Some (pat, id, loc) - | _ -> None -end +let parse_identifier (config, source) pos = + let path = Mreader.reconstruct_identifier config source 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))); + path diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 27385cb806..9f789b4269 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -23,11 +23,7 @@ end (* Add parenthesis to qualified operators *) val parenthesize_name : string -> string -module Compat : sig - val pat_var_id_and_loc : - Typedtree.pattern -> (Ident.t * string Location.loc) option - - val pat_alias_pat_id_and_loc - : Typedtree.pattern - -> (Typedtree.pattern * Ident.t * string Location.loc) option -end +(** [parse_identifier] attempts to re-parse a longident so that we get + the location of each of its components. *) +val parse_identifier : + (Mconfig.t * Msource.t) -> Lexing.position -> string Location.loc list diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index 8ad734bd83..3672ee87ea 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -370,3 +370,4 @@ let is_deprecated = ("deprecated" | "ocaml.deprecated"); loc = _}, _ -> true | _ -> false) + diff --git a/src/analysis/typedtree_utils.ml b/src/analysis/typedtree_utils.ml new file mode 100644 index 0000000000..bd9c68d339 --- /dev/null +++ b/src/analysis/typedtree_utils.ml @@ -0,0 +1,51 @@ +open Std + +let extract_toplevel_identifier item = + match item.Typedtree.sig_desc with + | Typedtree.Tsig_value { val_id; _ } -> [val_id] + | Typedtree.Tsig_modsubst { ms_id; _ } -> [ms_id] + | Typedtree.Tsig_modtype { mtd_id; _ } + | Typedtree.Tsig_modtypesubst { mtd_id; _ } -> [mtd_id] + | Typedtree.Tsig_module { md_id; _ } -> Option.to_list md_id + | Typedtree.Tsig_recmodule mods -> + List.filter_map ~f:(fun Typedtree.{md_id; _} -> md_id) mods + | Typedtree.Tsig_class cls -> + List.map ~f:(fun Typedtree.{ ci_id_class; _} -> ci_id_class) cls + | Typedtree.Tsig_class_type cls -> + List.map + ~f:(fun Typedtree.{ ci_id_class_type; _} -> ci_id_class_type) + cls + | Typedtree.Tsig_type _ + | Typedtree.Tsig_typesubst _ + | Typedtree.Tsig_typext _ + | Typedtree.Tsig_exception _ + | Typedtree.Tsig_open _ + | Typedtree.Tsig_include _ + | Typedtree.Tsig_attribute _ -> [] + +let let_bound_vars bindings = + List.filter_map ~f:(fun value_binding -> + match value_binding.Typedtree.vb_pat.pat_desc with + | Tpat_var (id, loc) -> Some (id, loc) + | Typedtree.Tpat_any + | Typedtree.Tpat_alias (_, _, _) + | Typedtree.Tpat_constant _ + | Typedtree.Tpat_tuple _ + | Typedtree.Tpat_construct (_, _, _, _) + | Typedtree.Tpat_variant (_, _, _) + | Typedtree.Tpat_record (_, _) + | Typedtree.Tpat_array _ + | Typedtree.Tpat_lazy _ + | Typedtree.Tpat_or (_, _, _) -> None + ) bindings + +let pat_var_id_and_loc = function + | Typedtree.{ pat_desc = Tpat_var (id, loc); _ } -> + Some (id, loc) + | _ -> None + +let pat_alias_pat_id_and_loc = function + | Typedtree.{ pat_desc = Tpat_alias (pat, id, loc); _ } -> + Some (pat, id, loc) + | _ -> None + diff --git a/src/analysis/typedtree_utils.mli b/src/analysis/typedtree_utils.mli new file mode 100644 index 0000000000..91f910a8b0 --- /dev/null +++ b/src/analysis/typedtree_utils.mli @@ -0,0 +1,23 @@ +(** Utilities to keep explicit Typedtree manipulations local to Merlin_lib + for alternative clients like [ocaml-lsp]. *) + +(** [extract_toplevel_identifier sigitem] extracts toplevel identifier of + a signature item. It returns a list for dealing with recursive elements. *) +val extract_toplevel_identifier : Typedtree.signature_item -> Ident.t list + +(** [let_bound_vars binding_list] extract the [Ident.t] and the + location of variables bind in the form of [let b = e ...] in a + list of bindings. *) +val let_bound_vars : + Typedtree.value_binding list -> (Ident.t * string Location.loc) list + +(** [pat_var_id_and_loc] try to extract the [id] and the [location] of + pattern variable. *) +val pat_var_id_and_loc : + Typedtree.pattern -> (Ident.t * string Location.loc) option + +(** [pat_alias_id_and_loc] try to extract the [id] and the [location] + of pattern alias. *) +val pat_alias_pat_id_and_loc + : Typedtree.pattern + -> (Typedtree.pattern * Ident.t * string Location.loc) option From cdda0ec74dc12aef5b397a1b6a6262103bc3e30b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:58:33 +0200 Subject: [PATCH 20/42] [B] #1720 Signature Help --- CHANGES.md | 1 + src/analysis/signature_help.ml | 260 ++++++++++++++++++ src/analysis/signature_help.mli | 28 ++ src/commands/new_commands.ml | 20 ++ src/commands/query_json.ml | 27 +- src/frontend/query_commands.ml | 33 ++- src/frontend/query_protocol.ml | 38 ++- src/utils/std.ml | 31 +++ tests/test-dirs/signature-help/sh-mix.t | 59 ++++ .../test-dirs/signature-help/signature-help.t | 240 ++++++++++++++++ 10 files changed, 727 insertions(+), 10 deletions(-) create mode 100644 src/analysis/signature_help.ml create mode 100644 src/analysis/signature_help.mli create mode 100644 tests/test-dirs/signature-help/sh-mix.t create mode 100644 tests/test-dirs/signature-help/signature-help.t diff --git a/CHANGES.md b/CHANGES.md index 88a8e99634..14581d1e97 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,6 +8,7 @@ unreleased - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770) - Implement new expand-node command for expanding PPX annotations (#1745) - Implement new inlay-hints command for adding hints on a sourcetree (#1812) + - Add `signature-help` command (#1720) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) diff --git a/src/analysis/signature_help.ml b/src/analysis/signature_help.ml new file mode 100644 index 0000000000..0482638255 --- /dev/null +++ b/src/analysis/signature_help.ml @@ -0,0 +1,260 @@ +open Std + +let {Logger. log} = Logger.for_section "signature-help" + +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 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 -> Format.fprintf ppf "%s" (Misc_utils.parenthesize_name s) + | Ldot (p, s) -> + Format.fprintf ppf "%a.%s" longident p (Misc_utils.parenthesize_name s) + | Lapply (p1, p2) -> Format.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:(Lvl 0) (fun () -> + Printtyp.shared_type_scheme ppf ty) + +let rec type_is_arrow ty = + match Types.get_desc ty with + | Tarrow _ -> true + | Tlink ty -> type_is_arrow ty + | Tpoly (ty, _) -> type_is_arrow ty + | _ -> false + +(* surround function types in parentheses *) +let pp_parameter_type env ppf ty = + if type_is_arrow ty then Format.fprintf ppf "(%a)" (pp_type env) ty + else pp_type env ppf ty + +(* print parameter labels and types *) +let pp_parameter env label ppf ty = + match (label : Asttypes.arg_label) with + | Nolabel -> pp_parameter_type env ppf ty + | Labelled l -> Format.fprintf ppf "%s:%a" l (pp_parameter_type env) ty + | 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 } + +(* This function preprocesses the signature and associate already assigned +arguments to the corresponding parameter. (They should always be in the correct +order in the typedtree, even if they are not in order in the source file.) *) +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 ?(parameters = []) args ty = + match (args, Types.get_desc ty) with + | (_l, arg) :: args, Tarrow (label, ty1, ty2, _) -> + let parameter = + print_parameter_offset ppf buffer e.exp_env label ty1 ?arg + in + separate args ty2 ~parameters:(parameter :: parameters) + | [], Tarrow (label, ty1, ty2, _) -> + let parameter = print_parameter_offset ppf buffer e.exp_env label ty1 in + separate args ty2 ~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 first_unassigned_argument params = + let positional = function + | { argument = None; label = Asttypes.Nolabel; _ } -> true + | _ -> false + in + let labelled = function + | { argument = None; label = Asttypes.Labelled _ | Optional _; _ } -> true + | _ -> false + in + try Some (List.index params ~f:positional) with Not_found -> + try Some (List.index params ~f:labelled) 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 ~cursor = function + | (_, Browse_raw.Expression arg) + :: ( _ + , Expression { exp_desc = Texp_apply (({ exp_type; _ } as e), args); _ } + ) + :: _ + when is_arrow exp_type -> + log ~title:"application_signature" "Last arg:\n%a" + Logger.fmt (fun fmt -> Printtyped.expression fmt arg); + let result = separate_function_signature e ~args in + let active_param = + if prefix = "" && Lexing.compare_pos cursor arg.exp_loc.loc_end > 0 then + begin + (* If the cursor is placed after the last arg it means that a whitespace + was inserted and we want to underline the next argument. *) + log ~title:"application_signature" + "Current cursor position is after the last argument"; + first_unassigned_argument result.parameters + end else + (* If not, we identify the argument which is being written *) + let active_param = + active_parameter_by_arg ~arg result.parameters + in + match active_param with + | Some _ as ap -> ap + | None -> active_parameter_by_prefix ~prefix result.parameters + in + Some { result with active_param } + | (_, Expression ({ exp_type; _ } as e)) :: _ when is_arrow exp_type -> + (* provide signature information directly after an unapplied function-type + value *) + 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 + +let prefix_of_position ~short_path source position = + match Msource.text source with + | "" -> "" + | text -> + let from = + let (`Offset index) = Msource.get_offset source position in + min (String.length text - 1) (index - 1) + in + let pos = + let should_terminate = ref false in + let has_seen_dot = ref false in + let is_prefix_char c = + if !should_terminate then false + else + match c with + | 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '\'' + | '_' + (* Infix function characters *) + | '$' + | '&' + | '*' + | '+' + | '-' + | '/' + | '=' + | '>' + | '@' + | '^' + | '!' + | '?' + | '%' + | '<' + | ':' + | '~' + | '#' -> true + | '`' -> + if !has_seen_dot then false + else ( + should_terminate := true; + true) + | '.' -> + has_seen_dot := true; + not short_path + | _ -> false + in + String.rfindi text ~from ~f:(fun c -> not (is_prefix_char c)) + in + let pos = + match pos with + | None -> 0 + | Some pos -> pos + 1 + in + let len = from - pos + 1 in + let reconstructed_prefix = String.sub text ~pos ~len in + (* if we reconstructed [~f:ignore] or [?f:ignore], we should take only + [ignore], so: *) + log ~title:"prefix_of_position" "%S" reconstructed_prefix; + if + String.is_prefix reconstructed_prefix ~prefix:"~" + || String.is_prefix reconstructed_prefix ~prefix:"?" + then + match String.lsplit2 reconstructed_prefix ~on:':' with + | Some (_, s) -> s + | None -> reconstructed_prefix + else reconstructed_prefix diff --git a/src/analysis/signature_help.mli b/src/analysis/signature_help.mli new file mode 100644 index 0000000000..f7c7738de7 --- /dev/null +++ b/src/analysis/signature_help.mli @@ -0,0 +1,28 @@ +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 + } + +(** provide signature information for applied functions *) +val application_signature : + prefix:string + -> cursor:Lexing.position + -> Mbrowse.t + -> application_signature option + +(** @see reference *) +val prefix_of_position : + short_path: bool + -> Msource.t + -> Msource.position + -> string diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 7e2535743b..1713d1b9d9 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -754,6 +754,26 @@ The return value has the shape: ] end ; + command "signature-help" + ~doc:"Returns LSP Signature Help response" + ~spec: [ + arg "-position" " Position of Signature Help request" + (marg_position (fun pos (expr,_pos) -> (expr,pos))); + ] + ~default:("",`None) + begin fun buffer (_,pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as position -> + let sh = { + Query_protocol.position; + trigger_kind = None; + is_retrigger = false; + active_signature_help = None; + } in + run buffer (Query_protocol.Signature_help sh) + end + ; (* Used only for testing *) command "dump" diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index f3ae5c8767..cadf70b070 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -226,6 +226,10 @@ let dump (type a) : a t -> json = | `Unqualify -> "unqualify"); "position", mk_position pos; ] + | Signature_help {position;_} -> + mk "signature-help" [ + "position", mk_position position + ] | Version -> mk "version" [] let string_of_completion_kind = function @@ -367,6 +371,22 @@ let json_of_inlay_hints hints = ] in `List (List.map ~f:json_of_hint hints) +let json_of_signature_help resp = + let param { label_start; label_end } = + `Assoc ["label", `List [`Int label_start; `Int label_end]] in + match resp with + | None -> `Assoc [] + | Some { label; parameters; active_param; active_signature } -> + let signature = + `Assoc + ["label", `String label; + "parameters", `List (List.map ~f:param parameters);] in + `Assoc + ["signatures", `List [signature]; + "activeParameter", `Int active_param; + "activeSignature", `Int active_signature; + ] + let json_of_response (type a) (query : a t) (response : a) : json = match query, response with | Type_expr _, str -> `String str @@ -400,7 +420,7 @@ let json_of_response (type a) (query : a t) (response : a) : json = | `Found doc -> `String doc end - | Syntax_document _, resp -> + | Syntax_document _, resp -> (match resp with | `Found info -> `Assoc @@ -410,9 +430,9 @@ let json_of_response (type a) (query : a t) (response : a) : json = ("url", `String info.documentation); ] | `No_documentation -> `String "No documentation found") - | Expand_ppx _, resp -> + | Expand_ppx _, resp -> let str = match resp with - | `Found ppx_info -> + | `Found ppx_info -> `Assoc [ ("code", `String ppx_info.code); @@ -471,5 +491,6 @@ let json_of_response (type a) (query : a t) (response : a) : json = let with_file = scope = `Project in `List (List.map locations ~f:(fun loc -> with_location ~with_file loc [])) + | Signature_help _, s -> json_of_signature_help s | Version, version -> `String version diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index db5e57b01b..77ca50b6e7 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -881,7 +881,38 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = ~stop structure end - + + | Signature_help { position; _ } -> + (* Todo: additionnal contextual information could help us provide better + results.*) + let typer = Mpipeline.typer_result pipeline in + let pos = Mpipeline.get_lexing_pos pipeline position in + let node = Mtyper.node_at typer pos in + let source = Mpipeline.input_source pipeline in + let prefix = + Signature_help.prefix_of_position ~short_path:true source position + in + let application_signature = + Signature_help.application_signature ~prefix ~cursor:pos node + in + let param offset (p: Signature_help.parameter_info) = + { label_start = offset + p.param_start; label_end = offset + p.param_end} + in + (match application_signature with + | Some s -> + let prefix = + let fun_name = + Option.value ~default:"_" s.function_name + in + sprintf "%s : " fun_name in + Some { label = prefix ^ s.signature; + parameters = + List.map ~f:(param (String.length prefix)) s.parameters; + active_param = Option.value ~default:0 s.active_param; + active_signature = 0; + } + | None -> None) + | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" Merlin_config.version Sys.ocaml_version; diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 364ecfc331..b7e59b6d71 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -96,20 +96,40 @@ type error_filter = { typing : bool; } -type syntax_doc_result = -{ - name : string; - description : string; - documentation : string +type syntax_doc_result = +{ + name : string; + description : string; + documentation : string } -type ppxed_source = +type ppxed_source = { code : string; attr_start : Lexing.position; attr_end : Lexing.position; } +type signature_help_param = { + label_start : int; + label_end : int; +} + +type signature_help_result = { + label : string; + parameters : signature_help_param list; + active_param : int; + active_signature: int; +} + +type trigger_kind = Invoked | Trigger_character of string | Content_change +type signature_help = { + position: Msource.position; + trigger_kind: trigger_kind option; + is_retrigger: bool; + active_signature_help: signature_help_result option; +} + type is_tail_position = [`No | `Tail_position | `Tail_call] type _ _bool = bool @@ -223,5 +243,11 @@ type _ t = | Occurrences(* *) : [`Ident_at of Msource.position] * [`Project | `Buffer] -> Location.t list t + | Signature_help + : signature_help + -> signature_help_result option t + (** In current version, Merlin only uses the parameter [position] to answer + signature_help queries. The additionnal parameters are described in the + LSP protocol and might enable finer behaviour in the future. *) | Version : string t diff --git a/src/utils/std.ml b/src/utils/std.ml index 586087b65e..c1b49ecfbf 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -518,6 +518,37 @@ module String = struct in aux 0 j0; Buffer.contents buffer + + let rfindi = + let rec loop s ~f i = + if i < 0 then None + else if f (String.unsafe_get s i) then Some i + else loop s ~f (i - 1) + in + fun ?from s ~f -> + let from = + let len = String.length s in + match from with + | None -> len - 1 + | Some i -> + if i > len - 1 then failwith "rfindi: invalid from" + else i + in + loop s ~f from + + let rec check_prefix s ~prefix len i = + i = len || (s.[i] = prefix.[i] && check_prefix s ~prefix len (i + 1)) + + let lsplit2 s ~on = + match String.index_opt s on with + | None -> None + | Some i -> + Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1)) + + let is_prefix s ~prefix = + let len = length s in + let prefix_len = length prefix in + len >= prefix_len && check_prefix s ~prefix prefix_len 0 end let sprintf = Printf.sprintf diff --git a/tests/test-dirs/signature-help/sh-mix.t b/tests/test-dirs/signature-help/sh-mix.t new file mode 100644 index 0000000000..d6e37d5e44 --- /dev/null +++ b/tests/test-dirs/signature-help/sh-mix.t @@ -0,0 +1,59 @@ + $ cat >test.ml <<'EOF' + > let f x ~lbl_a y ~lbl_b z = ignore (x, lbl_a, lbl_b, z) + > let _ = f + > EOF + +First is the first parameter: + $ $MERLIN single signature-help -position 2:11 -filename test jq '.value.activeParameter' + 0 + + $ cat >test.ml <<'EOF' + > let f x ~lbl_a y ~lbl_b z = ignore (x, lbl_a, lbl_b, z) + > let _ = f 0 + > EOF + +After we expect the next non-labelled parameter to be active: + $ $MERLIN single signature-help -position 2:12 -filename test jq '.value.activeParameter' + 2 + + $ cat >test.ml <<'EOF' + > let f x ~lbl_a y ~lbl_b z = ignore (x, lbl_a, lbl_b, z) + > let _ = f 0 3 + > EOF + +It does happen when the expression is being written: + $ $MERLIN single signature-help -position 2:12 -filename test jq '.value.activeParameter' + 2 + + $ cat >test.ml <<'EOF' + > let f x ~lbl_a y ~lbl_b z = ignore (x, lbl_a, lbl_b, z) + > let _ = f 0 ~ + > EOF + +And when a tilde is used the first labelled arg is higlighted: + $ $MERLIN single signature-help -position 2:13 -filename test jq '.value.activeParameter' + 1 + + $ cat >test.ml <<'EOF' + > let f x ~lbl_a y ~lbl_b z = ignore (x, lbl_a, lbl_b, z) + > let _ = f 0 ~lbl_b + > EOF + +Or the second one is the name corresponds: + $ $MERLIN single signature-help -position 2:18 -filename test jq '.value.activeParameter' + 3 + +If we write some positional arguments first they should not be suggested later: + $ cat >test.ml <<'EOF' + > let f x ~lbl_a y ~lbl_b z = ignore (x, lbl_a, lbl_b, z, y);; + > let _ = f 1 3 ~lbl_a:4 + > EOF + + $ $MERLIN single signature-help -position 2:23 -filename test jq '.value.activeParameter' + 4 diff --git a/tests/test-dirs/signature-help/signature-help.t b/tests/test-dirs/signature-help/signature-help.t new file mode 100644 index 0000000000..f59e9cf12a --- /dev/null +++ b/tests/test-dirs/signature-help/signature-help.t @@ -0,0 +1,240 @@ +It can provide signature help after a function-type value. + + $ $MERLIN single signature-help -position 2:11 < let map = ListLabels.map + > let _ = map + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "map : f:('a -> 'b) -> 'a list -> 'b list", + "parameters": [ + { + "label": [ + 6, + 18 + ] + }, + { + "label": [ + 22, + 29 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can provide signature help for an operator. + + $ $MERLIN single signature-help -position 2:13 < let (+) = (+) + > let _ = 1 + 2 + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "(+) : int -> int -> int", + "parameters": [ + { + "label": [ + 6, + 9 + ] + }, + { + "label": [ + 13, + 16 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can provide signature help for an anonymous function. + + $ $MERLIN single signature-help -position 1:26 < let _ = (fun x -> x + 1) + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "_ : int -> int", + "parameters": [ + { + "label": [ + 4, + 7 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make the non-labelled parameter active. + + $ $MERLIN single signature-help -position 2:14 < let map = ListLabels.map + > let _ = map [] + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "map : f:('a -> 'b) -> 'a list -> 'b list", + "parameters": [ + { + "label": [ + 6, + 18 + ] + }, + { + "label": [ + 22, + 29 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make the labelled parameter active. + $ $MERLIN single signature-help -position 2:14 < let map = ListLabels.map + > let _ = map ~f:Int.abs + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "map : f:(int -> int) -> int list -> int list", + "parameters": [ + { + "label": [ + 6, + 20 + ] + }, + { + "label": [ + 24, + 32 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make a labelled parameter active by prefix. + + $ $MERLIN single signature-help -position 2:15 < let mem = ListLabels.mem + > let _ = mem ~se + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "mem : 'a -> set:'a list -> bool", + "parameters": [ + { + "label": [ + 6, + 8 + ] + }, + { + "label": [ + 12, + 23 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make an optional parameter active by prefix. + + $ $MERLIN single signature-help -position 2:18 < let create = Hashtbl.create + > let _ = create ?ra + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "create : ?random:bool -> int -> ('a, 'b) Hashtbl.t", + "parameters": [ + { + "label": [ + 9, + 21 + ] + }, + { + "label": [ + 25, + 28 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +It shouldn't give a signature-help when outside of signature. + + $ $MERLIN single signature-help -position 1:8 < let my_fun x = 1 + > EOF + { + "class": "return", + "value": {}, + "notifications": [] + } From e438ad604d922d907b01c5f3a2cfee9a8703d140 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 13:01:09 +0200 Subject: [PATCH 21/42] Compat with new occurrences api --- src/commands/query_json.ml | 2 +- src/frontend/query_commands.ml | 2 +- src/frontend/query_protocol.ml | 5 ++++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index cadf70b070..fcf0d3110f 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -487,7 +487,7 @@ let json_of_response (type a) (query : a t) (response : a) : json = | 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 (_, scope), locations -> + | Occurrences (_, scope), (locations, _) -> let with_file = scope = `Project in `List (List.map locations ~f:(fun loc -> with_location ~with_file loc [])) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 77ca50b6e7..6d68b5db43 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -858,7 +858,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 + List.sort ~cmp locs, `Not_requested | Inlay_hints ( start, diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index b7e59b6d71..edceac009c 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -134,6 +134,9 @@ type is_tail_position = [`No | `Tail_position | `Tail_call] type _ _bool = bool +type occurrences_status = + [ `Not_requested | `Out_of_sync of string list | `No_def | `Included ] + type _ t = | Type_expr(* *) : string * Msource.position @@ -242,7 +245,7 @@ type _ t = -> string list t | Occurrences(* *) : [`Ident_at of Msource.position] * [`Project | `Buffer] - -> Location.t list t + -> (Location.t list * occurrences_status) t | Signature_help : signature_help -> signature_help_result option t From 5d5a94f3898349e0b5b991e9ccd98dda71d38e6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 13:32:50 +0200 Subject: [PATCH 22/42] Setup codebase formatting and fix a few comments. --- .github/workflows/main.yml | 7 +++++++ .ocamlformat | 11 +++++++++++ .ocamlformat-ignore | 1 + dune-project | 2 +- src/analysis/construct.ml | 2 +- src/kernel/mbrowse.ml | 2 +- src/ocaml/.ocamlformat | 1 + src/ocaml/.ocamlformat-enable | 1 + src/ocaml/parsing/.ocamlformat-enable | 1 + src/ocaml/typing/.ocamlformat-enable | 2 ++ src/utils/.ocamlformat-ignore | 4 ++++ 11 files changed, 31 insertions(+), 3 deletions(-) create mode 100644 .ocamlformat create mode 100644 .ocamlformat-ignore create mode 100644 src/ocaml/.ocamlformat create mode 100644 src/ocaml/.ocamlformat-enable create mode 100644 src/ocaml/parsing/.ocamlformat-enable create mode 100644 src/ocaml/typing/.ocamlformat-enable create mode 100644 src/utils/.ocamlformat-ignore diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 6361d80070..13122b8a88 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -82,3 +82,10 @@ jobs: opam exec -- dune clean opam exec -- dune build git diff --exit-code + + + - name: Check that the changes are correctly formatted + if: matrix.os == 'ubuntu-latest' + run: | + opam install ocamlformat.0.26.2 + opam exec -- dune build @fmt diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..2f1d4222b2 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,11 @@ +version=0.26.2 +disable=false + +break-cases=fit-or-vertical +doc-comments=before +cases-exp-indent=2 +dock-collection-brackets=false +# Preserve begin/end +exp-grouping=preserve +module-item-spacing=preserve +parse-docstrings=false diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 0000000000..3de980a472 --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1 @@ +upstream/** diff --git a/dune-project b/dune-project index 22f5248a79..dbae07868d 100644 --- a/dune-project +++ b/dune-project @@ -3,6 +3,6 @@ (using menhir 2.0) (cram enable) -(formatting disabled) +(formatting (enabled_for ocaml)) (implicit_transitive_deps false) (use_standard_c_and_cxx_flags true) diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index 5511c6a2b9..39bf5f5f6c 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -466,8 +466,8 @@ module Gen = struct 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 + (* If this is a "basic" type we propose a default value *) [ Hashtbl.find Util.predef_types path ] with Not_found -> let def = Env.find_type_descrs path env in diff --git a/src/kernel/mbrowse.ml b/src/kernel/mbrowse.ml index 9ee7c27f87..6fbea1c953 100644 --- a/src/kernel/mbrowse.ml +++ b/src/kernel/mbrowse.ml @@ -119,8 +119,8 @@ let compare_locations pos l1 l2 = Location_aux.compare_pos pos l1, Location_aux.compare_pos pos l2 with + (* Cursor inside both locations: favor non-ghost closer to the end *) | 0, 0 -> - (* Cursor inside both locations: favor non-ghost closer to the end *) begin match l1.Location.loc_ghost, l2.Location.loc_ghost with | true, false -> 1 | false, true -> -1 diff --git a/src/ocaml/.ocamlformat b/src/ocaml/.ocamlformat new file mode 100644 index 0000000000..e3346c163b --- /dev/null +++ b/src/ocaml/.ocamlformat @@ -0,0 +1 @@ +disable=true diff --git a/src/ocaml/.ocamlformat-enable b/src/ocaml/.ocamlformat-enable new file mode 100644 index 0000000000..23f379d2cc --- /dev/null +++ b/src/ocaml/.ocamlformat-enable @@ -0,0 +1 @@ +merlin_specific/** diff --git a/src/ocaml/parsing/.ocamlformat-enable b/src/ocaml/parsing/.ocamlformat-enable new file mode 100644 index 0000000000..34e2669741 --- /dev/null +++ b/src/ocaml/parsing/.ocamlformat-enable @@ -0,0 +1 @@ +msupport_parsing.ml diff --git a/src/ocaml/typing/.ocamlformat-enable b/src/ocaml/typing/.ocamlformat-enable new file mode 100644 index 0000000000..a7338db29e --- /dev/null +++ b/src/ocaml/typing/.ocamlformat-enable @@ -0,0 +1,2 @@ +msupport.ml +msupport.mli diff --git a/src/utils/.ocamlformat-ignore b/src/utils/.ocamlformat-ignore new file mode 100644 index 0000000000..430454161f --- /dev/null +++ b/src/utils/.ocamlformat-ignore @@ -0,0 +1,4 @@ +misc.ml +misc.mli +stamped_hashtable.ml +stamped_hashtable.mli From 9f8a3c80783612e795101e39e61509e0b95be9b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 16:01:37 +0200 Subject: [PATCH 23/42] Format the codebase --- src/analysis/browse_misc.ml | 182 +- src/analysis/browse_tree.ml | 130 +- src/analysis/browse_tree.mli | 75 +- src/analysis/completion.ml | 850 ++++----- src/analysis/completion.mli | 92 +- src/analysis/construct.ml | 473 +++-- src/analysis/construct.mli | 14 +- src/analysis/context.ml | 116 +- src/analysis/context.mli | 44 +- src/analysis/destruct.ml | 682 ++++---- src/analysis/destruct.mli | 49 +- src/analysis/expansion.ml | 64 +- src/analysis/inlay_hints.ml | 148 +- src/analysis/inlay_hints.mli | 14 +- src/analysis/jump.ml | 204 +-- src/analysis/jump.mli | 48 +- src/analysis/locate.ml | 1083 ++++++------ src/analysis/locate.mli | 121 +- src/analysis/misc_utils.ml | 37 +- src/analysis/misc_utils.mli | 6 +- src/analysis/namespaced_path.ml | 52 +- src/analysis/namespaced_path.mli | 19 +- src/analysis/ocamldoc.ml | 65 +- src/analysis/outline.ml | 207 +-- src/analysis/outline.mli | 40 +- src/analysis/polarity_search.ml | 114 +- src/analysis/ppx_expand.ml | 141 +- src/analysis/ptyp_of_type.ml | 201 +-- src/analysis/ptyp_of_type.mli | 10 +- src/analysis/refactor_open.ml | 40 +- src/analysis/refactor_open.mli | 11 +- src/analysis/signature_help.ml | 57 +- src/analysis/signature_help.mli | 31 +- src/analysis/syntax_doc.ml | 293 ++-- src/analysis/syntax_doc.mli | 5 +- src/analysis/tail_analysis.ml | 128 +- src/analysis/tail_analysis.mli | 46 +- src/analysis/type_enclosing.ml | 166 +- src/analysis/type_utils.ml | 316 ++-- src/analysis/type_utils.mli | 93 +- src/analysis/typedtree_utils.ml | 48 +- src/analysis/typedtree_utils.mli | 6 +- src/commands/new_commands.ml | 1542 ++++++++--------- src/commands/new_commands.mli | 51 +- src/commands/query_json.ml | 690 ++++---- src/config/gen_config.ml | 17 +- src/dot-merlin/dot_merlin_reader.ml | 546 +++--- src/dot-protocol/merlin_dot_protocol.ml | 115 +- src/dot-protocol/merlin_dot_protocol.mli | 90 +- src/extend/extend_driver.ml | 45 +- src/extend/extend_driver.mli | 4 +- src/extend/extend_helper.ml | 37 +- src/extend/extend_helper.mli | 7 +- src/extend/extend_main.ml | 105 +- src/extend/extend_main.mli | 12 +- src/extend/extend_protocol.ml | 73 +- src/frontend/ocamlmerlin/gen_ccflags.ml | 9 +- src/frontend/ocamlmerlin/log_info.ml | 10 +- src/frontend/ocamlmerlin/log_info.mli | 4 +- src/frontend/ocamlmerlin/new/new_merlin.ml | 238 +-- .../ocamlmerlin/ocamlmerlin_server.ml | 38 +- src/frontend/ocamlmerlin/old/old_IO.ml | 421 ++--- src/frontend/ocamlmerlin/old/old_IO.mli | 68 +- src/frontend/ocamlmerlin/old/old_command.ml | 234 +-- src/frontend/ocamlmerlin/old/old_command.mli | 50 +- src/frontend/ocamlmerlin/old/old_merlin.ml | 143 +- src/frontend/ocamlmerlin/old/old_protocol.ml | 135 +- src/frontend/query_commands.ml | 780 ++++----- src/frontend/query_commands.mli | 41 +- src/frontend/query_protocol.ml | 377 ++-- src/frontend/test/ocamlmerlin_test.ml | 215 ++- src/kernel/extension.ml | 219 ++- src/kernel/extension.mli | 57 +- src/kernel/mbrowse.ml | 200 +-- src/kernel/mbrowse.mli | 50 +- src/kernel/mconfig.ml | 1201 +++++++------ src/kernel/mconfig.mli | 124 +- src/kernel/mconfig_dot.ml | 439 +++-- src/kernel/mconfig_dot.mli | 90 +- src/kernel/mocaml.ml | 107 +- src/kernel/mocaml.mli | 3 +- src/kernel/mpipeline.ml | 406 ++--- src/kernel/mpipeline.mli | 2 +- src/kernel/mppx.ml | 22 +- src/kernel/mreader.ml | 171 +- src/kernel/mreader.mli | 41 +- src/kernel/mreader_explain.ml | 85 +- src/kernel/mreader_extend.ml | 91 +- src/kernel/mreader_extend.mli | 14 +- src/kernel/mreader_lexer.ml | 237 ++- src/kernel/mreader_lexer.mli | 52 +- src/kernel/mreader_parser.ml | 201 +-- src/kernel/mreader_parser.mli | 52 +- src/kernel/mreader_recover.ml | 143 +- src/kernel/mreader_recover.mli | 72 +- src/kernel/msource.ml | 106 +- src/kernel/msource.mli | 18 +- src/kernel/mtyper.ml | 184 +- src/kernel/mtyper.mli | 9 +- src/kernel/phase_cache.ml | 54 +- src/kernel/phase_cache.mli | 18 +- src/ocaml/merlin_specific/browse_raw.ml | 1209 ++++++------- src/ocaml/merlin_specific/browse_raw.mli | 147 +- src/ocaml/merlin_specific/tast_helper.ml | 14 +- src/ocaml/merlin_specific/typer_raw.ml | 451 +++-- src/ocaml/merlin_specific/typer_raw.mli | 46 +- src/ocaml/parsing/msupport_parsing.ml | 6 +- src/ocaml/typing/msupport.ml | 139 +- src/ocaml/typing/msupport.mli | 65 +- src/platform/os_ipc.ml | 32 +- src/utils/file_cache.ml | 108 +- src/utils/file_cache.mli | 46 +- src/utils/file_id.ml | 42 +- src/utils/file_id.mli | 8 +- src/utils/lib_config.ml | 6 +- src/utils/lib_config.mli | 26 +- src/utils/logger.ml | 112 +- src/utils/logger.mli | 53 +- src/utils/marg.ml | 84 +- src/utils/marg.mli | 16 +- src/utils/ppxsetup.ml | 94 +- src/utils/ppxsetup.mli | 50 +- src/utils/sexp.ml | 207 ++- src/utils/sexp.mli | 2 +- src/utils/std.ml | 576 +++--- 125 files changed, 10171 insertions(+), 10454 deletions(-) diff --git a/src/analysis/browse_misc.ml b/src/analysis/browse_misc.ml index 3b81949b25..5968885798 100644 --- a/src/analysis/browse_misc.ml +++ b/src/analysis/browse_misc.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -34,57 +34,67 @@ let dummy_type_scheme desc = 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)) + | [] -> 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) + 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_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 + | 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_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. *) + that information. *) function - | Env_value (_,i,v) -> Some (Sig_value (i,v,Exported)) + | 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)) + | 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 + | 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 + 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 + | Env.Env_module (_, i, _, _) -> Some i | _ -> None in let sg = ref [] in @@ -98,54 +108,54 @@ let signature_of_env ?(ignore_extensions=true) env = in aux (Env.summary env); (* Since 4.08 one can't simply call [simplify]. *) - (* Typemod.simplify_signature *) (!sg) + (* 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 " _") - ] + 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 + `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 []) + `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 = + (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 + (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 + ( (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) + 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/src/analysis/browse_tree.ml b/src/analysis/browse_tree.ml index 2f5b78b22b..9523b23fd7 100644 --- a/src/analysis/browse_tree.ml +++ b/src/analysis/browse_tree.ml @@ -1,50 +1,51 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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; -} +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 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 + 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) + 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 @@ -53,20 +54,21 @@ 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 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,_,_) -> + | 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 +and normalize_type_decl env decl = + match decl.Types.type_manifest with | Some expr -> normalize_type_expr env expr | None -> decl @@ -83,22 +85,21 @@ let same_constructor env a b = 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 - | Type_open -> - [`Uid d.cstr_uid] - | _ -> assert false + begin + match ty.Types.type_kind with + | Types.Type_variant (decls, _) -> List.map decls ~f:id_of_constr_decl + | Type_open -> [ `Uid d.cstr_uid ] + | _ -> assert false end - | `Declaration d -> - [`Id d.Typedtree.cd_id] + | `Declaration d -> [ `Id d.Typedtree.cd_id ] | `Extension_constructor ext_cons -> let des = Env.find_ident_constructor ext_cons.Typedtree.ext_id env in - [`Uid des.cstr_uid] + [ `Uid des.cstr_uid ] in let a = get_decls a in let b = get_decls b in - let same a b = match a, b with + let same a b = + match (a, b) with | `Id a, `Id b -> Ident.same a b | `Uid a, `Uid b -> Shape.Uid.equal a b | _, _ -> false @@ -115,50 +116,45 @@ let all_occurrences path = | [] -> acc | paths -> (t, paths) :: acc in - if Browse_raw.has_attr ~name:"merlin.hide" t.t_node then - acc - else - List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children) + if Browse_raw.has_attr ~name:"merlin.hide" t.t_node then acc + else List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children) in aux [] -let all_constructor_occurrences ({t_env = env; _},d) t = +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 + | 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 - if Browse_raw.has_attr ~name:"merlin.hide" t.t_node then - acc - else - List.fold_left ~f:aux ~init:acc (Lazy.force t.t_children) + if Browse_raw.has_attr ~name:"merlin.hide" t.t_node then acc + else 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 || + Path.same prefix path + || match path with - | Pdot (p,_) -> path_prefix ~prefix p + | 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; _}, _) = + 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 - ) + if has_prefix elt then elt :: acc else acc) in Browse_raw.fold_node aux env node acc in diff --git a/src/analysis/browse_tree.mli b/src/analysis/browse_tree.mli index 66713bba13..2947db4f6d 100644 --- a/src/analysis/browse_tree.mli +++ b/src/analysis/browse_tree.mli @@ -1,37 +1,37 @@ (* {{{ 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; -} + 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 @@ -41,16 +41,19 @@ val default_env : Env.t * 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 - | `Extension_constructor of Typedtree.extension_constructor ] - -> t -> t Location.loc list + t + * [ `Description of Types.constructor_description + | `Declaration of Typedtree.constructor_declaration + | `Extension_constructor of Typedtree.extension_constructor ] -> + 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/src/analysis/completion.ml b/src/analysis/completion.ml index f8d713250b..7b62e11f3a 100644 --- a/src/analysis/completion.ml +++ b/src/analysis/completion.ml @@ -1,31 +1,31 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + 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 + 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: + 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 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. + 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 @@ -33,7 +33,7 @@ open Browse_raw open Extend_protocol.Reader -let {Logger. log} = Logger.for_section "Completion" +let { Logger.log } = Logger.for_section "Completion" type raw_info = [ `Constructor of Types.constructor_description @@ -43,97 +43,91 @@ type raw_info = | `String of string | `Type_declaration of Ident.t * Types.type_declaration | `Type_scheme of Types.type_expr - | `Variant of string * Types.type_expr option - ] + | `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)) + | `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)) + `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 + `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 + try Some (f x env) with Not_found | Env.Error _ -> None -let rec methods_of_type env ?(acc=[]) type_expr = +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 + 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 + 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 - | Binding_op _ -> `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 + | Dummy -> `Expression + | Pattern _ -> `Pattern + | Expression _ -> `Expression + | Case _ -> `Pattern + | Class_expr _ -> `Expression + | Class_structure _ -> `Expression + | Class_field _ -> `Expression + | Class_field_kind _ -> `Expression + | Binding_op _ -> `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 @@ -142,11 +136,11 @@ let classify_node = function open Query_protocol.Compl -let map_entry f entry = - {entry with desc = f entry.desc; info = f entry.info} +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 + 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 @@ -159,47 +153,47 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = in let kind, text = match ty with - | `Value v -> - (`Value, `Type_scheme v.Types.val_type) - | `Cons c -> (`Constructor, `Constructor c) + | `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)) + 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) -> + | `Label_decl (ty, label_decl) -> let desc = - Types.(Tarrow (Ast_helper.no_label, - ty, label_decl.ld_type, commu_ok)) + 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 = - Mconfig.Verbosity.to_int !Type_utils.verbosity ~for_smart:1 - in - if Type_utils.mod_smallerthan (1000 * verbosity) m = None then raise Exit; - (`Module, `Modtype m) - with Exit -> (`Module, `None) - end + | `Mod m -> begin + try + if not exact then raise Exit; + let verbosity = + Mconfig.Verbosity.to_int !Type_utils.verbosity ~for_smart:1 + 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)) + 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*) + 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 @@ -210,31 +204,34 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = | `Module | `Modtype -> `None | _ -> text in - let info = match Type_utils.read_doc_attributes attrs, get_doc, kind with + 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 + | None, Some get_doc, kind -> ( + match (path, loc) with | Some p, Some loc -> - let namespace = (* FIXME: that's just terrible *) + 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 + begin + match get_doc (`Completion_entry (namespace, p, loc)) with | `Found str -> `String str | _ -> `None | exception _ -> `None end - | _, _ -> `None + | _, _ -> `None) in let deprecated = Type_utils.is_deprecated attrs in - {name; kind; desc; info; deprecated} + { name; kind; desc; info; deprecated } let item_for_global_module name = - {name; kind = `Module; desc = `None; info = `None; deprecated = false} + { name; kind = `Module; desc = `None; info = `None; deprecated = false } let fold_variant_constructors ~env ~init ~f = let rec aux acc t = @@ -260,14 +257,15 @@ let fold_variant_constructors ~env ~init ~f = 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' + 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 @@ -276,18 +274,17 @@ 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 + 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 + | _ -> init -let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch = +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 @@ -295,8 +292,9 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env 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 = + 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. @@ -308,26 +306,24 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env 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 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 + ((-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 + | 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 + 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. @@ -343,111 +339,123 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env | 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 cost = + let c = Types.linked_variables in + try 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 + 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 + 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 + 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; _}) :: _ -> + 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 [] - + 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 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 + 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 + 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 [] - + 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 [] - + 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 [] - + 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 [] + 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 @@ -455,100 +463,121 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env in try of_kind_group kind with exn -> - log ~title:"get_candidates/of_kind" - "Failed with exception: %a" Logger.exn 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.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 gen_values = `Group [ `Values; `Constructor ] -let default_kinds = [`Variants; gen_values; `Types; `Modules; `Modules_type] +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 + | `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 && + 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 + 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 } - ) + 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 + [ `No + | `Maybe | `Description of Types.label_description list - | `Declaration of Types.type_expr * Types.label_declaration 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 = +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) + 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 + 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-"] + 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 () + 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) + (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:[] + 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 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 + if not (valid `Label name) then candidates + else make_candidate ~prefix_path ~exact:(name = prefix) name - (`Label_decl (ty,l)) ~attrs:[] + (`Label_decl (ty, l)) + ~attrs:[] :: candidates in - let base_completion = match (is_label : is_label) with + let base_completion = + match (is_label : is_label) with | `No -> [] - | `Maybe -> - Env.fold_labels add_label_description prefix_path env [] + | `Maybe -> Env.fold_labels add_label_description prefix_path env [] | `Description lbls -> List.fold_right ~f:add_label_description lbls ~init:[] - | `Declaration (ty,decls) -> + | `Declaration (ty, decls) -> List.fold_right ~f:(add_label_declaration ty) decls ~init:[] in if base_completion = [] then @@ -556,16 +585,14 @@ let complete_prefix ?get_doc ?target_type ?(kinds=[]) ~keywords ~prefix if kinds = [] then let kind = classify_node node in completion_order kind - else - (kinds : kind list :> kinds) + else (kinds : kind list :> kinds) in let add_completions acc kind = - get_candidates - ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch + 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 + List.fold_left ~f:add_completions order ~init:[] |> List.concat else base_completion in try @@ -576,37 +603,44 @@ let complete_prefix ?get_doc ?target_type ?(kinds=[]) ~keywords ~prefix let compl = find ~is_label prefix in (* Keywords completion *) let compl = - if not (List.mem `Keywords ~set:kinds) then - 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 - ) + 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 + List.fold_left (Mconfig.global_modules config) ~init:compl + ~f:(fun candidates name -> + if not (String.no_double_underscore name) then candidates else - candidates - ) + 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 -> [] @@ -614,64 +648,67 @@ let complete_prefix ?get_doc ?target_type ?(kinds=[]) ~keywords ~prefix let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix = function | [] -> [] - | (env, node) :: branch -> + | (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 ; _ } -> + | 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) + 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 + 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) -> + 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 _ -> () + 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 + { 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 - | lbls -> - `Description (Array.to_list lbls) + | _ | (exception _) -> `Maybe + end + | lbls -> `Description (Array.to_list lbls) in let result = complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label @@ -683,9 +720,9 @@ let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix = 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 + (env, node) branch) -let expand_prefix ~global_modules ?(kinds=[]) env prefix = +let expand_prefix ~global_modules ?(kinds = []) env prefix = Env.with_cmis @@ fun () -> let lidents, last = let ts = Expansion.explore ~global_modules env in @@ -696,88 +733,92 @@ let expand_prefix ~global_modules ?(kinds=[]) env prefix = fun s -> Expansion.spell_match last s in let validate _ _ s = validate' s in - let kinds = match kinds with + 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 + 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) + if not (validate' name) then None + else Some (item_for_global_module name) in - candidates @ [List.filter_map global_modules ~f] - |> List.flatten + 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 })) + 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; _} -> + | { 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 + | 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' + 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) = + let is_application_of label (label', expr) = match expr with - | Some {exp_loc = {Location. loc_ghost; loc_start; loc_end}; _} -> + | Some { exp_loc = { Location.loc_ghost; loc_start; loc_end }; _ } -> label = label' - && (Btype.prefixed_label_name label <> prefix) - && not loc_ghost + && Btype.prefixed_label_name label <> prefix + && (not loc_ghost) && not (loc_start = loc_end) | None -> false in - List.filter_map ~f:(fun (label, ty) -> + 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], _) + 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 + 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 - ) + 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)) :: _ + 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. @@ -801,9 +842,10 @@ let application_context ~prefix path = 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; - } + `Application + { argument_type = pr earg.exp_type; + labels = List.map ~f:(fun (lbl, ty) -> (lbl, pr ty)) labels + } | _ -> `Unknown in - !target_type, context + (!target_type, context) diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli index 8cc348526d..8172c5da16 100644 --- a/src/analysis/completion.mli +++ b/src/analysis/completion.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -38,35 +38,37 @@ type raw_info = | `String of string | `Type_declaration of Ident.t * Types.type_declaration | `Type_scheme of Types.type_expr - | `Variant of string * Types.type_expr option - ] + | `Variant of string * Types.type_expr option ] -val raw_info_printer : raw_info -> +val raw_info_printer : + raw_info -> [ `String of string | `Print of Extend_protocol.Reader.outcometree - | `Concat of string * 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 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 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 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 ] +val application_context : + prefix:Asttypes.label -> + Mbrowse.t -> + Types.type_expr option + * [> `Application of Compl.application_context | `Unknown ] diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index 39bf5f5f6c..a7bb037662 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -1,7 +1,7 @@ open Std open Typedtree -let {Logger. log} = Logger.for_section "construct" +let { Logger.log } = Logger.for_section "construct" type values_scope = Null | Local type what = Modtype | Mod @@ -13,8 +13,7 @@ exception No_constraint let () = Location.register_error_of_exn (function - | Not_a_hole -> - Some (Location.error "Construct only works on holes.") + | 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) @@ -22,11 +21,11 @@ let () = 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 - ) + 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 @@ -34,31 +33,30 @@ module Util = struct let predef_types = let tbl = Hashtbl.create 14 in let () = - let constant c = - Ast_helper.Exp.constant c - in + 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 "false" ; - 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 "()") - ] + 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 "false"); + (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 @@ -73,7 +71,7 @@ module Util = struct let var_of_id id = Location.mknoloc @@ Ident.name id let type_to_string t = - Printtyp.type_expr (Format.str_formatter) t; + Printtyp.type_expr Format.str_formatter t; Format.flush_str_formatter () let unifiable env type_expr type_expected = @@ -81,7 +79,7 @@ module Util = struct try Ctype.unify env type_expected type_expr |> ignore; Some snap - with Ctype.Unify _ -> + with Ctype.Unify _ -> (* Unification failure *) Btype.backtrack snap; None @@ -89,19 +87,22 @@ module Util = struct let typeable env exp type_expected = let snap = Btype.snapshot () in let typeable = - match Typecore.type_expect env exp (Typecore.mk_expected type_expected) with + match + Typecore.type_expect env exp (Typecore.mk_expected type_expected) + with | (_ : Typedtree.expression) -> true | exception _ -> false in if not typeable then log ~title:"constructor" "%a does not have the expected type %a" - Logger.fmt (fun fmt -> Printast.expression 0 fmt exp) - Logger.fmt (fun fmt -> Printtyp.type_expr fmt type_expected); + Logger.fmt + (fun fmt -> Printast.expression 0 fmt exp) + Logger.fmt + (fun fmt -> Printtyp.type_expr fmt type_expected); Btype.backtrack snap; typeable - let is_in_stdlib path = - Path.head path |> Ident.name = "Stdlib" + 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] *) @@ -117,30 +118,31 @@ module Util = struct 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 -> begin + match type_expr.desc with + | Tarrow (arg_label, _, te, _) -> check_type te (arg_label :: params) | _ -> None - end + end in (* TODO we should probably sort the results better *) - match is_in_stdlib path, check_type value_description.val_type [] with + 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. *) + 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 - + 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 *) @@ -151,27 +153,23 @@ module Util = struct 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. - *) + [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)) + 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)) @@ -179,16 +177,16 @@ module Util = struct values in [l1] and [l2] *) let panache2 l1 l2 = let rec aux acc l1 l2 = - match l1, l2 with + 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 + | 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 + 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 @@ -199,16 +197,14 @@ module Gen = struct 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) + 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 + let open Ast_helper in + function | Mty_ident path -> begin try let m = Env.find_modtype path env in @@ -218,27 +214,30 @@ module Gen = struct with Not_found -> let name = Ident.name (Path.head path) in raise (Modtype_not_found (Modtype, name)) - end + 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 + 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_) + 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 + | 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 + with Not_found -> + let name = Ident.name (Path.head path) in + raise (Modtype_not_found (Mod, name)) + end | Mty_for_hole -> Mod.hole () + and structure_item env = let open Ast_helper in function @@ -247,22 +246,23 @@ module Gen = struct 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 + 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] + 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) + 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 + 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, _, _) -> @@ -270,20 +270,27 @@ module Gen = struct 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] + 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 + 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 + 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 @@ -291,17 +298,16 @@ module Gen = struct 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 *) + 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 *) + else (* else we return a hole *) [ Ast_helper.Exp.hole () ] in let arrow_rhs env typ = @@ -321,63 +327,65 @@ module Gen = struct try let i = Hashtbl.find idents_table n + 1 in make_i n i - with Not_found -> + 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 + 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 + (* 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 + (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))); + (List.map constrs ~f:(fun c -> c.Types.cstr_name))); (* [make_constr] builds the PAST repr of a type constructor applied - to holes *) + 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.maybe_prefix env - ~env_check:Env.find_constructor_by_name - path cstr_descr.cstr_name + Util.maybe_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 + let exps = + List.map args_combinations ~f:(function | [] -> None - | [e] -> Some e + | [ e ] -> Some e | l -> Some (Ast_helper.Exp.tuple l)) in Btype.backtrack snap; - List.filter_map exps - ~f:(fun exp -> + 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. + See Test 6.1b in c-simple.t for an example. - We therefore check that constructed expressions - can be typed. *) - if Util.typeable env exp type_expr - then Some exp else ( + We therefore check that constructed expressions + can be typed. *) + if Util.typeable env exp type_expr then Some exp + else ( log ~title:"constructor" "%s's type is not unifiable with %a" - cstr_descr.Types.cstr_name - Logger.fmt (fun fmt -> Printtyp.type_expr fmt type_expr); + cstr_descr.Types.cstr_name Logger.fmt (fun fmt -> + Printtyp.type_expr fmt type_expr); None)) | None -> [] in @@ -391,10 +399,10 @@ module Gen = struct 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 + ~f:(fun (_lbl, row_field) -> + match row_field_repr row_field with + | Rpresent _ | Reither (true, [], _) | Reither (false, [ _ ], _) -> + true | _ -> false) (row_fields row_desc) (* [row_fields] are ordered inversly to a source code declaration. @@ -405,95 +413,90 @@ module Gen = struct | [] -> 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) -> + (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 - |> List.rev + | _ -> [ None ]) + |> List.map ~f:(fun e -> Ast_helper.Exp.variant lbl e)) + |> List.flatten |> List.rev 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.maybe_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) + (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.maybe_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) + |> 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. *) + - 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, _) -> + 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 -> + | 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, _) -> - begin try + | Tconstr (path, _params, _) -> begin + try (* If this is a "basic" type we propose a default value *) [ Hashtbl.find Util.predef_types path ] - with Not_found -> + 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 + | Type_abstract | Type_open -> []) + end | Tarrow (label, tyleft, tyright, _) -> let argument, name = make_arg env label tyleft in - let value_description = { - val_type = tyleft; + 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 ()); + 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 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 + let choices = + List.map types ~f:(exp_or_hole env) |> Util.combinations in - List.map choices ~f:Ast_helper.Exp.tuple + 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 @@ -509,7 +512,8 @@ module Gen = struct [ ast ] with Typemod.Error _ -> let name = Ident.name (Path.head path) in - raise (Modtype_not_found (Modtype, name)) end + raise (Modtype_not_found (Modtype, name)) + end | Tobject (fields, _) -> let rec aux acc fields = match get_desc fields with @@ -517,22 +521,24 @@ module Gen = struct | Tvar _ | Tunivar _ -> acc | Tfield ("*dummy method*", _, _, fields) -> aux acc fields | Tfield (name, _, type_expr, fields) -> - let exprs = exp_or_hole env type_expr + 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) + 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 + 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) + 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 = @@ -544,43 +550,36 @@ module Gen = struct List.append constructed_from_type matching_values end -let needs_parentheses e = match e.Parsetree.pexp_desc with - | Pexp_fun _ - | Pexp_lazy _ - | Pexp_apply _ +let needs_parentheses e = + match e.Parsetree.pexp_desc with + | Pexp_fun _ | Pexp_lazy _ | Pexp_apply _ | Pexp_variant (_, Some _) - | Pexp_construct (_, Some _) - -> true + | Pexp_construct (_, Some _) -> true | _ -> false let to_string_with_parentheses exp = - let f : _ format6 = - if needs_parentheses exp then "(%a)" - else "%a" - in + let f : _ format6 = if needs_parentheses exp then "(%a)" else "%a" in Format.asprintf f Pprintast.expression exp let node ?(depth = 1) ~(config : Mconfig.t) ~keywords ~values_scope node = - Warnings.with_state config.ocaml.warnings - (fun () -> - 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. - - It is ok to raise here, since Warnings.with_state handles it. *) - raise No_constraint - | _ -> - (* As above, it is ok to raise here. *) - raise Not_a_hole) + Warnings.with_state config.ocaml.warnings (fun () -> + 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. + + It is ok to raise here, since Warnings.with_state handles it. *) + raise No_constraint + | _ -> + (* As above, it is ok to raise here. *) + raise Not_a_hole) diff --git a/src/analysis/construct.mli b/src/analysis/construct.mli index 668e186851..68d0e8b9e9 100644 --- a/src/analysis/construct.mli +++ b/src/analysis/construct.mli @@ -3,10 +3,10 @@ exception Not_a_hole type values_scope = Null | Local -val node - : ?depth : int - -> config : Mconfig.t - -> keywords : string list - -> values_scope : values_scope - -> Browse_raw.node - -> string list +val node : + ?depth:int -> + config:Mconfig.t -> + keywords:string list -> + values_scope:values_scope -> + Browse_raw.node -> + string list diff --git a/src/analysis/context.ml b/src/analysis/context.ml index 7fba149868..07551066c9 100644 --- a/src/analysis/context.ml +++ b/src/analysis/context.ml @@ -1,40 +1,40 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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" +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). *) + disambiguated constructors we actually directly look for the type + path (cf. #486, #794). *) | Expr | Label of Types.label_description (* Similar to constructors. *) | Module_path @@ -56,60 +56,48 @@ let to_string = function | 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 - = +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 end_offset = loc.loc_end.pos_cnum in let cstr_name_size = (* FIXME: this is britle, but lids don't have precise enough location information to handle these cases correctly. *) let name_lenght = String.length name in - if Pprintast.needs_parens name then - name_lenght + 2 - else - name_lenght + if Pprintast.needs_parens name then name_lenght + 2 else name_lenght in let constr_pos = - { loc.loc_end - with pos_cnum = end_offset - cstr_name_size } + { 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); + 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 -> + | 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. *) + 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) -> + && 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. *) + itself. *) Some (Constructor (cd, lid_loc.loc)) | Tpat_construct _ -> Some Module_path - | _ -> - Some Patt + | _ -> 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 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 @@ -124,25 +112,20 @@ let inspect_expression ~cursor ~lid e : t = 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 + else if cursor_on_longident_end ~cursor ~lid_loc name then Expr + else Module_path | Texp_constant _ -> Constant - | _ -> - Expr + | _ -> 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 - )); + (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; + log ~title:"inspect_context" "no enclosing around: %a" Lexing.print_position + cursor; Some Unknown - | enclosings -> + | enclosings -> ( let open Browse_raw in let node = Browse_tree.of_browse enclosings in log ~title:"inspect_context" "current enclosing node is: %s" @@ -153,17 +136,14 @@ let inspect_browse_tree ~cursor lid browse : t option = | Type_declaration _ | Extension_constructor _ | Module_binding_name _ - | Module_declaration_name _ -> - None - | Module_expr _ - | Open_description _ -> Some Module_path + | Module_declaration_name _ -> None + | Module_expr _ | Open_description _ -> Some Module_path | Module_type _ -> Some Module_type | Core_type { ctyp_desc = Ttyp_package _; _ } -> Some Module_type | Core_type _ -> Some Type - | Record_field (_, lbl, _) when (Longident.last lid) = lbl.lbl_name -> + | 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 + | _ -> Some Unknown) diff --git a/src/analysis/context.mli b/src/analysis/context.mli index 6884f8d325..d6707abb15 100644 --- a/src/analysis/context.mli +++ b/src/analysis/context.mli @@ -1,36 +1,36 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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). *) + disambiguated constructors we actually directly look for the type + path (cf. #486, #794). *) | Expr | Label of Types.label_description (* Similar to constructors. *) | Module_path diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index d7e34f60f5..01c2d8e787 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -35,78 +35,75 @@ exception Nothing_to_do exception Ill_typed exception Wrong_parent of string -let {Logger. log} = Logger.for_section "destruct" +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)) + | 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) + | 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 ] + [ 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 ] + [ zero; n ] let string_ env ty = let empty = - Tast_helper.Pat.constant env ty ( - Asttypes.Const_string ("", Location.none, None) - ) + Tast_helper.Pat.constant env ty + (Asttypes.Const_string ("", Location.none, None)) in let s = Patterns.omega in - [ empty ; s ] + [ 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_ ; - ] + 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 placeholder = Ast_helper.Exp.hole () -let rec gen_patterns ?(recurse=true) env type_expr = +let rec gen_patterns ?(recurse = true) env type_expr = let open Types in log ~title:"gen_patterns" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt "Generating patterns for type %a" - Printtyp.type_expr type_expr); + Format.fprintf fmt "Generating patterns for type %a" Printtyp.type_expr + type_expr); 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") + | 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 + | 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) - ) + 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, _) -> @@ -120,191 +117,194 @@ let rec gen_patterns ?(recurse=true) env type_expr = let snap = Btype.snapshot () in let res = try - ignore ( - Ctype.unify_gadt ~equations_level:0 - ~allow_recursive:true (* really? *) - (ref env) type_expr typ - ); + 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 ; + 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 + 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 + 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)) + 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)) | _, Reither (_, l, _) -> - let popt = match l with + let popt = + match l with | [] -> None - | _ :: _ -> Some Patterns.omega + | _ :: _ -> Some Patterns.omega in Some (Tast_helper.Pat.variant env type_expr lbl popt (ref row_desc)) - | _, _ -> - log ~title:"gen_patterns" "Absent"; None - ) + | _, _ -> + log ~title:"gen_patterns" "Absent"; + None) | _ -> let fmt, to_string = Format.to_string () in - Printtyp.type_expr fmt type_expr ; + 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 -> + | 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 -> + | 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 + | 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]. *) - -> + (* 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 + 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 + | [] -> 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 + ( m, + match Types.get_desc typ with | Tarrow (_, te, _, _) -> te - | _ -> assert false) - | _ -> assert false) + | 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)) - | _ -> - (* We were not in a match *) - let s = Mbrowse.print_node () parent in - raise (Not_allowed s) + raise (Not_allowed s)) let collect_every_pattern_for_expression parent = let patterns = - Mbrowse.fold_node (fun env node acc -> - match node with - | Pattern _ -> (* Not expected here *) raise Nothing_to_do - | Case _ -> - Mbrowse.fold_node (fun _env node acc -> - match node with - | Pattern p -> - let ill_typed_pred = Typedtree.{ 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 - else begin - match Typedtree.classify_pattern p with - | Value -> (p : Typedtree.pattern) :: acc - | Computation -> - begin - match Typedtree.split_pattern p with - | Some p, _ -> (p : Typedtree.pattern) :: acc - | None, _ -> acc + Mbrowse.fold_node + (fun env node acc -> + match node with + | Pattern _ -> (* Not expected here *) raise Nothing_to_do + | Case _ -> + Mbrowse.fold_node + (fun _env node acc -> + match node with + | Pattern p -> + let ill_typed_pred = + Typedtree. + { 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 + else begin + match Typedtree.classify_pattern p with + | Value -> (p : Typedtree.pattern) :: acc + | Computation -> begin + match Typedtree.split_pattern p with + | Some p, _ -> (p : Typedtree.pattern) :: acc + | None, _ -> acc + end end - end - | _ -> acc - ) env node acc - | _ -> acc - ) Env.empty parent [] + | _ -> 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 - 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 + (loc, patterns) let rec get_every_pattern = function | [] -> assert false - | parent :: parents -> + | parent :: parents -> ( match parent with - | Case _ - | Pattern _ -> + | 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 { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _); _ } + when Ident.name id = "*type-error*" -> raise Ill_typed | Expression _ -> (* We are on the right node *) collect_every_pattern_for_expression parent | _ -> (* We were not in a match *) let s = Mbrowse.print_node () parent in - raise (Not_allowed s) + 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 + | Tpat_alias (p, _, _) -> destructible p | _ -> false - let is_package ty = match ty.Types.desc with | Types.Tpackage _ -> true @@ -313,77 +313,67 @@ let is_package ty = let filter_attr = let default = Ast_mapper.default_mapper in let keep attr = - let ({Location.txt;_},_) = Ast_helper.Attr.as_tuple attr in + 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} + { default with Ast_mapper.attributes } -let filter_expr_attr expr = - filter_attr.Ast_mapper.expr filter_attr expr +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 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) } + 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_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) + 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_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) } + 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 rec qualify_constructors ~unmangling_tables f pat = let open Typedtree in let qualify_constructors = qualify_constructors ~unmangling_tables in let pat_desc = @@ -393,19 +383,15 @@ let rec qualify_constructors ~unmangling_tables f pat = | Tpat_record (labels, closed) -> let labels = let open Longident in - List.map labels - ~f:(fun ((Location.{ txt ; _ } as lid), lbl_des, pat) -> + 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 - ) + | 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 @@ -423,22 +409,25 @@ let rec qualify_constructors ~unmangling_tables f pat = 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 + 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 + 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 @@ -450,33 +439,27 @@ let rec qualify_constructors ~unmangling_tables f pat = | Tpat_lazy p -> Tpat_lazy (qualify_constructors f p) | desc -> desc in - { pat with pat_desc = pat_desc } + { pat with pat_desc } let find_branch patterns sub = let rec is_sub_patt patt ~sub = - if patt == sub then true else + 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 -> + | 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 -> + | 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 + | 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 :: after when is_sub_patt p ~sub -> (before, after, p) | p :: ps -> aux (p :: before) ps in aux [] patterns @@ -485,45 +468,47 @@ let find_branch patterns sub = reconstructed with the label. ie: [{a; b}] with destruction on [a] becomes [{a = destruct_result; b}]. *) let find_field_name_for_punned_field patt = function - | Pattern {pat_desc = Tpat_record (fields, _); _} :: _ -> - List.find_opt ~f:(fun (_, _, opat) -> + | Pattern { pat_desc = Tpat_record (fields, _); _ } :: _ -> + List.find_opt + ~f:(fun (_, _, opat) -> let ppat_loc = patt.Typedtree.pat_loc and opat_loc = opat.Typedtree.pat_loc in - Int.equal (Location_aux.compare ppat_loc opat_loc) 0 - ) fields |> Option.map ~f:(fun (_, label, _) -> label) + Int.equal (Location_aux.compare ppat_loc opat_loc) 0) + fields + |> Option.map ~f:(fun (_, label, _) -> label) | _ -> None let print_pretty ?punned_field config source subject = let result = Mreader.print_pretty config source subject in match punned_field with | None -> result - | Some label -> - label.Types.lbl_name ^ " = " ^ result + | Some label -> label.Types.lbl_name ^ " = " ^ result let need_recover_labeled_args = function - | Parsetree.Pexp_construct ({loc; txt = Longident.Lident ctor}, Some e) -> + | Parsetree.Pexp_construct ({ loc; txt = Longident.Lident ctor }, Some e) -> (* If the internal construction is ghosted, then the expression must be re-labelled. *) if String.equal "Some" ctor && loc.loc_ghost then Some e else None | _ -> None -let remove_non_applied_optional_args (Parsetree.{ pexp_desc; _} as base_expr) = +let remove_non_applied_optional_args (Parsetree.{ pexp_desc; _ } as base_expr) = (* Fix the behaviour described here https://github.com/ocaml/merlin/issues/1770 *) match pexp_desc with | Parsetree.Pexp_apply (expr, args) -> - let args = List.concat_map ~f:(fun (label, (expr : Parsetree.expression)) -> - match label, expr.pexp_loc.loc_ghost, expr.pexp_desc with - | Asttypes.Optional _, true, - Pexp_construct ({ txt = Longident.Lident "None"; _ }, _) -> - [] - | Asttypes.Optional str, false, exp_desc -> - (match need_recover_labeled_args exp_desc with - | Some e -> [(Asttypes.Labelled str, e)] - | None -> [(label, expr)] - ) - | _ -> [(label, expr)] - ) args + let args = + List.concat_map + ~f:(fun (label, (expr : Parsetree.expression)) -> + match (label, expr.pexp_loc.loc_ghost, expr.pexp_desc) with + | ( Asttypes.Optional _, + true, + Pexp_construct ({ txt = Longident.Lident "None"; _ }, _) ) -> [] + | Asttypes.Optional str, false, exp_desc -> ( + match need_recover_labeled_args exp_desc with + | Some e -> [ (Asttypes.Labelled str, e) ] + | None -> [ (label, expr) ]) + | _ -> [ (label, expr) ]) + args in let pexp_desc = Parsetree.Pexp_apply (expr, args) in { base_expr with pexp_desc } @@ -536,54 +521,56 @@ let destruct_expression loc config source parents expr = |> remove_non_applied_optional_args in let () = - log ~title:"node_expression" "%a" - Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp) + log ~title:"node_expression" "%a" Logger.fmt (fun fmt -> + Printast.expression 0 fmt pexp) in 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 + (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 + 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 - + (loc, str) let refine_partial_match last_case_loc config source 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 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 = Location.{ last_case_loc with loc_start = last_case_loc.loc_end } in let str = Mreader.print_pretty config source (Pretty_case_list cases) in - loc, str + (loc, str) let filter_new_branches new_branches patterns = let unused = Parmatch.return_unused patterns in 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)) + 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)) let refine_current_pattern patt config source parents generated_pattern = let punned_field = find_field_name_for_punned_field patt parents in let ppat = filter_pat_attr (Untypeast.untype_pattern generated_pattern) in let str = print_pretty ?punned_field config source (Pretty_pattern ppat) in - patt.Typedtree.pat_loc, str + (patt.Typedtree.pat_loc, str) let refine_and_generate_branches patt config source (patterns : Typedtree.pattern list) sub_patterns = @@ -595,81 +582,72 @@ let refine_and_generate_branches patt config source match filter_new_branches new_branches patterns 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) + 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 + (top_patt.Typedtree.pat_loc, str) -let refine_complete_match - (type a) (patt: a Typedtree.general_pattern) - config source parents patterns = +let refine_complete_match (type a) (patt : a Typedtree.general_pattern) config + source parents patterns = match Typedtree.classify_pattern patt with - | Computation -> raise (Not_allowed ("computation pattern")) + | Computation -> raise (Not_allowed "computation pattern") | Value -> - let _: Typedtree.value Typedtree.general_pattern = patt in + let _ : Typedtree.value Typedtree.general_pattern = patt in if not (destructible patt) then raise Nothing_to_do else let ty = patt.Typedtree.pat_type in - begin match gen_patterns patt.Typedtree.pat_env ty with - | [] -> assert false - | [more_precise_pattern] -> - (* If only one pattern is generated, then we're only refining the - current pattern, not generating new branches. *) - refine_current_pattern patt config source parents more_precise_pattern - | sub_patterns -> - (* If more than one pattern is generated, then we're generating new - branches. *) - refine_and_generate_branches patt config source patterns sub_patterns - end - -let destruct_pattern - (type a) (patt: a Typedtree.general_pattern) - config source parents = + begin + match gen_patterns patt.Typedtree.pat_env ty with + | [] -> assert false + | [ more_precise_pattern ] -> + (* If only one pattern is generated, then we're only refining the + current pattern, not generating new branches. *) + refine_current_pattern patt config source parents more_precise_pattern + | sub_patterns -> + (* If more than one pattern is generated, then we're generating new + branches. *) + refine_and_generate_branches patt config source patterns sub_patterns + end + +let destruct_pattern (type a) (patt : a Typedtree.general_pattern) config source + parents = let last_case_loc, patterns = get_every_pattern parents in (* Printf.eprintf "tot %d o%!"(List.length patterns); *) - let () = 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 () = + 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))) in 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 + Typecore.partial_pred ~lev:Btype.generic_level m.Typedtree.exp_env e_typ in match Parmatch.complete_partial ~pred pss with | [] -> (* The match is already complete, we try to refine it *) refine_complete_match patt config source parents patterns - | patterns -> - refine_partial_match last_case_loc config source patterns + | patterns -> refine_partial_match last_case_loc config source patterns let rec destruct_record config source selected_node = function - | Expression { exp_desc = Texp_field _; _ } as parent :: rest -> + | (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)) + | Expression e :: rest -> node config source (Expression e) rest + | _ -> raise (Not_allowed (string_of_node selected_node)) and node config source selected_node parents = let loc = Mbrowse.node_loc selected_node in match selected_node with | Record_field (`Expression _, _, _) -> destruct_record config source selected_node parents - | Expression expr -> - destruct_expression loc config source parents expr - | Pattern patt -> - destruct_pattern patt config source parents - | node -> - raise (Not_allowed (string_of_node node)) + | Expression expr -> destruct_expression loc config source parents expr + | Pattern patt -> destruct_pattern patt config source parents + | node -> raise (Not_allowed (string_of_node node)) diff --git a/src/analysis/destruct.mli b/src/analysis/destruct.mli index c1958ffd3c..f7f22df02b 100644 --- a/src/analysis/destruct.mli +++ b/src/analysis/destruct.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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: @@ -76,10 +76,13 @@ 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 node : + Mconfig.t -> + Msource.t -> + Browse_raw.node -> + Browse_raw.node list -> + Location.t * string val log : 'a Logger.printf diff --git a/src/analysis/expansion.ml b/src/analysis/expansion.ml index 05b9056761..2c1cc78246 100644 --- a/src/analysis/expansion.ml +++ b/src/analysis/expansion.ml @@ -9,10 +9,14 @@ let rec explore_node lident env = in Env.fold_modules add_module (Some lident) env [] -let explore ?(global_modules=[]) 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) + fun name -> + Hashtbl.mem tbl name + || + (Hashtbl.add tbl name (); + false) in let add_module l name = if seen name then l @@ -32,20 +36,17 @@ let explore ?(global_modules=[]) env = 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 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) + 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 + 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 *) @@ -55,30 +56,33 @@ let optimal_string_prefix_alignment key cutoff = (* 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; + v1.(0) <- i + 1; - let min = ref (i+1) in + 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); + 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) + 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); + Array.blit v1 0 v0 0 (String.length key + 1) done; let idx = String.length key in - min v1.(idx-1) v1.(idx) + min v1.(idx - 1) v1.(idx) with Exit -> cutoff + 1 let spell_index s1 = - let cutoff = match String.length s1 with + let cutoff = + match String.length s1 with | 0 -> 0 | 1 -> 0 | 2 -> 0 @@ -86,7 +90,7 @@ let spell_index s1 = | _ -> 2 in let f = optimal_string_prefix_alignment s1 cutoff in - fun s2 -> (s1 = "" || s2 = "" || (s1.[0] = s2.[0] && (f s2 <= cutoff))) + fun s2 -> s1 = "" || s2 = "" || (s1.[0] = s2.[0] && f s2 <= cutoff) let spell_match index str = index str @@ -98,15 +102,13 @@ let filter path 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 + 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 -> + | 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 @@ -115,9 +117,10 @@ 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 + let lident, last = + match lident with + | Ldot (l, id) -> (l, id) + | Lident id -> (Lident "", id) | Lapply _ -> assert false in let rec components acc = function @@ -126,11 +129,12 @@ let get_lidents ts path = | Lapply _ -> assert false | Ldot (l, id) -> components (id :: acc) l in - let lidents = match components [] lident with - | [] -> [None] + 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 + (lidents, last) diff --git a/src/analysis/inlay_hints.ml b/src/analysis/inlay_hints.ml index e07287f9b5..febfc0e0e0 100644 --- a/src/analysis/inlay_hints.ml +++ b/src/analysis/inlay_hints.ml @@ -1,44 +1,35 @@ open Std -let {Logger.log} = Logger.for_section "inlay-hints" +let { Logger.log } = Logger.for_section "inlay-hints" module Iterator = Ocaml_typing.Tast_iterator -let is_ghost_location avoid_ghost loc = - loc.Location.loc_ghost && avoid_ghost +let is_ghost_location avoid_ghost loc = loc.Location.loc_ghost && avoid_ghost -let pattern_has_constraint (type a) (pattern: a Typedtree.general_pattern) = - List.exists ~f:(fun (extra, _, _) -> +let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) = + List.exists + ~f:(fun (extra, _, _) -> match extra with | Typedtree.Tpat_constraint _ -> true | Typedtree.Tpat_type (_, _) | Typedtree.Tpat_open (_, _, _) - | Typedtree.Tpat_unpack -> false - ) pattern.pat_extra - -let structure_iterator - hint_let_binding - hint_pattern_binding - avoid_ghost_location - typedtree - range - callback = + | Typedtree.Tpat_unpack -> false) + pattern.pat_extra +let structure_iterator hint_let_binding hint_pattern_binding + avoid_ghost_location typedtree range callback = let case_iterator hint_lhs (iterator : Iterator.iterator) case = let () = log ~title:"case" "on case" in - let () = - if hint_lhs then - iterator.pat iterator case.Typedtree.c_lhs - in + let () = if hint_lhs then iterator.pat iterator case.Typedtree.c_lhs in let () = Option.iter ~f:(iterator.expr iterator) case.c_guard in iterator.expr iterator case.c_rhs in let value_binding_iterator hint_lhs (iterator : Iterator.iterator) vb = - let () = log ~title:"value_binding" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt "On value binding %a" - (Printtyped.pattern 0) vb.Typedtree.vb_pat - ) + let () = + log ~title:"value_binding" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "On value binding %a" (Printtyped.pattern 0) + vb.Typedtree.vb_pat) in if Location_aux.overlap_with_range range vb.Typedtree.vb_loc then if hint_lhs then @@ -50,10 +41,9 @@ let structure_iterator in let expr_iterator (iterator : Iterator.iterator) expr = - let () = log ~title:"expression" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt "On expression %a" - Printtyped.expression expr - ) + let () = + log ~title:"expression" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "On expression %a" Printtyped.expression expr) in if Location_aux.overlap_with_range range expr.Typedtree.exp_loc then let () = log ~title:"expression" "overlap" in @@ -64,7 +54,8 @@ let structure_iterator List.iter ~f:(value_binding_iterator hint_let_binding iterator) bindings - in iterator.expr iterator body + in + iterator.expr iterator body | Texp_letop { body; _ } -> let () = log ~title:"expression" "on let-op" in case_iterator hint_let_binding iterator body @@ -73,14 +64,14 @@ let structure_iterator let () = iterator.expr iterator expr in List.iter ~f:(case_iterator hint_pattern_binding iterator) cases | Texp_function - { arg_label = Optional _ - ; cases = + { arg_label = Optional _; + cases = [ { c_rhs = - { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ } - ; _ + { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ }; + _ } - ] - ; _ + ]; + _ } -> iterator.pat iterator vb_pat; iterator.expr iterator body @@ -96,8 +87,8 @@ let structure_iterator let () = log ~title:"structure_item" "overlap" in match item.str_desc with | Tstr_value (_, bindings) -> - List.iter ~f:(fun binding -> - expr_iterator iterator binding.Typedtree.vb_expr) + List.iter + ~f:(fun binding -> expr_iterator iterator binding.Typedtree.vb_expr) bindings | _ when is_ghost_location avoid_ghost_location item.str_loc -> (* Stop iterating when we see a ghost location to avoid @@ -106,15 +97,15 @@ let structure_iterator | _ -> Iterator.default_iterator.structure_item iterator item in - let pattern_iterator - (type a) iterator (pattern : a Typedtree.general_pattern) = - let () = log ~title:"pattern" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt "On pattern %a" - (Printtyped.pattern 0) pattern - ) + let pattern_iterator (type a) iterator (pattern : a Typedtree.general_pattern) + = + let () = + log ~title:"pattern" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt "On pattern %a" (Printtyped.pattern 0) pattern) in - if Location_aux.overlap_with_range range pattern.pat_loc - && not (pattern_has_constraint pattern) + if + Location_aux.overlap_with_range range pattern.pat_loc + && not (pattern_has_constraint pattern) then let () = log ~title:"pattern" "overlap" in let () = Iterator.default_iterator.pat iterator pattern in @@ -125,55 +116,48 @@ let structure_iterator | _ -> log ~title:"pattern" "not a var" in - let iterator = { - Ocaml_typing.Tast_iterator.default_iterator with - expr = expr_iterator; - structure_item = structure_item_iterator; - pat = pattern_iterator; - value_binding = value_binding_iterator true - } - in iterator.structure iterator typedtree + let iterator = + { Ocaml_typing.Tast_iterator.default_iterator with + expr = expr_iterator; + structure_item = structure_item_iterator; + pat = pattern_iterator; + value_binding = value_binding_iterator true + } + in + iterator.structure iterator typedtree type hint = Lexing.position * string let create_hint env typ loc = - let label = Printtyp.wrap_printing_env env (fun () -> - Format.asprintf "%a" Printtyp.type_scheme typ) + let label = + Printtyp.wrap_printing_env env (fun () -> + Format.asprintf "%a" Printtyp.type_scheme typ) in let position = loc.Location.loc_end in (position, label) -let of_structure - ~hint_let_binding - ~hint_pattern_binding - ~avoid_ghost_location - ~start - ~stop - structure = - let () = log ~title:"start" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt "Start on %s to %s with : let: %b, pat: %b, ghost: %b" - (Lexing.print_position () start) - (Lexing.print_position () stop) - hint_let_binding - hint_pattern_binding - avoid_ghost_location) +let of_structure ~hint_let_binding ~hint_pattern_binding ~avoid_ghost_location + ~start ~stop structure = + let () = + log ~title:"start" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt + "Start on %s to %s with : let: %b, pat: %b, ghost: %b" + (Lexing.print_position () start) + (Lexing.print_position () stop) + hint_let_binding hint_pattern_binding avoid_ghost_location) in let range = (start, stop) in let hints = ref [] in let () = - structure_iterator - hint_let_binding - hint_pattern_binding - avoid_ghost_location - structure - range - (fun env typ loc -> - let () = log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt -> - Format.fprintf fmt "%s - %a" - (Location_aux.print () loc) - (Printtyp.type_expr) typ) - in - let hint = create_hint env typ loc in - hints := hint :: !hints) + structure_iterator hint_let_binding hint_pattern_binding + avoid_ghost_location structure range (fun env typ loc -> + let () = + log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt -> + Format.fprintf fmt "%s - %a" + (Location_aux.print () loc) + Printtyp.type_expr typ) + in + let hint = create_hint env typ loc in + hints := hint :: !hints) in !hints diff --git a/src/analysis/inlay_hints.mli b/src/analysis/inlay_hints.mli index 2bf52c9536..575f8b7778 100644 --- a/src/analysis/inlay_hints.mli +++ b/src/analysis/inlay_hints.mli @@ -3,10 +3,10 @@ type hint = Lexing.position * string val of_structure : - hint_let_binding:bool - -> hint_pattern_binding:bool - -> avoid_ghost_location:bool - -> start:Lexing.position - -> stop:Lexing.position - -> Typedtree.structure - -> hint list + hint_let_binding:bool -> + hint_pattern_binding:bool -> + avoid_ghost_location:bool -> + start:Lexing.position -> + stop:Lexing.position -> + Typedtree.structure -> + hint list diff --git a/src/analysis/jump.ml b/src/analysis/jump.ml index 246b4f85c9..fd6ae9a4e5 100644 --- a/src/analysis/jump.ml +++ b/src/analysis/jump.ml @@ -1,31 +1,31 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + 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 + 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: + 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 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. + 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 @@ -37,19 +37,16 @@ type direction = Prev | Next 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 -> +let fun_pred all = (* For: `let f x y z = ...` jump to f For @@ -73,40 +70,34 @@ let fun_pred = fun all -> | node :: _ -> assert (is_node_fun node); node - | _ -> - assert false + | _ -> 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 module_type_pred = function | (Module_type_declaration _ as node) :: _ -> Some node | _ -> None let match_pred = function - | (Expression { exp_desc = Texp_match _ ; _ } as node) :: _ -> Some node + | (Expression { exp_desc = Texp_match _; _ } as node) :: _ -> Some node | _ -> None -;; let rec find_map ~f = function | [] -> None - | head :: tail -> + | head :: tail -> ( match f head with | Some v -> Some v - | None -> find_map tail ~f -;; + | None -> find_map tail ~f) exception No_matching_target exception No_predicate of string @@ -117,23 +108,20 @@ exception No_prev_match_case let rec find_node preds nodes = match nodes with | [] -> raise No_matching_target - | _ :: tail -> + | _ :: tail -> ( match find_map preds ~f:(fun pred -> pred nodes) with | Some node -> node - | None -> find_node preds tail -;; + | 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 -> + | 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 + else all | [] -> [] -;; let get_cases_from_match node = match node with @@ -145,88 +133,86 @@ let find_case_pos cases pos direction = match cases with | [] -> None | { c_lhs = { pat_loc; _ }; _ } :: tail -> - let check = - match direction with - | Prev -> - pos.Lexing.pos_cnum > pat_loc.loc_start.pos_cnum - | Next -> - pos.Lexing.pos_cnum < pat_loc.loc_start.pos_cnum - in - if check then - Some pat_loc.loc_start - else - find_pos pos tail direction + let check = + match direction with + | Prev -> pos.Lexing.pos_cnum > pat_loc.loc_start.pos_cnum + | Next -> pos.Lexing.pos_cnum < pat_loc.loc_start.pos_cnum + in + if check then Some pat_loc.loc_start else find_pos pos tail direction in let case = find_pos pos cases direction in match case with | Some location -> `Found location - | None -> - (match direction with + | None -> ( + match direction with | Next -> raise No_next_match_case | Prev -> raise No_prev_match_case) let get typed_tree pos target = let roots = Mbrowse.of_typedtree typed_tree in let enclosings = - match Mbrowse.enclosing pos [roots] with + 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; - "module-type", module_type_pred; - "match", match_pred; - "match-next-case", match_pred; - "match-prev-case", match_pred; - ] in + let all_preds = + [ ("fun", fun_pred); + ("let", let_pred); + ("module", module_pred); + ("module-type", module_type_pred); + ("match", match_pred); + ("match-next-case", match_pred); + ("match-prev-case", 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) - ) + 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" + if String.length target = 0 then `Error "Specify target" else let nodes = skip_non_moving pos enclosings in let node = find_node preds nodes in match target with | "match-next-case" -> find_case_pos (get_cases_from_match node) pos Next | "match-prev-case" -> - find_case_pos (List.rev (get_cases_from_match node)) pos Prev + find_case_pos (List.rev (get_cases_from_match node)) pos Prev | _ -> - let node_loc = Browse_raw.node_real_loc Location.none node in - `Found node_loc.Location.loc_start + let node_loc = Browse_raw.node_real_loc Location.none node in + `Found node_loc.Location.loc_start with - | No_predicate target -> - `Error ("No predicate for " ^ target) - | No_matching_target -> - `Error "No matching target" - | No_next_match_case -> - `Error "No next case found" - | No_prev_match_case -> - `Error "No previous case found" + | No_predicate target -> `Error ("No predicate for " ^ target) + | No_matching_target -> `Error "No matching target" + | No_next_match_case -> `Error "No next case found" + | No_prev_match_case -> `Error "No previous case found" 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 + 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) + 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 | [] -> [] + 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 @@ -239,29 +225,31 @@ let phrase typed_tree pos target = 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 + | 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 + 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/src/analysis/jump.mli b/src/analysis/jump.mli index f42a950e93..8c244f92ff 100644 --- a/src/analysis/jump.mli +++ b/src/analysis/jump.mli @@ -1,38 +1,40 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + 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 + 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: + 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 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. + 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 ] + string -> + [> `Error of string | `Found of Lexing.position ] val phrase : Mtyper.typedtree -> Std.Lexing.position -> - [< `Next | `Prev ] -> [> `End | `Logical of int * int | `Start ] + [< `Next | `Prev ] -> + [> `End | `Logical of int * int | `Start ] diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 44236c0df5..d81b17824c 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -1,42 +1,42 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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" +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 + | ML of string + | MLL of string + | MLI of string + | CMT of string | CMTI of string val ml : string -> t @@ -50,86 +50,85 @@ module File : sig val name : t -> string - val with_ext : ?src_suffix_pair:(string * string) -> 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 + | 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 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 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 + | [] | [ _ ] -> None | ext :: _ -> let ext = String.lowercase ext in - Some ( - match ext with + 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 - ) + | "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 + | ML s | MLL s -> MLI s | MLI s -> ML s - | CMT s -> CMTI s + | CMT s -> CMTI s | CMTI s -> CMT s let name = function - | ML name - | MLL name - | MLI name - | CMT name - | CMTI name -> name + | 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 + | 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 = + 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 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 + 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 + 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 + 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 + 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 + 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 + sprintf + "The documentation for '%s' originates in the current file, but no \ + cmt is available" + str_ident in `File_not_found msg end @@ -150,13 +149,13 @@ end = struct | `ML -> true | _ -> false - let src file = if !prioritize_impl then File.ml file else File.mli file + 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 + | Some (ML _) -> !prioritize_impl + | Some (MLI _) -> not !prioritize_impl | _ -> false end @@ -169,10 +168,7 @@ module File_switching : sig val source_digest : unit -> Digest.t option end = struct - type t = { - last_file_visited : string; - digest : Digest.t; - } + type t = { last_file_visited : string; digest : Digest.t } let last_file_visited t = t.last_file_visited let digest t = t.digest @@ -185,14 +181,13 @@ end = struct log ~title:"File_switching.move_to" "file: %s\ndigest: %s" file @@ Digest.to_hex digest; - state := Some { last_file_visited = file ; digest } + 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 @@ -212,11 +207,11 @@ module Utils = struct let fallback, ufallback = let alt = File.alternate file in let fallback = File.with_ext ?src_suffix_pair alt in - fallback, String.uncapitalize fallback + (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 + if Misc.exact_file_exists ~dirname ~basename then + Misc.canonicalize_filename (Filename.concat dirname basename) :: acc else acc in let try_dir acc dirname = @@ -227,23 +222,24 @@ module Utils = struct let acc = try_file dirname ufallback acc in let acc = try_file dirname fallback acc in acc - else - acc + else acc in acc in List.fold_left ~f:try_dir ~init:[] path - let find_all_matches ~config ?(with_fallback=false) file = + 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) + 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 = + 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 @@ -251,8 +247,7 @@ module Utils = struct let fallback = if with_fallback then Some (File.with_ext ~src_suffix_pair (File.alternate file)) - else - None + else None in let fname = File.with_ext ~src_suffix_pair file in try Some (Misc.find_in_path_uncap ?fallback path fname) @@ -260,14 +255,14 @@ module Utils = struct in try Some (List.find_map Mconfig.(config.merlin.suffixes) ~f:attempt_search) - with Not_found -> - None + with Not_found -> None let find_file ~config ?with_fallback (file : File.t) = - find_file_with_path ~config ?with_fallback file @@ - match file with - | ML _ | MLI _ | MLL _ -> Mconfig.source_path config - | CMT _ | CMTI _ -> Mconfig.build_path config + find_file_with_path ~config ?with_fallback file + @@ + match file with + | ML _ | MLI _ | MLL _ -> Mconfig.source_path config + | CMT _ | CMTI _ -> Mconfig.build_path config end let move_to filename cmt_infos = @@ -275,41 +270,39 @@ let move_to filename cmt_infos = (* [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) + 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 -> + 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:"." + 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) + 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 load_cmt ~config comp_unit ml_or_mli = Preferences.set ml_or_mli; - let file = - Preferences.build comp_unit - in + let file = Preferences.build comp_unit in match Utils.find_file ~config ~with_fallback:true file with | Some path -> - let cmt_infos = (Cmt_cache.read path).cmt_infos in - let source_file = cmt_infos.cmt_sourcefile in - let source_file = Option.value ~default:"*pack*" source_file in - move_to path cmt_infos; - Ok (source_file, cmt_infos) + let cmt_infos = (Cmt_cache.read path).cmt_infos in + let source_file = cmt_infos.cmt_sourcefile in + let source_file = Option.value ~default:"*pack*" source_file in + move_to path cmt_infos; + Ok (source_file, cmt_infos) | None -> Error () let scrape_alias ~env ~fallback_uid ~namespace path = @@ -317,11 +310,10 @@ let scrape_alias ~env ~fallback_uid ~namespace path = match namespace with | Shape.Sig_component_kind.Module -> let { Types.md_type; md_uid; _ } = Env.find_module path env in - md_type, md_uid - | Module_type -> - begin match Env.find_modtype path env with - | { Types.mtd_type = Some mtd_type; mtd_uid; _ } -> - mtd_type, mtd_uid + (md_type, md_uid) + | Module_type -> begin + match Env.find_modtype path env with + | { Types.mtd_type = Some mtd_type; mtd_uid; _ } -> (mtd_type, mtd_uid) | _ -> raise Not_found end | _ -> raise Not_found @@ -329,66 +321,66 @@ let scrape_alias ~env ~fallback_uid ~namespace path = let rec non_alias_declaration_uid ~fallback_uid path = match find_type_and_uid ~env ~namespace path with | Mty_alias path, fallback_uid -> - non_alias_declaration_uid ~fallback_uid path + non_alias_declaration_uid ~fallback_uid path | Mty_ident alias_path, fallback_uid when namespace = Shape.Sig_component_kind.Module_type -> - (* This case is necessary to traverse module type aliases *) - non_alias_declaration_uid ~fallback_uid alias_path + (* This case is necessary to traverse module type aliases *) + non_alias_declaration_uid ~fallback_uid alias_path | _, md_uid -> md_uid | exception Not_found -> fallback_uid in non_alias_declaration_uid ~fallback_uid path let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace = - let module Shape_reduce = - Shape.Make_reduce (struct - type env = Env.t - - let fuel = 10 - - let read_unit_shape ~unit_name = - log ~title:"read_unit_shape" "inspecting %s" unit_name; - match load_cmt ~config unit_name `ML with - | Ok (filename, cmt_infos) -> - move_to filename cmt_infos; - log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; - cmt_infos.cmt_impl_shape - | Error () -> - log ~title:"read_unit_shape" "failed to find %s" unit_name; - None - - let find_shape env id = Env.shape_of_path - ~namespace:Shape.Sig_component_kind.Module env (Pident id) - end) - in + let module Shape_reduce = Shape.Make_reduce (struct + type env = Env.t + + let fuel = 10 + + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + match load_cmt ~config unit_name `ML with + | Ok (filename, cmt_infos) -> + move_to filename cmt_infos; + log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; + cmt_infos.cmt_impl_shape + | Error () -> + log ~title:"read_unit_shape" "failed to find %s" unit_name; + None + + let find_shape env id = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env + (Pident id) + end) in let unalias fallback_uid = let uid = scrape_alias ~fallback_uid ~env ~namespace path in - log ~title:"uid_of_path" "Unaliasing uid: %a -> %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid) - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + log ~title:"uid_of_path" "Unaliasing uid: %a -> %a" Logger.fmt + (fun fmt -> Shape.Uid.print fmt fallback_uid) + Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); uid in match ml_or_mli with | `MLI -> unalias decl_uid - | `ML -> + | `ML -> ( let shape = Env.shape_of_path ~namespace env path in - log ~title:"shape_of_path" "initial: %a" - Logger.fmt (fun fmt -> Shape.print fmt shape); + 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); + log ~title:"shape_of_path" "reduced: %a" Logger.fmt (fun fmt -> + Shape.print fmt r); match r.uid with | Some uid -> uid | None -> log ~title:"shape_of_path" "No uid found; fallbacking to declaration uid"; - unalias decl_uid + unalias decl_uid) let from_uid ~config ~ml_or_mli uid loc path = let loc_of_comp_unit comp_unit = match load_cmt ~config comp_unit ml_or_mli with | Ok (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 + let loc = { Location.loc_start = pos; loc_end = pos; loc_ghost = true } in Some loc | _ -> None in @@ -396,13 +388,17 @@ let from_uid ~config ~ml_or_mli uid loc path = match uid with | Shape.Uid.Item { comp_unit; _ } -> let locopt = - let log_and_return msg = log ~title msg; None in + let log_and_return msg = + log ~title msg; + None + in let uid_to_loc_tbl = 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); Some (Env.get_uid_to_loc_tbl ()) - end else begin + end + else begin log ~title "Loading the cmt for unit %S" comp_unit; match load_cmt ~config comp_unit ml_or_mli with | Ok (_pos_fname, cmt) -> Some cmt.cmt_uid_to_loc @@ -410,31 +406,32 @@ let from_uid ~config ~ml_or_mli uid loc path = end in Option.bind uid_to_loc_tbl ~f:(fun tbl -> - log ~title "Looking for %a in the uid_to_loc table" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - 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_and_return "Uid not found in the table.") + log ~title "Looking for %a in the uid_to_loc table" Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + 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_and_return "Uid not found in the table.") in - begin match locopt with - | Some (uid, loc) -> `Found (Some uid, loc) - | None -> - log ~title "Fallbacking to lookup location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - `Found (Some uid, loc) - end - | Compilation_unit comp_unit -> begin - log ~title "Got the uid of a compilation unit: %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - match loc_of_comp_unit comp_unit with - | Some loc -> `Found (Some uid, loc) - | _ -> log ~title "Failed to load the CU's cmt"; - `Not_found (Path.name path, None) + match locopt with + | Some (uid, loc) -> `Found (Some uid, loc) + | None -> + log ~title "Fallbacking to lookup location: %a" Logger.fmt (fun fmt -> + Location.print_loc fmt loc); + `Found (Some uid, loc) end + | Compilation_unit comp_unit -> begin + log ~title "Got the uid of a compilation unit: %a" Logger.fmt (fun fmt -> + Shape.Uid.print fmt uid); + match loc_of_comp_unit comp_unit with + | Some loc -> `Found (Some uid, loc) + | _ -> + log ~title "Failed to load the CU's cmt"; + `Not_found (Path.name path, None) + end | Predef _ | Internal -> assert false let locate ~config ~env ~ml_or_mli decl_uid loc path ns = @@ -444,18 +441,18 @@ let locate ~config ~env ~ml_or_mli decl_uid loc path ns = let path_and_loc_of_cstr desc _ = let open Types in match desc.cstr_tag with - | Cstr_extension (path, _) -> path, desc.cstr_loc - | _ -> + | Cstr_extension (path, _) -> (path, desc.cstr_loc) + | _ -> ( match get_desc desc.cstr_res with - | Tconstr (path, _, _) -> path, desc.cstr_loc - | _ -> assert false + | 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 + (path, typ_decl.Types.type_loc) | _ -> assert false type find_source_result = @@ -465,7 +462,7 @@ type find_source_result = let find_source ~config loc = log ~title:"find_source" "attempt to find %S" - loc.Location.loc_start.Lexing.pos_fname ; + 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 = @@ -490,76 +487,74 @@ let find_source ~config loc = 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 + 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) + | 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" ; + "... 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 ; + "... 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 - ) + 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 + [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 + | (i1, _) :: (i2, _) :: _ when i1 = i2 -> Multiple_matches files | (_, s) :: _ -> Found s - | _ -> assert false + | _ -> assert false)) (* Well, that's just another hack. [find_source] doesn't like the "-o" option of the compiler. This hack handles @@ -569,36 +564,40 @@ let find_source ~config loc path = let result = match find_source ~config loc with | Found _ as result -> result - | failure -> + | 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 + 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 + | 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) + `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 t = + (* TODO: share with [Namespaced_path.Namespace.t] *) [ `Type | `Mod | `Modtype | `Vals | under_type ] type inferred = @@ -607,139 +606,125 @@ module Namespace = struct | `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 ] + | 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 - + 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 -> + 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 -> + (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 -> + (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 + (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 + (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) + 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" ; + 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) + 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); + Logger.fmt + (fun fmt -> Shape.Uid.print fmt decl_uid); Some x end let uid_from_longident ~config ~env nss ml_or_mli ident = let str_ident = try String.concat ~sep:"." (Longident.flatten ident) - with _-> "Not a flat longident" + with _ -> "Not a flat longident" 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 + if Utils.is_builtin_path path then `Builtin else let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace in `Uid (uid, loc, path) @@ -751,47 +736,43 @@ let from_longident ~config ~env nss ml_or_mli ident = let from_path ~config ~env ~namespace ml_or_mli path = File_switching.reset (); - if Utils.is_builtin_path path then - `Builtin + 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) -> + | Some (loc, uid, namespace) -> ( match locate ~config ~env ~ml_or_mli uid loc path namespace with - | `Not_found _ - | `File_not_found _ as err -> err - | `Found (uid, loc) -> + | (`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 + | `File_not_found _ as otherwise -> otherwise)) let infer_namespace ?namespaces ~pos lid browse is_label = match namespaces with | Some nss -> - if not is_label - then `Ok (nss :> Namespace.inferred list) + 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 ( + `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 + `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" ; + 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); + | 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 ] + `Ok [ `Labels ]) let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = File_switching.reset (); @@ -801,27 +782,30 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = let ident, is_label = Longident.keep_suffix lid in match infer_namespace ?namespaces ~pos lid browse is_label with | `Error e -> e - | `Ok nss -> + | `Ok nss -> ( log ~title:"from_string" - "looking for the source of '%s' (prioritizing %s files)" - path (match switch with `ML -> ".ml" | `MLI -> ".mli"); + "looking for the source of '%s' (prioritizing %s files)" path + (match switch with + | `ML -> ".ml" + | `MLI -> ".mli"); match from_longident ~config ~env nss switch ident with - | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err + | (`File_not_found _ | `Not_found _ | `Not_in_env _) as err -> err | `Builtin -> `Builtin path - | `Found (uid, loc) -> + | `Found (uid, loc) -> ( match find_source ~config loc path with | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise + | `File_not_found _ as otherwise -> otherwise)) in Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid +(* In a future release of OCaml the cmt's uid_to_loc table will contain + fragments of the typedtree that might be used to get the docstrings without + relying on this iteration *) + (** 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 *) -(* In a future release of OCaml the cmt's uid_to_loc table will contain - fragments of the typedtree that might be used to get the docstrings without - relying on this iteration *) let find_doc_attributes_in_typedtree ~config ~comp_unit uid = let exception Found_attributes of Typedtree.attributes in let test elt_uid attributes = @@ -829,131 +813,158 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = in let iterator = let first_item = ref true in - let uid_is_comp_unit = match uid with + 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_attributes [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_attributes [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) -> - let pat_var_iter ~f pat = - let rec aux pat = - let open Typedtree in - match pat.pat_desc with - | Tpat_var (id, _) -> f id - | Tpat_alias (pat, _, _) - | Tpat_variant (_, Some pat, _) - | Tpat_lazy pat - | Tpat_or (pat, _, _) -> - aux pat - | Tpat_tuple pats - | Tpat_construct (_, _, pats, _) - | Tpat_array pats -> - List.iter ~f:aux pats - | Tpat_record (pats, _) -> - List.iter ~f:(fun (_, _, pat) -> aux pat) pats - | _ -> () - in - aux pat - in - pat_var_iter vb_pat ~f:(fun id -> - try - let vd = Env.find_value (Pident id) env in - test vd.val_uid vb_attributes - with Not_found -> ()); - Tast_iterator.default_iterator.value_binding sub vb) - } + 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_attributes [ 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_attributes [ 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) -> + let pat_var_iter ~f pat = + let rec aux pat = + let open Typedtree in + match pat.pat_desc with + | Tpat_var (id, _) -> f id + | Tpat_alias (pat, _, _) + | Tpat_variant (_, Some pat, _) + | Tpat_lazy pat + | Tpat_or (pat, _, _) -> aux pat + | Tpat_tuple pats + | Tpat_construct (_, _, pats, _) + | Tpat_array pats -> List.iter ~f:aux pats + | Tpat_record (pats, _) -> + List.iter ~f:(fun (_, _, pat) -> aux pat) pats + | _ -> () + in + aux pat + in + pat_var_iter vb_pat ~f:(fun id -> + try + let vd = Env.find_value (Pident id) env in + test vd.val_uid vb_attributes + with Not_found -> ()); + Tast_iterator.default_iterator.value_binding sub vb) + } in let typedtree = log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; match load_cmt ~config 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 + 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) -> + 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) -> + | 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; + | _ -> () + end; `No_documentation with - | Found_attributes attrs -> - log ~title:"doc_from_uid" "Found attributes for this uid"; - 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 - begin match parse_attributes attrs with - | Some (doc, _) -> `Found (doc |> String.trim) - | None -> `No_documentation end - | Not_found -> `No_documentation + | Found_attributes attrs -> + log ~title:"doc_from_uid" "Found attributes for this uid"; + 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 + begin + match parse_attributes attrs with + | Some (doc, _) -> `Found (doc |> String.trim) + | None -> `No_documentation + end + | Not_found -> `No_documentation let doc_from_uid ~config ~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 find_doc_attributes_in_typedtree ~config ~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 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 loc + 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\n\ + \ compilation unit (%s)" Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid) + comp_unit; + match find_doc_attributes_in_typedtree ~config ~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 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 loc end let doc_from_comment_list ~local_defs ~buffer_comments 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. *) + 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 -> @@ -961,79 +972,79 @@ let doc_from_comment_list ~local_defs ~buffer_comments loc = buffer_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 + 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; + 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" - ); + Format.fprintf fmt " (%S, %a);\n" c Location.print_loc l); + Format.fprintf fmt "]\n"); let browse = Mbrowse.of_typedtree local_defs in - let (_, deepest_before) = - Mbrowse.(leaf_node @@ deepest_before loc.Location.loc_start [browse]) + let _, deepest_before = + Mbrowse.(leaf_node @@ deepest_before loc.Location.loc_start [ browse ]) in (* based on https://v2.ocaml.org/manual/doccomments.html#ss:label-comments: *) - let after_only = begin match deepest_before with - | Browse_raw.Constructor_declaration _ -> true - (* The remaining `true` cases are currently not reachable *) - | Label_declaration _ | Record_field _ | Row_field _ -> true - | _ -> false - end in - match - Ocamldoc.associate_comment ~after_only comments loc !last_location - with - | None, _ -> `No_documentation + let after_only = + begin + match deepest_before with + | Browse_raw.Constructor_declaration _ -> true + (* The remaining `true` cases are currently not reachable *) + | Label_declaration _ | Record_field _ | Row_field _ -> true + | _ -> false + end + in + match Ocamldoc.associate_comment ~after_only comments loc !last_location with + | None, _ -> `No_documentation | Some doc, _ -> `Found doc let get_doc ~config ~env ~local_defs ~comments ~pos = File_switching.reset (); fun path -> - let_ref last_location Location.none @@ fun () -> - let doc_from_uid_result = - 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 - doc_from_uid ~config ~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; - 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 - doc_from_uid ~config ~loc uid - | `At_origin -> - `Found_loc { Location.loc_start = pos; loc_end = pos; loc_ghost = true } - | `Missing_labels_namespace -> `No_documentation - | `Builtin _ -> `Builtin - | (`Not_in_env _ | `Not_found _ |`File_not_found _ ) - as otherwise -> otherwise - end - in - match doc_from_uid_result with - | `Found_doc doc -> `Found doc - | `Found_loc loc -> + let_ref last_location Location.none @@ fun () -> + let doc_from_uid_result = + 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 + doc_from_uid ~config ~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; + 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 + doc_from_uid ~config ~loc uid + | `At_origin -> + `Found_loc + { Location.loc_start = pos; loc_end = pos; loc_ghost = true } + | `Missing_labels_namespace -> `No_documentation + | `Builtin _ -> `Builtin + | (`Not_in_env _ | `Not_found _ | `File_not_found _) as otherwise -> + otherwise + end + in + match doc_from_uid_result with + | `Found_doc doc -> `Found doc + | `Found_loc loc -> doc_from_comment_list ~local_defs ~buffer_comments:comments loc - | `Builtin -> - begin match path with - | `User_input path -> `Builtin path - | `Completion_entry (_, path, _) -> `Builtin (Path.name path) + | `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 + | (`File_not_found _ | `Not_found _ | `No_documentation | `Not_in_env _) as + otherwise -> otherwise diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index 581d75c294..28b8f848b3 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -32,46 +32,45 @@ 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_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 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 ] +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/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 9d3b705e66..7c372f6548 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -6,11 +6,13 @@ module Path : sig val to_shortest_lid : env:Env.t -> ?name:string -> - env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t + 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 + | Env.Env_open (s, path) -> aux (path :: acc) s | s -> Option.map ~f:(aux acc) (Browse_misc.summary_prev s) |> Option.value ~default:acc @@ -28,43 +30,32 @@ end = struct let maybe_replace_name ?name lid = let open Longident in - Option.value_map name - ~default:lid - ~f:(fun name -> match lid with + 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 + 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) + 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 ^ ")" - ) + if name = "" || not (Oprint.parenthesized_ident name) then name + else if name.[0] = '*' || name.[String.length name - 1] = '*' then + "( " ^ name ^ " )" + else "(" ^ name ^ ")" let parse_identifier (config, source) pos = let path = Mreader.reconstruct_identifier config source pos in let path = Mreader_lexer.identifier_suffix path in - Logger.log - ~section:Type_enclosing.log_section - ~title:"reconstruct-identifier" + Logger.log ~section:Type_enclosing.log_section ~title:"reconstruct-identifier" "paths: [%s]" - (String.concat ~sep:";" (List.map path - ~f:(fun l -> l.Location.txt))); + (String.concat ~sep:";" (List.map path ~f:(fun l -> l.Location.txt))); path diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 9f789b4269..7fdab690e3 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -14,7 +14,9 @@ module Path : sig val to_shortest_lid : env:Env.t -> ?name:string -> - env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t + 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 @@ -26,4 +28,4 @@ val parenthesize_name : string -> string (** [parse_identifier] attempts to re-parse a longident so that we get the location of each of its components. *) val parse_identifier : - (Mconfig.t * Msource.t) -> Lexing.position -> string Location.loc list + Mconfig.t * Msource.t -> Lexing.position -> string Location.loc list diff --git a/src/analysis/namespaced_path.ml b/src/analysis/namespaced_path.ml index 2ade36f4c7..58f2a6cf44 100644 --- a/src/analysis/namespaced_path.ml +++ b/src/analysis/namespaced_path.ml @@ -1,8 +1,8 @@ open Std module Namespace = struct - type t = [ - | `Vals + type t = + [ `Vals | `Type | `Constr | `Mod @@ -10,8 +10,7 @@ module Namespace = struct | `Functor | `Labels | `Unknown - | `Apply - ] + | `Apply ] let to_tag_string = function | `Mod -> "" @@ -37,9 +36,7 @@ module Namespace = struct end module Id = struct - type t = - | Id of Ident.t - | String of string + type t = Id of Ident.t | String of string let name = function | Id id -> Ident.name id @@ -50,30 +47,25 @@ module Id = struct | String s -> s let equal mi1 mi2 = - match mi1, mi2 with + match (mi1, mi2) with | Id i1, Id i2 -> Ident.equal i1 i2 - | Id i, String s - | String s, Id i -> (Ident.name i) = s + | 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 +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" + | [] | 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 -> + 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) - ) + | 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 @@ -85,9 +77,7 @@ let of_path ~namespace p = | 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 + let acc = Applied_to (aux `Mod [] p2) :: acc in aux `Mod acc p1 in aux namespace [] p @@ -96,21 +86,18 @@ let head_exn = function | [] -> invalid_arg "head" | x :: _ -> x -let head x = - try Some (head_exn x) - with Invalid_argument _ -> None +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 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 + 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 @@ -120,13 +107,12 @@ 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 - ) + | elt -> elt) let empty = [] let rec subst_prefix ~old_prefix ~new_prefix p = - match old_prefix, p with + 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 diff --git a/src/analysis/namespaced_path.mli b/src/analysis/namespaced_path.mli index 4e4a75cec2..ede5b97761 100644 --- a/src/analysis/namespaced_path.mli +++ b/src/analysis/namespaced_path.mli @@ -1,6 +1,6 @@ module Namespace : sig - type t = [ - | `Vals + type t = + [ `Vals | `Type | `Constr | `Mod @@ -8,24 +8,21 @@ module Namespace : sig | `Functor | `Labels | `Unknown - | `Apply - ] + | `Apply ] val to_string : t -> string end module Id : sig - type t = private - | Id of Ident.t - | String of string + 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 +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 diff --git a/src/analysis/ocamldoc.ml b/src/analysis/ocamldoc.ml index 3383b4250d..0979c1e5c9 100644 --- a/src/analysis/ocamldoc.ml +++ b/src/analysis/ocamldoc.ml @@ -17,45 +17,44 @@ the location. *) let associate_comment ~after_only comments loc nextloc = let lstart = loc.Location.loc_start.Lexing.pos_lnum - and lend = loc.Location.loc_end.Lexing.pos_lnum in + 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 + 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 + | [] -> (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) + 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 + | None, comments -> (Some comment, comments) + | Some c, comments -> + (Some (String.concat "\n" [ comment; c ]), comments)) in aux comments diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml index ed179236ca..69468ceb1a 100644 --- a/src/analysis/outline.ml +++ b/src/analysis/outline.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -36,106 +36,111 @@ open Browse_raw open Browse_tree let id_of_patt = function - | { pat_desc = Tpat_var (id, _) ; _ } -> Some id + | { 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 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) + | 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:(Mconfig.Verbosity.Lvl 0) env ppf typ); + Type_utils.print_type_with_decl ~verbosity:(Mconfig.Verbosity.Lvl 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 -> + | 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) + 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 -> + | 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) + 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) + 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 (* ! *) - ) - | _ -> [] - ) + 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 } - ) + 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 } - + 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 = @@ -144,23 +149,22 @@ and get_class_elements node = 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 + 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 - ) + | _ -> None) | _ -> [] and get_mod_children node = @@ -168,17 +172,16 @@ and get_mod_children node = and remove_mod_indir node = match node.t_node with - | Module_expr _ - | Module_type _ -> + | 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 + | 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 @@ -188,7 +191,8 @@ let shape cursor nodes = (* A node is selected if: - part of the module language - or under the cursor *) - let selected = match node.t_node with + let selected = + match node.t_node with | Module_expr _ | Module_type_constraint _ | Structure _ @@ -202,15 +206,16 @@ let shape cursor nodes = | 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 + | _ -> + 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) - }] + 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/src/analysis/outline.mli b/src/analysis/outline.mli index 20ae50e535..cf1c047711 100644 --- a/src/analysis/outline.mli +++ b/src/analysis/outline.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index ee224c12d1..33d68cd7cf 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -2,34 +2,29 @@ open Std type t = Trie of (string * Longident.t * t list lazy_t) -module PathSet = Set.Make(Path) +module PathSet = Set.Make (Path) -type query = { - positive: PathSet.t; - pos_fun: int; - - negative: PathSet.t; - neg_fun: int; -} +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 - ) + set := PathSet.remove path !set) let rec normalize_path env path = match Env.find_type path env with | exception Not_found -> path - | decl -> + | 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 + | 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 + end + | _ -> path) let match_query env query t = let cost = ref 0 in @@ -39,57 +34,50 @@ let match_query env query t = 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 - ) - ) + 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 *) - + | 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 + 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 + 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) + 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; + { positive = PathSet.of_list positive; negative = PathSet.of_list negative; - neg_fun = !neg_fun; pos_fun = !pos_fun; + neg_fun = !neg_fun; + pos_fun = !pos_fun } let directories ~global_modules env = @@ -103,25 +91,27 @@ let directories ~global_modules env = in Env.fold_modules add_module (Some lident) env [] in - List.fold_left ~f:(fun l name -> + 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 []*) + | _ -> 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 -> + 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 + | None -> acc) + dir env acc in let rec recurse acc (Trie (_, dir, children)) = match diff --git a/src/analysis/ppx_expand.ml b/src/analysis/ppx_expand.ml index 2982ea78d5..2e04459642 100644 --- a/src/analysis/ppx_expand.ml +++ b/src/analysis/ppx_expand.ml @@ -8,7 +8,7 @@ let check_at_pos pos loc = Location_aux.compare_pos pos loc = 0 let check_extension_node pos (expression : Parsetree.expression) = match expression.pexp_desc with | Pexp_extension (loc, _) -> - if check_at_pos pos loc.loc then Some expression.pexp_loc else None + if check_at_pos pos loc.loc then Some expression.pexp_loc else None | _ -> None let check_deriving_attr pos (attrs : Parsetree.attributes) = @@ -26,10 +26,10 @@ let check_deriving_attr pos (attrs : Parsetree.attributes) = let check_structures pos (item : Parsetree.structure_item_desc) = match item with | Pstr_type (_, ty) -> - List.find_map - (fun (t : Parsetree.type_declaration) -> - check_deriving_attr pos t.ptype_attributes) - ty + List.find_map + (fun (t : Parsetree.type_declaration) -> + check_deriving_attr pos t.ptype_attributes) + ty | Pstr_exception tc -> check_deriving_attr pos tc.ptyexn_attributes | Pstr_modtype mt -> check_deriving_attr pos mt.pmtd_attributes | Pstr_typext tex -> check_deriving_attr pos tex.ptyext_attributes @@ -38,10 +38,10 @@ let check_structures pos (item : Parsetree.structure_item_desc) = let check_signatures pos (item : Parsetree.signature_item_desc) = match item with | Psig_type (_, ty) -> - List.find_map - (fun (t : Parsetree.type_declaration) -> - check_deriving_attr pos t.ptype_attributes) - ty + List.find_map + (fun (t : Parsetree.type_declaration) -> + check_deriving_attr pos t.ptype_attributes) + ty | Psig_exception tc -> check_deriving_attr pos tc.ptyexn_attributes | Psig_modtype mt -> check_deriving_attr pos mt.pmtd_attributes | Psig_typext tex -> check_deriving_attr pos tex.ptyext_attributes @@ -84,76 +84,71 @@ let get_ppxed_source ~ppxed_parsetree ~pos ppx_kind_with_attr : let () = match ppx_kind_with_attr with | Expr original_expr, _ -> ( - let expr (self : Ast_iterator.iterator) - (new_expr : Parsetree.expression) = - match - Location_aux.included ~into:original_expr.pexp_loc new_expr.pexp_loc - with - | true -> expression := Some new_expr - | false -> Ast_iterator.default_iterator.expr self new_expr - in - let iterator = { Ast_iterator.default_iterator with expr } in - match ppxed_parsetree with - | `Interface si -> iterator.signature iterator si - | `Implementation str -> iterator.structure iterator str) + let expr (self : Ast_iterator.iterator) (new_expr : Parsetree.expression) + = + match + Location_aux.included ~into:original_expr.pexp_loc new_expr.pexp_loc + with + | true -> expression := Some new_expr + | false -> Ast_iterator.default_iterator.expr self new_expr + in + let iterator = { Ast_iterator.default_iterator with expr } in + match ppxed_parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str) | Sig_item original_sg, _ -> ( - let signature_item (self : Ast_iterator.iterator) - (new_sg : Parsetree.signature_item) = - let included = - Location_aux.included new_sg.psig_loc ~into:original_sg.psig_loc - in - match included && original_sg <> new_sg, new_sg.psig_loc.loc_ghost with - | true, _ -> signature := new_sg :: !signature - | false, false -> Ast_iterator.default_iterator.signature_item self new_sg - | false, true -> () (* We don't enter nested ppxes *) + let signature_item (self : Ast_iterator.iterator) + (new_sg : Parsetree.signature_item) = + let included = + Location_aux.included new_sg.psig_loc ~into:original_sg.psig_loc in - let iterator = { Ast_iterator.default_iterator with signature_item } in - match ppxed_parsetree with - | `Interface si -> iterator.signature iterator si - | `Implementation str -> iterator.structure iterator str) + match + (included && original_sg <> new_sg, new_sg.psig_loc.loc_ghost) + with + | true, _ -> signature := new_sg :: !signature + | false, false -> + Ast_iterator.default_iterator.signature_item self new_sg + | false, true -> () (* We don't enter nested ppxes *) + in + let iterator = { Ast_iterator.default_iterator with signature_item } in + match ppxed_parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str) | Str_item original_str, _ -> ( - let structure_item (self : Ast_iterator.iterator) - (new_str : Parsetree.structure_item) = - let included = - Location_aux.included new_str.pstr_loc ~into:original_str.pstr_loc - in - match included, new_str.pstr_loc.loc_ghost with - | true, _ -> - (match check_structures pos new_str.pstr_desc with - | None -> structure := new_str :: !structure - | Some _ -> ()) - | false, false -> Ast_iterator.default_iterator.structure_item self new_str - | false, true -> () + let structure_item (self : Ast_iterator.iterator) + (new_str : Parsetree.structure_item) = + let included = + Location_aux.included new_str.pstr_loc ~into:original_str.pstr_loc in - let iterator = { Ast_iterator.default_iterator with structure_item } in - match ppxed_parsetree with - | `Interface si -> iterator.signature iterator si - | `Implementation str -> iterator.structure iterator str) + match (included, new_str.pstr_loc.loc_ghost) with + | true, _ -> ( + match check_structures pos new_str.pstr_desc with + | None -> structure := new_str :: !structure + | Some _ -> ()) + | false, false -> + Ast_iterator.default_iterator.structure_item self new_str + | false, true -> () + in + let iterator = { Ast_iterator.default_iterator with structure_item } in + match ppxed_parsetree with + | `Interface si -> iterator.signature iterator si + | `Implementation str -> iterator.structure iterator str) in match (ppx_kind_with_attr : ppx_kind * Warnings.loc) with | Expr _, ext_loc -> - { - code = Pprintast.string_of_expression (Option.get !expression); - attr_start = ext_loc.loc_start; - attr_end = ext_loc.loc_end; - } + { code = Pprintast.string_of_expression (Option.get !expression); + attr_start = ext_loc.loc_start; + attr_end = ext_loc.loc_end + } | Sig_item _, attr_loc -> - let exp = - Pprintast.signature Format.str_formatter (List.rev !signature); - Format.flush_str_formatter () - in - { - code = exp; - attr_start = attr_loc.loc_start; - attr_end = attr_loc.loc_end; - } + let exp = + Pprintast.signature Format.str_formatter (List.rev !signature); + Format.flush_str_formatter () + in + { code = exp; attr_start = attr_loc.loc_start; attr_end = attr_loc.loc_end } | Str_item _, attr_loc -> - let exp = - Pprintast.structure Format.str_formatter (List.rev !structure); - Format.flush_str_formatter () - in - { - code = exp; - attr_start = attr_loc.loc_start; - attr_end = attr_loc.loc_end; - } + let exp = + Pprintast.structure Format.str_formatter (List.rev !structure); + Format.flush_str_formatter () + in + { code = exp; attr_start = attr_loc.loc_start; attr_end = attr_loc.loc_end } diff --git a/src/analysis/ptyp_of_type.ml b/src/analysis/ptyp_of_type.ml index 3f76d4c704..b93a0f4680 100644 --- a/src/analysis/ptyp_of_type.ml +++ b/src/analysis/ptyp_of_type.ml @@ -9,41 +9,41 @@ type signature_elt = | Type of Asttypes.rec_flag * Parsetree.type_declaration list let rec module_type = - let open Ast_helper in function + 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_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 + 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) + 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) + 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 + 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 @@ -52,13 +52,13 @@ and core_type type_expr = aux (core_type :: acc) fields | _ -> - failwith @@ Format.asprintf - "Unexpected type constructor in fields list: %a" - Printtyp.type_expr type_expr + 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." + | Tfield _ -> failwith "Found object field outside of object." | Tnil -> Typ.object_ [] Closed | Tlink type_expr | Tsubst (type_expr, _) -> core_type type_expr | Tvariant row -> @@ -67,8 +67,7 @@ and core_type type_expr = 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 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 ] @@ -81,86 +80,86 @@ and core_type type_expr = (* 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 + 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) + 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 + 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 + 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; _ } = + +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; + { 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) + 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 + +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)) + @@ 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 + let kind = + match type_kind with | Type_abstract -> Parsetree.Ptype_abstract | Type_open -> Ptype_open | Type_variant (constrs, _) -> @@ -169,68 +168,76 @@ and type_declaration id { 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) + 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.value vd | Sig_type (id, type_decl, rec_flag, _visibility) -> - let rec_flag = match rec_flag with + 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] + 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] + 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 + 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 + 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 + +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) + | 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 + | _ -> (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 + 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 + let type_, rest = read_type [ type_declaration id type_decl ] rest in group (Type (Asttypes.Nonrecursive, type_) :: acc) rest - | Sig_class _ as item :: _ :: _ :: _ :: rest -> + | (Sig_class _ as item) :: _ :: _ :: _ :: rest -> group (Item item :: acc) rest - | Sig_class_type _ as item :: _ :: _ :: rest -> + | (Sig_class_type _ as item) :: _ :: _ :: rest -> group (Item item :: acc) rest | item :: rest -> group (Item item :: acc) rest | [] -> List.rev acc diff --git a/src/analysis/ptyp_of_type.mli b/src/analysis/ptyp_of_type.mli index 26fb46eb8b..2a35aae277 100644 --- a/src/analysis/ptyp_of_type.mli +++ b/src/analysis/ptyp_of_type.mli @@ -1,15 +1,13 @@ type signature_elt = -| Item of Types.signature_item -| Type of Asttypes.rec_flag * Parsetree.type_declaration list + | 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 + Ident.t -> Types.modtype_declaration -> Parsetree.module_type_declaration val module_declaration : Ident.t -> Types.module_declaration -> Parsetree.module_declaration @@ -33,7 +31,7 @@ val constructor_declaration : val type_declaration : Ident.t -> Types.type_declaration -> Parsetree.type_declaration -val signature : Types.signature -> Parsetree.signature +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 diff --git a/src/analysis/refactor_open.ml b/src/analysis/refactor_open.ml index 8d9afc78a5..162636d862 100644 --- a/src/analysis/refactor_open.ml +++ b/src/analysis/refactor_open.ml @@ -15,38 +15,36 @@ let qual_or_unqual_path mode ~open_lident ~open_path node_path node_lid = 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 *)) - -> + | 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' + | 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 = + 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 + | _ | (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) :: _)) -> + | 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) + 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/src/analysis/refactor_open.mli b/src/analysis/refactor_open.mli index 9a4f2cb43a..17a4e58908 100644 --- a/src/analysis/refactor_open.mli +++ b/src/analysis/refactor_open.mli @@ -1,6 +1,5 @@ - -val get_rewrites - : mode:[> `Qualify | `Unqualify ] - -> Mtyper.result - -> Lexing.position - -> (string * Location.t) list +val get_rewrites : + mode:[> `Qualify | `Unqualify ] -> + Mtyper.result -> + Lexing.position -> + (string * Location.t) list diff --git a/src/analysis/signature_help.ml b/src/analysis/signature_help.ml index 0482638255..3f84261b90 100644 --- a/src/analysis/signature_help.ml +++ b/src/analysis/signature_help.ml @@ -1,20 +1,20 @@ open Std -let {Logger. log} = Logger.for_section "signature-help" +let { Logger.log } = Logger.for_section "signature-help" type parameter_info = - { label : Asttypes.arg_label - ; param_start : int - ; param_end : int - ; argument : Typedtree.expression option + { 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 + { function_name : string option; + function_position : Msource.position; + signature : string; + parameters : parameter_info list; + active_param : int option } (* extract a properly parenthesized identifier from (expression_desc (Texp_ident @@ -80,8 +80,8 @@ let print_parameter_offset ?arg:argument ppf buffer env label ty = { label; param_start; param_end; argument } (* This function preprocesses the signature and associate already assigned -arguments to the corresponding parameter. (They should always be in the correct -order in the typedtree, even if they are not in order in the source file.) *) + arguments to the corresponding parameter. (They should always be in the correct + order in the typedtree, even if they are not in order in the source file.) *) let separate_function_signature ~args (e : Typedtree.expression) = Type_utils.Printtyp.reset (); let buffer = Buffer.create 16 in @@ -99,11 +99,11 @@ let separate_function_signature ~args (e : Typedtree.expression) = (* 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 + { 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 @@ -124,8 +124,9 @@ let first_unassigned_argument params = | { argument = None; label = Asttypes.Labelled _ | Optional _; _ } -> true | _ -> false in - try Some (List.index params ~f:positional) with Not_found -> - try Some (List.index params ~f:labelled) with Not_found -> None + try Some (List.index params ~f:positional) + with Not_found -> ( + try Some (List.index params ~f:labelled) with Not_found -> None) let active_parameter_by_prefix ~prefix params = let common = function @@ -156,27 +157,25 @@ let is_arrow t = let application_signature ~prefix ~cursor = function | (_, Browse_raw.Expression arg) - :: ( _ - , Expression { exp_desc = Texp_apply (({ exp_type; _ } as e), args); _ } + :: ( _, + Expression { exp_desc = Texp_apply (({ exp_type; _ } as e), args); _ } ) :: _ when is_arrow exp_type -> - log ~title:"application_signature" "Last arg:\n%a" - Logger.fmt (fun fmt -> Printtyped.expression fmt arg); + log ~title:"application_signature" "Last arg:\n%a" Logger.fmt (fun fmt -> + Printtyped.expression fmt arg); let result = separate_function_signature e ~args in let active_param = - if prefix = "" && Lexing.compare_pos cursor arg.exp_loc.loc_end > 0 then - begin + if prefix = "" && Lexing.compare_pos cursor arg.exp_loc.loc_end > 0 then begin (* If the cursor is placed after the last arg it means that a whitespace was inserted and we want to underline the next argument. *) log ~title:"application_signature" "Current cursor position is after the last argument"; first_unassigned_argument result.parameters - end else + end + else (* If not, we identify the argument which is being written *) - let active_param = - active_parameter_by_arg ~arg result.parameters - in + let active_param = active_parameter_by_arg ~arg result.parameters in match active_param with | Some _ as ap -> ap | None -> active_parameter_by_prefix ~prefix result.parameters diff --git a/src/analysis/signature_help.mli b/src/analysis/signature_help.mli index f7c7738de7..0aa6657625 100644 --- a/src/analysis/signature_help.mli +++ b/src/analysis/signature_help.mli @@ -1,28 +1,25 @@ type parameter_info = - { label : Asttypes.arg_label - ; param_start : int - ; param_end : int - ; argument : Typedtree.expression option + { 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 + { function_name : string option; + function_position : Msource.position; + signature : string; + parameters : parameter_info list; + active_param : int option } (** provide signature information for applied functions *) val application_signature : - prefix:string - -> cursor:Lexing.position - -> Mbrowse.t - -> application_signature option + prefix:string -> + cursor:Lexing.position -> + Mbrowse.t -> + application_signature option (** @see reference *) val prefix_of_position : - short_path: bool - -> Msource.t - -> Msource.position - -> string + short_path:bool -> Msource.t -> Msource.position -> string diff --git a/src/analysis/syntax_doc.ml b/src/analysis/syntax_doc.ml index 49335d12cd..e011cdfc33 100644 --- a/src/analysis/syntax_doc.ml +++ b/src/analysis/syntax_doc.ml @@ -12,30 +12,28 @@ let get_syntax_doc cursor_loc node : syntax_info = :: (_, Type_declaration _) :: (_, With_constraint (Twith_typesubst _)) :: _ -> - Some - { - name = "Destructive substitution"; - description = - "Behaves like normal signature constraints but removes the \ - redefined type or module from the signature."; - documentation = - syntax_doc_url - "signaturesubstitution.html#ss:destructive-substitution"; - } + Some + { name = "Destructive substitution"; + description = + "Behaves like normal signature constraints but removes the redefined \ + type or module from the signature."; + documentation = + syntax_doc_url + "signaturesubstitution.html#ss:destructive-substitution" + } | (_, Type_kind _) :: (_, Type_declaration _) :: (_, Signature_item ({ sig_desc = Tsig_typesubst _; _ }, _)) :: _ -> - Some - { - name = "Local substitution"; - description = - "Behaves like destructive substitution but is introduced during \ - the specification of the signature, and will apply to all the \ - items that follow."; - documentation = - syntax_doc_url "signaturesubstitution.html#ss:local-substitution"; - } + Some + { name = "Local substitution"; + description = + "Behaves like destructive substitution but is introduced during the \ + specification of the signature, and will apply to all the items \ + that follow."; + documentation = + syntax_doc_url "signaturesubstitution.html#ss:local-substitution" + } | (_, Module_type _) :: (_, Module_type _) :: ( _, @@ -43,36 +41,34 @@ let get_syntax_doc cursor_loc node : syntax_info = (Tmodtype_explicit { mty_desc = Tmty_with (_, [ (_, _, Twith_modtype _) ]); _ }) ) :: _ -> - Some - { - name = "Module substitution"; - description = - "Behaves like type substitutions but are useful to refine an \ - abstract module type in a signature into a concrete module type,"; - documentation = - syntax_doc_url - "signaturesubstitution.html#ss:module-type-substitution"; - } + Some + { name = "Module substitution"; + description = + "Behaves like type substitutions but are useful to refine an \ + abstract module type in a signature into a concrete module type,"; + documentation = + syntax_doc_url + "signaturesubstitution.html#ss:module-type-substitution" + } | (_, Type_kind Ttype_open) :: (_, Type_declaration { typ_private; _ }) :: _ -> - let e_name = "Extensible Variant Type" in - let e_description = - "Can be extended with new variant constructors using `+=`." - in - let e_url = "extensiblevariants.html" in - let name, description, url = - match typ_private with - | Public -> (e_name, e_description, e_url) - | Private -> - ( Format.sprintf "Private %s" e_name, - Format.sprintf - "%s. Prevents new constructors from being declared directly, \ - but allows extension constructors to be referred to in \ - interfaces." - e_description, - "extensiblevariants.html#ss:private-extensible" ) - in - Some { name; description; documentation = syntax_doc_url url } + let e_name = "Extensible Variant Type" in + let e_description = + "Can be extended with new variant constructors using `+=`." + in + let e_url = "extensiblevariants.html" in + let name, description, url = + match typ_private with + | Public -> (e_name, e_description, e_url) + | Private -> + ( Format.sprintf "Private %s" e_name, + Format.sprintf + "%s. Prevents new constructors from being declared directly, but \ + allows extension constructors to be referred to in interfaces." + e_description, + "extensiblevariants.html#ss:private-extensible" ) + in + Some { name; description; documentation = syntax_doc_url url } | (_, Constructor_declaration _) :: (_, Type_kind (Ttype_variant _)) :: (_, Type_declaration { typ_private; _ }) @@ -82,149 +78,140 @@ let get_syntax_doc cursor_loc node : syntax_info = :: (_, Type_kind (Ttype_variant _)) :: (_, Type_declaration { typ_private; _ }) :: _ -> - let v_name = "Variant Type" in - let v_description = - "Represent's data that may take on multiple different forms." - in - let v_url = "typedecl.html#ss:typedefs" in - let name, description, url = - match typ_private with - | Public -> (v_name, v_description, v_url) - | Private -> - ( Format.sprintf "Private %s" v_name, - Format.sprintf - "%s This type is private, values cannot be constructed \ - directly but can be de-structured as usual." - v_description, - "privatetypes.html#ss:private-types-variant" ) - in - Some { name; description; documentation = syntax_doc_url url } + let v_name = "Variant Type" in + let v_description = + "Represent's data that may take on multiple different forms." + in + let v_url = "typedecl.html#ss:typedefs" in + let name, description, url = + match typ_private with + | Public -> (v_name, v_description, v_url) + | Private -> + ( Format.sprintf "Private %s" v_name, + Format.sprintf + "%s This type is private, values cannot be constructed directly \ + but can be de-structured as usual." + v_description, + "privatetypes.html#ss:private-types-variant" ) + in + Some { name; description; documentation = syntax_doc_url url } | (_, Core_type _) :: (_, Core_type _) :: (_, Label_declaration _) :: (_, Type_kind (Ttype_record _)) :: (_, Type_declaration { typ_private; _ }) :: _ -> - let r_name = "Record Type" in - let r_description = "Defines variants with a fixed set of fields" in - let r_url = "typedecl.html#ss:typedefs" in - let name, description, url = - match typ_private with - | Public -> (r_name, r_description, r_url) - | Private -> - ( Format.sprintf "Private %s" r_name, - Format.sprintf - "%s This type is private, values cannot be constructed \ - directly but can be de-structured as usual." - r_description, - "privatetypes.html#ss:private-types-variant" ) - in - Some { name; description; documentation = syntax_doc_url url } + let r_name = "Record Type" in + let r_description = "Defines variants with a fixed set of fields" in + let r_url = "typedecl.html#ss:typedefs" in + let name, description, url = + match typ_private with + | Public -> (r_name, r_description, r_url) + | Private -> + ( Format.sprintf "Private %s" r_name, + Format.sprintf + "%s This type is private, values cannot be constructed directly \ + but can be de-structured as usual." + r_description, + "privatetypes.html#ss:private-types-variant" ) + in + Some { name; description; documentation = syntax_doc_url url } | (_, Type_kind (Ttype_variant _)) :: (_, Type_declaration { typ_private = Public; _ }) :: _ -> - Some - { - name = "Empty Variant Type"; - description = "An empty variant type."; - documentation = syntax_doc_url "emptyvariants.html"; - } + Some + { name = "Empty Variant Type"; + description = "An empty variant type."; + documentation = syntax_doc_url "emptyvariants.html" + } | (_, Type_kind Ttype_abstract) :: (_, Type_declaration { typ_private = Public; typ_manifest = None; _ }) :: _ -> - Some - { - name = "Abstract Type"; - description = - "Define variants with arbitrary data structures, including other \ - variants, records, and functions"; - documentation = syntax_doc_url "typedecl.html#ss:typedefs"; - } + Some + { name = "Abstract Type"; + description = + "Define variants with arbitrary data structures, including other \ + variants, records, and functions"; + documentation = syntax_doc_url "typedecl.html#ss:typedefs" + } | (_, Type_kind Ttype_abstract) :: (_, Type_declaration { typ_private = Private; _ }) :: _ -> - Some - { - name = "Private Type Abbreviation"; - description = - "Declares a type that is distinct from its implementation type \ - `typexpr`."; - documentation = - syntax_doc_url "privatetypes.html#ss:private-types-abbrev"; - } + Some + { name = "Private Type Abbreviation"; + description = + "Declares a type that is distinct from its implementation type \ + `typexpr`."; + documentation = + syntax_doc_url "privatetypes.html#ss:private-types-abbrev" + } | (_, Expression _) :: (_, Expression _) :: (_, Value_binding _) :: (_, Structure_item ({ str_desc = Tstr_value (Recursive, _); _ }, _)) :: _ -> - Some - { - name = "Recursive value definition"; - description = - "Supports a certain class of recursive definitions of \ - non-functional values."; - documentation = syntax_doc_url "letrecvalues.html"; - } + Some + { name = "Recursive value definition"; + description = + "Supports a certain class of recursive definitions of non-functional \ + values."; + documentation = syntax_doc_url "letrecvalues.html" + } | (_, Module_expr _) :: (_, Module_type { mty_desc = Tmty_typeof _; _ }) :: _ -> - Some - { - name = "Recovering module type"; - description = - "Expands to the module type (signature or functor type) inferred \ - for the module expression `module-expr`. "; - documentation = syntax_doc_url "moduletypeof.html"; - } + Some + { name = "Recovering module type"; + description = + "Expands to the module type (signature or functor type) inferred for \ + the module expression `module-expr`. "; + documentation = syntax_doc_url "moduletypeof.html" + } | (_, Module_expr _) :: (_, Module_expr _) :: (_, Module_binding _) :: (_, Structure_item ({ str_desc = Tstr_recmodule _; _ }, _)) :: _ -> - Some - { - name = "Recursive module"; - description = - "A simultaneous definition of modules that can refer recursively \ - to each others."; - documentation = syntax_doc_url "recursivemodules.html"; - } + Some + { name = "Recursive module"; + description = + "A simultaneous definition of modules that can refer recursively to \ + each others."; + documentation = syntax_doc_url "recursivemodules.html" + } | (_, Expression _) :: (_, Expression _) :: (_, Case _) :: (_, Expression _) :: ( _, Value_binding - { - vb_expr = + { vb_expr = { exp_extra = [ (Texp_newtype' (_, loc), _, _) ]; exp_loc; _ }; - _; + _ } ) :: _ -> ( - let in_range = - cursor_loc.Lexing.pos_cnum - 1 > exp_loc.loc_start.pos_cnum - && cursor_loc.Lexing.pos_cnum <= loc.loc.loc_end.pos_cnum + 1 - in - match in_range with - | true -> - Some - { - name = "Locally Abstract Type"; - description = - "Type constructor which is considered abstract in the scope of \ - the sub-expression and replaced by a fresh type variable."; - documentation = syntax_doc_url "locallyabstract.html"; - } - | false -> None) + let in_range = + cursor_loc.Lexing.pos_cnum - 1 > exp_loc.loc_start.pos_cnum + && cursor_loc.Lexing.pos_cnum <= loc.loc.loc_end.pos_cnum + 1 + in + match in_range with + | true -> + Some + { name = "Locally Abstract Type"; + description = + "Type constructor which is considered abstract in the scope of the \ + sub-expression and replaced by a fresh type variable."; + documentation = syntax_doc_url "locallyabstract.html" + } + | false -> None) | (_, Module_expr _) :: (_, Module_expr _) :: (_, Expression { exp_desc = Texp_pack _; _ }) :: _ -> - Some - { - name = "First class module"; - description = - "Converts a module (structure or functor) to a value of the core \ - language that encapsulates the module."; - documentation = syntax_doc_url "firstclassmodules.html"; - } + Some + { name = "First class module"; + description = + "Converts a module (structure or functor) to a value of the core \ + language that encapsulates the module."; + documentation = syntax_doc_url "firstclassmodules.html" + } | _ -> None diff --git a/src/analysis/syntax_doc.mli b/src/analysis/syntax_doc.mli index 17adafbca7..452806ea81 100644 --- a/src/analysis/syntax_doc.mli +++ b/src/analysis/syntax_doc.mli @@ -1 +1,4 @@ -val get_syntax_doc: Lexing.position -> (Env.t * Browse_raw.node) list -> Query_protocol.syntax_doc_result option +val get_syntax_doc : + Lexing.position -> + (Env.t * Browse_raw.node) list -> + Query_protocol.syntax_doc_result option diff --git a/src/analysis/tail_analysis.ml b/src/analysis/tail_analysis.ml index 3e75a758d7..5140bd7d39 100644 --- a/src/analysis/tail_analysis.ml +++ b/src/analysis/tail_analysis.ml @@ -1,80 +1,100 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 + | { 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] - + | 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] + | 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) + | Texp_function { cases; _ } -> List.map cases ~f:(fun c -> Case c) | _ -> [] let entry_points = function @@ -84,5 +104,5 @@ let entry_points = function (* 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 + | Expression { exp_desc = Texp_apply _; _ } -> true | _ -> false diff --git a/src/analysis/tail_analysis.mli b/src/analysis/tail_analysis.mli index 6e29c3808c..e66b6ebebe 100644 --- a/src/analysis/tail_analysis.mli +++ b/src/analysis/tail_analysis.mli @@ -1,38 +1,38 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 +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 entry_points : Browse_raw.node -> Browse_raw.node list -val is_call: Browse_raw.node -> bool +val is_call : Browse_raw.node -> bool diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml index 6d8e05bf95..096ad2d571 100644 --- a/src/analysis/type_enclosing.ml +++ b/src/analysis/type_enclosing.ml @@ -1,7 +1,7 @@ open Std let log_section = "type-enclosing" -let {Logger.log} = Logger.for_section log_section +let { Logger.log } = Logger.for_section log_section type type_info = | Modtype of Env.t * Types.module_type @@ -17,44 +17,39 @@ let from_nodes ~path = 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} -> + | 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}} -> + | 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 + { 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 }) } -> + { 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 }, _) } -> + | Class_field + { cf_desc = Tcf_val (_, _, _, Tcfk_virtual { ctyp_type = t }, _) } -> ret (Type (env, t)) - | Binding_op { bop_op_type; _ } -> ret (Type(env, bop_op_type)) + | Binding_op { bop_op_type; _ } -> ret (Type (env, bop_op_type)) | _ -> None in List.filter_map ~f:aux path @@ -64,76 +59,67 @@ let from_reconstructed ~nodes ~cursor ~verbosity exprs = 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 + (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 + let include_uident = + match node with | Module_binding _ | Module_binding_name _ | Module_declaration _ | Module_declaration_name _ | Module_type_declaration _ - | Module_type_declaration_name _ - -> false + | Module_type_declaration_name _ -> false | _ -> true in let get_context lident = - Context.inspect_browse_tree - ~cursor - (Longident.parse lident) - [nodes] + 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.Label { lbl_name; lbl_arg; _ }) -> - log ~title:"from_reconstructed" "ctx: label %s" lbl_name; - let ppf, to_string = Format.to_string () in - Type_utils.print_type_with_decl ~verbosity env ppf lbl_arg; - 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 + let f { 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.Label { lbl_name; lbl_arg; _ }) -> + log ~title:"from_reconstructed" "ctx: label %s" lbl_name; + let ppf, to_string = Format.to_string () in + Type_utils.print_type_with_decl ~verbosity env ppf lbl_arg; + 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/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index 3672ee87ea..d05e828167 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -1,44 +1,44 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 Verbosity = Mconfig.Verbosity let protect expr = - Pprintast.protect_ident (Format.str_formatter) expr; + Pprintast.protect_ident Format.str_formatter expr; Format.flush_str_formatter () -let parse_expr ?(keywords=Lexer_raw.keywords []) expr = +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.Fail (e, l) -> raise (Lexer_raw.Error (e, l)) | Lexer_raw.Return token -> token | Lexer_raw.Refill k -> lexer (k ()) in @@ -50,7 +50,7 @@ let parse_longident lid = let lexbuf = Lexing.from_string protected_lid in let state = Lexer_raw.make @@ Lexer_raw.keywords [] in let rec lexer = function - | Lexer_raw.Fail (e,l) -> raise (Lexer_raw.Error (e,l)) + | Lexer_raw.Fail (e, l) -> raise (Lexer_raw.Error (e, l)) | Lexer_raw.Return token -> token | Lexer_raw.Refill k -> lexer (k ()) in @@ -60,7 +60,7 @@ let parse_longident lid = 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 + (path, md.Types.md_type, md.Types.md_attributes) let verbosity = ref Verbosity.default @@ -68,7 +68,8 @@ module Printtyp = struct include Printtyp let expand_type env ty = - Env.with_cmis @@ fun () -> (* ?? Not sure *) + Env.with_cmis @@ fun () -> + (* ?? Not sure *) match !verbosity with | Smart | Lvl 0 -> ty | Lvl (_ : int) -> @@ -77,38 +78,39 @@ module Printtyp = struct 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) + 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 + 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) + 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 + if d > 0 then Btype.iter_type_expr (iter (pred d)) ty0 end in - iter (match !verbosity with | Smart -> assert false | Lvl v -> v) ty; + iter + (match !verbosity with + | Smart -> assert false + | Lvl v -> v) + 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)} + | 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 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) @@ -116,34 +118,30 @@ module Printtyp = struct 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 verbose_modtype env ppf t = Printtyp.modtype ppf (expand_sig env t) - let select_by_verbosity ~default ?(smart=default) ~verbose = + let select_by_verbosity ~default ?(smart = default) ~verbose = match !verbosity with | Smart -> smart | Lvl 0 -> default | Lvl _ -> verbose let type_scheme env ppf ty = - (select_by_verbosity - ~default:type_scheme - ~verbose:(verbose_type_scheme env)) ppf ty + (select_by_verbosity ~default:type_scheme ~verbose:(verbose_type_scheme env)) + ppf ty let type_declaration env id ppf = - (select_by_verbosity - ~default:type_declaration - ~verbose:(verbose_type_declaration env)) id ppf + (select_by_verbosity ~default:type_declaration + ~verbose:(verbose_type_declaration env)) + id ppf let modtype env ppf mty = let smart ppf = function | Types.Mty_ident _ | Mty_alias _ -> verbose_modtype env ppf mty | _ -> modtype ppf mty in - (select_by_verbosity - ~default:modtype - ~verbose:(verbose_modtype env) - ~smart) ppf mty + (select_by_verbosity ~default:modtype ~verbose:(verbose_modtype env) ~smart) + ppf mty let wrap_printing_env env ~verbosity:v f = let_ref verbosity v (fun () -> wrap_printing_env env f) @@ -164,56 +162,54 @@ let rec mod_smallerthan n m = 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 + | Mty_signature s -> begin + match List.length_lessthan n s with | None -> None - | Some n2 -> Some (n1 + n2) + | 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 - | _ -> Some 1 + | 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 = +let print_short_modtype verbosity env ppf md = (* In smart mode we list modules' contents, so [for_smart = 1] here *) let verbosity = Verbosity.to_int verbosity ~for_smart:1 in 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 + Format.pp_print_string ppf "(* large signature, repeat to confirm *)" + | _ -> Printtyp.modtype env ppf md let print_type_with_decl ~verbosity env ppf typ = match verbosity with - | Verbosity.Smart | Lvl 0 -> Printtyp.type_scheme env ppf typ + | Verbosity.Smart | Lvl 0 -> Printtyp.type_scheme env ppf typ | Lvl _ -> begin match Types.get_desc typ with | Types.Tconstr (path, params, _) -> - let decl = - Env.with_cmis @@ fun () -> - Env.find_type path env - in + 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 @@ -221,24 +217,22 @@ let print_type_with_decl ~verbosity env ppf typ = 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 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 + 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 end @@ -248,11 +242,10 @@ let print_exn ppf exn = Format.pp_print_string ppf (Printexc.to_string exn) | Some (`Ok report) -> Location.print_main ppf report -let print_type ppf env lid = +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)) + (Ident.create_persistent (* Incorrect, but doesn't matter. *) (Path.last p)) ppf t let print_modtype ppf verbosity env lid = @@ -262,41 +255,38 @@ let print_modtype ppf verbosity env lid = | 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 _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 + 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=Verbosity.default) ?keywords ~context env ppf expr = +let type_in_env ?(verbosity = Verbosity.default) ?keywords ~context env ppf expr + = let print_expr expression = - let (str, _sg, _shape, _) = + let str, _sg, _shape, _ = Env.with_cmis @@ fun () -> - Typemod.type_toplevel_phrase env - [Ast_helper.Str.eval expression] + 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,_); _ }] -> + | [ { 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 @@ protect expr with - | exception exn -> print_exn ppf exn; false - - | e -> + | 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 @@ -305,58 +295,61 @@ let type_in_env ?(verbosity=Verbosity.default) ?keywords ~context env ppf expr = 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 _ -> + | `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 + with exn -> ( + try print_modpath ppf verbosity env longident; true - with _ -> try + with _ -> ( + try (* TODO: useless according to test suite *) print_modtype ppf verbosity env longident; true - with _ -> try + 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 + 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 + 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) :: _ -> + | ({ Location.txt = "doc" | "ocaml.doc"; loc = _ }, payload) :: _ -> Ast_helper.extract_str_payload payload | _ :: rest -> loop rest | [] -> None @@ -366,8 +359,5 @@ let read_doc_attributes 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 + | { Location.txt = "deprecated" | "ocaml.deprecated"; loc = _ }, _ -> true | _ -> false) - diff --git a/src/analysis/type_utils.mli b/src/analysis/type_utils.mli index 73ad9e7a31..b0630438f9 100644 --- a/src/analysis/type_utils.mli +++ b/src/analysis/type_utils.mli @@ -1,37 +1,39 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 : Mconfig.Verbosity.t ref module Printtyp : sig - include module type of struct include Printtyp end + include module type of struct + include Printtyp + end val type_declaration : Env.t -> Ident.t -> Format.formatter -> Types.type_declaration -> unit @@ -40,51 +42,52 @@ module Printtyp : sig val modtype : Env.t -> Format.formatter -> Types.module_type -> unit - val wrap_printing_env : Env.t -> verbosity:Mconfig.Verbosity.t -> (unit -> 'a) -> 'a + val wrap_printing_env : + Env.t -> verbosity:Mconfig.Verbosity.t -> (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 mod_smallerthan : int -> Types.module_type -> int option -val type_in_env : - ?verbosity:Mconfig.Verbosity.t - -> ?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 type_in_env : + ?verbosity:Mconfig.Verbosity.t -> + ?keywords:Lexer_raw.keywords -> + context:Context.t -> + Env.t -> + Format.formatter -> + string -> + bool -val print_type_with_decl : - verbosity:Mconfig.Verbosity.t - -> 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 print_type_with_decl : + verbosity:Mconfig.Verbosity.t -> + Env.t -> + Format.formatter -> + Types.type_expr -> + unit -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 lookup_module : + Longident.t -> Env.t -> Path.t * Types.module_type * Parsetree.attributes -val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option (** [read_doc_attributes] looks for a docstring in an attribute list. *) +val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option val is_deprecated : Parsetree.attributes -> bool val print_constr : - verbosity:Mconfig.Verbosity.t - -> Env.t - -> Format.formatter - -> Types.constructor_description - -> unit + verbosity:Mconfig.Verbosity.t -> + Env.t -> + Format.formatter -> + Types.constructor_description -> + unit val parse_longident : string -> Longident.t option diff --git a/src/analysis/typedtree_utils.ml b/src/analysis/typedtree_utils.ml index bd9c68d339..99c8a32b9b 100644 --- a/src/analysis/typedtree_utils.ml +++ b/src/analysis/typedtree_utils.ml @@ -2,19 +2,17 @@ open Std let extract_toplevel_identifier item = match item.Typedtree.sig_desc with - | Typedtree.Tsig_value { val_id; _ } -> [val_id] - | Typedtree.Tsig_modsubst { ms_id; _ } -> [ms_id] + | Typedtree.Tsig_value { val_id; _ } -> [ val_id ] + | Typedtree.Tsig_modsubst { ms_id; _ } -> [ ms_id ] | Typedtree.Tsig_modtype { mtd_id; _ } - | Typedtree.Tsig_modtypesubst { mtd_id; _ } -> [mtd_id] + | Typedtree.Tsig_modtypesubst { mtd_id; _ } -> [ mtd_id ] | Typedtree.Tsig_module { md_id; _ } -> Option.to_list md_id | Typedtree.Tsig_recmodule mods -> - List.filter_map ~f:(fun Typedtree.{md_id; _} -> md_id) mods + List.filter_map ~f:(fun Typedtree.{ md_id; _ } -> md_id) mods | Typedtree.Tsig_class cls -> - List.map ~f:(fun Typedtree.{ ci_id_class; _} -> ci_id_class) cls + List.map ~f:(fun Typedtree.{ ci_id_class; _ } -> ci_id_class) cls | Typedtree.Tsig_class_type cls -> - List.map - ~f:(fun Typedtree.{ ci_id_class_type; _} -> ci_id_class_type) - cls + List.map ~f:(fun Typedtree.{ ci_id_class_type; _ } -> ci_id_class_type) cls | Typedtree.Tsig_type _ | Typedtree.Tsig_typesubst _ | Typedtree.Tsig_typext _ @@ -24,28 +22,24 @@ let extract_toplevel_identifier item = | Typedtree.Tsig_attribute _ -> [] let let_bound_vars bindings = - List.filter_map ~f:(fun value_binding -> - match value_binding.Typedtree.vb_pat.pat_desc with - | Tpat_var (id, loc) -> Some (id, loc) - | Typedtree.Tpat_any - | Typedtree.Tpat_alias (_, _, _) - | Typedtree.Tpat_constant _ - | Typedtree.Tpat_tuple _ - | Typedtree.Tpat_construct (_, _, _, _) - | Typedtree.Tpat_variant (_, _, _) - | Typedtree.Tpat_record (_, _) - | Typedtree.Tpat_array _ - | Typedtree.Tpat_lazy _ - | Typedtree.Tpat_or (_, _, _) -> None - ) bindings + List.filter_map + ~f:(fun value_binding -> + match value_binding.Typedtree.vb_pat.pat_desc with + | Tpat_var (id, loc) -> Some (id, loc) + | Typedtree.Tpat_any + | Typedtree.Tpat_alias (_, _, _) + | Typedtree.Tpat_constant _ | Typedtree.Tpat_tuple _ + | Typedtree.Tpat_construct (_, _, _, _) + | Typedtree.Tpat_variant (_, _, _) + | Typedtree.Tpat_record (_, _) + | Typedtree.Tpat_array _ | Typedtree.Tpat_lazy _ + | Typedtree.Tpat_or (_, _, _) -> None) + bindings let pat_var_id_and_loc = function - | Typedtree.{ pat_desc = Tpat_var (id, loc); _ } -> - Some (id, loc) + | Typedtree.{ pat_desc = Tpat_var (id, loc); _ } -> Some (id, loc) | _ -> None let pat_alias_pat_id_and_loc = function - | Typedtree.{ pat_desc = Tpat_alias (pat, id, loc); _ } -> - Some (pat, id, loc) + | Typedtree.{ pat_desc = Tpat_alias (pat, id, loc); _ } -> Some (pat, id, loc) | _ -> None - diff --git a/src/analysis/typedtree_utils.mli b/src/analysis/typedtree_utils.mli index 91f910a8b0..3ec58b24c3 100644 --- a/src/analysis/typedtree_utils.mli +++ b/src/analysis/typedtree_utils.mli @@ -18,6 +18,6 @@ val pat_var_id_and_loc : (** [pat_alias_id_and_loc] try to extract the [id] and the [location] of pattern alias. *) -val pat_alias_pat_id_and_loc - : Typedtree.pattern - -> (Typedtree.pattern * Ident.t * string Location.loc) option +val pat_alias_pat_id_and_loc : + Typedtree.pattern -> + (Typedtree.pattern * Ident.t * string Location.loc) option diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 1713d1b9d9..02d23b99a3 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -1,85 +1,90 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + 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 + 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: + 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 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. + 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 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 : + 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 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) +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 _ -> - 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 - ) + 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 command_is ~name (Command (name', _, _, _, _)) = String.equal name name' @@ -88,714 +93,707 @@ let find_command name = List.find ~f:(command_is ~name) let find_command_opt name = List.find_opt ~f:(command_is ~name) let run pipeline query = - Logger.log ~section:"New_commands" ~title:"run(query)" - "%a" Logger.json (fun () -> Query_json.dump 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 "syntax-document" - ~doc: "Returns documentation for OCaml syntax for the entity under the cursor" - ~spec: [ - arg "-position" " Position to complete" - (marg_position (fun pos _pos -> pos)); - ] - ~default: `None - begin fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Syntax_document pos) - end - ; - - command "expand-ppx" - ~doc: "Returns the generated code of a PPX." - ~spec: [ - arg "-position" " Position to expand" - (marg_position (fun pos _pos -> pos)); - ] - ~default: `None - begin fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Expand_ppx 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', \ -'module-type' 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 of the identifier" - (marg_position (fun pos (_pos, scope) -> (`Ident_at pos, scope))); - optional "-scope" "buffer|project Scope of the query" - (Marg.param "" - (fun scope (pos, _scope) -> - match scope with - | "buffer" -> (pos, `Buffer) - | "project" -> (pos, `Project) - | _ -> failwith "-scope should be one of buffer or project" - )); - ] -~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, `Buffer) - begin fun buffer -> - function - | `None, _ -> failwith "-identifier-at is mandatory" - | `Ident_at pos, scope -> - run buffer (Query_protocol.Occurrences (`Ident_at pos, scope)) - 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 "inlay-hints" - ~doc:"return a list of inly-hints for additional client (like LSP)" - ~spec: [ - arg "-start" " Where inlay-hints generation start" - (marg_position - (fun start - (_start, stop, let_binding, pattern_binding, ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); - arg "-end" " Where inlay-hints generation stop" - (marg_position - (fun stop - (start, _stop, let_binding, pattern_binding, ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); - optional "-let-binding" " Hint let-binding (default is false)" - (Marg.bool - (fun let_binding - (start, stop, _let_binding, pattern_binding, ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); - optional - "-pattern-binding" " Hint pattern-binding (default is false)" - (Marg.bool - (fun pattern_binding - (start, stop, let_binding, _pattern_binding, ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); - optional - "-avoid-ghost-location" - " Avoid hinting ghost location (default is true)" - (Marg.bool - (fun ghost - (start, stop, let_binding, pattern_binding, _ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); - ] - ~default:(`None, `None, false, false, true) - begin fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) -> - match (start, stop) with - | (`None, `None) -> failwith "-start and -end are mandatory" - | (`None, _) -> failwith "-start is mandatory" - | (_, `None) -> failwith "-end is mandatory" - | (#Msource.position, #Msource.position) as position -> - let (start, stop) = position in - run buffer - (Query_protocol.Inlay_hints - (start, stop, let_binding, pattern_binding, avoid_ghost)) - 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 - ; - command "signature-help" - ~doc:"Returns LSP Signature Help response" - ~spec: [ - arg "-position" " Position of Signature Help request" - (marg_position (fun pos (expr,_pos) -> (expr,pos))); - ] - ~default:("",`None) - begin fun buffer (_,pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as position -> - let sh = { - Query_protocol.position; - trigger_kind = None; - is_retrigger = false; - active_signature_help = None; - } in - run buffer (Query_protocol.Signature_help sh) - 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 - ; - -] +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,\n\ + 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.\n\ + When it is a variable pattern, it is further expanded and new \ + branches are introduced for each possible immediate constructor of \ + this variable.\n\ + The return value has the shape `[{'start': position, 'end': \ + position}, content]`, where content is string.\n" + ~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\n\ + hole at '-position' given its inferred type. The '-depth' parameter \ + allows to\n\ + recursively construct terms. Note that when '-depth' > 1 partial \ + results of\n\ + 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.\n\ + It returns a list of possible completions.\n\ + With '-types y' (default), each completion comes with type information.\n\ + With '-doc y' it tries to lookup OCamldoc, which is slightly more \ + time consuming.\n\n\ + The result has the form:\n\ + ```javascript\n\ + {\n\ + \ 'context': (null | ['application',{'argument_type': string, \ + 'labels': [{'name':string,'type':string}]}]),\n\ + \ 'entries': \ + [{'name':string,'kind':string,'desc':string,'info':string}]\n\ + }\n\ + ```\n\n\ + 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.\n\n\ + Entries is the list of possible completion. Each entry is made of:\n\ + - a name, the text that should be put in the buffer if selected\n\ + - a kind, one of `'value'`, `'variant'`, `'constructor'`, `'label'`, \ + `'module'`, `'signature'`, `'type'`, `'method'`, `'#'` (for method \ + calls), `'exn'`, `'class'`\n\ + - a description, most of the time a type or a definition line, to be \ + put next to the name in completion box\n\ + - 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.\n\ + If `-identifier ident` is specified, documentation for this ident is \ + looked up from environment at `-position`.\n\ + 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 "syntax-document" + ~doc: + "Returns documentation for OCaml syntax for the entity under the cursor" + ~spec: + [ arg "-position" " Position to complete" + (marg_position (fun pos _pos -> pos)) + ] + ~default:`None + begin + fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Syntax_document pos) + end; + command "expand-ppx" ~doc:"Returns the generated code of a PPX." + ~spec: + [ arg "-position" " Position to expand" + (marg_position (fun pos _pos -> pos)) + ] + ~default:`None + begin + fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Expand_ppx 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.\n\ + (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.\n\ + The value is a list where each item as the shape:\n\n\ + ```javascript\n\ + {\n\ + 'start' : position,\n\ + 'end' : position,\n\ + 'valid' : bool,\n\ + 'message' : string,\n\ + 'type' : ('type'|'parser'|'env'|'warning'|'unkown')\n\ + }\n\ + ```\n\n\ + `start` and `end` are omitted if error has no location (e.g. wrong \ + file format), otherwise the editor should probably highlight / mark \ + this range.\n\ + `type` is an attempt to classify the error.\n\ + `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.\n\ + `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: + "\n\ + The function behaves like `complete-prefix`, but it also handles \ + partial, incorrect, or wrongly spelled prefixes (as determined by \ + some heuristic).\n\ + For instance, `L.ma` can get expanded to `List.map`. This function is \ + a useful fallback if normal completion gave no results.\n\ + 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.\n\ + Target is a string that can contain one or more of the 'fun', 'let', \ + 'module', 'module-type' and 'match' words.\n\ + It returns the starting position of the function, let definition, \ + module or match expression that contains the cursor\n" + ~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.\n\ + Returns either:\n\ + - if location failed, a `string` describing the reason to the user,\n\ + - `{'pos': position}` if the location is in the current buffer,\n\ + - `{'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 of the identifier" + (marg_position (fun pos (_pos, scope) -> (`Ident_at pos, scope))); + optional "-scope" "buffer|project Scope of the query" + (Marg.param "" (fun scope (pos, _scope) -> + match scope with + | "buffer" -> (pos, `Buffer) + | "project" -> (pos, `Project) + | _ -> failwith "-scope should be one of buffer or project")) + ] + ~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, `Buffer) + begin + fun buffer -> function + | `None, _ -> failwith "-identifier-at is mandatory" + | `Ident_at pos, scope -> + run buffer (Query_protocol.Occurrences (`Ident_at pos, scope)) + 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\tTODO" + ~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\tTODO" + ~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 "inlay-hints" + ~doc:"return a list of inly-hints for additional client (like LSP)" + ~spec: + [ arg "-start" " Where inlay-hints generation start" + (marg_position + (fun start (_start, stop, let_binding, pattern_binding, ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + arg "-end" " Where inlay-hints generation stop" + (marg_position + (fun stop (start, _stop, let_binding, pattern_binding, ghost) -> + (start, stop, let_binding, pattern_binding, ghost))); + optional "-let-binding" " Hint let-binding (default is false)" + (Marg.bool + (fun + let_binding + (start, stop, _let_binding, pattern_binding, ghost) + -> (start, stop, let_binding, pattern_binding, ghost))); + optional "-pattern-binding" + " Hint pattern-binding (default is false)" + (Marg.bool + (fun + pattern_binding + (start, stop, let_binding, _pattern_binding, ghost) + -> (start, stop, let_binding, pattern_binding, ghost))); + optional "-avoid-ghost-location" + " Avoid hinting ghost location (default is true)" + (Marg.bool + (fun ghost (start, stop, let_binding, pattern_binding, _ghost) -> + (start, stop, let_binding, pattern_binding, ghost))) + ] + ~default:(`None, `None, false, false, true) + begin + fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) -> + match (start, stop) with + | `None, `None -> failwith "-start and -end are mandatory" + | `None, _ -> failwith "-start is mandatory" + | _, `None -> failwith "-end is mandatory" + | (#Msource.position, #Msource.position) as position -> + let start, stop = position in + run buffer + (Query_protocol.Inlay_hints + (start, stop, let_binding, pattern_binding, avoid_ghost)) + end; + command "shape" + ~doc: + "This command can be used to assist navigation in a source code buffer.\n\ + It returns a tree of all relevant locations around the cursor.\n\ + It is similar to outline without telling any information about the \ + entity at a given location.\n\ + ```javascript\n\ + shape =\n\ + {\n\ + \ 'start' : position,\n\ + \ 'end' : position,\n\ + \ 'children' : [shape]\n\ + }\n\ + ```\n" + ~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.\n\ + 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`.\n\n\ + If `-expression` and `-cursor` are specified, the first result will \ + be the type\n\ + relevant to the prefix ending at the `cursor` offset.\n\n\ + `-index` can be used to print only one type information. This is \ + useful to\n\ + query the types lazily: normally, Merlin would return the signature \ + of all\n\ + enclosing modules, which can be very expensive.\n\n\ + The result is returned as a list of:\n\ + ```javascript\n\ + {\n\ + \ 'start': position,\n\ + \ 'end': position,\n\ + \ 'type': string,\n\ + \ // is this expression not in tail position, in tail position, or \ + even a tail call?\n\ + \ 'tail': ('no' | 'position' | 'call')\n\ + }\n\ + ```" + ~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.\n\ + The return value has the shape:\n\ + ```javascript\n\ + {\n\ + \ 'dot_merlins': [path], // a list of string\n\ + \ 'failures': [message] // a list of string\n\ + }\n\ + ```" + ~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; + command "signature-help" ~doc:"Returns LSP Signature Help response" + ~spec: + [ arg "-position" " Position of Signature Help request" + (marg_position (fun pos (expr, _pos) -> (expr, pos))) + ] + ~default:("", `None) + begin + fun buffer (_, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as position -> + let sh = + { Query_protocol.position; + trigger_kind = None; + is_retrigger = false; + active_signature_help = None + } + in + run buffer (Query_protocol.Signature_help sh) + 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/src/commands/new_commands.mli b/src/commands/new_commands.mli index 7c62b49d8f..0cb3ad5b24 100644 --- a/src/commands/new_commands.mli +++ b/src/commands/new_commands.mli @@ -1,37 +1,42 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + 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 + 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: + 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 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. + 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 command = - Command : string * Marg.docstring * ([`Mandatory|`Optional|`Many] * 'args Marg.spec) list * 'args * - (Mpipeline.t -> 'args -> json) -> command + | Command : + string + * Marg.docstring + * ([ `Mandatory | `Optional | `Many ] * 'args Marg.spec) list + * 'args + * (Mpipeline.t -> 'args -> json) + -> command val all_commands : command list diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index fcf0d3110f..30e1e73914 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -1,274 +1,245 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 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] + | `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) + `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; - ] - + mk "type-expression" + [ ("expression", `String expr); ("position", mk_position pos) ] | Type_enclosing (opt_cursor, pos, index) -> - mk "type-enclosing" [ - "cursor", (match opt_cursor with + mk "type-enclosing" + [ ( "cursor", + match opt_cursor with | None -> `Null - | Some (text, offset) -> `Assoc [ - "text", `String text; - "offset", `Int offset; - ] - ); - "index", (match index with + | 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; - ] - + | 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; - ] - + 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; - ] + 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 + mk "document" + [ ( "identifier", + match identifier with | None -> `Null - | Some ident -> `String ident - ); - "position", mk_position pos; - ] + | Some ident -> `String ident ); + ("position", mk_position pos) + ] | Syntax_document pos -> mk "syntax-document" [ ("position", mk_position pos) ] - | Expand_ppx pos -> - mk "ppx-expand" [ ("position", mk_position pos) ] + | Expand_ppx pos -> mk "ppx-expand" [ ("position", mk_position pos) ] | Locate (prefix, look_for, pos) -> - mk "locate" [ - "prefix", (match prefix with + mk "locate" + [ ( "prefix", + match prefix with | None -> `Null - | Some prefix -> `String prefix - ); - "look-for", (match look_for with + | Some prefix -> `String prefix ); + ( "look-for", + match look_for with | `ML -> `String "implementation" - | `MLI -> `String "interface" - ); - "position", mk_position pos; - ] + | `MLI -> `String "interface" ); + ("position", mk_position pos) + ] | Jump (target, pos) -> - mk "jump" [ - "target", `String target; - "position", mk_position 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; - ] + 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 - ] + mk "construct" + [ ("position", mk_position pos); + ( "with_values", + match with_values with + | Some `None | None -> `String "none" + | Some `Local -> `String "local" ); + ("depth", `Int depth) + ] | Inlay_hints (start, stop, hint_let_binding, hint_pattern_var, ghost) -> - mk "inlay-hints" [ - "start", mk_position start; - "stop", mk_position stop; - "hint-let-binding", `Bool hint_let_binding; - "hint-pattern-variable", `Bool hint_pattern_var; - "avoid-ghost-location", `Bool ghost - ] + mk "inlay-hints" + [ ("start", mk_position start); + ("stop", mk_position stop); + ("hint-let-binding", `Bool hint_let_binding); + ("hint-pattern-variable", `Bool hint_pattern_var); + ("avoid-ghost-location", `Bool ghost) + ] | Outline -> mk "outline" [] | Errors { lexing; parsing; typing } -> let args = - if lexing && parsing && typing - then [] - else [ - "lexing", `Bool lexing; - "parsing", `Bool parsing; - "typing", `Bool typing; - ] + 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 - ] + | 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) - ] + 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) - ] + 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 + mk "extension-list" + [ ( "filter", + match status with | `All -> `String "all" | `Enabled -> `String "enabled" - | `Disabled -> `String "disabled" - ); - ] + | `Disabled -> `String "disabled" ) + ] | Path_list var -> - mk "path-list" [ - "variable", (match var with + mk "path-list" + [ ( "variable", + match var with | `Build -> `String "build" - | `Source -> `String "source" - ); - ] + | `Source -> `String "source" ) + ] | Polarity_search (query, pos) -> - mk "polarity-search" [ - "query", `String query; - "position", mk_position pos; - ] + mk "polarity-search" + [ ("query", `String query); ("position", mk_position pos) ] | Occurrences (`Ident_at pos, scope) -> - mk "occurrences" [ - "kind", `String "identifiers"; - "position", mk_position pos; - "scope", (match scope with - | `Buffer -> `String "local" - | `Project -> `String "project" - ) - ] + mk "occurrences" + [ ("kind", `String "identifiers"); + ("position", mk_position pos); + ( "scope", + match scope with + | `Buffer -> `String "local" + | `Project -> `String "project" ) + ] | Refactor_open (action, pos) -> - mk "refactor-open" [ - "action", `String (match action with `Qualify -> "qualify" - | `Unqualify -> "unqualify"); - "position", mk_position pos; - ] - | Signature_help {position;_} -> - mk "signature-help" [ - "position", mk_position position - ] + mk "refactor-open" + [ ( "action", + `String + (match action with + | `Qualify -> "qualify" + | `Unqualify -> "unqualify") ); + ("position", mk_position pos) + ] + | Signature_help { position; _ } -> + mk "signature-help" [ ("position", mk_position position) ] | Version -> mk "version" [] let string_of_completion_kind = function - | `Value -> "Value" - | `Variant -> "Variant" + | `Value -> "Value" + | `Variant -> "Variant" | `Constructor -> "Constructor" - | `Label -> "Label" - | `Module -> "Module" - | `Modtype -> "Signature" - | `Type -> "Type" - | `Method -> "Method" - | `MethodCall -> "#" - | `Exn -> "Exn" - | `Class -> "Class" - | `Keyword -> "Keyword" + | `Label -> "Label" + | `Module -> "Module" + | `Modtype -> "Signature" + | `Type -> "Type" + | `Method -> "Method" + | `MethodCall -> "#" + | `Exn -> "Exn" + | `Class -> "Class" + | `Keyword -> "Keyword" -let with_location ?(with_file=false) ?(skip_none=false) loc assoc = +let with_location ?(with_file = false) ?(skip_none = false) loc assoc = let with_file l = if not with_file then l else ("file", `String loc.Location.loc_start.pos_fname) :: l in - if skip_none && loc = Location.none then - `Assoc assoc + if skip_none && loc = Location.none then `Assoc assoc else - `Assoc ( with_file @@ - ("start", Lexing.json_of_position loc.Location.loc_start) :: - ("end", Lexing.json_of_position loc.Location.loc_end) :: - assoc ) + `Assoc + (with_file + @@ ("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 +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") - ] + | `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 = @@ -276,211 +247,214 @@ let json_of_error (error : Location.error) = Location.print_sub_msg Format.str_formatter sub; String.trim (Format.flush_str_formatter ()) in - with_location ~skip_none:true loc ["message", `String msg] + 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 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.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" + 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" + | 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 - 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_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 +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]) - ] + | `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 - ] + 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); - ] + 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) + `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] + `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_inlay_hints hints = let json_of_hint (position, label) = - `Assoc [ - "pos", Lexing.json_of_position position; - "label", `String label - ] - in `List (List.map ~f:json_of_hint hints) + `Assoc + [ ("pos", Lexing.json_of_position position); ("label", `String label) ] + in + `List (List.map ~f:json_of_hint hints) let json_of_signature_help resp = let param { label_start; label_end } = - `Assoc ["label", `List [`Int label_start; `Int label_end]] in + `Assoc [ ("label", `List [ `Int label_start; `Int label_end ]) ] + in match resp with | None -> `Assoc [] | Some { label; parameters; active_param; active_signature } -> let signature = `Assoc - ["label", `String label; - "parameters", `List (List.map ~f:param parameters);] in + [ ("label", `String label); + ("parameters", `List (List.map ~f:param parameters)) + ] + in `Assoc - ["signatures", `List [signature]; - "activeParameter", `Int active_param; - "activeSignature", `Int active_signature; + [ ("signatures", `List [ signature ]); + ("activeParameter", `Int active_param); + ("activeSignature", `Int active_signature) ] let json_of_response (type a) (query : a t) (response : a) : json = - match query, response with + match (query, response) with | Type_expr _, str -> `String str - | Type_enclosing _, results -> - `List (List.map ~f:json_of_type_loc results) + | 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 + | 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 - | Syntax_document _, resp -> - (match resp with + `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 + | Syntax_document _, resp -> ( + match resp with | `Found info -> `Assoc - [ - ("name", `String info.name); - ("description", `String info.description); - ("url", `String info.documentation); - ] + [ ("name", `String info.name); + ("description", `String info.description); + ("url", `String info.documentation) + ] | `No_documentation -> `String "No documentation found") | Expand_ppx _, resp -> - let str = match resp with - | `Found ppx_info -> - `Assoc - [ - ("code", `String ppx_info.code); - ("deriver", `Assoc [ - ("start", Lexing.json_of_position ppx_info.attr_start); - ("end", Lexing.json_of_position ppx_info.attr_end); - ]) - ] - | `No_ppx -> `String "No PPX deriver/extension node found on this position" - in str + let str = + match resp with + | `Found ppx_info -> + `Assoc + [ ("code", `String ppx_info.code); + ( "deriver", + `Assoc + [ ("start", Lexing.json_of_position ppx_info.attr_start); + ("end", Lexing.json_of_position ppx_info.attr_end) + ] ) + ] + | `No_ppx -> + `String "No PPX deriver/extension node found on this position" + in + str | 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) -> + | 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 ; - ] + `Assoc + [ ("start", Lexing.json_of_position loc_start); + ("end", Lexing.json_of_position loc_end) + ] in - `List [ assoc ; `String str ] + `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) -> + `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 ; - ] + `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) - | Inlay_hints _, result -> - json_of_inlay_hints result - | Errors _, errors -> - `List (List.map ~f:json_of_error errors) + `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) + | Inlay_hints _, result -> json_of_inlay_hints result + | 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) @@ -489,8 +463,6 @@ let json_of_response (type a) (query : a t) (response : a) : json = | Path_list _, strs -> `List (List.map ~f:Json.string strs) | Occurrences (_, scope), (locations, _) -> let with_file = scope = `Project in - `List (List.map locations - ~f:(fun loc -> with_location ~with_file loc [])) + `List (List.map locations ~f:(fun loc -> with_location ~with_file loc [])) | Signature_help _, s -> json_of_signature_help s - | Version, version -> - `String version + | Version, version -> `String version diff --git a/src/config/gen_config.ml b/src/config/gen_config.ml index 9919271aa3..806b6f30ea 100644 --- a/src/config/gen_config.ml +++ b/src/config/gen_config.ml @@ -1,16 +1,14 @@ let ocaml_version_val = match - Scanf.sscanf Sys.argv.(1) "%s@.%s@.%d" (fun maj min p -> maj, min, p) + 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 + | "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 {| + Printf.printf + {| let version = "%%VERSION%%" let ocamlversion : [ `OCaml_4_02_0 | `OCaml_4_02_1 | `OCaml_4_02_2 | `OCaml_4_02_3 @@ -18,4 +16,5 @@ let ocamlversion : | `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 +|} + ocaml_version_val diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index d5c3e26c1d..e219bbf22b 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2019 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -32,126 +32,117 @@ open Std open Std.Result let findlib_ok = - try - Ok (Findlib.init ()) + try Ok (Findlib.init ()) with exn -> - let message = match exn with + 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" - | _ -> () + 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" +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; -} +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:"SOURCE_ROOT " line then - tell (`SOURCE_ROOT (String.drop 12 line)) - else if String.is_prefixed ~by:"UNIT_NAME " line then - tell (`UNIT_NAME (String.drop 10 line)) - else if String.is_prefixed ~by:"WRAPPING_PREFIX " line then - tell (`WRAPPING_PREFIX (String.drop 16 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:"USE_PPX_CACHE" line then - tell `USE_PPX_CACHE - else if String.is_prefixed ~by:"#" line then - () - else - tell (`UNKNOWN_TAG (String.split_on_char ~sep:' ' line |> List.hd)); - aux () - in + 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:"SOURCE_ROOT " line then + tell (`SOURCE_ROOT (String.drop 12 line)) + else if String.is_prefixed ~by:"UNIT_NAME " line then + tell (`UNIT_NAME (String.drop 10 line)) + else if String.is_prefixed ~by:"WRAPPING_PREFIX " line then + tell (`WRAPPING_PREFIX (String.drop 16 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:"USE_PPX_CACHE" line then + tell `USE_PPX_CACHE + else if String.is_prefixed ~by:"#" line then () + else tell (`UNKNOWN_TAG (String.split_on_char ~sep:' ' line |> List.hd)); 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) + 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 + 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 + 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 + 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 when Hashtbl.mem marked x -> process acc rest | x :: rest -> Hashtbl.add marked x (); let file = Cache.read x in @@ -160,24 +151,24 @@ let directives_of_files filenames = List.map ~f:(canonicalize_filename ~cwd:dir) file.includes @ rest in let rest = - if file.recurse then ( + if file.recurse then let dir = - if Filename.basename file.path <> ".merlin" - then dir else Filename.dirname 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 + else rest in process (file :: acc) rest | [] -> List.rev acc in process [] filenames -let ppx_of_package ?(predicates=[]) setup pkg = +let ppx_of_package ?(predicates = []) setup pkg = let d = Findlib.package_directory pkg in (* Determine the 'ppx' property: *) let in_words ~comma s = @@ -186,74 +177,79 @@ let ppx_of_package ?(predicates=[]) setup pkg = 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 ',' || comma -> + if i < j then String.sub s ~pos:i ~len:(j - i) :: split (j + 1) (j + 1) + else split (j + 1) (j + 1) + | _ -> split i (j + 1) + else if i < j then [ String.sub s ~pos:i ~len:(j - i) ] + else [] in split 0 0 in let resolve_path = Findlib.resolve_path ~base:d ~explicit:true in let ppx = - try Some(resolve_path (Findlib.package_property predicates pkg "ppx")) + try Some (resolve_path (Findlib.package_property predicates pkg "ppx")) with Not_found -> 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 + 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 + begin + match ppx with | None -> () | Some ppx -> log ~title:"ppx" "%s" ppx end; - begin match ppxopts with + 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)] + 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 + 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) + 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" -> ";" - | _ -> ":" + | "Cygwin" | "Win32" -> ";" + | _ -> ":" let set_findlib_path = - let findlib_cache = ref ("",[],"") in - fun ?(conf="") ?(path=[]) ?(toolchain="") () -> - let key = (conf,path,toolchain) in + 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 + let env_ocamlpath = + match path with | [] -> None | path -> Some (String.concat ~sep:path_separator path) - and config = match conf with + and config = + match conf with | "" -> None | s -> Some s - and toolchain = match toolchain with + 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); + conf + (String.concat ~sep:path_separator path); Findlib.init ?env_ocamlpath ?config ?toolchain (); findlib_cache := key end @@ -268,122 +264,121 @@ let is_package_optional name = 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 + 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) + 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 - ) + 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] + | 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 + | packages -> (packages, failures) | exception exn -> - [], (sprintf "Findlib failure: %S" (Printexc.to_string exn) :: failures) + ([], 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; - source_root : 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; - source_root = None; - packages_to_load = []; - findlib = None; - findlib_path = []; - findlib_toolchain = None; -} + (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; + source_root : 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; + source_root = 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 - | `USE_PPX_CACHE - | `UNIT_NAME _ - | `WRAPPING_PREFIX _ - | `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 } - | `SOURCE_ROOT path -> - let canon_path = canonicalize_filename ~cwd path in - { cfg with source_root = 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; _ } = + 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 + | `USE_PPX_CACHE + | `UNIT_NAME _ + | `WRAPPING_PREFIX _ + | `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 } + | `SOURCE_ROOT path -> + let canon_path = canonicalize_filename ~cwd path in + { cfg with source_root = 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 + name <> "" && name.[0] <> '.' && try Sys.is_directory path with _ -> false in fun ~stdlib dir path -> let path = expand_directory stdlib path in @@ -398,16 +393,14 @@ module Import_from_dune = struct for i = 0 to len - 1 do if unsafe_get s i = c then incr n done; - if !n = 0 then - s + 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 - ); + incr n); Bytes.unsafe_set b !n (unsafe_get s i); incr n done; @@ -418,19 +411,10 @@ module Import_from_dune = struct len = 0 || let rec loop i = - if i = len then - false + if i = len then false else match s.[i] with - | ' ' - | '\"' - | '(' - | ')' - | '{' - | '}' - | ';' - | '#' -> - true + | ' ' | '\"' | '(' | ')' | '{' | '}' | ';' | '#' -> true | _ -> loop (i + 1) in loop 0 @@ -442,13 +426,9 @@ module Import_from_dune = struct protected by single quotes). It is only a problem on windows because Filename.quote is using double quotes. *) escape_only '\\' s - else - s + else s in - if need_quoting s then - Filename.quote s - else - s + if need_quoting s then Filename.quote s else s end let postprocess cfg = @@ -458,40 +438,42 @@ let postprocess cfg = match Ppxsetup.command_line ppxsetup with | [] -> [] | lst -> - let cmd = List.concat_map lst ~f:(fun pp -> ["-ppx"; pp]) - in - [ `FLG cmd] + 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) - ; cfg.stdlib |> Option.map ~f:(fun stdlib -> `STDLIB stdlib) |> Option.to_list - ; List.concat_map pkg_paths ~f:(fun p -> [ `B p; `S p ]) - ; ppx - ; List.map failures ~f:(fun s -> `ERROR_MSG s) + 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); + cfg.stdlib + |> Option.map ~f:(fun stdlib -> `STDLIB stdlib) + |> Option.to_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) + 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 + match (cfg.packages_to_load, findlib_ok) with | [], _ | _, Ok _ -> directives - | _, Error msg -> (`ERROR_MSG msg) :: directives + | _, Error msg -> `ERROR_MSG msg :: directives -let dot_merlin_file = Filename.concat (Sys.getcwd ()) ".merlin" +let dot_merlin_file = Filename.concat (Sys.getcwd ()) ".merlin" let rec main () = let open Merlin_dot_protocol.Blocking in diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 181175cca7..df885ac521 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2019 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -49,9 +49,7 @@ module Directive = struct module Processed = struct type acceptable_in_input = [ include_path | no_processing_required ] - type t = - [ acceptable_in_input - | `ERROR_MSG of string ] + type t = [ acceptable_in_input | `ERROR_MSG of string ] end module Raw = struct @@ -72,36 +70,40 @@ module Sexp = struct 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) + 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;[")"]]) + | 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 - | "SOURCE_ROOT" -> `SOURCE_ROOT value - | "UNIT_NAME" -> `UNIT_NAME value - | "WRAPPING_PREFIX" -> `WRAPPING_PREFIX 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; Atom value ] -> begin + match tag with + | "S" -> `S value + | "B" -> `B value + | "CMI" -> `CMI value + | "CMT" -> `CMT value + | "STDLIB" -> `STDLIB value + | "SOURCE_ROOT" -> `SOURCE_ROOT value + | "UNIT_NAME" -> `UNIT_NAME value + | "WRAPPING_PREFIX" -> `WRAPPING_PREFIX 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 + let value = strings_of_atoms l in + begin + match tag with | "EXT" -> `EXT value | "FLG" -> `FLG value | "READER" -> `READER value @@ -131,8 +133,8 @@ module Sexp = struct | `READER ss -> ("READER", [ List (atoms_of_strings ss) ]) | `EXCLUDE_QUERY_DIR -> ("EXCLUDE_QUERY_DIR", []) | `USE_PPX_CACHE -> ("USE_PPX_CACHE", []) - | `UNKNOWN_TAG tag -> ("ERROR", single @@ - Printf.sprintf "Unknown tag in .merlin: %s" tag) + | `UNKNOWN_TAG tag -> + ("ERROR", single @@ Printf.sprintf "Unknown tag in .merlin: %s" tag) | `ERROR_MSG s -> ("ERROR", single s) in List (Atom tag :: body) @@ -140,9 +142,7 @@ module Sexp = struct List (List.map ~f directives) end -type read_error = - | Unexpected_output of string - | Csexp_parse_error of string +type read_error = Unexpected_output of string | Csexp_parse_error of string type command = File of string | Halt | Unknown @@ -192,13 +192,13 @@ struct let open IO.O in let+ input = Chan.read chan in match input with - | Ok (List [Atom "File"; Atom path]) -> File path + | Ok (List [ Atom "File"; Atom path ]) -> File path | Ok (Atom "Halt") -> Halt | Ok _ -> Unknown | Error _ -> Halt let send_file chan path = - Chan.write chan Sexp.(List [Atom "File"; Atom path]) + Chan.write chan Sexp.(List [ Atom "File"; Atom path ]) let halt chan = Chan.write chan (Sexp.Atom "Halt") end @@ -221,9 +221,12 @@ struct end module Blocking = - Make (struct + Make + (struct type 'a t = 'a - module O = struct let ( let+ ) x f = f x end + module O = struct + let ( let+ ) x f = f x + end end) (struct type in_chan = in_channel diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index 1b96bf2f2c..0441ead7be 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -1,45 +1,45 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2019 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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. + 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. *) + 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 = @@ -61,9 +61,7 @@ module Directive : sig module Processed : sig type acceptable_in_input = [ include_path | no_processing_required ] - type t = - [ acceptable_in_input - | `ERROR_MSG of string ] + type t = [ acceptable_in_input | `ERROR_MSG of string ] end module Raw : sig @@ -78,9 +76,7 @@ end type directive = Directive.Processed.t -type read_error = - | Unexpected_output of string - | Csexp_parse_error of string +type read_error = Unexpected_output of string | Csexp_parse_error of string type command = File of string | Halt | Unknown @@ -120,12 +116,14 @@ end) (Chan : sig val read : in_chan -> (Csexp.t, string) result IO.t val write : out_chan -> Csexp.t -> unit IO.t -end) : S - with type 'a io = 'a IO.t - and type in_chan = Chan.in_chan - and type out_chan = Chan.out_chan - -module Blocking : S - with type 'a io = 'a - and type in_chan = in_channel - and type out_chan = out_channel +end) : + S + with type 'a io = 'a IO.t + and type in_chan = Chan.in_chan + and type out_chan = Chan.out_chan + +module Blocking : + S + with type 'a io = 'a + and type in_chan = in_channel + and type out_chan = out_channel diff --git a/src/extend/extend_driver.ml b/src/extend/extend_driver.ml index 076621a414..d2b6ff94a0 100644 --- a/src/extend/extend_driver.ml +++ b/src/extend/extend_driver.ml @@ -2,20 +2,19 @@ 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; -} +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 run ?(notify = ignore) ?(debug = ignore) name = let pstdin, stdin = Unix.pipe () in let stdout, pstdout = Unix.pipe () in Unix.set_close_on_exec pstdin; @@ -23,16 +22,14 @@ let run ?(notify=ignore) ?(debug=ignore) name = Unix.set_close_on_exec pstdout; Unix.set_close_on_exec stdout; let pid = - Unix.create_process - ("ocamlmerlin-" ^ name) [||] - pstdin pstdout Unix.stderr + 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 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} + | capabilities -> { name; capabilities; stdin; stdout; pid; notify; debug } | exception exn -> close_out_noerr stdin; close_in_noerr stdout; @@ -41,10 +38,9 @@ let run ?(notify=ignore) ?(debug=ignore) name = let stop t = close_out_noerr t.stdin; close_in_noerr t.stdout; - if t.pid <> -1 then ( + if t.pid <> -1 then let _, _ = Unix.waitpid [] t.pid in - t.pid <- -1; - ) + t.pid <- -1 let capabilities t = t.capabilities @@ -55,12 +51,15 @@ let reader t 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.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 + | P.Reader_response response -> response in aux () diff --git a/src/extend/extend_driver.mli b/src/extend/extend_driver.mli index baf7f6ed4d..a87fb391b4 100644 --- a/src/extend/extend_driver.mli +++ b/src/extend/extend_driver.mli @@ -11,6 +11,4 @@ val stop : t -> unit val capabilities : t -> capabilities -val reader : t -> - Reader.request -> - Reader.response +val reader : t -> Reader.request -> Reader.response diff --git a/src/extend/extend_helper.ml b/src/extend/extend_helper.ml index 8aedb35cd7..8c751d3ee2 100644 --- a/src/extend/extend_helper.ml +++ b/src/extend/extend_helper.ml @@ -4,16 +4,15 @@ open Parsetree 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)), [] - ); - }] + 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. @@ -37,8 +36,6 @@ let syntax_error msg loc : extension = 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. @@ -72,12 +69,12 @@ let focus_node : attribute = (* Projections for merlin attributes and extensions *) -let classify_extension (id, _ : extension) : [`Other | `Syntax_error] = +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 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 @@ -85,18 +82,20 @@ let classify_attribute attr : [`Other | `Relaxed_location | `Hide | `Focus] = | "merlin.focus" -> `Focus | _ -> `Other -let extract_syntax_error (id, payload : extension) : string * Location.t = +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 + "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 + (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 + | { Location.txt = "merlin.relaxed-location"; loc }, _ -> loc | _ -> invalid_arg "Merlin_extend.Reader_helper.extract_relaxed_location" diff --git a/src/extend/extend_helper.mli b/src/extend/extend_helper.mli index 3488b4f58f..638ce64332 100644 --- a/src/extend/extend_helper.mli +++ b/src/extend/extend_helper.mli @@ -55,12 +55,11 @@ val focus_node : attribute (* Projections for merlin attributes and extensions *) -val classify_extension : extension -> - [`Other | `Syntax_error] +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 classify_attribute : + attribute -> [ `Other | `Relaxed_location | `Hide | `Focus ] val extract_relaxed_location : attribute -> Location.t diff --git a/src/extend/extend_main.ml b/src/extend/extend_main.ml index d7363d674f..b09505bb11 100644 --- a/src/extend/extend_main.ml +++ b/src/extend/extend_main.ml @@ -4,7 +4,7 @@ module R = P.Reader module Description = struct type t = P.description - let make_v0 ~name ~version = { P. name; version } + let make_v0 ~name ~version = { P.name; version } end module Reader = struct @@ -12,7 +12,6 @@ module Reader = struct let make_v0 (x : (module R.V0)) : t = x module Make (V : R.V0) = struct - open P.Reader let buffer = ref None @@ -26,8 +25,7 @@ module Reader = struct | Req_load buf -> buffer := Some (V.load buf); Res_loaded - | Req_parse -> - Res_parse (V.parse (get_buffer ())) + | 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 -> @@ -45,12 +43,10 @@ module Reader = struct | 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 @@ -63,12 +59,9 @@ module Utils = struct List.iter really_send postponed' in let send msg = - if !is_ready then - really_send msg - else - postponed := msg :: !postponed + if !is_ready then really_send msg else postponed := msg :: !postponed in - send, set_ready + (send, set_ready) let notify msg = send (P.Notify msg) let debug msg = send (P.Debug msg) @@ -77,21 +70,22 @@ 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) = + 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; @@ -108,26 +102,25 @@ module Handshake = struct let () = Printexc.register_printer (function - | Error msg -> - Some (Printf.sprintf "Extend_main.Handshake.Error %S" msg) - | _ -> None - ) + | 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) - ); + (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) + 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 @@ -137,31 +130,31 @@ module Handshake = struct 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 + 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; - | _ -> () + 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") + 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 + let module M = Reader.Make (R) in M.exec in let respond f = diff --git a/src/extend/extend_main.mli b/src/extend/extend_main.mli index 05020198cc..c33ff2ee77 100644 --- a/src/extend/extend_main.mli +++ b/src/extend/extend_main.mli @@ -18,12 +18,12 @@ 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; - } + type versions = + { ast_impl_magic_number : string; + ast_intf_magic_number : string; + cmi_magic_number : string; + cmt_magic_number : string + } exception Error of string diff --git a/src/extend/extend_protocol.ml b/src/extend/extend_protocol.ml index b7c522dc3f..835cec4331 100644 --- a/src/extend/extend_protocol.ml +++ b/src/extend/extend_protocol.ml @@ -1,56 +1,49 @@ module Reader = struct - (** Description of a buffer managed by Merlin *) - type buffer = { - - path : string; - (** Path of the buffer in the editor. + 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 *) - } + 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 *) - + (** An implementation, usually coming from a .ml file *) | Signature of Parsetree.signature - (** An interface, usually coming from a .mli file *) + (** 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_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 + | 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 + | 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. *) - } + 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. @@ -126,24 +119,16 @@ module Reader = struct | 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; -} +type description = { name : string; version : string } (* Services an extension can provide *) -type capabilities = { - reader: bool; -} +type capabilities = { reader : bool } (* Main protocol *) -type request = - | Start_communication - | Reader_request of Reader.request +type request = Start_communication | Reader_request of Reader.request type response = | Notify of string diff --git a/src/frontend/ocamlmerlin/gen_ccflags.ml b/src/frontend/ocamlmerlin/gen_ccflags.ml index 5095258401..5bbf386b2a 100644 --- a/src/frontend/ocamlmerlin/gen_ccflags.ml +++ b/src/frontend/ocamlmerlin/gen_ccflags.ml @@ -1,12 +1,11 @@ -let ccomp_type = Sys.argv.(1) -let pre_flags_f = Sys.argv.(2) +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", "" + ("/Fe", "advapi32.lib") + else ("-o", "") let write_lines f s = let oc = open_out f in diff --git a/src/frontend/ocamlmerlin/log_info.ml b/src/frontend/ocamlmerlin/log_info.ml index 94e5923b2a..558f666d47 100644 --- a/src/frontend/ocamlmerlin/log_info.ml +++ b/src/frontend/ocamlmerlin/log_info.ml @@ -1,8 +1,8 @@ -let get () = - let log_file, sections = +let get () = + let log_file, sections = match String.split_on_char ',' (Sys.getenv "MERLIN_LOG") with - | (value :: sections) -> (Some value, sections) + | 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 + in + (`Log_file_path log_file, `Log_sections sections) diff --git a/src/frontend/ocamlmerlin/log_info.mli b/src/frontend/ocamlmerlin/log_info.mli index c74beb9222..d93236fc66 100644 --- a/src/frontend/ocamlmerlin/log_info.mli +++ b/src/frontend/ocamlmerlin/log_info.mli @@ -1,2 +1,2 @@ -val get : - unit -> [`Log_file_path of string option] * [`Log_sections of string list] +val get : + unit -> [ `Log_file_path of string option ] * [ `Log_sections of string list ] diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 6139a201a3..78e13d9c34 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/src/frontend/ocamlmerlin/new/new_merlin.ml @@ -1,6 +1,6 @@ (** {1 Prepare command-line arguments} *) -let {Logger. log} = Logger.for_section "New_merlin" +let { Logger.log } = Logger.for_section "New_merlin" let usage () = prerr_endline @@ -14,32 +14,38 @@ let usage () = let commands_help () = print_endline "Query commands are:"; - List.iter (fun (New_commands.Command (name, doc, args, _, _)) -> + 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 = + 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 + 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 + print_endline doc) + New_commands.all_commands let run = let query_num = ref (-1) in @@ -63,99 +69,112 @@ let run = | "-commands-help" :: _ -> commands_help (); 0 - | query :: raw_args -> + | query :: raw_args -> ( incr query_num; 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) -> + | 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 + match + begin + let start_cpu = Misc.time_spent () in + let start_clock = Unix.gettimeofday () *. 1000. 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 + 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 - let config = - let failures = !fails @ config.merlin.failures in - Mconfig.({config with merlin = {config.merlin with failures}}) + (* Start processing query *) + Logger.with_log_file + Mconfig.(config.merlin.log_file) + ~sections:Mconfig.(config.merlin.log_sections) + @@ fun () -> + Mocaml.flush_caches + ~older_than: + (float_of_int (60 * Mconfig.(config.merlin.cache_lifespan))) + (); + 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 gc_stats = Gc.quick_stat () in + let heap_mbytes = + gc_stats.heap_words * (Sys.word_size / 8) / 1_000_000 + 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)); + ("heap_mbytes", `Int heap_mbytes); + ("cache", Mpipeline.cache_information pipeline); + ("query_num", `Int !query_num) + ] in - config, command_args - in - (* Start processing query *) - Logger.with_log_file Mconfig.(config.merlin.log_file) - ~sections:Mconfig.(config.merlin.log_sections) @@ fun () -> - Mocaml.flush_caches - ~older_than:(float_of_int (60 * Mconfig.(config.merlin.cache_lifespan))) (); - 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 gc_stats = Gc.quick_stat () in - let heap_mbytes = gc_stats.heap_words * (Sys.word_size / 8) / 1_000_000 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); - "heap_mbytes", `Int heap_mbytes; - "cache", Mpipeline.cache_information pipeline; - "query_num", `Int !query_num; - ] - 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 + 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 + 1)) let with_wd ~wd ~old_wd f args = match Sys.chdir wd with @@ -163,24 +182,25 @@ let with_wd ~wd ~old_wd f args = log ~title:"run" "changed directory to %S (old wd: %S)" wd old_wd; Fun.protect ~finally:(fun () -> Sys.chdir old_wd) (fun () -> f args) | exception Sys_error _ -> - log ~title:"run" "cannot change working directory to %S (old wd: %S)" - wd old_wd; + log ~title:"run" "cannot change working directory to %S (old wd: %S)" wd + old_wd; f args 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; + 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 old_wd = Sys.getcwd () in - let run args () = match wd with + let run args () = + match wd with | Some wd -> with_wd ~wd ~old_wd run args | None -> log ~title:"run" "No working directory specified (old wd: %S)" old_wd; run args in - let `Log_file_path log_file, `Log_sections sections = - Log_info.get () - in + let `Log_file_path log_file, `Log_sections sections = Log_info.get () in Logger.with_log_file log_file ~sections @@ run args diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml index 56b967a9a4..5fb565b79d 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml @@ -1,15 +1,13 @@ let merlin_timeout = - try float_of_string (Sys.getenv "MERLIN_TIMEOUT") - with _ -> 600.0 + 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 + | exception Unix.Unix_error (Unix.EINTR, _, _) -> protect_eintr f | result -> result - let process_request {Os_ipc. wd; environ; argv; context = _} = + 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 @@ -27,15 +25,13 @@ module Server = struct close_with (-1); raise Exit | exception exn -> - Logger.log ~section:"server" ~title:"process failed" "%a" - Logger.exn exn; + Logger.log ~section:"server" ~title:"process failed" "%a" Logger.exn exn; close_with (-1) let server_accept merlinid server = let rec loop total = let merlinid' = File_id.get Sys.executable_name in - if total > merlin_timeout || - not (File_id.check merlinid merlinid') then + 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 @@ -49,7 +45,8 @@ module Server = struct let rec loop merlinid server = match server_accept merlinid server with - | None -> (* Timeout *) + | None -> + (* Timeout *) () | Some client -> let continue = @@ -61,8 +58,7 @@ module Server = struct 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" "" + | None -> Logger.log ~section:"server" ~title:"cannot setup listener" "" | Some server -> (* If the client closes its connection, don't let it kill us with a SIGPIPE. *) if Sys.unix then Sys.set_signal Sys.sigpipe Sys.Signal_ignore; @@ -76,16 +72,16 @@ let main () = 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 + | [ "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\ + 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" @@ -94,7 +90,5 @@ let main () = let () = Lib_config.Json.set_pretty_to_string Yojson.Basic.pretty_to_string; - let `Log_file_path log_file, `Log_sections sections = - Log_info.get () - in + let `Log_file_path log_file, `Log_sections sections = Log_info.get () in Logger.with_log_file log_file ~sections main diff --git a/src/frontend/ocamlmerlin/old/old_IO.ml b/src/frontend/ocamlmerlin/old/old_IO.ml index 1cf3422098..1ef04be4e8 100644 --- a/src/frontend/ocamlmerlin/old/old_IO.ml +++ b/src/frontend/ocamlmerlin/old/old_IO.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -32,8 +32,10 @@ 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} + { Old_protocol.Context.document = None; + printer_width = None; + printer_verbosity = None + } let invalid_arguments () = failwith "invalid arguments" @@ -44,34 +46,39 @@ 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) + | `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 + with Not_found -> failwith "Incorrect position" + end | _ -> failwith "Incorrect position" let mandatory_position = function - | [`String "at"; jpos] -> pos_of_json jpos + | [ `String "at"; jpos ] -> pos_of_json jpos | _ -> invalid_arguments () let optional_string = function - | [`String name] -> Some name + | [ `String name ] -> Some name | [] -> None | _ -> invalid_arguments () let string_list l = - List.map ~f:(function `String s -> s | _ -> invalid_arguments ()) l + List.map + ~f:(function + | `String s -> s + | _ -> invalid_arguments ()) + l let source_or_build = function | "source" -> `Source - | "build" -> `Build + | "build" -> `Build | _ -> invalid_arguments () let ml_or_mli = function | "ml" -> `ML - | "mli" -> `MLI + | "mli" -> `MLI | _ -> invalid_arguments () let auto_ml_or_mli = function @@ -79,21 +86,20 @@ let auto_ml_or_mli = function | x -> ml_or_mli x let add_or_remove = function - | "add" -> `Add + | "add" -> `Add | "remove" -> `Rem | _ -> invalid_arguments () -let with_failures failures assoc = match failures with +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) -> + 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 - ) + | Arg.Bad _ -> (str :: flgs, exts) + | Extension.Unknown -> (flgs, str :: exts) + | _ -> assert false) in let flags = match flags with @@ -113,171 +119,182 @@ let with_failures failures assoc = match failures with let document_of_json = let make kind path dot_merlins = - {Context.dot_merlins; - kind = auto_ml_or_mli kind; - path = optional_string path; + { 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 () + 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), `Buffer))) - | (`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 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), `Buffer))) + | `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 +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_get, flags -> `List (List.map ~f:Json.string flags) | Flags_set _, failures -> - `Assoc (with_failures failures ["result", `Bool true]) + `Assoc (with_failures failures [ ("result", `Bool true) ]) | Findlib_use _, failures -> - `Assoc (with_failures failures ["result", `Bool true]) + `Assoc (with_failures failures [ ("result", `Bool true) ]) | Extension_set _, failures -> - `Assoc (with_failures failures ["result", `Bool true]) + `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 - ] + `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)] + 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) + `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 + | 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) + | 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] + `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); - ] + `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 @@ -289,59 +306,56 @@ let request_of_json = function 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) + 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_string_option in - let context = {Context. document; printer_verbosity; printer_width} in + let printer_verbosity = + member "printer_verbosity" json |> to_string_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 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 + 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 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 = 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 + (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 + match begin - try Some (Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o600) - with - | Unix.Unix_error _ -> + 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) + 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 + 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 @@ -354,12 +368,9 @@ let make_sexp ?on_read ~input ~output () = 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') + 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 + if Buffer.length buf > 100_000 then Buffer.reset buf else Buffer.clear buf in - input', output + (input', output) diff --git a/src/frontend/ocamlmerlin/old/old_IO.mli b/src/frontend/ocamlmerlin/old/old_IO.mli index dbf9cf38b0..2c92b90cba 100644 --- a/src/frontend/ocamlmerlin/old/old_IO.mli +++ b/src/frontend/ocamlmerlin/old/old_IO.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -35,15 +35,19 @@ val current_version : Old_protocol.protocol_version ref 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) +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/src/frontend/ocamlmerlin/old/old_command.ml b/src/frontend/ocamlmerlin/old/old_command.ml index ca0751687d..829729315b 100644 --- a/src/frontend/ocamlmerlin/old/old_command.ml +++ b/src/frontend/ocamlmerlin/old/old_command.ml @@ -1,114 +1,113 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 +type customization = + [ `Ext of [ `Enabled | `Disabled ] * string | `Flags of string list | `Use of string list - | `Path of [`Build | `Source] * [`Add | `Rem] * 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}}; + { 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}}; + { 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 + 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 + 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} + | `Build -> { merlin with build_path = f merlin.build_path } + | `Source -> { merlin with source_path = f merlin.source_path } in - {config with merlin} - + { config with merlin } -type buffer = { - path: string option; - dot_merlins: string list option; - mutable customization : customization list; - mutable source : Msource.t; -} +type buffer = + { path : string option; + dot_merlins : string list option; + mutable customization : customization list; + mutable source : Msource.t + } -type state = { - mutable buffer : buffer; -} +type state = { mutable buffer : buffer } -let normalize_document doc = - doc.Context.path, doc.Context.dot_merlins +let normalize_document doc = (doc.Context.path, doc.Context.dot_merlins) let new_buffer (path, dot_merlins) = - { path; dot_merlins; customization = []; - source = Msource.make "" } + { 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 = + { 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... *) + | Some (first :: _) -> + (* ignore anything but the first one... *) Mconfig.get_external_config first config - | None | Some [] -> + | None | Some [] -> ( match state.path with | None -> config - | Some p -> Mconfig.get_external_config p 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 new_state document = { buffer = new_buffer document } let checkout_buffer_cache = ref [] let checkout_buffer = @@ -118,7 +117,8 @@ let checkout_buffer = try List.assoc document !checkout_buffer_cache with Not_found -> let buffer = new_buffer document in - begin match document with + begin + match document with | Some _, _ -> checkout_buffer_cache := (document, buffer) :: List.take_n cache_size !checkout_buffer_cache @@ -126,118 +126,122 @@ let checkout_buffer = end; buffer -let make_pipeline config buffer = - Mpipeline.make config buffer.source +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; + `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; + `Use packages + :: List.filter + ~f:(function + | `Use _ -> false + | _ -> true) + state.customization; `Ok - - | Extension_set (action,exts) -> + | 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; + 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) -> + | Path (var, _, paths) -> state.customization <- - List.filter_map ~f:(function + 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)) + 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 - + | x -> Some x) + state.customization | Path_reset -> state.customization <- - List.filter ~f:(function | `Path _ -> false - | _ -> true - ) state.customization; - + List.filter + ~f:(function + | `Path _ -> false + | _ -> true) + state.customization | Protocol_version version -> - begin match version with + 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) - + ( `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) + List.concat_map + ~f:(fun f -> f.workval) Mconfig.(config.merlin.flags_to_apply) - | Project_get -> - let failures = match Mconfig.(config.merlin.failures) with + let failures = + match Mconfig.(config.merlin.failures) with | [] -> `Ok - | failures -> `Failures failures in + | 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 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 + let state = + match context.document with | None -> Lazy.force default_state - | Some document -> + | 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 + state) in let config = configure state.buffer in (* Printer verbosity *) - let config = match context.printer_verbosity with + let config = + match context.printer_verbosity with | None -> config | Some verbosity -> let verbosity = Mconfig.Verbosity.of_string verbosity in - Mconfig.({config with query = {config.query with verbosity}}) + Mconfig.{ config with query = { config.query with verbosity } } in - let config = match context.printer_width with + let config = + match context.printer_width with | None -> config | Some printer_width -> - Mconfig.({config with query = {config.query with printer_width}}) + Mconfig.{ config with query = { config.query with printer_width } } in (* Printer width *) Format.default_width := Option.value ~default:0 context.printer_width; diff --git a/src/frontend/ocamlmerlin/old/old_command.mli b/src/frontend/ocamlmerlin/old/old_command.mli index d478106cf1..27537db2d1 100644 --- a/src/frontend/ocamlmerlin/old/old_command.mli +++ b/src/frontend/ocamlmerlin/old/old_command.mli @@ -1,30 +1,30 @@ (* {{{ 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. - -)* }}} *) + 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 diff --git a/src/frontend/ocamlmerlin/old/old_merlin.ml b/src/frontend/ocamlmerlin/old/old_merlin.ml index 6211688020..ae7273bd30 100644 --- a/src/frontend/ocamlmerlin/old/old_merlin.ml +++ b/src/frontend/ocamlmerlin/old/old_merlin.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -32,53 +32,38 @@ 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 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) @@ -100,7 +85,8 @@ let rec merlin_loop input output = let trace = { Logger.section = "backtrace"; msg = Printexc.get_backtrace () } in - output ~notifications:(trace :: List.rev !notifications) + output + ~notifications:(trace :: List.rev !notifications) (Old_protocol.Exception exn); merlin_loop input output | true -> merlin_loop input output @@ -110,31 +96,32 @@ 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 + 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 + 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 + 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 + let input () = + match input () with | None -> None | Some json -> - Logger.log ~section:"frontend" ~title:"input" "%a" - Logger.json (fun () -> 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); + Logger.log ~section:"frontend" ~title:"output" "%a" Logger.json (fun () -> + json); output json in (input, output) diff --git a/src/frontend/ocamlmerlin/old/old_protocol.ml b/src/frontend/ocamlmerlin/old/old_protocol.ml index 96a5f3b117..9ca6b50a62 100644 --- a/src/frontend/ocamlmerlin/old/old_protocol.ml +++ b/src/frontend/ocamlmerlin/old/old_protocol.ml @@ -1,98 +1,87 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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} *) + | `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; - } +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: string option; - } + type t = + { document : document option; + printer_width : int option; + printer_verbosity : string 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 + | 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 + : (string list * [ `Ok | `Failures of string list ]) sync_command -type 'a command = - | Query of 'a Query_protocol.t - | Sync of 'a 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 + | Return : 'a command * 'a -> response + | Failure : string -> response + | Error : Json.t -> response | Exception : exn -> response diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 6d68b5db43..20cf3172dd 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -34,7 +34,7 @@ module Printtyp = Type_utils.Printtyp exception No_nodes let print_completion_entries ~with_types config source entries = - if with_types then + if with_types then ( let input_ref = ref [] and output_ref = ref [] in let preprocess entry = match Completion.raw_info_printer entry with @@ -44,22 +44,22 @@ let print_completion_entries ~with_types config source entries = input_ref := t :: !input_ref; output_ref := r :: !output_ref; `Print r - | `Concat (s,t) -> + | `Concat (s, t) -> let r = ref "" in input_ref := t :: !input_ref; output_ref := r :: !output_ref; - `Concat (s,r) + `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; + List.iter2 ~f:( := ) !output_ref outcomes; let postprocess = function | `String s -> s | `Print r -> !r - | `Concat (s,r) -> s ^ !r + | `Concat (s, r) -> s ^ !r in - List.rev_map ~f:(Completion.map_entry postprocess) entries + List.rev_map ~f:(Completion.map_entry postprocess) entries) else List.rev_map ~f:(Completion.map_entry (fun _ -> "")) entries let for_completion pipeline position = @@ -71,162 +71,160 @@ let verbosity pipeline = Mconfig.((Mpipeline.final_config pipeline).query.verbosity) let dump pipeline = function - | [`String "ppxed-source"] -> + | [ `String "ppxed-source" ] -> let ppf, to_string = Format.to_string () in - begin match Mpipeline.ppx_parsetree pipeline with + 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"] -> + | [ `String "source" ] -> let ppf, to_string = Format.to_string () in - begin match Mpipeline.reader_parsetree pipeline with + 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"] -> + | [ `String "parsetree" ] -> let ppf, to_string = Format.to_string () in - begin match Mpipeline.reader_parsetree pipeline with + 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"] -> + | [ `String "ppxed-parsetree" ] -> let ppf, to_string = Format.to_string () in - begin match Mpipeline.ppx_parsetree pipeline with + 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) -> + | `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 + | [ `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 + 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 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]; + Printtyp.signature ppf [ item ]; `String (to_string ()) in `List (List.map ~f:aux sg) - - | [`String "browse"] -> + | [ `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"] -> + | [ `String "current-level" ] -> let _typer = Mpipeline.typer_result pipeline in `Int (Ctype.get_current_level ()) - - | [`String "tokens"] -> - failwith "TODO" - - | [`String "flags"] -> + | [ `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"] -> + 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"] -> + | [ `String "exn" ] -> let exns = - Mpipeline.reader_lexer_errors pipeline @ - Mpipeline.reader_parser_errors pipeline @ - Mpipeline.typer_errors pipeline + 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"] -> + | [ `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 + | [ `String "typedtree" ] -> + let tree = Mpipeline.typer_result pipeline |> Mtyper.get_typedtree in let ppf, to_string = Format.to_string () in - begin match tree with + 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:})" + | _ -> + 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 + 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))); + 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') + if + dot = "" + || (dot.[0] >= 'a' && dot.[0] <= 'z') + || (dot.[0] >= 'A' && dot.[0] <= 'Z') then dot else "( " ^ dot ^ ")" in - begin match path with + begin + match path with | [] -> [] | base :: tail -> - let f {Location. txt=base; loc=bl} {Location. txt=dot; loc=dl} = + 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 @@ -244,25 +242,23 @@ let reconstruct_identifier pipeline pos = function in let add_loc source = let loc = - { Location. - loc_start ; - loc_end = shift loc_start (String.length source) ; - loc_ghost = false ; - } in + { 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) + 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 + else aux acc (succ i) + in aux [] offset -let dispatch pipeline (type a) : a Query_protocol.t -> a = - function +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 @@ -272,14 +268,16 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 + 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 @@ -290,116 +288,115 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let exprs = reconstruct_identifier pipeline pos expro in let () = Logger.log ~section:Type_enclosing.log_section - ~title:"reconstruct identifier" "%a" - Logger.json (fun () -> + ~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] - ) + `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 - ) + `List lst) in let small_enclosings = - Type_enclosing.from_reconstructed exprs - ~nodes:structures ~cursor:pos ~verbosity + 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 - ); + 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 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); + 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); + 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); + Printtyp.wrap_printing_env env ~verbosity (fun () -> + Printtyp.modtype env ppf m); ret (`String (Format.flush_str_formatter ())) - | _ -> ret (`Index i) - ) + | _ -> ret (`Index i)) in - let normalize ({Location. loc_start; loc_end; _}, text, _tail) = - Lexing.split_pos loc_start, Lexing.split_pos loc_end, text + 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) + 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 mbrowse = Mbrowse.enclosing pos [structures] in + let mbrowse = Mbrowse.enclosing pos [ structures ] in (* We remove possible duplicates from the list*) List.fold_left mbrowse ~init:[] ~f:(fun acc node -> - let loc = Mbrowse.node_loc (snd node) in - match acc with - | hd::_ as acc when Location_aux.compare hd loc = 0 -> acc - | _ -> loc::acc) + let loc = Mbrowse.node_loc (snd node) in + match acc with + | hd :: _ as acc when Location_aux.compare hd loc = 0 -> acc + | _ -> loc :: acc) |> List.rev - | 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 + 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); + 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 + | 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 + begin + match path with | None -> `Invalid_context - | Some (env, path) -> + | 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 + 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 + | `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 @@ -409,13 +406,15 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 target_type, context = Completion.application_context ~prefix branch in let get_doc = - if not with_doc then None else + 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) + 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 = @@ -423,13 +422,13 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = Completion.branch_complete config ~kinds ?get_doc ?target_type ~keywords prefix branch |> print_completion_entries ~with_types config source - and context = match context with + and context = + match context with | `Application context when no_labels -> - `Application {context with Compl.labels = []} + `Application { context with Compl.labels = [] } | context -> context in - {Compl. entries; context } - + { 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 @@ -438,26 +437,27 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 + Completion.expand_prefix env ~global_modules ~kinds prefix + |> print_completion_entries ~with_types config source in - { Compl. entries ; context = `Unknown } - + { 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 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) + 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) + 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 @@ -465,24 +465,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 } - + 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 @@ -496,22 +494,20 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | 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 = 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) - - | Syntax_document pos -> + if path = "" then `Invalid_context + else + Locate.get_doc ~config ~env ~local_defs ~comments ~pos (`User_input path) + | Syntax_document pos -> ( let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in let node = Mtyper.node_at typer pos in let res = Syntax_doc.get_syntax_doc pos node in - (match res with + match res with | Some res -> `Found res | None -> `No_documentation) - | Expand_ppx pos -> ( let pos = Mpipeline.get_lexing_pos pipeline pos in let parsetree = Mpipeline.reader_parsetree pipeline in @@ -519,11 +515,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let ppx_kind_with_attr = Ppx_expand.check_extension ~parsetree ~pos in match ppx_kind_with_attr with | Some _ -> - `Found - (Ppx_expand.get_ppxed_source ~ppxed_parsetree ~pos - (Option.get ppx_kind_with_attr)) + `Found + (Ppx_expand.get_ppxed_source ~ppxed_parsetree ~pos + (Option.get ppx_kind_with_attr)) | None -> `No_ppx) - | Locate (patho, ml_or_mli, pos) -> let typer = Mpipeline.typer_result pipeline in let local_defs = Mtyper.get_typedtree typer in @@ -535,83 +530,85 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | 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 = 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 + 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 = 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 + 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 -> + | (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 @@ -621,26 +618,23 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = match type_ with | `Exp type_expr -> Type_utils.print_type_with_decl ~verbosity env ppf type_expr - | `Mod module_type -> + | `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; _}) :: _ -> + 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 + | _ -> 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_); + 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 + let values_scope = + match with_values with | Some `None | None -> Construct.Null | Some `Local -> Construct.Local in @@ -649,45 +643,46 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 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 ~config ~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 ~config ~keywords ?depth ~values_scope node) - | _ :: _ -> raise Construct.Not_a_hole - | [] -> raise No_nodes + | (_, (Browse_raw.Expression { exp_desc = Texp_hole; _ } as node)) + :: _parents -> + let loc = Mbrowse.node_loc node in + (loc, Construct.node ~config ~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] - + 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 }-> + Outline.shape pos [ Browse_tree.of_browse browse ] + | Errors { lexing; parsing; typing } -> let typer = Mpipeline.typer_result pipeline in let verbosity = verbosity pipeline in - let lexer_errors = Mpipeline.reader_lexer_errors pipeline in + 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 + let typer_errors = Mpipeline.typer_errors pipeline in Printtyp.wrap_printing_env (Mtyper.get_env typer) ~verbosity @@ fun () -> (* 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 + let cmi_error = function + | Magic_numbers.Cmi.Error _ -> true + | _ -> false + in match List.find typer_errors ~f:cmi_error with - | e -> [e] + | e -> [ e ] | exception Not_found -> typer_errors in let error_start e = (Location.loc_of_report e).Location.loc_start in @@ -697,37 +692,44 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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) + 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 + 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; + 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 + 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 + 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; + 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 @@ -735,14 +737,13 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = (* 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) + 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 [])) + ((if lexing then lexer_errors else []) + @ (if parsing then parser_errors else []) + @ if typing then typer_errors else []) in (* Add configuration errors *) let errors = @@ -754,103 +755,95 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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) - ) - + 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 + | 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 + let with_ext ext = + modules_in_path ~ext Mconfig.(config.merlin.source_path) + in List.concat_map ~f:with_ext exts - - | Findlib_list -> - [] - + | 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 + 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, _scope) -> 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 enclosing = Mbrowse.enclosing pos [ str ] in let curr_node = let is_wildcard_pat = function - | Browse_raw.Pattern {pat_desc = Typedtree.Tpat_any; _} -> true + | 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)) + (* 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 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 ()) + 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)); + in + `List (List.map ~f:dump_path paths)); match List.filter paths ~f:under_cursor with | [] -> [] - | (path :: _) -> + | 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 + 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 + 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 @@ -858,33 +851,23 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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, `Not_requested - - | Inlay_hints ( - start, - stop, - hint_let_binding, - hint_pattern_binding, - avoid_ghost_location - ) -> + (List.sort ~cmp locs, `Not_requested) + | Inlay_hints + (start, stop, hint_let_binding, hint_pattern_binding, avoid_ghost_location) + -> let start = Mpipeline.get_lexing_pos pipeline start and stop = Mpipeline.get_lexing_pos pipeline stop in let typer_result = Mpipeline.typer_result pipeline in - begin match Mtyper.get_typedtree typer_result with - | `Interface _ -> [] - | `Implementation structure -> - Inlay_hints.of_structure - ~hint_let_binding - ~hint_pattern_binding - ~avoid_ghost_location - ~start - ~stop - structure + begin + match Mtyper.get_typedtree typer_result with + | `Interface _ -> [] + | `Implementation structure -> + Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding + ~avoid_ghost_location ~start ~stop structure end - - | Signature_help { position; _ } -> + | Signature_help { position; _ } -> ( (* Todo: additionnal contextual information could help us provide better - results.*) + results.*) let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline position in let node = Mtyper.node_at typer pos in @@ -895,25 +878,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let application_signature = Signature_help.application_signature ~prefix ~cursor:pos node in - let param offset (p: Signature_help.parameter_info) = - { label_start = offset + p.param_start; label_end = offset + p.param_end} + let param offset (p : Signature_help.parameter_info) = + { label_start = offset + p.param_start; label_end = offset + p.param_end } in - (match application_signature with - | Some s -> - let prefix = - let fun_name = - Option.value ~default:"_" s.function_name - in - sprintf "%s : " fun_name in - Some { label = prefix ^ s.signature; - parameters = - List.map ~f:(param (String.length prefix)) s.parameters; - active_param = Option.value ~default:0 s.active_param; - active_signature = 0; - } + match application_signature with + | Some s -> + let prefix = + let fun_name = Option.value ~default:"_" s.function_name in + sprintf "%s : " fun_name + in + Some + { label = prefix ^ s.signature; + parameters = List.map ~f:(param (String.length prefix)) s.parameters; + active_param = Option.value ~default:0 s.active_param; + active_signature = 0 + } | None -> None) - | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" - Merlin_config.version Sys.ocaml_version; - + Merlin_config.version Sys.ocaml_version diff --git a/src/frontend/query_commands.mli b/src/frontend/query_commands.mli index 7663d00ed2..9db02f23f7 100644 --- a/src/frontend/query_commands.mli +++ b/src/frontend/query_commands.mli @@ -1,31 +1,30 @@ - (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index edceac009c..911465d9e3 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -1,136 +1,119 @@ (* {{{ 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; - } + 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 application_context = + { argument_type : string; labels : (string * string) list } - type t = { - entries: entry list; - context: [ `Unknown - | `Application of application_context - ] - } + type t = + { entries : entry list; + context : [ `Unknown | `Application of application_context ] + } - type kind = [ - | `Constructor + type kind = + [ `Constructor | `Labels | `Modules | `Modules_type | `Types | `Values | `Variants - | `Keywords - ] + | `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 ; -} +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 shape = { shape_loc : Location_aux.t; shape_sub : shape list } -type error_filter = { - lexing : bool; - parsing : bool; - typing : bool; -} +type error_filter = { lexing : bool; parsing : bool; typing : bool } type syntax_doc_result = -{ - name : string; - description : string; - documentation : string -} + { name : string; description : string; documentation : string } type ppxed_source = -{ - code : string; - attr_start : Lexing.position; - attr_end : Lexing.position; -} + { code : string; attr_start : Lexing.position; attr_end : Lexing.position } -type signature_help_param = { - label_start : int; - label_end : int; -} +type signature_help_param = { label_start : int; label_end : int } -type signature_help_result = { - label : string; - parameters : signature_help_param list; - active_param : int; - active_signature: int; -} +type signature_help_result = + { label : string; + parameters : signature_help_param list; + active_param : int; + active_signature : int + } type trigger_kind = Invoked | Trigger_character of string | Content_change -type signature_help = { - position: Msource.position; - trigger_kind: trigger_kind option; - is_retrigger: bool; - active_signature_help: signature_help_result option; -} +type signature_help = + { position : Msource.position; + trigger_kind : trigger_kind option; + is_retrigger : bool; + active_signature_help : signature_help_result option + } -type is_tail_position = [`No | `Tail_position | `Tail_call] +type is_tail_position = [ `No | `Tail_position | `Tail_call ] type _ _bool = bool @@ -138,119 +121,89 @@ type occurrences_status = [ `Not_requested | `Out_of_sync of string list | `No_def | `Included ] 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 - | Syntax_document - : Msource.position - -> [ `Found of syntax_doc_result - | `No_documentation - ] t - | Expand_ppx - : Msource.position - -> [ `Found of ppxed_source - | `No_ppx - ] t - | Locate_type - : Msource.position + | 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 + | Syntax_document : + Msource.position + -> [ `Found of syntax_doc_result | `No_documentation ] t + | Expand_ppx : Msource.position -> [ `Found of ppxed_source | `No_ppx ] 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 - | 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 - | Inlay_hints - : Msource.position * Msource.position * bool * bool * bool - -> (Lexing.position * 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] * [`Project | `Buffer] - -> (Location.t list * occurrences_status) t - | Signature_help - : signature_help - -> signature_help_result option t - (** In current version, Merlin only uses the parameter [position] to answer + | `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 + | Inlay_hints : + Msource.position * Msource.position * bool * bool * bool + -> (Lexing.position * 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 ] * [ `Project | `Buffer ] + -> (Location.t list * occurrences_status) t + | Signature_help : signature_help -> signature_help_result option t + (** In current version, Merlin only uses the parameter [position] to answer signature_help queries. The additionnal parameters are described in the LSP protocol and might enable finer behaviour in the future. *) - | Version - : string t + | Version : string t diff --git a/src/frontend/test/ocamlmerlin_test.ml b/src/frontend/test/ocamlmerlin_test.ml index f458058cb6..524c1826fc 100644 --- a/src/frontend/test/ocamlmerlin_test.ml +++ b/src/frontend/test/ocamlmerlin_test.ml @@ -3,30 +3,27 @@ open Std (* Poor man's test framework *) type name = string -type test = - | Single of name * (unit -> unit) - | Group of name * test list +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)) -> +let () = + Printexc.register_printer (function + | Detail (exn, msg) -> Some (Printexc.to_string exn ^ "\nAdditional information:\n" ^ msg) - | _ -> None - ) + | _ -> None) -let str_match ~re str = - Str.string_match (Str.regexp (re ^ "$")) str 0 +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 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 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 @@ -35,16 +32,15 @@ let process ?(with_config=fun x -> x) ?for_completion filename text = (* All tests *) -let assert_errors ?with_config - filename ?(lexer=0) ?(parser=0) ?(typer=0) ?(config=0) source = +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 lexer_errors = M.reader_lexer_errors m in let parser_errors = M.reader_parser_errors m in - let failures, typer_errors = + let failures, typer_errors = Mtyper.with_typer (M.typer_result m) @@ fun () -> - Mconfig.((M.final_config m).merlin.failures), - M.typer_errors m + (Mconfig.((M.final_config m).merlin.failures), M.typer_errors m) in let fmt_msg exn = match Location.error_of_exn exn with @@ -53,25 +49,23 @@ let assert_errors ?with_config 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) - ) + 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; - ) + expect ~count:config "configuration failures" failures) let assertf b fmt = - if b then - Printf.ikfprintf ignore () fmt - else - Printf.ksprintf failwith 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 () -> @@ -79,12 +73,13 @@ let validate_output ?with_config filename source query pred = 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)) - ) + 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 = @@ -92,81 +87,72 @@ let validate_failure ?with_config filename source query pred = 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 + | 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"]; + 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 *) @@ -182,7 +168,8 @@ let rec run_tests indent = function and run_test indent = function | Single (name, f) -> Printf.printf "%s%s:\t%!" indent name; - begin match f () with + begin + match f () with | () -> incr passed; Printf.printf "OK\n%!" @@ -190,15 +177,15 @@ and run_test indent = function 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 + 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 + | 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}) -> + | Some (`Ok { Location.msg; loc }) -> Printf.eprintf "%sError message:\n%s\n%!" indent msg end; Printf.eprintf "%sBacktrace:\n%s\n%!" indent bt diff --git a/src/kernel/extension.ml b/src/kernel/extension.ml index 91a08cdd53..0206dc74f1 100644 --- a/src/kernel/extension.ml +++ b/src/kernel/extension.ml @@ -1,43 +1,43 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 t = + { name : string; + private_def : string list; + public_def : string list; + packages : string list; + keywords : (string * Parser_raw.token) list + } type set = string list @@ -46,88 +46,83 @@ type set = string list 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 = []; -} +let ext_lwt = + { name = "lwt"; + private_def = + [ "module Lwt : sig\n\ + \ val un_lwt : 'a Lwt.t -> 'a\n\ + \ val in_lwt : 'a Lwt.t -> 'a Lwt.t\n\ + \ val to_lwt : 'a -> 'a Lwt.t\n\ + \ val finally' : 'a Lwt.t -> unit Lwt.t -> 'a Lwt.t\n\ + \ val un_stream : 'a Lwt_stream.t -> 'a\n\ + \ val unit_lwt : unit Lwt.t -> unit Lwt.t\n\ + \ end" + ]; + public_def = + [ "val (>>) : unit Lwt.t -> 'a Lwt.t -> 'a Lwt.t\n\ + \ val raise_lwt : exn -> 'a Lwt.t\n\ + \ 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\n\ + \ val code : 'a -> 'a code\n\ + \ val uncode : 'a code -> 'a\n\ + \ end" + ]; + public_def = []; + keywords = [ (">.", GREATERDOT) ]; + packages = [] + } (* Known extensions *) -let registry = [ext_lwt;ext_meta] +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) + 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 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. *) + "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 + if + List.mem name ~set:extensions + || List.exists ~f:(List.mem ~set:ext.packages) packages then name :: set - else 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 = + 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 @@ -143,16 +138,17 @@ let keywords set = (* 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 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 @@ -177,18 +173,21 @@ 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 + 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 + (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 + (Types.Mty_signature (List.concat fakes)) + env diff --git a/src/kernel/extension.mli b/src/kernel/extension.mli index b46fd50fa4..f27c2722e9 100644 --- a/src/kernel/extension.mli +++ b/src/kernel/extension.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -41,13 +41,13 @@ exception Unknown *) (** 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; -} +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. *) @@ -58,6 +58,7 @@ 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 @@ -67,7 +68,7 @@ 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. *) + "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 diff --git a/src/kernel/mbrowse.ml b/src/kernel/mbrowse.ml index 6fbea1c953..18050a75fd 100644 --- a/src/kernel/mbrowse.ml +++ b/src/kernel/mbrowse.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -57,13 +57,11 @@ let approximate_loc get_loc node = 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 + 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 + else loc let node_loc node = approximate_loc Browse_raw.node_real_loc node @@ -78,55 +76,43 @@ let drop_leaf t = | [] | [ _ ] -> None | _leaf :: parents -> Some parents -let is_hidden node = - Browse_raw.has_attr ~name:"merlin.hide" node +let is_hidden node = Browse_raw.has_attr ~name:"merlin.hide" node -let is_focus node = - Browse_raw.has_attr ~name:"merlin.focus" node +let is_focus node = Browse_raw.has_attr ~name:"merlin.focus" node 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 - if Location_aux.compare_pos pos loc = 0 && - not (is_hidden node) - then - (traverse ((env, node) :: branch); true) - else - has_selected + if Location_aux.compare_pos pos loc = 0 && not (is_hidden node) then ( + traverse ((env, node) :: branch); + true) + else has_selected and traverse branch = let env, node = leaf_node branch in - if (is_focus node) then ( + if is_focus node 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 (is_hidden node) then ( + if not has_leaves then branches := [ branch ]; + raise Exit) + else if not (is_hidden node) then let has_leaves = fold_node (select_child branch) env node false in - if not has_leaves then - branches := branch :: !branches - ) + 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 t2_first = 1 in let t1_first = -1 in - match - Location_aux.compare_pos pos l1, - Location_aux.compare_pos pos l2 - with + match (Location_aux.compare_pos pos l1, Location_aux.compare_pos pos l2) with (* Cursor inside both locations: favor non-ghost closer to the end *) - | 0, 0 -> - begin match l1.Location.loc_ghost, l2.Location.loc_ghost with + | 0, 0 -> begin + match (l1.Location.loc_ghost, l2.Location.loc_ghost) with | true, false -> 1 | false, true -> -1 - | _ -> - Lexing.compare_pos l1.Location.loc_end l2.Location.loc_end - end + | _ -> Lexing.compare_pos l1.Location.loc_end l2.Location.loc_end + end (* Cursor inside one location: it has priority *) | 0, _ -> t1_first | _, 0 -> t2_first @@ -134,16 +120,13 @@ let compare_locations pos l1 l2 = | 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 + | _, _ -> 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 + if compare_locations pos (leaf_loc acc) (leaf_loc x) <= 0 then acc else x in List.fold_left ~f ~init xs @@ -161,45 +144,55 @@ let deepest_before pos roots = 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) + 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) + | Some (env, _, node) -> aux ((env, node) :: path) in - (aux root) + 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 -> +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) - | (_, ( 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) + | ( _, + 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 @@ -211,7 +204,7 @@ let of_structure str = | [] -> str.str_final_env | item :: _ -> item.str_env in - [env, Browse_raw.Structure str] + [ (env, Browse_raw.Structure str) ] let of_signature sg = let env = @@ -219,32 +212,27 @@ let of_signature sg = | [] -> sg.sig_final_env | item :: _ -> item.sig_env in - [env, Browse_raw.Signature sg] + [ (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]) + | Typedtree.Texp_construct (id, _, [ e ]) when id.Location.loc.Location.loc_ghost - && id.Location.txt = Longident.Lident "Some" -> - Some e + && 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 -> + (* 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 = @@ -256,8 +244,6 @@ let is_recovered = function | Expression e -> is_recovered_expression e | _ -> false -let print_node () node = - Browse_raw.string_of_node node +let print_node () node = Browse_raw.string_of_node node -let print () t = - List.print (fun () (_,node) -> print_node () node) () t +let print () t = List.print (fun () (_, node) -> print_node () node) () t diff --git a/src/kernel/mbrowse.mli b/src/kernel/mbrowse.mli index 4dc10b5584..a0bedc4ce3 100644 --- a/src/kernel/mbrowse.mli +++ b/src/kernel/mbrowse.mli @@ -1,38 +1,38 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 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 @@ -46,7 +46,6 @@ val drop_leaf : t -> t option * 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 @@ -55,13 +54,14 @@ val of_structure : Typedtree.structure -> t val of_signature : Typedtree.signature -> t val of_typedtree : - [ `Implementation of Typedtree.structure - | `Interface of Typedtree.signature ] -> t + [ `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 diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index f2b4ddfbc5..222c119411 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -2,143 +2,135 @@ 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 { 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; - ] + 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 +let unsafe_get_cwd () = + match !cwd with | None -> assert false | Some cwd -> cwd -let canonicalize_filename path = - Misc.canonicalize_filename ?cwd:!cwd path +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) + 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; - source_root : string option; - unit_name : string option; - wrapping_prefix : string option; - reader : string list; - protocol : [`Json | `Sexp]; - log_file : string option; - log_sections : string list; - config_path : string option; - - use_ppx_cache : bool; - - 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; - - cache_lifespan : int -} +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; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; + reader : string list; + protocol : [ `Json | `Sexp ]; + log_file : string option; + log_sections : string list; + config_path : string option; + use_ppx_cache : bool; + 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; + cache_lifespan : int + } 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; - "source_root" , Json.option Json.string x.source_root; - "unit_name" , Json.option Json.string x.unit_name; - "wrapping_prefix" , Json.option Json.string x.wrapping_prefix; - "reader" , `List (List.map ~f:Json.string x.reader); - "protocol" , (match x.protocol with + 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); + ("source_root", Json.option Json.string x.source_root); + ("unit_name", Json.option Json.string x.unit_name); + ("wrapping_prefix", Json.option Json.string x.wrapping_prefix); + ("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 - ); - "cache_lifespan" , Json.string (string_of_int x.cache_lifespan) - ] + | `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) ); + ("cache_lifespan", Json.string (string_of_int x.cache_lifespan)) + ] module Verbosity = struct type t = Smart | Lvl of int @@ -154,78 +146,84 @@ module Verbosity = struct let of_string = function | "smart" -> Smart - | maybe_int -> + | maybe_int -> ( try Lvl (int_of_string maybe_int) - with _ -> invalid_arg ("argument should be: " ^ param_spec) + with _ -> invalid_arg ("argument should be: " ^ param_spec)) let to_string = function | Smart -> "smart" - | Lvl v -> "lvl " ^ (string_of_int v) + | Lvl v -> "lvl " ^ string_of_int v let to_json t = `String (to_string t) end -type query = { - filename : string; - directory : string; - printer_width : int; - verbosity : Verbosity.t; -} - -let dump_query x = `Assoc [ - "filename" , `String x.filename; - "directory" , `String x.directory; - "printer_width", `Int x.printer_width; - "verbosity" , Verbosity.to_json x.verbosity; - ] +type query = + { filename : string; + directory : string; + printer_width : int; + verbosity : Verbosity.t + } -type t = { - ocaml : ocaml; - merlin : merlin; - query : query; -} +let dump_query x = + `Assoc + [ ("filename", `String x.filename); + ("directory", `String x.directory); + ("printer_width", `Int x.printer_width); + ("verbosity", Verbosity.to_json x.verbosity) + ] -let dump x = `Assoc [ - "ocaml" , dump_ocaml x.ocaml; - "merlin" , dump_merlin x.merlin; - "query" , dump_query x.query; - ] +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 + 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 + | None -> ( + match env with | Some stdlib -> stdlib - | None -> Standard_library.path + | 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; - } } + 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 + 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 + { t with + merlin = { t.merlin with failures = !failures @ t.merlin.failures } + } + else t let is_normalized t = let merlin = t.merlin in @@ -234,9 +232,8 @@ let is_normalized t = let rec normalize t = if is_normalized t then ( log ~title:"normalize" "%a" Logger.json (fun () -> dump t); - t - ) else - normalize (normalize_step t) + t) + else normalize (normalize_step t) let merge_merlin_config dot merlin ~failures ~config_path = { merlin with @@ -254,16 +251,12 @@ let merge_merlin_config dot merlin ~failures ~config_path = unit_name = (if dot.unit_name = None then merlin.unit_name else dot.unit_name); wrapping_prefix = - if dot.wrapping_prefix = None - then merlin.wrapping_prefix - else dot.wrapping_prefix; - reader = - if dot.reader = [] - then merlin.reader - else dot.reader; + (if dot.wrapping_prefix = None then merlin.wrapping_prefix + else dot.wrapping_prefix); + 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; + config_path = Some config_path } let get_external_config path t = @@ -276,182 +269,236 @@ let get_external_config path t = let merlin = merge_merlin_config dot t.merlin ~failures ~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" - ); - ( - "-cache-lifespan", - Marg.param "int" (fun prot merlin -> - try {merlin with cache_lifespan = (int_of_string prot)} - with _ -> invalid_arg "Valid value is int"; - ), - "Change file cache retention period. It's measured in minutes. \ - Default value is 5." - ); - ( - (* Legacy support for janestreet. Ignored. To be removed soon. *) - "-attributes-allowed", - Marg.unit_ignore, - " DEPRECATED" - ); -] - -let query_flags = [ - ( - "-verbosity", - Marg.param Verbosity.param_spec (fun verbosity query -> - let verbosity = - Verbosity.of_string verbosity - in - {query with verbosity}), - "\"smart\" | Verbosity determines the number of \ - expansions of aliases in answers. \"smart\" is equivalent to \ - verbosity=0 but expands module types." - ); - ( - "-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"; "-dshape"; - "-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"; "-no-unboxed-types"; "-O2"; "-O3"; - "-Oclassic"; "-opaque"; "-output-complete-obj"; "-output-obj"; "-p"; "-pack"; - "-remove-unused-arguments"; "-S"; "-shared"; "-unbox-closures"; - "-unboxed-types"; "-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"; "-dump-dir"; -] +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" ); + ( "-cache-lifespan", + Marg.param "int" (fun prot merlin -> + try { merlin with cache_lifespan = int_of_string prot } + with _ -> invalid_arg "Valid value is int"), + "Change file cache retention period. It's measured in minutes. Default \ + value is 5." ); + ( (* Legacy support for janestreet. Ignored. To be removed soon. *) + "-attributes-allowed", + Marg.unit_ignore, + " DEPRECATED" ) + ] + +let query_flags = + [ ( "-verbosity", + Marg.param Verbosity.param_spec (fun verbosity query -> + let verbosity = Verbosity.of_string verbosity in + { query with verbosity }), + "\"smart\" | Verbosity determines the number of expansions of \ + aliases in answers. \"smart\" is equivalent to verbosity=0 but expands \ + module types." ); + ( "-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"; + "-dshape"; + "-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"; + "-no-unboxed-types"; + "-O2"; + "-O3"; + "-Oclassic"; + "-opaque"; + "-output-complete-obj"; + "-output-obj"; + "-p"; + "-pack"; + "-remove-unused-arguments"; + "-S"; + "-shared"; + "-unbox-closures"; + "-unboxed-types"; + "-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"; + "-dump-dir" + ] 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 () -> + Misc.try_finally + (fun () -> ignore @@ Warnings.parse_options error spec; { ocaml with warnings = Warnings.backup () }) ~always:(fun () -> Warnings.restore b')) @@ -460,282 +507,227 @@ let ocaml_alert_spec = Marg.param "alert specification" (fun spec ocaml -> let b' = Warnings.backup () in Warnings.restore ocaml.warnings; - Misc.try_finally (fun () -> + 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" - ); -] +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; - source_root = None; - unit_name = None; - wrapping_prefix = None; - reader = []; - protocol = `Json; - log_file = None; - log_sections = []; - config_path = None; - - exclude_query_dir = false; - - use_ppx_cache = false; - - flags_to_apply = []; - flags_applied = []; - - failures = []; - extension_to_reader = [(".re","reason");(".rei","reason")]; - cache_lifespan = 5; - }; - query = { - filename = "*buffer*"; - directory = Sys.getcwd (); - verbosity = Verbosity.default; - printer_width = 0; +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; + source_root = None; + unit_name = None; + wrapping_prefix = None; + reader = []; + protocol = `Json; + log_file = None; + log_sections = []; + config_path = None; + exclude_query_dir = false; + use_ppx_cache = false; + flags_to_apply = []; + flags_applied = []; + failures = []; + extension_to_reader = [ (".re", "reason"); (".rei", "reason") ]; + cache_lifespan = 5 + }; + query = + { filename = "*buffer*"; + directory = Sys.getcwd (); + verbosity = Verbosity.default; + 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 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) + 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) + 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 + 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) + (args, upd a b) in - let add prj upd (name,flag,_doc) = + let add prj upd (name, flag, _doc) = if Hashtbl.mem arguments_table name then failwith ("Duplicate flag spec: " ^ 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})) + ~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})) + ~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})) + ~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 + 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 - ) + 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) + 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"; @@ -743,72 +735,56 @@ let document_arguments oc = 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" + 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] + 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 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 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 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 + 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 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 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 + 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 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 + else + match config.query.filename with | "" -> modules | filename -> List.remove (Misc.unitname filename) modules -) (** {1 Accessors for other information} *) @@ -819,7 +795,8 @@ let unitname t = | Some name -> Misc.unitname name | None -> let basename = Misc.unitname t.query.filename in - begin match t.merlin.wrapping_prefix with - | Some prefix -> prefix ^ basename - | None -> basename + begin + match t.merlin.wrapping_prefix with + | Some prefix -> prefix ^ basename + | None -> basename end diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 3b1215b28f..119fb0c60b 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -2,59 +2,54 @@ 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; -} +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; - source_root : string option; - unit_name : string option; - wrapping_prefix : string option; - reader : string list; - protocol : [`Json | `Sexp]; - log_file : string option; - log_sections: string list; - config_path : string option; - use_ppx_cache : bool; - - 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; - cache_lifespan : int -} +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; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; + reader : string list; + protocol : [ `Json | `Sexp ]; + log_file : string option; + log_sections : string list; + config_path : string option; + use_ppx_cache : bool; + 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; + cache_lifespan : int + } val dump_merlin : merlin -> json @@ -73,28 +68,27 @@ module Verbosity : sig val to_int : t -> for_smart:int -> int end -type query = { - filename : string; - directory : string; - printer_width : int; - verbosity : Verbosity.t; -} +type query = + { filename : string; + directory : string; + printer_width : int; + verbosity : Verbosity.t + } (** {1 Main configuration} *) -type t = { - ocaml : ocaml; - merlin : merlin; - query : query; -} +type t = { ocaml : ocaml; merlin : merlin; query : query } val initial : t val dump : t -> json val merge_merlin_config : - Mconfig_dot.config - -> merlin -> failures:(string list) -> config_path:string -> merlin + Mconfig_dot.config -> + merlin -> + failures:string list -> + config_path:string -> + merlin val get_external_config : string -> t -> t @@ -104,8 +98,12 @@ val is_normalized : t -> bool val parse_arguments : wd:string -> - warning:(string -> unit) -> 'a Marg.spec list -> string list -> - t -> 'a -> t * 'a + warning:(string -> unit) -> + 'a Marg.spec list -> + string list -> + t -> + 'a -> + t * 'a val flags_for_completion : unit -> string list diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index 0a17f4671c..d7817f7b2a 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -1,70 +1,70 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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" +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; - source_root : string option; - unit_name : string option; - wrapping_prefix : string option; - reader : string list; - exclude_query_dir : bool; - use_ppx_cache : bool; -} - -let empty_config = { - build_path = []; - source_path = []; - cmi_path = []; - cmt_path = []; - extensions = []; - suffixes = []; - flags = []; - stdlib = None; - source_root = None; - unit_name = None; - wrapping_prefix = None; - reader = []; - exclude_query_dir = false; - use_ppx_cache = false; -} +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; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; + reader : string list; + exclude_query_dir : bool; + use_ppx_cache : bool + } + +let empty_config = + { build_path = []; + source_path = []; + cmi_path = []; + cmt_path = []; + extensions = []; + suffixes = []; + flags = []; + stdlib = None; + source_root = None; + unit_name = None; + wrapping_prefix = None; + reader = []; + exclude_query_dir = false; + use_ppx_cache = false + } let white_regexp = Str.regexp "[ \t]+" @@ -72,21 +72,21 @@ let white_regexp = Str.regexp "[ \t]+" designating implementation/interface suffixes. These would be supplied in the .merlin file as: - SUFFIX .sfx .sfxi *) + 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 + 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)] + else [ (first, second) ] (* This module contains invariants around processes that need to be preserved *) module Configurator : sig - type t = - | Dot_merlin - | Dune + type t = Dot_merlin | Dune val of_string_opt : string -> t option val to_string : t -> string @@ -94,13 +94,13 @@ module Configurator : sig exception Process_exited module Process : sig - type nonrec t = { - kind: t; - initial_cwd: string; - stdin: out_channel; - stdout: in_channel; - stderr: in_channel - } + 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 @@ -110,15 +110,11 @@ module Configurator : sig [Unix_error]. *) val get_process_exn : dir:string -> t -> Process.t end = struct - type t = - | Dot_merlin - | Dune + type t = Dot_merlin | Dune let of_string_opt = function - | ".merlin" -> - Some Dot_merlin - | "dune-project" | "dune-workspace" -> - Some Dune + | ".merlin" -> Some Dot_merlin + | "dune-project" | "dune-workspace" -> Some Dune | _ -> None let to_string = function @@ -128,19 +124,16 @@ end = struct exception Process_exited module Process = struct - type nonrec t = { - kind : t; - initial_cwd : string; - stdin: out_channel; - stdout: in_channel; - stderr: in_channel; - } + 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 - } + type nonrec t = { pid : int; process : t } end let start ~dir cfg = @@ -148,10 +141,10 @@ end = struct match cfg with | Dot_merlin -> let prog = "dot-merlin-reader" in - prog, [| prog |] + (prog, [| prog |]) | Dune -> let prog = "dune" in - prog, [| prog; "ocaml-merlin"; "--no-print-directory" |] + (prog, [| prog; "ocaml-merlin"; "--no-print-directory" |]) in let cwd = Sys.getcwd () in let stdin_r, stdin_w = Unix.pipe () in @@ -176,8 +169,7 @@ end = struct *) Os_ipc.merlin_dont_inherit_stdio true; log ~title:"get_config" "Starting %s configuration provider from dir %s." - (to_string cfg) - dir; + (to_string cfg) dir; let pid = let open Unix in @@ -186,7 +178,7 @@ end = struct Os_ipc.merlin_dont_inherit_stdio false; chdir cwd; List.iter ~f:close - [stdin_r; stdin_w; stdout_r; stdout_w; stderr_r; stderr_w]; + [ stdin_r; stdin_w; stdout_r; stdout_w; stderr_r; stderr_w ]; raise err in Os_ipc.merlin_dont_inherit_stdio false; @@ -197,11 +189,9 @@ end = struct 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 } - } + 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 @@ -215,8 +205,7 @@ end = struct try let p = Hashtbl.find running_processes (dir, configurator) in let i, _ = Unix.waitpid [ WNOHANG ] p.pid in - if i = 0 then - p + if i = 0 then p else let p = Process.start ~dir configurator in Hashtbl.replace running_processes (dir, configurator) p; @@ -230,87 +219,76 @@ end = struct let p = get_process_with_pid ~dir configurator in match Unix.waitpid [ WNOHANG ] p.pid with | 0, _ -> p.process - | _ -> begin + | _ -> begin Hashtbl.remove running_processes (dir, configurator); raise Process_exited 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 - | `SOURCE_ROOT path -> - {config with source_root = Some path}, errors - | `UNIT_NAME name -> - {config with unit_name = Some name}, errors - | `WRAPPING_PREFIX prefix -> - {config with wrapping_prefix = Some prefix}, errors - | `READER reader -> - {config with reader}, errors - | `EXCLUDE_QUERY_DIR -> - {config with exclude_query_dir = true}, errors - | `USE_PPX_CACHE -> - {config with use_ppx_cache = 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 + 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) + | `SOURCE_ROOT path -> ({ config with source_root = Some path }, errors) + | `UNIT_NAME name -> ({ config with unit_name = Some name }, errors) + | `WRAPPING_PREFIX prefix -> + ({ config with wrapping_prefix = Some prefix }, errors) + | `READER reader -> ({ config with reader }, errors) + | `EXCLUDE_QUERY_DIR -> ({ config with exclude_query_dir = true }, errors) + | `USE_PPX_CACHE -> ({ config with use_ppx_cache = 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; + { 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; source_root = config.source_root; - unit_name = config.unit_name; + unit_name = config.unit_name; wrapping_prefix = config.wrapping_prefix; - reader = config.reader; + reader = config.reader; exclude_query_dir = config.exclude_query_dir; - use_ppx_cache = config.use_ppx_cache; + use_ppx_cache = config.use_ppx_cache } -type context = { - workdir: string; - configurator: Configurator.t; - process_dir: string; -} +type context = + { workdir : string; configurator : Configurator.t; process_dir : string } exception End_of_input let get_config { workdir; process_dir; configurator } path_abs = let log_query path = - log - ~title:"get_config" + log ~title:"get_config" "Querying %s (inital cwd: %s) for file: %s.\nWorkdir: %s" (Configurator.to_string configurator) - process_dir - path - workdir + process_dir path workdir in let query path (p : Configurator.Process.t) = let open Merlin_dot_protocol.Blocking in @@ -326,16 +304,16 @@ let get_config { workdir; process_dir; configurator } path_abs = 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) + (* 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 + match (p.kind, path_rel) with | Dune, Some path_rel -> path_rel | _, _ -> path_abs in @@ -345,8 +323,7 @@ let get_config { workdir; process_dir; configurator } path_abs = 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 + | Ok [ `ERROR_MSG _ ] when p.kind = Dune -> query path_abs p | answer -> answer in @@ -355,96 +332,100 @@ let get_config { workdir; process_dir; configurator } path_abs = 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 ] + (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 - | Configurator.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 program_name = Lib_config.program_name () in - let error = Printf.sprintf - "A problem occurred with %s external configuration reader. %s If \ - the problem persists, please file an issue on %s's tracker." + | Configurator.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 program_name = Lib_config.program_name () in + let error = + Printf.sprintf + "A problem occurred with %s external configuration reader. %s If the \ + problem persists, please file an issue on %s's tracker." program_name (match configurator with | Dot_merlin -> "Check that `dot-merlin-reader` is installed." | Dune -> "Check that `dune` is installed and up-to-date.") program_name - in - empty_config, [ error ] - | Unix.Unix_error (ENOENT, "create_process", "dune") -> - let error = Printf.sprintf - "%s could not find `dune` in the PATH to get project configuration. \ - If you do not rely on Dune, make sure `.merlin` files are present in \ - the project's sources." + in + (empty_config, [ error ]) + | Unix.Unix_error (ENOENT, "create_process", "dune") -> + let error = + Printf.sprintf + "%s could not find `dune` in the PATH to get project configuration. If \ + you do not rely on Dune, make sure `.merlin` files are present in the \ + project's sources." (Lib_config.program_name ()) - in - empty_config, [ error ] - | Unix.Unix_error (ENOENT, "create_process", "dot-merlin-reader") -> - let error = Printf.sprintf + in + (empty_config, [ error ]) + | Unix.Unix_error (ENOENT, "create_process", "dot-merlin-reader") -> + let error = + Printf.sprintf "%s could not find `dot-merlin-reader` in the PATH. Please make sure \ - that `dot-merlin-reader` is installed and in the PATH." + that `dot-merlin-reader` is installed and in the PATH." (Lib_config.program_name ()) - 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 program_name = Lib_config.program_name () in - let error = Printf.sprintf + 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 program_name = Lib_config.program_name () in + let error = + Printf.sprintf "%s could not load its configuration from the external reader. %s" program_name (match configurator with | Dot_merlin -> "If the problem persists, please file an issue." | Dune -> "Building your project with `dune` might solve this issue.") - in - empty_config, [ error ] + 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. *) + 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 + 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 - ) - ) + 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 + if parent <> dir then (* Was this directory the workdir ? *) let workdir = map_workdir dir workdir in loop workdir parent diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 1cb93ebac7..6afdd8026c 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -1,55 +1,53 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 Configurator : sig - type t = - | Dot_merlin - | Dune + type t = Dot_merlin | Dune end -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; - source_root : string option; - unit_name : string option; - wrapping_prefix : string option; - reader : string list; - exclude_query_dir : bool; - use_ppx_cache : bool; -} +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; + source_root : string option; + unit_name : string option; + wrapping_prefix : string option; + reader : string list; + exclude_query_dir : bool; + use_ppx_cache : bool + } val empty_config : config @@ -57,12 +55,12 @@ val empty_config : config [config] accordingly, prepending new items when to already existing list fields of [config]. [dir] is used as the [workdir] for flags declared in the [directives]. If [c = Dune], unknown directives are ignored. *) -val prepend_config - : dir:string - -> Configurator.t - -> Merlin_dot_protocol.directive list - -> config - -> config * string list +val prepend_config : + dir:string -> + Configurator.t -> + Merlin_dot_protocol.directive list -> + config -> + config * string list (** [prostprocess_config config] removes duplicates and reverses the lists in [config] *) @@ -72,7 +70,6 @@ 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, @@ -85,3 +82,4 @@ val find_project_context : string -> (context * string) option 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. *) +val find_project_context : string -> (context * string) option diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index 6b4cd38dc9..1e401e436d 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -16,100 +16,97 @@ 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 + | 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 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 = ( + 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); -) + 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_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 default_out_phrase = !Oprint.out_phrase let replacement_printer = ref None -let oprint default inj ppf x = match !replacement_printer with +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_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_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) + 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 + 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 - + | Out_phrase x -> default_out_phrase ppf x -let with_printer printer f = - let_ref replacement_printer (Some printer) f +let with_printer printer f = let_ref replacement_printer (Some printer) f (* Cleanup caches *) -let clear_caches () = ( +let clear_caches () = Cmi_cache.clear (); Cmt_cache.clear (); - Directory_content_cache.clear (); -) + Directory_content_cache.clear () (* Flush cache *) -let flush_caches ?older_than () = ( +let flush_caches ?older_than () = Cmi_cache.flush ?older_than (); Cmt_cache.flush ?older_than () -) diff --git a/src/kernel/mocaml.mli b/src/kernel/mocaml.mli index 3a8fb6d551..62b45e5525 100644 --- a/src/kernel/mocaml.mli +++ b/src/kernel/mocaml.mli @@ -15,7 +15,8 @@ val default_printer : val with_printer : (Format.formatter -> Extend_protocol.Reader.outcometree -> unit) -> - (unit -> 'a) -> 'a + (unit -> 'a) -> + 'a (* Clear caches, remove all items *) val clear_caches : unit -> unit diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index cbfedbe790..2180675a74 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -1,23 +1,26 @@ open Std -let {Logger. log} = Logger.for_section "Pipeline" +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 - ) + 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 [] @@ -40,12 +43,11 @@ module Cache = struct *) let key config = - Mconfig.( - config.query.filename, - config.query.directory, - config.ocaml, - {config.merlin with log_file = None; log_sections = []} - ) + 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 @@ -63,47 +65,36 @@ module Cache = struct end module Typer = struct - type t = { - errors : exn list lazy_t; - result : Mtyper.result; - } + 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; - } + type t = + { config : Mconfig.t; errors : exn list; parsetree : Mreader.parsetree } end module Reader = struct - type t = { - result : Mreader.result; - config : Mconfig.t; - cache_version : int option; - } + type t = + { result : Mreader.result; config : Mconfig.t; cache_version : int option } end -type t = { - config : Mconfig.t; - state : Mocaml.typer_state; - raw_source : Msource.t; - source : (Msource.t * Mreader.parsetree option) lazy_t; - reader : Reader.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; - - ppx_cache_hit : bool ref; - reader_cache_hit : bool ref; - typer_cache_stats : Mtyper.typer_cache_stats ref; -} +type t = + { config : Mconfig.t; + state : Mocaml.typer_state; + raw_source : Msource.t; + source : (Msource.t * Mreader.parsetree option) lazy_t; + reader : Reader.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; + ppx_cache_hit : bool ref; + reader_cache_hit : bool ref; + typer_cache_stats : Mtyper.typer_cache_stats ref + } let raw_source t = t.raw_source @@ -115,13 +106,14 @@ let with_pipeline t f = 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 + 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 ppx t = Lazy.force t.ppx +let typer t = Lazy.force t.typer let reader_config t = (reader t).config let reader_parsetree t = (reader t).result.Mreader.parsetree @@ -134,28 +126,28 @@ let reader_no_labels_for_completion t = (reader t).result.Mreader.no_labels_for_completion let ppx_parsetree t = (ppx t).Ppx.parsetree -let ppx_errors t = (ppx t).Ppx.errors +let ppx_errors t = (ppx t).Ppx.errors -let final_config t = (ppx t).Ppx.config +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 module Reader_phase = struct - type t = { - source : Msource.t * Mreader.parsetree option; - for_completion : Msource.position option; - config : Mconfig.t; - } + type t = + { source : Msource.t * Mreader.parsetree option; + for_completion : Msource.position option; + config : Mconfig.t + } - type output = { result: Mreader.result; cache_version: int } + type output = { result : Mreader.result; cache_version : int } let f = let cache_version = ref 0 in fun { source; for_completion; config } -> - let result = Mreader.parse ?for_completion config source in - incr cache_version; - { result; cache_version = !cache_version } + let result = Mreader.parse ?for_completion config source in + incr cache_version; + { result; cache_version = !cache_version } let title = "Reader phase" @@ -171,10 +163,11 @@ module Reader_with_cache = Phase_cache.With_cache (Reader_phase) module Ppx_phase = struct type reader_cache = Off | Version of int - type t = { - parsetree : Mreader.parsetree; - config : Mconfig.t; - reader_cache : reader_cache } + type t = + { parsetree : Mreader.parsetree; + config : Mconfig.t; + reader_cache : reader_cache + } type output = Mreader.parsetree let f { parsetree; config; _ } = Mppx.rewrite parsetree config @@ -197,158 +190,175 @@ module Ppx_phase = struct end module Fingerprint = struct - type t = (Single_fingerprint.t list * reader_cache) + type t = Single_fingerprint.t list * reader_cache let make { config; reader_cache; _ } = let rec all_fingerprints acc = function | [] -> acc | { Std.workdir; workval } :: tl -> ( - match Std.String.split_on_char ~sep:' ' workval with - | [] -> Error ("unhandled workval" ^ workval) - | binary :: args -> - Result.bind - ~f:(fun fp -> - all_fingerprints (Result.map ~f:(List.cons fp) acc) tl) - (Single_fingerprint.make ~binary ~args ~workdir)) + match Std.String.split_on_char ~sep:' ' workval with + | [] -> Error ("unhandled workval" ^ workval) + | binary :: args -> + Result.bind + ~f:(fun fp -> + all_fingerprints (Result.map ~f:(List.cons fp) acc) tl) + (Single_fingerprint.make ~binary ~args ~workdir)) in - Result.map (all_fingerprints (Ok []) config.ocaml.ppx) - ~f:(fun l -> (l, reader_cache)) + Result.map (all_fingerprints (Ok []) config.ocaml.ppx) ~f:(fun l -> + (l, reader_cache)) let equal_cache_version cv1 cv2 = - match cv1, cv2 with + match (cv1, cv2) with | Off, _ | _, Off -> false | Version v1, Version v2 -> Int.equal v1 v2 let equal (f1, rcv1) (f2, rcv2) = - equal_cache_version rcv1 rcv2 && - List.equal ~eq:Single_fingerprint.equal f1 f2 + equal_cache_version rcv1 rcv2 + && List.equal ~eq:Single_fingerprint.equal f1 f2 end end module Ppx_with_cache = Phase_cache.With_cache (Ppx_phase) - -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) - ?(ppx_cache_hit = ref false) - ?(reader_cache_hit = ref false) - ?(typer_cache_stats = ref Mtyper.Miss) - ?for_completion - config raw_source = - let state = match state with +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) + ?(ppx_cache_hit = ref false) ?(reader_cache_hit = ref false) + ?(typer_cache_stats = ref Mtyper.Miss) ?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 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 ((_, pp_result) as source)) = source in - let config = Mconfig.normalize config in - Mocaml.setup_reader_config config; - let cache_disabling = - match (config.merlin.use_ppx_cache, pp_result) with - | false, _ -> Some "configuration" - | true, Some _ -> - (* The cache could be refined in the future to also act on the - PP phase. For now, let's disable the whole cache when there's - a PP. *) - Some "source preprocessor usage" - | true, None -> None - in - let { Reader_with_cache.output = { result; cache_version }; cache_was_hit } = - Reader_with_cache.apply ~cache_disabling - { source; for_completion; config } - in - reader_cache_hit := cache_was_hit; - let cache_version = - if Option.is_some cache_disabling then None else Some cache_version - in - { Reader.result; config; cache_version } - )) in - let ppx = timed_lazy ppx_time (lazy ( - let (lazy { - Reader.result = { Mreader.parsetree; _ }; - config; - cache_version; - }) = reader - in - let caught = ref [] in - Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> - (* Currently the cache is invalidated even for source changes that don't - change the parsetree. To avoid that, we'd have to digest the - parsetree in the cache. *) - let cache_disabling, reader_cache = - match cache_version with - | Some v -> None, Ppx_phase.Version v - | None -> Some "reader cache is disabled", Off - in - let { Ppx_with_cache.output = parsetree; cache_was_hit } = - Ppx_with_cache.apply ~cache_disabling - {parsetree; config; reader_cache} - in - ppx_cache_hit := cache_was_hit; - { 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_cache_stats := Mtyper.get_cache_stat result; - { Typer. errors; result } - )) in - { config; state; raw_source; source; reader; ppx; typer; - pp_time; reader_time; ppx_time; typer_time; error_time; - ppx_cache_hit; reader_cache_hit; typer_cache_stats } - -let make config source = - process (Mconfig.normalize config) source + let config = Mconfig.normalize config in + Mocaml.setup_reader_config config; + let cache_disabling = + match (config.merlin.use_ppx_cache, pp_result) with + | false, _ -> Some "configuration" + | true, Some _ -> + (* The cache could be refined in the future to also act on the + PP phase. For now, let's disable the whole cache when there's + a PP. *) + Some "source preprocessor usage" + | true, None -> None + in + let { Reader_with_cache.output = { result; cache_version }; + cache_was_hit + } = + Reader_with_cache.apply ~cache_disabling + { source; for_completion; config } + in + reader_cache_hit := cache_was_hit; + let cache_version = + if Option.is_some cache_disabling then None else Some cache_version + in + { Reader.result; config; cache_version })) + in + let ppx = + timed_lazy ppx_time + (lazy + (let (lazy + { Reader.result = { Mreader.parsetree; _ }; + config; + cache_version + }) = + reader + in + let caught = ref [] in + Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught + @@ fun () -> + (* Currently the cache is invalidated even for source changes that don't + change the parsetree. To avoid that, we'd have to digest the + parsetree in the cache. *) + let cache_disabling, reader_cache = + match cache_version with + | Some v -> (None, Ppx_phase.Version v) + | None -> (Some "reader cache is disabled", Off) + in + let { Ppx_with_cache.output = parsetree; cache_was_hit } = + Ppx_with_cache.apply ~cache_disabling + { parsetree; config; reader_cache } + in + ppx_cache_hit := cache_was_hit; + { 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_cache_stats := Mtyper.get_cache_stat result; + { Typer.errors; result })) + in + { config; + state; + raw_source; + source; + reader; + ppx; + typer; + pp_time; + reader_time; + ppx_time; + typer_time; + error_time; + ppx_cache_hit; + reader_cache_hit; + typer_cache_stats + } + +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); -] + { 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)) + ] let cache_information t = let typer = match !(t.typer_cache_stats) with | Miss -> `String "miss" | Hit { reused; typed } -> - `Assoc - [ "reused" , `Int reused; - "typed", `Int typed - ] + `Assoc [ ("reused", `Int reused); ("typed", `Int typed) ] in - let fmt_hit_miss h m = - `Assoc [ "hit", `Int h; "miss", `Int m ] in + let fmt_hit_miss h m = `Assoc [ ("hit", `Int h); ("miss", `Int m) ] in let cmt_stat = Cmt_cache.get_cache_stats () in let cmt = fmt_hit_miss cmt_stat.hit cmt_stat.miss in let cmi_stat = Cmi_cache.get_cache_stats () in @@ -356,10 +366,10 @@ let cache_information t = Cmt_cache.clear_cache_stats (); Cmi_cache.clear_cache_stats (); let fmt_bool hit = `String (if hit then "hit" else "miss") in - `Assoc [ - "reader_phase" , fmt_bool !(t.reader_cache_hit); - "ppx_phase" , fmt_bool !(t.ppx_cache_hit); - "typer" , typer; - "cmt" , cmt; - "cmi" , cmi - ] + `Assoc + [ ("reader_phase", fmt_bool !(t.reader_cache_hit)); + ("ppx_phase", fmt_bool !(t.ppx_cache_hit)); + ("typer", typer); + ("cmt", cmt); + ("cmi", cmi) + ] diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index 58355efdce..f6f1d21df6 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -7,7 +7,7 @@ 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 get_lexing_pos : t -> [< Msource.position ] -> Lexing.position val reader_config : t -> Mconfig.t val reader_comments : t -> (string * Location.t) list diff --git a/src/kernel/mppx.ml b/src/kernel/mppx.ml index 4e1fea6002..602e926066 100644 --- a/src/kernel/mppx.ml +++ b/src/kernel/mppx.ml @@ -1,6 +1,6 @@ open Mconfig -let {Logger. log} = Logger.for_section "Mppx" +let { Logger.log } = Logger.for_section "Mppx" let with_include_dir path f = let saved = !Clflags.include_dirs in @@ -8,12 +8,10 @@ let with_include_dir path f = Clflags.include_dirs := path; let result = begin - try - f () - with - | e -> - restore (); - raise e + try f () + with e -> + restore (); + raise e end in restore (); @@ -29,11 +27,9 @@ let rewrite parsetree cfg = | 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 - ); + 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/src/kernel/mreader.ml b/src/kernel/mreader.ml index 61a238eec8..bec0e36a7c 100644 --- a/src/kernel/mreader.ml +++ b/src/kernel/mreader.ml @@ -1,20 +1,18 @@ 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; -} +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 *) @@ -26,9 +24,11 @@ let normal_parse ?for_completion config source = | 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) + 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 @@ -37,11 +37,12 @@ let normal_parse ?for_completion config source = 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 + 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 + let pos = + Msource.get_lexing_pos source ~filename:(Mconfig.filename config) pos in Mreader_lexer.for_completion lexer pos in @@ -50,10 +51,14 @@ let normal_parse ?for_completion config source = 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; } + and comments = Mreader_lexer.comments lexer in + { lexer_keywords; + lexer_errors; + parser_errors; + comments; + parsetree; + no_labels_for_completion + } (* Pretty-printing *) @@ -62,22 +67,26 @@ 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 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)) + ( 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 + | (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 *) @@ -85,8 +94,9 @@ let get_reader config = | x -> x let mocaml_printer reader ppf otree = - let str = match reader with - | lazy (Some reader) -> Mreader_extend.print_outcome otree reader + let str = + match reader with + | (lazy (Some reader)) -> Mreader_extend.print_outcome otree reader | _ -> None in match str with @@ -100,36 +110,39 @@ let with_ambient_reader config source f = 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 ()) + ~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 = + 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 + 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 + | 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 + 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 + 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 () @@ -139,21 +152,18 @@ let default_print_outcome tree = Format.flush_str_formatter () let print_outcome config source tree = - match try_with_reader config source - (Mreader_extend.print_outcome tree) with + 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 + 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) + try_with_reader config source (Mreader_extend.reconstruct_identifier pos) with | None | Some [] -> Mreader_lexer.reconstruct_identifier config source pos | Some result -> result @@ -161,20 +171,29 @@ let reconstruct_identifier config source pos = (* 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 + | 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; } + { lexer_keywords; + lexer_errors; + parser_errors; + comments; + parsetree; + no_labels_for_completion = false + } diff --git a/src/kernel/mreader.mli b/src/kernel/mreader.mli index 2594d65c8c..7a940e1460 100644 --- a/src/kernel/mreader.mli +++ b/src/kernel/mreader.mli @@ -1,18 +1,16 @@ -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 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 @@ -28,16 +26,17 @@ 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 + ?for_completion:Msource.position -> + Mconfig.t -> + Msource.t * parsetree option -> + result -val print_pretty : - Mconfig.t -> Msource.t -> pretty_parsetree -> string +val print_pretty : Mconfig.t -> Msource.t -> pretty_parsetree -> string -val print_outcome : - Mconfig.t -> Msource.t -> outcometree -> 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: +val reconstruct_identifier : Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list diff --git a/src/kernel/mreader_explain.ml b/src/kernel/mreader_explain.ml index 83c5186dd1..6e7cbcb8f3 100644 --- a/src/kernel/mreader_explain.ml +++ b/src/kernel/mreader_explain.ml @@ -2,16 +2,16 @@ 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_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 "{<" + | T_LBRACELESS -> Some "{<" | _ -> None let opening_st st = @@ -20,12 +20,12 @@ let opening_st st = | _ -> 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_END -> true + | T_RPAREN -> true + | T_RBRACKET -> true + | T_RBRACE -> true + | T_BARRBRACKET -> true + | T_GREATERRBRACE -> true | T_GREATERRBRACKET -> true | _ -> false @@ -34,17 +34,17 @@ let closing_st st = | 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; -} +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 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 @@ -52,45 +52,52 @@ let explain env (unexpected, startp, endp) popped shifted = let return item = { item; unclosed = !unclosed; location; popped; shifted; unexpected } in - let rec process env = match top env with + let rec process env = + match top env with | None -> return None - | Some (Element (st, _, startp, endp)) -> + | Some (Element (st, _, startp, endp)) -> ( if closing_st st then incr closed; - begin match opening_st st with + begin + match opening_st st with | None -> () | Some st -> if !closed = 0 && !unclosed = None then unclosed := Some (st, mkloc startp endp) - else - decr closed + else decr closed end; match Parser_explain.named_item_at (number st) with | name -> return (Some (name, mkloc startp endp)) - | exception Not_found -> + | exception Not_found -> ( match pop env with | None -> return None - | Some env -> process env + | Some env -> process env)) in process env let to_error { item; unclosed; location; popped; shifted; unexpected = _ } = - let inside = match item with + let inside = + match item with | None -> "" - | Some (name, _) -> " inside `" ^ name ^ "'" in - let after = match unclosed with + | Some (name, _) -> " inside `" ^ name ^ "'" + in + let after = + match unclosed with | None -> "" - | Some (name, _) -> " after unclosed " ^ name in - let friendly_name sym = match sym with + | 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 + 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) + 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 diff --git a/src/kernel/mreader_extend.ml b/src/kernel/mreader_extend.ml index b5c59a53e0..39cd0beec3 100644 --- a/src/kernel/mreader_extend.ml +++ b/src/kernel/mreader_extend.ml @@ -1,16 +1,16 @@ open Std open Extend_protocol.Reader -let {Logger. log} = Logger.for_section "Mreader_extend" +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; -} +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 @@ -18,26 +18,24 @@ 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 + 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 - ) + 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 - ) + stop t) let load_source t config source = - let buffer = { - path = Mconfig.filename config; - flags = t.args; - text = Msource.text source; - } in + 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 | _ -> @@ -60,21 +58,22 @@ let parsetree = function let parse ?for_completion t = log ~title:"parse" "?for_completion:%a %a" - (Option.print Msource.print_position) for_completion - print t; + (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) + | 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 ast -> Some (`No_labels false, parsetree ast) | Res_parse_for_completion (info, ast) -> Some (`No_labels (not info.complete_labels), parsetree ast) | _ -> @@ -82,8 +81,7 @@ let parse ?for_completion t = None let reconstruct_identifier pos t = - log ~title:"reconstruct_identifier" "%a %a" - Lexing.print_position pos print 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 | _ -> @@ -94,23 +92,21 @@ 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 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) + 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 -> @@ -133,16 +129,17 @@ 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 + | 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 + 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 + 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/src/kernel/mreader_extend.mli b/src/kernel/mreader_extend.mli index 01ee90fa43..8c38c9cc3a 100644 --- a/src/kernel/mreader_extend.mli +++ b/src/kernel/mreader_extend.mli @@ -5,19 +5,19 @@ 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]) + ?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_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 +val print_outcome : Extend_protocol.Reader.outcometree -> t -> string option diff --git a/src/kernel/mreader_lexer.ml b/src/kernel/mreader_lexer.ml index c889790b3d..28d77d2599 100644 --- a/src/kernel/mreader_lexer.ml +++ b/src/kernel/mreader_lexer.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -37,12 +37,12 @@ type item = | 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; -} +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 @@ -55,16 +55,10 @@ let get_tokens keywords pos text = | 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) + 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 - in function | [] -> (* First line: skip #! ... *) @@ -74,35 +68,28 @@ let get_tokens keywords pos text = continue items let initial_position config = - { Lexing. - pos_fname = (Mconfig.filename config); + { Lexing.pos_fname = Mconfig.filename config; pos_lnum = 1; pos_bol = 0; - pos_cnum = 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) - [] + 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 + | 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 + | Triple (_, _, e) -> e + | Comment (_, l) | Error (_, l) -> l.Location.loc_end -let initial_position t = - initial_position t.config +let initial_position t = initial_position t.config let rev_filter_map ~f lst = let rec aux acc = function @@ -118,36 +105,49 @@ let rev_filter_map ~f lst = aux [] lst let tokens t = - rev_filter_map t.items - ~f:(function Triple t -> Some t | _ -> None) + rev_filter_map t.items ~f:(function + | Triple t -> Some t + | _ -> None) -let keywords t = - Lexer_raw.list_keywords t.keywords +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) + 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) + 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 + | 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 "+=" + | 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 @@ -225,60 +225,51 @@ let is_operator = function let reconstruct_identifier_from_tokens tokens pos = let rec look_for_component acc = function - (* Skip 'a and `A *) - | ((LIDENT _ | UIDENT _), _, _) :: - ((BACKQUOTE | QUOTE), _, _) :: items -> + | ((LIDENT _ | UIDENT _), _, _) :: ((BACKQUOTE | QUOTE), _, _) :: items -> check acc items - (* UIDENT is a regular a component *) - | (UIDENT _, _, _) as item :: items -> - look_for_dot (item :: acc) items - + | ((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) - + | ((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 - + | (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 - + | ((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 - + | _ :: items -> check acc items | [] -> raise Not_found - and look_for_dot acc = function - | (DOT,_,_) :: items -> look_for_component acc items + | (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) + 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 + 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 -> @@ -286,15 +277,15 @@ let reconstruct_identifier_from_tokens tokens pos = let id = match token with | UIDENT s | LIDENT s -> s - | _ -> match is_operator token with + | _ -> ( + match is_operator token with | Some t -> t - | None -> assert false + | None -> assert false) in - Location.mkloc id {Location. loc_start; loc_end; loc_ghost = false} + Location.mkloc id { Location.loc_start; loc_end; loc_ghost = false } in let before_pos = function - | (_, s, _) -> - Lexing.compare_pos s pos <= 0 + | _, s, _ -> Lexing.compare_pos s pos <= 0 in List.map ~f:fmt (List.filter ~f:before_pos acc) @@ -303,9 +294,9 @@ let reconstruct_identifier config source pos = 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) + | EOF -> item :: acc | EOL when Lexing.compare_pos lexbuf.Lexing.lex_curr_p pos > 0 -> - (item :: acc) + item :: acc | EOL -> lex [] lexbuf | _ -> lex (item :: acc) lexbuf in @@ -314,11 +305,10 @@ let reconstruct_identifier config source pos = let tokens = lex [] lexbuf in reconstruct_identifier_from_tokens tokens pos -let is_uppercase {Location. txt = x; _} = - x <> "" && Char.is_uppercase x.[0] +let is_uppercase { Location.txt = x; _ } = x <> "" && Char.is_uppercase x.[0] let rec drop_lowercase acc = function - | [x] -> List.rev (x :: acc) + | [ 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 @@ -333,30 +323,29 @@ let for_completion t pos = (* 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 + | (Triple (token, _, loc_end) as item) :: _ as items when Lexing.compare_pos pos loc_end = 0 -> check_label item; - begin match token with + begin + match token with (* Already on identifier, no need to introduce *) | UIDENT _ | LIDENT _ -> raise Exit - | _ -> acc, items + | _ -> (acc, items) end - - | items -> acc, items + | 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)} + { t with + items = List.rev_append acc (Triple (LIDENT "", pos, pos) :: items) + } in (!no_labels, t) diff --git a/src/kernel/mreader_lexer.mli b/src/kernel/mreader_lexer.mli index f9236a72f2..c671e98dc8 100644 --- a/src/kernel/mreader_lexer.mli +++ b/src/kernel/mreader_lexer.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -34,17 +34,17 @@ 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 for_completion : + t -> Lexing.position -> bool (* complete labels or not *) * t val initial_position : t -> Lexing.position -val tokens : t -> triple list +val tokens : t -> triple list val keywords : t -> string list -val errors : t -> exn list +val errors : t -> exn list val comments : t -> (string * Location.t) list -val reconstruct_identifier: +val reconstruct_identifier : Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list -val identifier_suffix: string Location.loc list -> string Location.loc list +val identifier_suffix : string Location.loc list -> string Location.loc list diff --git a/src/kernel/mreader_parser.ml b/src/kernel/mreader_parser.ml index f05ec067e6..5f3f32efb9 100644 --- a/src/kernel/mreader_parser.ml +++ b/src/kernel/mreader_parser.ml @@ -1,45 +1,44 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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*) +type kind = ML | MLI +(*| MLL | MLY*) module Dump = struct let symbol () = Parser_printer.print_symbol end -module R = Mreader_recover.Make +module R = + Mreader_recover.Make (I) (struct include Parser_recover @@ -56,29 +55,24 @@ module R = Mreader_recover.Make 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; -} + (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) @@ -87,81 +81,72 @@ 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, [] + 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 - + | (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 - + | 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 + 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, [] + let token, tokens = + match tokens with + | token :: tokens -> (token, tokens) + | [] -> (eof_token, []) in - let acc' = ((Recovering candidates, token) :: acc) 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 + | 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 + | 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 -> + | step :: steps, token :: tokens when snd step = token -> aux (step :: acc) (steps, tokens) - | _, tokens -> acc, tokens + | _, tokens -> (acc, tokens) in aux [] (steps, tokens) @@ -173,38 +158,42 @@ let parse initial steps tokens initial_pos = | [] -> Correct (initial initial_pos) in let acc, result = resume_parse acc tokens step in - List.rev acc, result + (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 + | 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 + parse state steps tokens initial_pos + in + (`Structure steps, `Implementation result) | MLI -> - let steps = match previous with + 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 + 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} + { kind; steps; tree; errors; lexer } let result t = t.tree diff --git a/src/kernel/mreader_parser.mli b/src/kernel/mreader_parser.mli index d2b9ebff0b..4a14af2486 100644 --- a/src/kernel/mreader_parser.mli +++ b/src/kernel/mreader_parser.mli @@ -1,44 +1,40 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 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 -] +type tree = + [ `Interface of Parsetree.signature | `Implementation of Parsetree.structure ] val result : t -> tree diff --git a/src/kernel/mreader_recover.ml b/src/kernel/mreader_recover.ml index 4015905036..d13314cbb0 100644 --- a/src/kernel/mreader_recover.ml +++ b/src/kernel/mreader_recover.ml @@ -1,51 +1,46 @@ open Std -let {Logger. log} = Logger.for_section "Mreader_recover" +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 + 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 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) + type decision = + | Nothing + | One of action list + | Select of (int -> action list) - val depth : int array + val depth : int array - val recover : int -> decision + val recover : int -> decision - val guide : 'a Parser.symbol -> bool + val guide : 'a Parser.symbol -> bool - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token + val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - val nullable : 'a Parser.nonterminal -> bool - end) + val nullable : 'a Parser.nonterminal -> bool + end) (Dump : sig - val symbol : unit -> Parser.xsymbol -> string - end) = + 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 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; - } + 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 @@ -74,41 +69,41 @@ struct | Parser.HandlingError _ | Parser.Rejected -> `Fail | Parser.AboutToReduce _ when not allow_reduction -> `Fail | Parser.Accepted v -> `Accept v - | Parser.Shifting _ | Parser.AboutToReduce _ as checkpoint -> + | (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 + 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 + else col let candidate env = let line, min_col, max_col = match Parser.top env with - | None -> 1, 0, 0 + | 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 + if depth = 0 then (line, col, col) else - let col' = match Parser.pop_many depth env with + let col' = + match Parser.pop_many depth env with | None -> max_int - | Some env -> + | Some env -> ( match Parser.top env with | None -> max_int | Some (Parser.Element (_, _, pos, _)) -> - follow_guide (snd (Lexing.split_pos pos)) env + follow_guide (snd (Lexing.split_pos pos)) env) in - line, min col col', max col col' + (line, min col col', max col col') in { line; min_col; max_col; env } @@ -116,27 +111,29 @@ struct let _, startp, _ = token in let line, col = Lexing.split_pos startp in let more_indented candidate = - line <> candidate.line && candidate.min_col > col in + 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) + 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 + | 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 + | `Accept v -> begin + match aux xs with + | `Fail -> `Accept v + | x -> x + end) in aux recoveries @@ -148,7 +145,9 @@ struct | Some (Parser.Element (state, _, _, _)) -> Parser.number state else match Parser.pop env with - | None -> assert (n = 1); -1 + | None -> + assert (n = 1); + -1 | Some env -> nth_state env (n - 1) in let st = nth_state env 0 in @@ -164,13 +163,14 @@ struct let shifted = ref None in let rec aux acc env = match Parser.top env with - | None -> None, acc - | Some (Parser.Element (state, _, _startp, endp)) -> + | 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 + let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env = + function | Recovery.Abort -> log ~title:"eval Abort" ""; raise Not_found @@ -185,20 +185,25 @@ struct 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 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 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 + begin + match feed_token ~allow_reduction:true token env with | `Fail -> assert false | `Accept v -> raise (E.Result v) - | `Recovered (_,env) -> env + | `Recovered (_, env) -> env end | Recovery.Sub actions -> log ~title:"enter Sub" ""; @@ -208,13 +213,12 @@ struct in match List.rev_scan_left [] ~f:eval ~init:env actions - |> List.map ~f:(fun env -> {candidate0 with env}) + |> 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 + | 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 = @@ -250,10 +254,11 @@ struct 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)) + 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 } + { 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 ( diff --git a/src/kernel/mreader_recover.mli b/src/kernel/mreader_recover.mli index 5cf5c0a2dd..c71b4d591c 100644 --- a/src/kernel/mreader_recover.mli +++ b/src/kernel/mreader_recover.mli @@ -1,56 +1,48 @@ module Make (Parser : MenhirLib.IncrementalEngine.EVERYTHING) (Recovery : sig - val default_value : Location.t -> 'a Parser.symbol -> 'a + 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 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) + type decision = + | Nothing + | One of action list + | Select of (int -> action list) - val depth : int array + val depth : int array - val can_pop : 'a Parser.terminal -> bool + val can_pop : 'a Parser.terminal -> bool - val recover : int -> decision + val recover : int -> decision - val guide : 'a Parser.symbol -> bool + val guide : 'a Parser.symbol -> bool - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token + val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - val nullable : 'a Parser.nonterminal -> bool - end) + 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 -> + 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 ] + [> `Accept of 'a | `Fail | `Ok of 'a Parser.checkpoint * 'a Parser.env ] val generate : 'a Parser.env -> 'a candidates - end diff --git a/src/kernel/msource.ml b/src/kernel/msource.ml index eebad4edb8..b975cc556f 100644 --- a/src/kernel/msource.ml +++ b/src/kernel/msource.ml @@ -1,11 +1,9 @@ (* Merlin representation of a textual source code *) open Std -let {Logger. log} = Logger.for_section "Msource" +let { Logger.log } = Logger.for_section "Msource" -type t = { - text: string; -} +type t = { text : string } module Digest = struct type t = Digest.t @@ -14,64 +12,56 @@ module Digest = struct let equal = Digest.equal end -let dump t = `Assoc [ - "text" , `String t.text; - ] +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 + | `Logical (l, c) -> string_of_int l ^ ":" ^ string_of_int c | `End -> "end" -let make text = {text} +let make text = { text } (* Position management *) -type position = [ - | `Start - | `Offset of int - | `Logical of int * int - | `End -] +type position = [ `Start | `Offset of int | `Logical of int * int | `End ] exception Found of int -let find_line line {text} = +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 + "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); + if !line' = 1 then raise (Found i) end done; - log ~title:"find_line" "line %d out of bounds (max = %d)" - line (line - !line'); + log ~title:"find_line" "line %d out of bounds (max = %d)" line + (line - !line'); String.length text - with Found n -> - n + 1 + with Found n -> n + 1 -let find_offset ({text} as t) line col = +let find_offset ({ text } as t) line col = assert (col >= 0); let offset = find_line line t in - if col = 0 then offset else + 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); + "%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 + if offset + col > String.length text then begin log ~title:"find_offset" "%d:%d out of file bounds" line col end; offset + col @@ -81,24 +71,22 @@ let get_offset t = function | `Start -> `Offset 0 | `Offset x -> assert (x >= 0); - if x <= String.length t.text then - (`Offset x) + 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)) + 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) + | `End -> `Offset (String.length t.text) + | `Logical (line, col) -> `Offset (find_offset t line col) -let get_logical {text} = function +let get_logical { text } = function | `Start -> `Logical (1, 0) | `Logical _ as p -> p - | `Offset _ | `End as r -> + | (`Offset _ | `End) as r -> let len = String.length text in - let offset = match r with + 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 @@ -112,29 +100,28 @@ let get_logical {text} = function for i = 0 to offset - 1 do if text.[i] = '\n' then begin incr line; - cnum := i + 1; - end; + 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; + 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; + 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 + 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) + 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; @@ -142,14 +129,13 @@ let substitute t starting ending text = end | #position as p -> get_offset t p in - if ending < starting then - invalid_arg "Source.substitute: ending < starting"; + 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) + String.sub t.text ~pos:0 ~len:starting + ^ text + ^ String.sub t.text ~pos:ending ~len:(len - ending) in - {text} + { text } (* Accessing content *) diff --git a/src/kernel/msource.mli b/src/kernel/msource.mli index b7f4d47c6b..ff0b72b9e0 100644 --- a/src/kernel/msource.mli +++ b/src/kernel/msource.mli @@ -21,27 +21,23 @@ val make : string -> t (** {1 Position management} *) -type position = [ - | `Start - | `Offset of int - | `Logical of int * int - | `End -] +type position = [ `Start | `Offset of int | `Logical of int * int | `End ] -val get_offset : t -> [< position] -> [> `Offset of int] +val get_offset : t -> [< position ] -> [> `Offset of int ] -val get_logical : t -> [< position] -> [> `Logical of int * int] +val get_logical : t -> [< position ] -> [> `Logical of int * int ] -val get_lexing_pos : t -> filename:string -> [< position] -> Lexing.position +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 +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 +val print_position : unit -> [< position ] -> string diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 034cb10c7d..574d025c8e 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -1,23 +1,21 @@ 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_stamp : int; - 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 { 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_stamp : int; + 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 ] type typer_cache_stats = Miss | Hit of { reused : int; typed : int } @@ -33,28 +31,27 @@ let fresh_env config = let get_cache config = match !cache with | Some (env0, snap0, stamp0, items, _) when Types.is_valid snap0 -> - env0, snap0, stamp0, Some items + (env0, snap0, stamp0, Some items) | Some _ | None -> let env0, snap0, stamp0 = fresh_env config in - env0, snap0, stamp0, None + (env0, snap0, stamp0, None) let return_and_cache status = cache := Some status; status -type result = { - config : Mconfig.t; - initial_env : Env.t; - initial_snapshot : Types.snapshot; - initial_stamp : int; - typedtree : [ - | `Interface of +type result = + { config : Mconfig.t; + initial_env : Env.t; + initial_snapshot : Types.snapshot; + initial_stamp : int; + typedtree : + [ `Interface of (Parsetree.signature_item, Typedtree.signature_item) item list - | `Implementation of - (Parsetree.structure_item, Typedtree.structure_item) item list - ]; - cache_stat : typer_cache_stats -} + | `Implementation of + (Parsetree.structure_item, Typedtree.structure_item) item list ]; + cache_stat : typer_cache_stats + } let initial_env res = res.initial_env @@ -62,50 +59,58 @@ let get_cache_stat res = res.cache_stat let compatible_prefix result_items tree_items = let rec aux acc = function - | (ritem :: ritems, pitem :: pitems) + | ritem :: ritems, pitem :: pitems when Types.is_valid ritem.part_snapshot - && compare ritem.parsetree_item pitem = 0 -> + && compare ritem.parsetree_item pitem = 0 -> aux (ritem :: acc) (ritems, pitems) - | (_, pitems) -> + | _, pitems -> let reused = List.length acc in let typed = List.length pitems in let cache_stat = Hit { reused; typed } in log ~title:"compatible_prefix" "reusing %d items, %d new items to type" reused typed; - acc, pitems, cache_stat + (acc, pitems, cache_stat) 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] + 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_stamp = Ident.get_currentstamp (); - part_errors = !caught; - part_checks = !Typecore.delayed_checks; - part_warnings = Warnings.backup (); - } in + (items.Typedtree.str_items, items.Typedtree.str_type) + in + let item = + { parsetree_item; + typedtree_items; + part_env; + part_snapshot = Btype.snapshot (); + part_stamp = Ident.get_currentstamp (); + 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_stamp = Ident.get_currentstamp (); - part_errors = !caught; - part_checks = !Typecore.delayed_checks; - part_warnings = Warnings.backup (); - } in + 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_stamp = Ident.get_currentstamp (); + part_errors = !caught; + part_checks = !Typecore.delayed_checks; + part_warnings = Warnings.backup () + } + in item :: type_signature caught part_env rest | [] -> [] @@ -116,7 +121,8 @@ let type_implementation config caught parsetree = | Some (`Implementation items) -> compatible_prefix items parsetree | Some (`Interface _) | None -> ([], parsetree, Miss) in - let env', snap', stamp', warn' = match prefix with + let env', snap', stamp', warn' = + match prefix with | [] -> (env0, snap0, stamp0, Warnings.backup ()) | x :: _ -> caught := x.part_errors; @@ -128,7 +134,11 @@ let type_implementation config caught parsetree = Env.cleanup_functor_caches ~stamp:stamp'; let suffix = type_structure caught env' parsetree in return_and_cache - (env0, snap0, stamp0, `Implementation (List.rev_append prefix suffix), cache_stat) + ( env0, + snap0, + stamp0, + `Implementation (List.rev_append prefix suffix), + cache_stat ) let type_interface config caught parsetree = let env0, snap0, stamp0, prefix = get_cache config in @@ -137,7 +147,8 @@ let type_interface config caught parsetree = | Some (`Interface items) -> compatible_prefix items parsetree | Some (`Implementation _) | None -> ([], parsetree, Miss) in - let env', snap', stamp', warn' = match prefix with + let env', snap', stamp', warn' = + match prefix with | [] -> (env0, snap0, stamp0, Warnings.backup ()) | x :: _ -> caught := x.part_errors; @@ -159,39 +170,45 @@ let run config parsetree = Mocaml.flush_caches (); Local_store.reset (); Load_path.reset (); - Load_path.init load_path; - ); + 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, initial_stamp, typedtree, cache_stat = match parsetree with + let initial_env, initial_snapshot, initial_stamp, typedtree, cache_stat = + 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; initial_stamp; typedtree; cache_stat } + { config; + initial_env; + initial_snapshot; + initial_stamp; + typedtree; + cache_stat + } let get_env ?pos:_ t = - Option.value ~default:t.initial_env ( - match t.typedtree with + 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) - ) + | `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) - ) + 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; + Msupport.catch_errors + Mconfig.(t.config.ocaml.warnings) + caught Typecore.force_delayed_checks; Typecore.reset_delayed_checks (); - (!caught) + !caught let get_typedtree t = let split_items l = @@ -201,25 +218,24 @@ let get_typedtree t = 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} + `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} + `Interface { Typedtree.sig_items; sig_type; sig_final_env = get_env t } -let node_at ?(skip_recovered=false) t pos_cursor = +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 + | (_, _) :: ((_, 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] + 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); + log ~title:"node_at" "Deepest before %s" (Mbrowse.print () path); path diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index fd6a7a6b77..9e214024de 100644 --- a/src/kernel/mtyper.mli +++ b/src/kernel/mtyper.mli @@ -9,10 +9,8 @@ type result -type typedtree = [ - | `Interface of Typedtree.signature - | `Implementation of Typedtree.structure -] +type typedtree = + [ `Interface of Typedtree.signature | `Implementation of Typedtree.structure ] type typer_cache_stats = Miss | Hit of { reused : int; typed : int } @@ -42,5 +40,4 @@ val get_cache_stat : result -> typer_cache_stats * 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 +val node_at : ?skip_recovered:bool -> result -> Lexing.position -> Mbrowse.t diff --git a/src/kernel/phase_cache.ml b/src/kernel/phase_cache.ml index eb8c2de4c5..f08b5c2da9 100644 --- a/src/kernel/phase_cache.ml +++ b/src/kernel/phase_cache.ml @@ -28,33 +28,33 @@ module With_cache (Phase : S) = struct let title = Phase.title in match cache_disabling with | Some reason -> - log ~title "Cache is disabled: %s" reason; - cache := None; + log ~title "Cache is disabled: %s" reason; + cache := None; + let output = Phase.f input in + { output; cache_was_hit = false } + | None -> ( + let new_fingerprint = Phase.Fingerprint.make input in + match (!cache, new_fingerprint) with + | None, Ok new_fingerprint -> + log ~title "Cache wasn't populated\n"; let output = Phase.f input in + cache := Some { fingerprint = new_fingerprint; output }; { output; cache_was_hit = false } - | None -> ( - let new_fingerprint = Phase.Fingerprint.make input in - match (!cache, new_fingerprint) with - | None, Ok new_fingerprint -> - log ~title "Cache wasn't populated\n"; - let output = Phase.f input in - cache := Some { fingerprint = new_fingerprint; output }; - { output; cache_was_hit = false } - | Some { fingerprint; output }, Ok new_fingerprint -> - if - (not force_invalidation) - && Phase.Fingerprint.equal fingerprint new_fingerprint - then ( - log ~title "Cache hit"; - { output; cache_was_hit = true }) - else ( - log ~title "Cache invalidation"; - let output = Phase.f input in - cache := Some { fingerprint = new_fingerprint; output }; - { output; cache_was_hit = false }) - | (None | Some _), Error err -> - log ~title "Cache workflow is incomplete: %s" err; - cache := None; - let output = Phase.f input in - { output; cache_was_hit = false }) + | Some { fingerprint; output }, Ok new_fingerprint -> + if + (not force_invalidation) + && Phase.Fingerprint.equal fingerprint new_fingerprint + then ( + log ~title "Cache hit"; + { output; cache_was_hit = true }) + else ( + log ~title "Cache invalidation"; + let output = Phase.f input in + cache := Some { fingerprint = new_fingerprint; output }; + { output; cache_was_hit = false }) + | (None | Some _), Error err -> + log ~title "Cache workflow is incomplete: %s" err; + cache := None; + let output = Phase.f input in + { output; cache_was_hit = false }) end diff --git a/src/kernel/phase_cache.mli b/src/kernel/phase_cache.mli index 14a86f7467..739084160a 100644 --- a/src/kernel/phase_cache.mli +++ b/src/kernel/phase_cache.mli @@ -1,29 +1,29 @@ (** An all-or-nothing cache mechanism that can be used for any phase *) module type S = sig - type t (** Phase input *) + type t - type output (** Phase output *) + type output - val f : t -> output (** Phase computation *) + val f : t -> output - val title : string (** Phase title for logging *) + val title : string module Fingerprint : sig type input - type t (** Fingerprint used to determine whether the cache should be invalidated *) + type t - val make : input -> (t, string) result (** Creates a fingerprint from the phase input *) + val make : input -> (t, string) result - val equal : t -> t -> bool (** Determines whether two fingerprints are the same *) + val equal : t -> t -> bool end with type input := t end @@ -31,8 +31,6 @@ end module With_cache (Phase : S) : sig type t = { output : Phase.output; cache_was_hit : bool } - val apply : - ?cache_disabling:string option -> ?force_invalidation:bool -> Phase.t -> t (** [apply ~cache_disabling ~force_invalidation phase_input] runs the phase computation [Phase.f phase_input], if there's some [cache_disabling]. Otherwise, the phase computation is run with a cache mechanism. Whether @@ -40,4 +38,6 @@ module With_cache (Phase : S) : sig comparison between the current fingerprint and the last one. Additionally, the invalidation of the cache can be forced by setting the force_invalidation parameter to true.*) + val apply : + ?cache_disabling:string option -> ?force_invalidation:bool -> Phase.t -> t end diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 88caa4bed6..b630a24f16 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -1,30 +1,30 @@ (* {{{ Copying *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2017 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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"] @@ -36,169 +36,194 @@ 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 - | Binding_op of binding_op - - | 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 + | 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 + | Binding_op of binding_op + | 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 _ - | Binding_op _ - -> env0 + | 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 _ + | Binding_op _ -> 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} - | Binding_op {bop_op_name = {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 + | 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 } + | Binding_op { bop_op_name = { 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 + | 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 + | 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 + | 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 + | 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_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 + | Method_call (obj, _, _) -> obj.exp_attributes + | Record_field (`Expression obj, _, _) -> obj.exp_attributes + | Record_field (`Pattern obj, _, _) -> obj.pat_attributes | _ -> [] let has_attr ~name node = let attrs = node_attributes node in - List.exists ~f:(fun a -> - let (str,_) = Ast_helper.Attr.as_tuple a in - str.Location.txt = name - ) attrs + List.exists + ~f:(fun a -> + let str, _ = Ast_helper.Attr.as_tuple a in + str.Location.txt = name) + attrs let node_merlin_loc loc0 node = let attributes = node_attributes node in @@ -209,30 +234,31 @@ let node_merlin_loc loc0 node = | { 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) + 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) + | 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 +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 +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 ( ** ) 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 +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 @@ -243,30 +269,30 @@ let array_fold (f' : _ f1) arr 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 +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 +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_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 +let of_pat_extra (pat, _, _) = + match pat with | Tpat_constraint ct -> of_core_type ct | Tpat_type _ | Tpat_unpack | Tpat_open _ -> id_fold @@ -278,7 +304,7 @@ 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_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 @@ -286,99 +312,97 @@ let of_constructor_arguments = function let of_bop ({ bop_exp; _ } as bop) = app (Binding_op bop) ** 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_record_field obj loc lbl 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_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_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 -> + | Tpat_tuple ps | Tpat_construct (_, _, ps, None) | Tpat_array ps -> list_fold of_pattern ps - | Tpat_construct (_,_,ps,Some (_, ct)) -> + | 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 -> + | 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 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 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) -> + | 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 ** + option_fold of_expression extended_expression + ** let fold_field = function - | (_,Typedtree.Kept _) -> id_fold - | (desc,Typedtree.Overridden (lid_loc,e)) -> + | _, 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) -> + | Texp_field (e, lid_loc, lbl) -> of_expression e ** of_exp_record_field e lid_loc lbl - | Texp_setfield (e1,lid_loc,lbl,e2) -> + | 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) -> + | 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_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 } + { 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) -> + | 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_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; _ } -> (* let+ ..pat1 and pat2 and ... are represented as pattern couples: [pat1; [pat2; ...]]. The following function flattens these couples. @@ -387,137 +411,97 @@ let of_expression_desc loc = function let rec flatten_patterns ~size acc pat = match pat.pat_desc with | Tpat_tuple [ tuple; pat ] when size > 0 -> - flatten_patterns ~size:(size - 1) (pat :: acc) tuple + flatten_patterns ~size:(size - 1) (pat :: acc) tuple | _ -> List.rev (pat :: acc) in let bindops = let_ :: ands in let patterns = flatten_patterns ~size:(List.length ands) [] body.c_lhs in let of_letop (pat, bindop) = of_bop bindop ** of_pattern pat in - list_fold of_letop (List.combine patterns bindops) ** - of_expression body.c_rhs - | Texp_open (od, e) -> - app (Module_expr od.open_expr) ** of_expression e + list_fold of_letop (List.combine patterns bindops) + ** of_expression body.c_rhs + | 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) + | 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) -> + | 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*) + | 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) -> + | 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_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_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 + 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) -> + | 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 + | 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_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 -> @@ -532,270 +516,223 @@ and of_signature_item_desc = function 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) -> + | 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) + | 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) + | 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 + | 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 } -> + | 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 + 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 + 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 -> + 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 + | Structure_item ({ str_desc }, _) -> of_structure_item_desc str_desc | Module_binding mb -> - app (Module_expr mb.mb_expr) ** - app (Module_binding_name 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 + 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 -> + 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 + | Signature_item ({ sig_desc }, _) -> of_signature_item_desc sig_desc | Module_declaration md -> - of_module_type md.md_type ** - app (Module_declaration_name 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) + 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_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 + | Core_type { ctyp_desc } -> of_core_type_desc ctyp_desc | Package_type { pack_fields } -> - list_fold (fun (_,ct) -> of_core_type ct) 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 + 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 + 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_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 + 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 + 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 + 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 + 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 + 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 + 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 - | Binding_op { bop_exp=_ } -> - 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 + | Binding_op { bop_exp = _ } -> id_fold -let fold_node f env node acc = - of_node node env f acc +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 -> + | Pattern p -> let fmt, printer = Format.to_string () in - Printtyped.pattern 0 fmt p ; + 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" + | 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" + | 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" - | Binding_op _ -> "binding_op" - | Method_call _ -> "method_call" - | Record_field _ -> "record_field" - | Module_binding_name _ -> "module_binding_name" + | 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" + | Binding_op _ -> "binding_op" + | 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" + | 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 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 + | 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 = +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.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 -> [] + [ (mkloc (Path.Pident (Ident.create_persistent name)) loc, Some lid) ] + | _ | (exception Not_found) -> [] -let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } = +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; _},_,_) -> + | 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)] + | 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,_,_) -> + List.fold_left ~init pat_extra ~f:(fun acc (extra, _, _) -> match extra with - | Tpat_open (path,loc,_) | Tpat_type (path,loc) -> + | Tpat_open (path, loc, _) | Tpat_type (path, loc) -> (reloc path loc, Some loc.txt) :: acc | _ -> acc) -let module_expr_paths { Typedtree. mod_desc } = +let module_expr_paths { Typedtree.mod_desc } = match mod_desc with - | Tmod_ident (path, loc) -> [reloc path loc, Some loc.txt] + | 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] + [ (reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt) ] | _ -> [] let bindop_path { bop_op_name; bop_op_path } = @@ -803,130 +740,134 @@ let bindop_path { bop_op_name; bop_op_path } = let path = bop_op_path in (reloc path loc, Some (Longident.Lident loc.txt)) -let expression_paths { Typedtree. exp_desc; exp_extra; _ } = +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} -> + | 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},_,_,_,_) -> + | 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) + | 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; _}, _) -> + [ (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 + | Texp_open (od, _) -> module_expr_paths od.open_expr | _ -> [] in - List.fold_left ~init exp_extra - ~f:(fun acc (extra, _, _) -> + 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 + let lid = Longident.Lident label_loc.txt in (mkloc path label_loc.loc, Some lid) :: acc | _ -> acc) -let core_type_paths { Typedtree. ctyp_desc } = +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] + | 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 } = +let class_expr_paths { Typedtree.cl_desc } = match cl_desc with - | Tcl_ident (path, loc, _) -> [reloc path loc, Some loc.txt] + | Tcl_ident (path, loc, _) -> [ (reloc path loc, Some loc.txt) ] | _ -> [] -let class_field_paths { Typedtree. cf_desc } = +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)] + | Tcf_val (loc, _, id, _, _) -> + [ (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)) ] | _ -> [] -let structure_item_paths { Typedtree. str_desc } = +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 + 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 } = +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 + [ (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 } = +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] + | 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] + | 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 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 + 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 + | 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] + [ (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 + | 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] + [ (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) ] + [ (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] + [ (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)] + [ (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)] + [ (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] + [ (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)] + [ (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)] + [ (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)] + [ (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) -> + | Record_field (_, { Types.lbl_res; lbl_name; _ }, lid_loc) -> fake_path lid_loc lbl_res lbl_name | _ -> [] @@ -934,58 +875,40 @@ 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) - ) + | 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} + 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 } | Extension_constructor ext_cons -> - Some { Location.loc = ext_cons.ext_loc; - txt = `Extension_constructor ext_cons} + Some + { Location.loc = ext_cons.ext_loc; txt = `Extension_constructor ext_cons } | _ -> 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 + | 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 + 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 diff --git a/src/ocaml/merlin_specific/browse_raw.mli b/src/ocaml/merlin_specific/browse_raw.mli index 06d2b1cecc..0495a00185 100644 --- a/src/ocaml/merlin_specific/browse_raw.mli +++ b/src/ocaml/merlin_specific/browse_raw.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2014 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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]. @@ -48,56 +48,54 @@ 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 + | 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 - | Binding_op of binding_op - - | 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 + 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 + | Binding_op of binding_op + | 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 @@ -115,16 +113,17 @@ 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 -> +val node_is_constructor : + node -> [ `Description of Types.constructor_description | `Declaration of Typedtree.constructor_declaration | `Extension_constructor of Typedtree.extension_constructor ] - Location.loc option + 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 + (Location.t * Env.t * [ `Exp of Types.type_expr | `Mod of Types.module_type ]) + list diff --git a/src/ocaml/merlin_specific/tast_helper.ml b/src/ocaml/merlin_specific/tast_helper.ml index 1664fa1586..42612cc034 100644 --- a/src/ocaml/merlin_specific/tast_helper.ml +++ b/src/ocaml/merlin_specific/tast_helper.ml @@ -4,7 +4,7 @@ module Pat = struct let pat_extra = [] let pat_attributes = [] - let constant ?(loc=Location.none) pat_env pat_type c = + 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 } @@ -17,24 +17,24 @@ module Pat = struct 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 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 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 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_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 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/src/ocaml/merlin_specific/typer_raw.ml b/src/ocaml/merlin_specific/typer_raw.ml index 0d83b8b20c..c70136dc82 100644 --- a/src/ocaml/merlin_specific/typer_raw.ml +++ b/src/ocaml/merlin_specific/typer_raw.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -33,10 +33,7 @@ open Parsetree let fresh_env () = (*Ident.reinit();*) let initially_opened_module = - if !Clflags.nopervasives then - None - else - Some "Stdlib" + if !Clflags.nopervasives then None else Some "Stdlib" in Typemod.initial_env ~loc:(Location.in_file "command line") @@ -54,17 +51,23 @@ module Rewrite_loc = struct | l' :: ls -> queue := Location_aux.union l l' :: ls let enter () = queue := Location.none :: !queue - let leave l0 = match !queue with + let leave l0 = + match !queue with | [] -> assert false - | [l] -> queue := []; Location_aux.extend l0 l + | [ 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 := [] + let start () = + assert (!queue = []); + enter () + let exit () = + match !queue with + | [ _ ] -> queue := [] | _ -> assert false let u_option f = function @@ -72,13 +75,12 @@ module Rewrite_loc = struct | Some x -> Some (f x) let u_loc (loc : _ Location.loc) = - update loc.loc; loc + update loc.loc; + loc - let rec u_attribute { attr_name = loc ; attr_payload; attr_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 } + { 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 @@ -89,68 +91,75 @@ module Rewrite_loc = struct and u_payload = function | PStr str -> PStr (u_structure str) | PSig sg -> PSig (u_signature sg) - | PTyp ct -> PTyp (u_core_type ct) + | 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} = + 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} + { ptyp_desc; ptyp_loc; ptyp_attributes; ptyp_loc_stack } and u_core_type_desc = function - | Ptyp_any | Ptyp_var _ as desc -> desc + | (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_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 } + { 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_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) + (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, 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 } + { 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} = + 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} + { ppat_desc; ppat_loc; ppat_attributes; ppat_loc_stack } and u_pattern_desc = function - | Ppat_any | Ppat_constant _ | Ppat_interval _ as p -> p + | (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_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_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) @@ -159,50 +168,62 @@ module Rewrite_loc = struct | 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) + | Ppat_open (l, p) -> Ppat_open (u_loc l, u_pattern p) - and u_expression {pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack} = + 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} + { 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_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_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_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_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_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_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_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_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_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_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) @@ -213,61 +234,85 @@ module Rewrite_loc = struct | 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_letop + { let_ = u_binding_op let_; + ands = List.map ~f:u_binding_op ands; + body = u_expression body + } 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} = + { 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} = + { 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_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 + 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} + { 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_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} = + 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} + { 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} = + 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 @@ -275,47 +320,63 @@ module Rewrite_loc = struct 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} + { 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 } = + { 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_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} = + { 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} + { 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_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} = + 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} + { pcty_desc; pcty_loc; pcty_attributes } and u_class_type_desc = function | Pcty_constr (loc, cts) -> @@ -323,83 +384,86 @@ module Rewrite_loc = struct | 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) + | 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} = + 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} + { pcsig_self; pcsig_fields } - and u_class_type_field {pctf_desc; pctf_loc; pctf_attributes} = + 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} + { 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_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} -> + 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_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} + { 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} = + 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} + { 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_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_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_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) + | Pcl_open (od, ce) -> Pcl_open (u_open_description od, u_class_expr ce) - and u_class_structure {pcstr_self; pcstr_fields} = + 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} + { pcstr_self; pcstr_fields } - and u_class_field {pcf_desc; pcf_loc; pcf_attributes} = + 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} + { 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_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) @@ -407,22 +471,24 @@ module Rewrite_loc = struct 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) + | 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} = + 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} + { 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_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) @@ -433,11 +499,11 @@ module Rewrite_loc = struct and u_signature l = List.map ~f:u_signature_item l - and u_signature_item {psig_desc; psig_loc} = + 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} + { psig_desc; psig_loc } and u_signature_item_desc = function | Psig_value vd -> Psig_value (u_value_description vd) @@ -445,68 +511,78 @@ module Rewrite_loc = struct | 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_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_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_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_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} = + 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} + { pmd_name; pmd_type; pmd_attributes; pmd_loc } - and u_module_substitution {pms_name; pms_manifest; pms_attributes; pms_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} = + 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} + { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } - and u_open_declaration {popen_expr; popen_override; popen_loc; popen_attributes} = + 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} + { popen_expr; popen_override; popen_loc; popen_attributes } - and u_open_description {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} + { 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} -> + 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} + { 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 @@ -519,20 +595,19 @@ module Rewrite_loc = struct | Pwith_modtypesubst (loc, mt) -> Pwith_modtypesubst (u_loc loc, u_module_type mt) - and u_module_expr {pmod_desc; pmod_loc; pmod_attributes} = + 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} + { 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_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) @@ -540,14 +615,15 @@ module Rewrite_loc = struct and u_structure l = List.map ~f:u_structure_item l - and u_structure_item {pstr_desc; pstr_loc} = + 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} + { pstr_desc; pstr_loc } and u_structure_item_desc = function - | Pstr_eval (expr, attrs) -> Pstr_eval (u_expression expr, u_attributes attrs) + | 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) @@ -558,31 +634,34 @@ module Rewrite_loc = struct | 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_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) + | Pstr_extension (ext, attrs) -> + Pstr_extension (u_extension ext, u_attributes attrs) - and u_value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = + 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} + { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } - and u_module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_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} + { pmb_name; pmb_expr; pmb_attributes; pmb_loc } end let rewrite_loc t = Rewrite_loc.start (); - let t = match t with + 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) diff --git a/src/ocaml/merlin_specific/typer_raw.mli b/src/ocaml/merlin_specific/typer_raw.mli index 669bdf1dd7..c510c6fd1e 100644 --- a/src/ocaml/merlin_specific/typer_raw.mli +++ b/src/ocaml/merlin_specific/typer_raw.mli @@ -1,35 +1,37 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 + [ `str of Parsetree.structure + | `sg of Parsetree.signature | `fake of Parsetree.structure ] -> - [ `str of Parsetree.structure | `sg of Parsetree.signature + [ `str of Parsetree.structure + | `sg of Parsetree.signature | `fake of Parsetree.structure ] diff --git a/src/ocaml/parsing/msupport_parsing.ml b/src/ocaml/parsing/msupport_parsing.ml index 567e5e28e1..0a3fa62283 100644 --- a/src/ocaml/parsing/msupport_parsing.ml +++ b/src/ocaml/parsing/msupport_parsing.ml @@ -1,6 +1,4 @@ (* Filled in from Msupport. *) -let msupport_raise_error : (exn -> unit) ref = - ref raise +let msupport_raise_error : (exn -> unit) ref = ref raise -let raise_error exn = - !msupport_raise_error exn +let raise_error exn = !msupport_raise_error exn diff --git a/src/ocaml/typing/msupport.ml b/src/ocaml/typing/msupport.ml index 02619389a2..3681764c4a 100644 --- a/src/ocaml/typing/msupport.ml +++ b/src/ocaml/typing/msupport.ml @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 @@ -32,29 +32,25 @@ let errors : (exn list ref * unit Btype.TypeHash.t) option ref = ref None let monitor_errors' = ref (ref false) let monitor_errors () = - if !(!monitor_errors') then - monitor_errors' := (ref false); + if !(!monitor_errors') then monitor_errors' := ref false; !monitor_errors' -let raise_error ?(ignore_unify=false) exn = +let raise_error ?(ignore_unify = false) exn = !monitor_errors' := true; match !errors with - | Some (l,_) -> - begin match exn with - | Ctype.Unify _ when ignore_unify -> () - | Ctype.Unify _ | Failure _ -> - Logger.log ~section:"Typing_aux.raise_error" - ~title:(Printexc.exn_slot_name exn) "%a" - Logger.fmt (fun fmt -> - Printexc.record_backtrace true; - Format.pp_print_string fmt (Printexc.get_backtrace ()) - ) - | exn -> l := exn :: !l - end + | Some (l, _) -> begin + match exn with + | Ctype.Unify _ when ignore_unify -> () + | Ctype.Unify _ | Failure _ -> + Logger.log ~section:"Typing_aux.raise_error" + ~title:(Printexc.exn_slot_name exn) "%a" Logger.fmt (fun fmt -> + Printexc.record_backtrace true; + Format.pp_print_string fmt (Printexc.get_backtrace ())) + | exn -> l := exn :: !l + end | None -> raise exn -let () = - Msupport_parsing.msupport_raise_error := raise_error +let () = Msupport_parsing.msupport_raise_error := raise_error exception Resume @@ -66,33 +62,31 @@ let catch_errors warnings caught f = let warnings' = Warnings.backup () in let errors' = !errors in Warnings.restore warnings; - errors := (Some (caught,Btype.TypeHash.create 3)); - Misc.try_finally f - ~always:(fun () -> - errors := errors'; - Warnings.restore warnings') + errors := Some (caught, Btype.TypeHash.create 3); + Misc.try_finally f ~always:(fun () -> + errors := errors'; + Warnings.restore warnings') -let uncatch_errors f = - let_ref errors None f +let uncatch_errors f = let_ref errors None f let erroneous_type_register te = let te = Types.Transient_expr.coerce te in match !errors with - | Some (_,h) -> Btype.TypeHash.replace h te () + | Some (_, h) -> Btype.TypeHash.replace h te () | None -> () let erroneous_type_check te = let te = Types.Transient_expr.coerce te in match !errors with - | Some (_,h) -> Btype.TypeHash.mem h te + | Some (_, h) -> Btype.TypeHash.mem h te | _ -> false let rec erroneous_expr_check e = - (erroneous_type_check e.Typedtree.exp_type) || + erroneous_type_check e.Typedtree.exp_type + || match e.Typedtree.exp_desc with - | Typedtree.Texp_ident (p,_,_) - when Ident.name (Path.head p) = "_" -> true - | Typedtree.Texp_apply (e',_) -> erroneous_expr_check e' + | Typedtree.Texp_ident (p, _, _) when Ident.name (Path.head p) = "_" -> true + | Typedtree.Texp_apply (e', _) -> erroneous_expr_check e' | _ -> false exception Warning of Location.t * string @@ -100,27 +94,28 @@ exception Warning of Location.t * string let prerr_warning loc w = match !errors with | None -> () (*Location.print_warning loc Format.err_formatter w*) - | Some (l, _) -> + | Some (l, _) -> ( let ppf, to_string = Format.to_string () in Location.print_warning loc ppf w; match to_string () with - | "" -> () - | s -> l := Warning (loc,s) :: !l + | "" -> () + | s -> l := Warning (loc, s) :: !l) let prerr_alert loc w = match !errors with | None -> () (*Location.print_warning loc Format.err_formatter w*) - | Some (l, _) -> + | Some (l, _) -> ( let ppf, to_string = Format.to_string () in Location.print_alert loc ppf w; match to_string () with - | "" -> () - | s -> l := Warning (loc,s) :: !l + | "" -> () + | s -> l := Warning (loc, s) :: !l) -let () = Location.register_error_of_exn (function - | Warning (loc, str) -> Some (Location.error ~loc ~source:Location.Warning str) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Warning (loc, str) -> + Some (Location.error ~loc ~source:Location.Warning str) + | _ -> None) let () = Location.prerr_warning_ref := prerr_warning @@ -134,23 +129,24 @@ let flush_saved_types () = let open Ast_helper in let pexp = Exp.constant (Saved_parts.store parts) in let pstr = Str.eval pexp in - [Attr.mk (Saved_parts.attribute) (Parsetree.PStr [pstr])] + [ Attr.mk Saved_parts.attribute (Parsetree.PStr [ pstr ]) ] let rec get_saved_types_from_attributes = function | [] -> [] | attr :: attrs -> - let (attr, str) = Ast_helper.Attr.as_tuple attr in + let attr, str = Ast_helper.Attr.as_tuple attr in if attr = Saved_parts.attribute then let open Parsetree in - begin match str with - | PStr({pstr_desc = - Pstr_eval ({pexp_desc = Pexp_constant key; _ } ,_) - ; _ } :: _) -> - Saved_parts.find key + begin + match str with + | PStr + ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant key; _ }, _); + _ + } + :: _) -> Saved_parts.find key | _ -> [] end - else - get_saved_types_from_attributes attrs + else get_saved_types_from_attributes attrs let with_warning_attribute ?warning_attribute f = match warning_attribute with @@ -162,13 +158,14 @@ let with_saved_types ?warning_attribute ?save_part f = Cmt_format.set_saved_types []; try let result = with_warning_attribute ?warning_attribute f in - begin match save_part with + begin + match save_part with | None -> () | Some f -> Cmt_format.set_saved_types (f result :: saved_types) end; result with exn -> - let saved_types'= Cmt_format.get_saved_types () in + let saved_types' = Cmt_format.get_saved_types () in Cmt_format.set_saved_types (saved_types' @ saved_types); reraise exn diff --git a/src/ocaml/typing/msupport.mli b/src/ocaml/typing/msupport.mli index 43d0493509..a5e8935be5 100644 --- a/src/ocaml/typing/msupport.mli +++ b/src/ocaml/typing/msupport.mli @@ -1,52 +1,53 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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. -)* }}} *) + )* }}} *) (** Raise an error that can be caught: normal flow is resumed if a [catch_errors] handler was installed. *) -val raise_error: ?ignore_unify:bool -> exn -> unit +val raise_error : ?ignore_unify:bool -> exn -> unit (** Resume after error: like [raise_error], but if a handler was provided a Resume exception is raised. This allows to specify a special case when an error is caught. *) exception Resume -val resume_raise: exn -> 'a + +val resume_raise : exn -> 'a (** Installing (and removing) error handlers. *) (** Any [raise_error] invoked inside catch_errors will be added to the list. *) -val catch_errors: Warnings.state -> exn list ref -> (unit -> 'a) -> 'a +val catch_errors : Warnings.state -> exn list ref -> (unit -> 'a) -> 'a (** Temporary disable catching errors *) -val uncatch_errors: (unit -> 'a) -> 'a +val uncatch_errors : (unit -> 'a) -> 'a (** Returns a reference initially set to false that will be set to true when a type error is raised. *) -val monitor_errors: unit -> bool ref +val monitor_errors : unit -> bool ref (** Warnings can also be stored in the caught exception list, wrapped inside this exception *) @@ -54,23 +55,25 @@ exception Warning of Location.t * string (* Keep track of type variables generated by error recovery. *) -val erroneous_type_register: Types.type_expr -> unit -val erroneous_type_check: Types.type_expr -> bool -val erroneous_expr_check: Typedtree.expression -> bool +val erroneous_type_register : Types.type_expr -> unit +val erroneous_type_check : Types.type_expr -> bool +val erroneous_expr_check : Typedtree.expression -> bool (** Turn saved types from Cmt_format into attributes *) val flush_saved_types : unit -> Parsetree.attributes -val incorrect_attribute: Parsetree.attribute +val incorrect_attribute : Parsetree.attribute (** Extend the given attributes with an incorrect attribute and the saved types after turning them into attributes *) val recovery_attributes : Parsetree.attributes -> Parsetree.attributes (** Retrieve saved types that were turned into attributes *) -val get_saved_types_from_attributes : Parsetree.attributes -> Cmt_format.binary_part list +val get_saved_types_from_attributes : + Parsetree.attributes -> Cmt_format.binary_part list val with_saved_types : ?warning_attribute:Parsetree.attributes -> ?save_part:('a -> Cmt_format.binary_part) -> - (unit -> 'a) -> 'a + (unit -> 'a) -> + 'a diff --git a/src/platform/os_ipc.ml b/src/platform/os_ipc.ml index d5d7624036..b6b3137d1b 100644 --- a/src/platform/os_ipc.ml +++ b/src/platform/os_ipc.ml @@ -1,40 +1,34 @@ type server type context -type client = { - context : context; - wd : string; - environ : string; - argv : string array; -} +type client = + { context : context; wd : string; environ : string; argv : string array } (* {1 Server management} Listen, accept client and close *) -external server_setup : string -> string -> server option = - "ml_merlin_server_setup" +external server_setup : string -> string -> server option + = "ml_merlin_server_setup" -external server_accept : server -> timeout:float -> client option = - "ml_merlin_server_accept" +external server_accept : server -> timeout:float -> client option + = "ml_merlin_server_accept" -external server_close : server -> unit = - "ml_merlin_server_close" +external server_close : server -> unit = "ml_merlin_server_close" (* {1 Context management (stdin, stdout, stderr)} Setup and close *) -external context_setup : context -> unit = - "ml_merlin_context_setup" +external context_setup : context -> unit = "ml_merlin_context_setup" -external context_close : context -> return_code:int -> unit = - "ml_merlin_context_close" +external context_close : context -> return_code:int -> unit + = "ml_merlin_context_close" (* {1 Environment management} *) -external merlin_set_environ : string -> unit = - "ml_merlin_set_environ" (** completely replace the environment *) +external merlin_set_environ : string -> unit = "ml_merlin_set_environ" (* {1 Fixup for Windows process management} *) -external merlin_dont_inherit_stdio : bool -> unit = "ml_merlin_dont_inherit_stdio" +external merlin_dont_inherit_stdio : bool -> unit + = "ml_merlin_dont_inherit_stdio" diff --git a/src/utils/file_cache.ml b/src/utils/file_cache.ml index 0ce83ef54b..ad464082a8 100644 --- a/src/utils/file_cache.ml +++ b/src/utils/file_cache.ml @@ -1,58 +1,60 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 Make(Input : sig +module Make (Input : sig type t val read : string -> t val cache_name : string -end) = struct - let {Logger. log} = Logger.for_section ("File_cache("^Input.cache_name^")") +end) = +struct + let { Logger.log } = + Logger.for_section ("File_cache(" ^ Input.cache_name ^ ")") - let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t - = Hashtbl.create 17 + let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t = + Hashtbl.create 17 - type cache_stats = { hit: int; miss: int } + type cache_stats = { hit : int; miss : int } let cache_hit = ref 0 let cache_miss = ref 0 let get_cache_stats () = { hit = !cache_hit; miss = !cache_miss } let clear_cache_stats () = - cache_hit := 0; cache_miss := 0 + cache_hit := 0; + cache_miss := 0 let get_cached_entry ~title fid filename = let fid', latest_use, file = Hashtbl.find cache filename in - if (File_id.check fid fid') then ( + if File_id.check fid fid' then ( log ~title "reusing %S" filename; cache_hit := !cache_hit + 1) else ( log ~title "%S was updated on disk" filename; - raise Not_found; - ); + raise Not_found); latest_use := Unix.time (); file @@ -60,28 +62,29 @@ end) = struct let fid = File_id.get filename in let title = "read" in try get_cached_entry ~title fid filename - with Not_found -> - try - cache_miss := !cache_miss + 1; - log ~title "reading %S from disk" filename; - let file = Input.read filename in - Hashtbl.replace cache filename (fid, ref (Unix.time ()), file); - file - with exn -> - log ~title "failed to read %S (%t)" - filename (fun () -> Printexc.to_string exn); - Hashtbl.remove cache filename; - raise exn + with Not_found -> ( + try + cache_miss := !cache_miss + 1; + log ~title "reading %S from disk" filename; + let file = Input.read filename in + Hashtbl.replace cache filename (fid, ref (Unix.time ()), file); + file + with exn -> + log ~title "failed to read %S (%t)" filename (fun () -> + Printexc.to_string exn); + Hashtbl.remove cache filename; + raise exn) let check filename = let fid = File_id.get filename in match Hashtbl.find cache filename with | exception Not_found -> false - | (fid', latest_use, _) -> + | fid', latest_use, _ -> if File_id.check fid fid' then begin latest_use := Unix.time (); true - end else begin + end + else begin false end @@ -92,24 +95,21 @@ end) = struct let flush ?older_than () = let title = "flush" in - let limit = match older_than with + let limit = + match older_than with | None -> -.max_float | Some dt -> Unix.time () -. dt in let add_invalid filename (fid, latest_use, _) invalids = - if !latest_use > limit && - File_id.check (File_id.get filename) fid - then ( + if !latest_use > limit && File_id.check (File_id.get filename) fid then ( log ~title "keeping %S" filename; - invalids - ) else ( + invalids) + else ( log ~title "removing %S" filename; - filename :: invalids - ) + filename :: invalids) in let invalid = Hashtbl.fold add_invalid cache [] in List.iter (Hashtbl.remove cache) invalid - let clear () = - Hashtbl.clear cache + let clear () = Hashtbl.clear cache end diff --git a/src/utils/file_cache.mli b/src/utils/file_cache.mli index 5ea735405b..3a82c7f5a1 100644 --- a/src/utils/file_cache.mli +++ b/src/utils/file_cache.mli @@ -1,45 +1,45 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 Make (Input : sig type t val read : string -> t val cache_name : string end) : sig - val read : string -> Input.t + val read : string -> Input.t val flush : ?older_than:float -> unit -> unit val clear : unit -> unit val check : string -> bool - val get_cached_entry : string -> Input.t (** @raises Not_found if the file is not in cache. *) + val get_cached_entry : string -> Input.t - type cache_stats = { hit: int; miss: int } + type cache_stats = { hit : int; miss : int } val get_cache_stats : unit -> cache_stats val clear_cache_stats : unit -> unit end diff --git a/src/utils/file_id.ml b/src/utils/file_id.ml index bcf9e6eebe..70069ca74a 100644 --- a/src/utils/file_id.ml +++ b/src/utils/file_id.ml @@ -1,37 +1,45 @@ type t = Unix.stats let null_stat = - { Unix. - st_dev = -1; st_ino = -1; st_kind = Unix.S_REG; st_nlink = -1; - st_perm = -1; st_uid = -1; st_gid = -1; st_rdev = -1; st_size = -1; - st_atime = nan; st_mtime = nan; st_ctime = nan } + { Unix.st_dev = -1; + st_ino = -1; + st_kind = Unix.S_REG; + st_nlink = -1; + st_perm = -1; + st_uid = -1; + st_gid = -1; + st_rdev = -1; + st_size = -1; + st_atime = nan; + st_mtime = nan; + st_ctime = nan + } let get_res filename = try Result.ok @@ Unix.stat filename with _ -> Error ("Stat for" ^ filename ^ "couldn't be gathered") let get filename = - match get_res filename with Ok fn -> fn | Error _ -> null_stat + match get_res filename with + | Ok fn -> fn + | Error _ -> null_stat let check a b = - a == b || ( - (a != null_stat) && (b != null_stat) && - let open Unix in - a.st_mtime = b.st_mtime && - a.st_size = b.st_size && - a.st_ino = b.st_ino && - a.st_dev = b.st_dev - ) + a == b + || a != null_stat && b != null_stat + && + let open Unix in + a.st_mtime = b.st_mtime && a.st_size = b.st_size && a.st_ino = b.st_ino + && a.st_dev = b.st_dev let cache = ref None -let with_cache k = - Std.let_ref cache (Some (Hashtbl.create 7)) k +let with_cache k = Std.let_ref cache (Some (Hashtbl.create 7)) k let get filename = match !cache with | None -> get filename - | Some table -> + | Some table -> ( match Hashtbl.find table filename with | stats -> Logger.log ~section:"stat_cache" ~title:"reuse cache" "%s" filename; @@ -39,4 +47,4 @@ let get filename = | exception Not_found -> let stats = get filename in Hashtbl.add table filename stats; - stats + stats) diff --git a/src/utils/file_id.mli b/src/utils/file_id.mli index d045375c02..88cf3eaf4a 100644 --- a/src/utils/file_id.mli +++ b/src/utils/file_id.mli @@ -1,20 +1,20 @@ -type t (** An instance of [t] represents the identity of the contents of a file path. Use this to quickly detect if a file has changed. (Detection is done by checking some fields from stat syscall, it can be tricked but should behave well in regular cases). FIXME: precision of mtime is still the second?! *) +type t -val check: t -> t -> bool (** Returns true iff the heuristic determines that the file contents has not changed. *) +val check : t -> t -> bool -val get: string -> t (** [file_id filename] computes an id for the current contents of [filename]. Returns a generic id, if the id can't be computed. *) +val get : string -> t -val get_res: string -> (t, string) Result.t (** Same as [get], but returns an error, if the id can't be computed. *) +val get_res : string -> (t, string) Result.t val with_cache : (unit -> 'a) -> 'a diff --git a/src/utils/lib_config.ml b/src/utils/lib_config.ml index 493124178f..566f9c9c66 100644 --- a/src/utils/lib_config.ml +++ b/src/utils/lib_config.ml @@ -5,11 +5,9 @@ let set_program_name name = program_name := name let program_name () = !program_name module Json = struct - let set_pretty_to_string f = - Std.Json.pretty_to_string := f + let set_pretty_to_string f = Std.Json.pretty_to_string := f end module System = struct - let set_run_in_directory f = - Std.System.run_in_directory := f + let set_run_in_directory f = Std.System.run_in_directory := f end diff --git a/src/utils/lib_config.mli b/src/utils/lib_config.mli index 7516d49be3..2725672f01 100644 --- a/src/utils/lib_config.mli +++ b/src/utils/lib_config.mli @@ -10,10 +10,10 @@ val set_program_name : string -> unit val program_name : unit -> string module Json : sig - (** Merlin's logger requires a Json pretty-printer for correct operation. + (** Merlin's logger requires a Json pretty-printer for correct operation. [set_pretty_to_string] can be used to provide one. A common pretifier is [Yojson.Basic.pretty_to_string]. *) - val set_pretty_to_string : (Std.json -> string) -> unit + val set_pretty_to_string : (Std.json -> string) -> unit end (** Merlin spawns child processes for preprocessors (pp and ppx), which can be @@ -41,15 +41,15 @@ module System : sig - As of today Merlin handles the [`Cancelled] return case identically as other error codes. *) - val set_run_in_directory - : (prog:string - -> prog_is_quoted:bool - -> args:string list - -> cwd:string - -> ?stdin:string - -> ?stdout:string - -> ?stderr:string - -> unit - -> [ `Finished of int | `Cancelled ]) - -> unit + val set_run_in_directory : + (prog:string -> + prog_is_quoted:bool -> + args:string list -> + cwd:string -> + ?stdin:string -> + ?stdout:string -> + ?stderr:string -> + unit -> + [ `Finished of int | `Cancelled ]) -> + unit end diff --git a/src/utils/logger.ml b/src/utils/logger.ml index c24d126f4d..f695e7eb03 100644 --- a/src/utils/logger.ml +++ b/src/utils/logger.ml @@ -1,37 +1,36 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 time = ref 0.0 -let delta_time () = - Sys.time () -. !time +let delta_time () = Sys.time () -. !time let destination = ref None let selected_sections = ref None @@ -52,26 +51,25 @@ let log_flush () = let log ~section ~title fmt = match !destination with | Some oc when is_section_enabled section -> - Printf.ksprintf (fun str -> + Printf.ksprintf + (fun str -> output_section oc section title; if str <> "" then ( output_string oc str; - if str.[String.length str - 1] <> '\n' then - output_char oc '\n' - ) - ) fmt - | None | Some _ -> - Printf.ifprintf () fmt + if str.[String.length str - 1] <> '\n' then output_char oc '\n')) + fmt + | None | Some _ -> Printf.ifprintf () fmt let fmt_buffer = Buffer.create 128 let fmt_handle = Format.formatter_of_buffer fmt_buffer let fmt () f = Buffer.reset fmt_buffer; - begin match f fmt_handle with - | () -> () - | exception exn -> - Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn); + begin + match f fmt_handle with + | () -> () + | exception exn -> + Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn) end; Format.pp_print_flush fmt_handle (); let msg = Buffer.contents fmt_buffer in @@ -81,15 +79,11 @@ let fmt () f = let json () f = match f () with | json -> !Json.pretty_to_string json - | exception exn -> - Printf.sprintf "Exception: %s" (Printexc.to_string exn) + | exception exn -> Printf.sprintf "Exception: %s" (Printexc.to_string exn) let exn () exn = Printexc.to_string exn -type notification = { - section: string; - msg: string; -} +type notification = { section : string; msg : string } let notifications : notification list ref option ref = ref None @@ -98,15 +92,15 @@ let notify ~section = log ~section ~title:"notify" "%s" msg; match !notifications with | None -> () - | Some r -> r := {section; msg} :: !r + | Some r -> r := { section; msg } :: !r in Printf.ksprintf tell -let with_notifications r f = - let_ref notifications (Some r) f +let with_notifications r f = let_ref notifications (Some r) f let with_sections sections f = - let sections = match sections with + let sections = + match sections with | [] -> None | sections -> let table = Hashtbl.create (List.length sections) in @@ -116,25 +110,29 @@ let with_sections sections f = let sections0 = !selected_sections in selected_sections := sections; match f () with - | result -> selected_sections := sections0; result - | exception exn -> selected_sections := sections0; reraise exn + | result -> + selected_sections := sections0; + result + | exception exn -> + selected_sections := sections0; + reraise exn -let with_log_file file ?(sections=[]) f = +let with_log_file file ?(sections = []) f = match file with | None -> with_sections sections f - | Some file -> + | Some file -> ( log_flush (); - let destination', release = match file with + let destination', release = + match file with | "" -> (None, ignore) | "-" -> (Some stderr, ignore) - | filename -> + | filename -> ( match open_out filename with | exception exn -> - Printf.eprintf "cannot open %S for logging: %s" - filename (Printexc.to_string exn); + Printf.eprintf "cannot open %S for logging: %s" filename + (Printexc.to_string exn); (None, ignore) - | oc -> - (Some oc, (fun () -> close_out_noerr oc)) + | oc -> (Some oc, fun () -> close_out_noerr oc)) in let destination0 = !destination in destination := destination'; @@ -144,8 +142,12 @@ let with_log_file file ?(sections=[]) f = release () in match with_sections sections f with - | v -> release (); v - | exception exn -> release (); reraise exn + | v -> + release (); + v + | exception exn -> + release (); + reraise exn) type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a type logger = { log : 'a. 'a printf } diff --git a/src/utils/logger.mli b/src/utils/logger.mli index 13bbc22de8..4b50468da8 100644 --- a/src/utils/logger.mli +++ b/src/utils/logger.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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. -)* }}} *) + )* }}} *) (** Log module * @@ -35,19 +35,16 @@ * **) -val log - : section:string -> title:string -> ('b, unit, string, unit) format4 -> 'b +val log : + section:string -> title:string -> ('b, unit, string, unit) format4 -> 'b -val fmt : unit -> (Format.formatter -> unit) -> string +val fmt : unit -> (Format.formatter -> unit) -> string val json : unit -> (unit -> Std.json) -> string -val exn : unit -> exn -> string +val exn : unit -> exn -> string val log_flush : unit -> unit -type notification = { - section: string; - msg: string; -} +type notification = { section : string; msg : string } val notify : section:string -> ('b, unit, string, unit) format4 -> 'b val with_notifications : notification list ref -> (unit -> 'a) -> 'a diff --git a/src/utils/marg.ml b/src/utils/marg.ml index 4b6641866c..58ab0ad394 100644 --- a/src/utils/marg.ml +++ b/src/utils/marg.ml @@ -2,36 +2,33 @@ open Std (** {1 Flag parsing utils} *) -type 'a t = string list -> 'a -> (string list * 'a) +type 'a t = string list -> 'a -> string list * 'a type 'a table = (string, 'a t) Hashtbl.t -let unit f : 'a t = fun args acc -> (args, (f acc)) +let unit f : 'a t = fun args acc -> (args, f acc) -let param ptype f : 'a t = fun args acc -> +let param ptype f : 'a t = + fun args acc -> match args with | [] -> failwith ("expects a " ^ ptype ^ " argument") - | arg :: args -> args, f arg acc + | arg :: args -> (args, f arg acc) -let unit_ignore : 'a t = - fun x -> unit (fun x -> x) x +let unit_ignore : 'a t = fun x -> unit (fun x -> x) x -let param_ignore = - fun x -> param "string" (fun _ x -> x) x +let param_ignore x = param "string" (fun _ x -> x) x -let bool f = param "bool" - (function - | "yes" | "y" | "Y" | "true" | "True" | "1" -> f true - | "no" | "n" | "N" | "false" | "False" | "0" -> f false - | str -> - failwithf "expecting boolean (%s), got %S." - "yes|y|Y|true|1 / no|n|N|false|0" - str - ) +let bool f = + param "bool" (function + | "yes" | "y" | "Y" | "true" | "True" | "1" -> f true + | "no" | "n" | "N" | "false" | "False" | "0" -> f false + | str -> + failwithf "expecting boolean (%s), got %S." + "yes|y|Y|true|1 / no|n|N|false|0" str) type docstring = string -type 'a spec = (string * docstring * 'a t) +type 'a spec = string * docstring * 'a t let rec assoc3 key = function | [] -> raise Not_found @@ -45,52 +42,55 @@ let rec mem_assoc3 key = function let parse_one ~warning global_spec local_spec args global local = match args with | [] -> None - | arg :: args -> + | arg :: args -> ( match Hashtbl.find global_spec arg with - | action -> begin match action args global with - | (args, global) -> - Some (args, global, local) - | exception (Failure msg) -> - warning ("flag " ^ arg ^ " " ^ msg); - Some (args, global, local) - | exception exn -> - warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); - Some (args, global, local) - end - | exception Not_found -> + | action -> begin + match action args global with + | args, global -> Some (args, global, local) + | exception Failure msg -> + warning ("flag " ^ arg ^ " " ^ msg); + Some (args, global, local) + | exception exn -> + warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); + Some (args, global, local) + end + | exception Not_found -> ( match assoc3 arg local_spec with - | action -> begin match action args local with - | (args, local) -> - Some (args, global, local) - | exception (Failure msg) -> + | action -> begin + match action args local with + | args, local -> Some (args, global, local) + | exception Failure msg -> warning ("flag " ^ arg ^ " " ^ msg); Some (args, global, local) | exception exn -> warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); Some (args, global, local) end - | exception Not_found -> None + | exception Not_found -> None)) let parse_all ~warning global_spec local_spec = let rec normal_parsing args global local = match parse_one ~warning global_spec local_spec args global local with | Some (args, global, local) -> normal_parsing args global local - | None -> match args with + | None -> ( + match args with | arg :: args -> begin (* We split on the first '=' to check if the argument was of the form name=value *) try let name, value = Misc.cut_at arg '=' in - normal_parsing (name::value::args) global local + normal_parsing (name :: value :: args) global local with Not_found -> warning ("unknown flag " ^ arg); resume_parsing args global local - end - | [] -> (global, local) + end + | [] -> (global, local)) and resume_parsing args global local = - let args = match args with - | arg :: args when not (Hashtbl.mem global_spec arg || - mem_assoc3 arg local_spec) -> args + let args = + match args with + | arg :: args + when not (Hashtbl.mem global_spec arg || mem_assoc3 arg local_spec) -> + args | args -> args in normal_parsing args global local diff --git a/src/utils/marg.mli b/src/utils/marg.mli index ae3fb27650..f867199694 100644 --- a/src/utils/marg.mli +++ b/src/utils/marg.mli @@ -35,7 +35,7 @@ val param_ignore : 'acc t type docstring = string -type 'a spec = (string * docstring * 'a t) +type 'a spec = string * docstring * 'a t (** Consume at most one flag from the list, returning updated state or [None] in case of failure. @@ -43,14 +43,20 @@ type 'a spec = (string * docstring * 'a t) use. *) val parse_one : warning:(string -> unit) -> - 'global table -> 'local spec list -> - string list -> 'global -> 'local -> + 'global table -> + 'local spec list -> + string list -> + 'global -> + 'local -> (string list * 'global * 'local) option (** Consume all arguments from the input list, calling warning for incorrect ones and resuming parsing after. *) val parse_all : warning:(string -> unit) -> - 'global table -> 'local spec list -> - string list -> 'global -> 'local -> + 'global table -> + 'local spec list -> + string list -> + 'global -> + 'local -> 'global * 'local diff --git a/src/utils/ppxsetup.ml b/src/utils/ppxsetup.ml index 885a3241bd..e426bd9cf1 100644 --- a/src/utils/ppxsetup.ml +++ b/src/utils/ppxsetup.ml @@ -1,73 +1,68 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 = { - ppxs: string list; - ppxopts: string list list String.Map.t; -} +type t = { ppxs : string list; ppxopts : string list list String.Map.t } let empty = { ppxs = []; ppxopts = String.Map.empty } let add_ppx ppx t = - if List.mem ppx ~set:t.ppxs - then t - else {t with ppxs = ppx :: t.ppxs} + if List.mem ppx ~set:t.ppxs then t else { t with ppxs = ppx :: t.ppxs } let add_ppxopts ppx opts t = match opts with | [] -> t | opts -> let ppx = Filename.basename ppx in - let optss = - try String.Map.find ppx t.ppxopts - with Not_found -> [] - in + let optss = try String.Map.find ppx t.ppxopts with Not_found -> [] in if not (List.mem ~set:optss opts) then let ppxopts = String.Map.add ~key:ppx ~data:(opts :: optss) t.ppxopts in - {t with ppxopts} + { t with ppxopts } else t let union ta tb = { ppxs = List.filter_dup (ta.ppxs @ tb.ppxs); - ppxopts = String.Map.merge ~f:(fun _ a b -> match a, b with - | v, None | None, v -> v - | Some a, Some b -> Some (List.filter_dup (a @ b))) + ppxopts = + String.Map.merge + ~f:(fun _ a b -> + match (a, b) with + | v, None | None, v -> v + | Some a, Some b -> Some (List.filter_dup (a @ b))) ta.ppxopts tb.ppxopts } let command_line t = - List.fold_right ~f:(fun ppx ppxs -> + List.fold_right + ~f:(fun ppx ppxs -> let basename = Filename.basename ppx in let opts = - try String.Map.find basename t.ppxopts - with Not_found -> [] + try String.Map.find basename t.ppxopts with Not_found -> [] in let opts = List.concat (List.rev opts) in String.concat ~sep:" " (ppx :: opts) :: ppxs) @@ -76,16 +71,13 @@ let command_line t = let dump t = let string k = `String k in let string_list l = `List (List.map ~f:string l) in - `Assoc [ - "preprocessors", - string_list t.ppxs; - "options", - `Assoc ( - String.Map.fold - ~f:(fun ~key ~data:opts acc -> - let opts = List.rev_map ~f:string_list opts in - (key, `List opts) :: acc) - ~init:[] - t.ppxopts - ) - ] + `Assoc + [ ("preprocessors", string_list t.ppxs); + ( "options", + `Assoc + (String.Map.fold + ~f:(fun ~key ~data:opts acc -> + let opts = List.rev_map ~f:string_list opts in + (key, `List opts) :: acc) + ~init:[] t.ppxopts) ) + ] diff --git a/src/utils/ppxsetup.mli b/src/utils/ppxsetup.mli index b1758c9de6..e3517c3ecc 100644 --- a/src/utils/ppxsetup.mli +++ b/src/utils/ppxsetup.mli @@ -1,39 +1,39 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 -val empty: t -val add_ppx: string -> t -> t -val add_ppxopts: string -> string list -> t -> t +val empty : t +val add_ppx : string -> t -> t +val add_ppxopts : string -> string list -> t -> t -val union: t -> t -> t +val union : t -> t -> t -val command_line: t -> string list +val command_line : t -> string list val dump : t -> Std.json diff --git a/src/utils/sexp.ml b/src/utils/sexp.ml index ddff641487..85f4f7b180 100644 --- a/src/utils/sexp.ml +++ b/src/utils/sexp.ml @@ -1,9 +1,9 @@ type t = - | Cons of t * t - | Sym of string + | Cons of t * t + | Sym of string | String of string - | Int of int - | Float of float + | Int of int + | Float of float let nil = Sym "nil" @@ -17,16 +17,13 @@ let escaped str = done; let buf = Buffer.create (len + !extra_chars + 2) in Buffer.add_char buf '"'; - if !extra_chars = 0 then ( - Buffer.add_string buf str - ) else ( + if !extra_chars = 0 then Buffer.add_string buf str + else for i = 0 to len - 1 do let c = str.[i] in - if c = '"' || c = '\\' then - Buffer.add_char buf '\\'; + if c = '"' || c = '\\' then Buffer.add_char buf '\\'; Buffer.add_char buf c done; - ); Buffer.add_char buf '"'; Buffer.contents buf @@ -46,27 +43,27 @@ let unescaped str = let i = ref 0 in while !i < len do match str.[!i] with - | '\\' -> ( - incr i; - begin match str.[!i] with - | 'n' -> Buffer.add_char buf '\n' - | 'r' -> Buffer.add_char buf '\r' - | 't' -> Buffer.add_char buf '\t' - | 'x' -> - let c0 = Char.code str.[!i+1] in - let c1 = Char.code str.[!i+2] in - Buffer.add_char buf (Char.chr ((c0 * 16) lor c1)); - i := !i + 2; - | '0'..'9' -> - let c0 = Char.code str.[!i+1] in - let c1 = Char.code str.[!i+2] in - let c2 = Char.code str.[!i+3] in - Buffer.add_char buf (Char.chr ((c0 * 64) lor (c1 * 8) lor c2)); - i := !i + 2; - | c -> Buffer.add_char buf c - end; - incr i - ) + | '\\' -> + incr i; + begin + match str.[!i] with + | 'n' -> Buffer.add_char buf '\n' + | 'r' -> Buffer.add_char buf '\r' + | 't' -> Buffer.add_char buf '\t' + | 'x' -> + let c0 = Char.code str.[!i + 1] in + let c1 = Char.code str.[!i + 2] in + Buffer.add_char buf (Char.chr (c0 * 16 lor c1)); + i := !i + 2 + | '0' .. '9' -> + let c0 = Char.code str.[!i + 1] in + let c1 = Char.code str.[!i + 2] in + let c2 = Char.code str.[!i + 3] in + Buffer.add_char buf (Char.chr (c0 * 64 lor (c1 * 8) lor c2)); + i := !i + 2 + | c -> Buffer.add_char buf c + end; + incr i | c -> Buffer.add_char buf c; incr i @@ -78,18 +75,18 @@ let rec of_list = function | a :: tl -> Cons (a, of_list tl) let rec tell_sexp tell = function - | Cons (a,b) -> + | Cons (a, b) -> tell "("; tell_sexp tell a; tell_cons tell b - | Sym s -> tell s + | Sym s -> tell s | String s -> tell (escaped s) - | Int i -> tell (string_of_int i) - | Float f -> tell (string_of_float f) + | Int i -> tell (string_of_int i) + | Float f -> tell (string_of_float f) and tell_cons tell = function | Sym "nil" -> tell ")" - | Cons (a,b) -> + | Cons (a, b) -> tell " "; tell_sexp tell a; tell_cons tell b @@ -98,39 +95,33 @@ and tell_cons tell = function tell_sexp tell sexp; tell ")" -let is_alpha c = - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') +let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') -let is_num c = - (c >= '0' && c <= '9' || c == '-') +let is_num c = (c >= '0' && c <= '9') || c == '-' let is_alphanum c = is_alpha c || is_num c let read_sexp getch = let buf = Buffer.create 10 in let rec read_sexp getch = function - | ' ' | '\t' | '\n' -> - read_sexp getch (getch ()) - - | c when is_num c -> - read_num getch c - - | '\'' | ':' | '_' as c -> read_sym getch (Some c) + | ' ' | '\t' | '\n' -> read_sexp getch (getch ()) + | c when is_num c -> read_num getch c + | ('\'' | ':' | '_') as c -> read_sym getch (Some c) | c when is_alpha c -> read_sym getch (Some c) - - | '"' -> - read_string getch + | '"' -> read_string getch | '\000' -> raise End_of_file | '(' -> let lhs, next = read_sexp getch (getch ()) in read_cons getch (fun rhs -> Cons (lhs, rhs)) next | _ -> failwith "Invalid parse" - and read_cons getch k next = - match (match next with Some c -> c | None -> getch ()) with + match + match next with + | Some c -> c + | None -> getch () + with | ' ' | '\t' | '\n' -> read_cons getch k None - | ')' -> k nil, None + | ')' -> (k nil, None) | '.' -> let rhs, next = read_sexp getch (getch ()) in let rec aux = function @@ -138,34 +129,35 @@ let read_sexp getch = | ' ' | '\t' | '\n' -> aux (getch ()) | _ -> failwith "Invalid parse" in - begin match next with - | Some c -> aux c - | None -> aux (getch ()) - end, None + ( begin + match next with + | Some c -> aux c + | None -> aux (getch ()) + end, + None ) | c -> let cell, next = read_sexp getch c in read_cons getch (fun rhs -> k (Cons (cell, rhs))) next - and read_num getch c = Buffer.clear buf; Buffer.add_char buf c; let rec aux ~is_start ~is_float = match getch () with | '-' when is_start -> - Buffer.add_char buf c; aux ~is_start:false ~is_float + Buffer.add_char buf c; + aux ~is_start:false ~is_float | c when c >= '0' && c <= '9' -> - Buffer.add_char buf c; aux ~is_start:false ~is_float - | '.' | 'e' | 'E' as c -> - Buffer.add_char buf c; aux ~is_start:false ~is_float:true + Buffer.add_char buf c; + aux ~is_start:false ~is_float + | ('.' | 'e' | 'E') as c -> + Buffer.add_char buf c; + aux ~is_start:false ~is_float:true | c -> let s = Buffer.contents buf in - (if is_float - then Float (float_of_string s) - else Int (int_of_string s)), - Some c + ( (if is_float then Float (float_of_string s) else Int (int_of_string s)), + Some c ) in aux ~is_start:true ~is_float:false - and read_string getch = Buffer.clear buf; let rec aux () = @@ -175,32 +167,33 @@ let read_sexp getch = Buffer.add_char buf '\\'; Buffer.add_char buf (getch ()); aux () - | '"' -> - String (unescaped (Buffer.contents buf)), None + | '"' -> (String (unescaped (Buffer.contents buf)), None) | c -> Buffer.add_char buf c; aux () in aux () - and read_sym getch next = Buffer.clear buf; let rec aux next = - match (match next with Some c -> c | None -> getch ()) with + match + match next with + | Some c -> c + | None -> getch () + with | ('\'' | '-' | ':' | '_') as c -> Buffer.add_char buf c; aux None | c when is_alphanum c -> Buffer.add_char buf c; aux None - | c -> Sym (Buffer.contents buf), Some c + | c -> (Sym (Buffer.contents buf), Some c) in aux next in read_sexp getch (getch ()) -let to_buf sexp buf = - tell_sexp (Buffer.add_string buf) sexp +let to_buf sexp buf = tell_sexp (Buffer.add_string buf) sexp let to_string sexp = let buf = Buffer.create 100 in @@ -213,35 +206,32 @@ let getch_of_substring str pos len = invalid_arg "Sexp.getch_of_substring"; let pos = ref pos in let getch () = - if !pos < len then + if !pos < len then ( let r = str.[!pos] in incr pos; - r + r) else '\000' in getch -let getch_of_string str = - getch_of_substring str 0 (String.length str) +let getch_of_string str = getch_of_substring str 0 (String.length str) -let of_string str = - fst (read_sexp (getch_of_string str)) +let of_string str = fst (read_sexp (getch_of_string str)) let getch_of_subbytes str pos len = let len = pos + len in - if pos < 0 || len > Bytes.length str then - invalid_arg "Sexp.getch_of_subbytes"; + if pos < 0 || len > Bytes.length str then invalid_arg "Sexp.getch_of_subbytes"; let pos = ref pos in let getch () = - if !pos < len then + if !pos < len then ( let r = Bytes.get str !pos in incr pos; - r + r) else '\000' in getch -let of_file_descr ?(on_read=ignore) fd = +let of_file_descr ?(on_read = ignore) fd = let getch = ref (fun () -> '\000') in let rest = ref None in let buffer = Bytes.create 1024 in @@ -250,18 +240,17 @@ let of_file_descr ?(on_read=ignore) fd = | Some r -> rest := None; r - | None -> + | None -> ( match !getch () with | '\000' -> on_read fd; let read = Unix.read fd buffer 0 1024 in if read = 0 then '\000' - else - begin - getch := getch_of_subbytes buffer 0 read; - !getch () - end - | c -> c + else begin + getch := getch_of_subbytes buffer 0 read; + !getch () + end + | c -> c) in fun () -> try @@ -274,21 +263,20 @@ let of_channel ?on_read ic = of_file_descr ?on_read (Unix.descr_of_in_channel ic) let rec of_json = - let assoc_item (a,b) = Cons (Sym a, of_json b) in + let assoc_item (a, b) = Cons (Sym a, of_json b) in function - | `Null -> Sym "null" - | `Int i -> Int i - | `Float f -> Float f - | `String s -> String s - | `Bool true -> Sym "true" + | `Null -> Sym "null" + | `Int i -> Int i + | `Float f -> Float f + | `String s -> String s + | `Bool true -> Sym "true" | `Bool false -> Sym "false" - | `Assoc lst -> Cons (Cons (Sym "assoc", Sym "nil"), of_list (List.map assoc_item lst)) - | `List lst -> of_list (List.map of_json lst) + | `Assoc lst -> + Cons (Cons (Sym "assoc", Sym "nil"), of_list (List.map assoc_item lst)) + | `List lst -> of_list (List.map of_json lst) let rec to_json = - let fail msg sexp = - failwith (msg ^ ", got: \n" ^ to_string sexp) - in + let fail msg sexp = failwith (msg ^ ", got: \n" ^ to_string sexp) in let rec assoc_item = function | Cons (Cons (Sym a, b), c) -> (a, to_json b) :: assoc_item c | Sym "nil" -> [] @@ -300,14 +288,13 @@ let rec to_json = | sexp -> fail "expecting list" sexp in function - | Sym "null" -> `Null - | Sym "true" -> `Bool true + | Sym "null" -> `Null + | Sym "true" -> `Bool true | Sym "false" -> `Bool false - | Int i -> `Int i - | Float f -> `Float f + | Int i -> `Int i + | Float f -> `Float f | String s -> `String s - | Cons (Cons (Sym "assoc", Sym "nil"), assocs) -> - `Assoc (assoc_item assocs) + | Cons (Cons (Sym "assoc", Sym "nil"), assocs) -> `Assoc (assoc_item assocs) | Sym "nil" -> `List [] | Cons (hd, tl) -> `List (to_json hd :: list_items tl) | Sym s -> `String s diff --git a/src/utils/sexp.mli b/src/utils/sexp.mli index 3801f3eadb..bd738b036b 100644 --- a/src/utils/sexp.mli +++ b/src/utils/sexp.mli @@ -1,7 +1,7 @@ open Std type t = - Cons of t * t + | Cons of t * t | Sym of string | String of string | Int of int diff --git a/src/utils/std.ml b/src/utils/std.ml index c1b49ecfbf..79365ab859 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -1,39 +1,39 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + 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: + 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 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. + 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 json = -[ `Assoc of (string * json) list -| `Bool of bool -| `Float of float -| `Int of int -| `List of json list -| `Null -| `String of string ] + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] module Json = struct type t = json @@ -46,23 +46,20 @@ module Json = struct | None -> `Null | Some x -> f x - let list f x = - `List (List.map f x) + let list f x = `List (List.map f x) - let pretty_to_string : (t -> string) ref = ref @@ fun _ -> + let pretty_to_string : (t -> string) ref = + ref @@ fun _ -> Printf.sprintf - "Logger error: `Std.Json.pretty_to_string` \ - is not set. You should initialize that reference with the \ - pretifier of your choice to enable json logging. \ - A common one is `Yojson.Basic.pretty_to_string`." + "Logger error: `Std.Json.pretty_to_string` is not set. You should \ + initialize that reference with the pretifier of your choice to enable \ + json logging. A common one is `Yojson.Basic.pretty_to_string`." end module Hashtbl = struct include Hashtbl - let find_some tbl key = - try Some (find tbl key) - with Not_found -> None + let find_some tbl key = try Some (find tbl key) with Not_found -> None let elements tbl = Hashtbl.fold (fun _key elt acc -> elt :: acc) tbl [] @@ -87,18 +84,16 @@ module List = struct in aux 0 l - let find_some ~f l = - try Some (find ~f l) - with Not_found -> None + let find_some ~f l = try Some (find ~f l) with Not_found -> None - let rec rev_scan_left acc ~f l ~init = match l with + let rec rev_scan_left acc ~f l ~init = + match l with | [] -> acc | x :: xs -> let init = f init x in rev_scan_left (init :: acc) ~f xs ~init - let scan_left ~f l ~init = - List.rev (rev_scan_left [] ~f l ~init) + let scan_left ~f l ~init = List.rev (rev_scan_left [] ~f l ~init) let rev_filter ~f lst = let rec aux acc = function @@ -109,33 +104,33 @@ module List = struct let rec filter_map ~f = function | [] -> [] - | x :: xs -> + | x :: xs -> ( match f x with | None -> filter_map ~f xs - | Some x -> x :: filter_map ~f xs + | Some x -> x :: filter_map ~f xs) let rec find_map ~f = function | [] -> raise Not_found - | x :: xs -> + | x :: xs -> ( match f x with | None -> find_map ~f xs - | Some x' -> x' + | Some x' -> x') let rec map_end ~f l1 l2 = match l1 with | [] -> l2 - | hd::tl -> f hd :: map_end ~f tl l2 + | hd :: tl -> f hd :: map_end ~f tl l2 let concat_map ~f l = flatten (map ~f l) let replicate elem n = let rec aux acc elem n = - if n <= 0 then acc else aux (elem :: acc) elem (n-1) + if n <= 0 then acc else aux (elem :: acc) elem (n - 1) in aux [] elem n - let rec remove ?(phys=false) x = - let check = if phys then (==) else (=) in + let rec remove ?(phys = false) x = + let check = if phys then ( == ) else ( = ) in function | [] -> [] | hd :: tl when check x hd -> tl @@ -146,9 +141,10 @@ module List = struct | hd :: tl when x = hd -> remove_all x tl | hd :: tl -> hd :: remove_all x tl - let rec same ~f l1 l2 = match l1, l2 with + let rec same ~f l1 l2 = + match (l1, l2) with | [], [] -> true - | (hd1 :: tl1), (hd2 :: tl2) when f hd1 hd2 -> same ~f tl1 tl2 + | hd1 :: tl1, hd2 :: tl2 when f hd1 hd2 -> same ~f tl1 tl2 | _, _ -> false (* [length_lessthan n l] returns @@ -166,20 +162,21 @@ module List = struct let tbl = Hashtbl.create 17 in let f a b = let b' = equiv b in - if Hashtbl.mem tbl b' - then a - else (Hashtbl.add tbl b' (); b :: a) + if Hashtbl.mem tbl b' then a + else ( + Hashtbl.add tbl b' (); + b :: a) in rev (fold_left ~f ~init:[] lst) let filter_dup lst = filter_dup' ~equiv:(fun x -> x) lst let rec merge_cons ~f = function - | a :: ((b :: tl) as tl') -> - begin match f a b with - | Some a' -> merge_cons ~f (a' :: tl) - | None -> a :: merge_cons ~f tl' - end + | a :: (b :: tl as tl') -> begin + match f a b with + | Some a' -> merge_cons ~f (a' :: tl) + | None -> a :: merge_cons ~f tl' + end | tl -> tl let rec take_while ~f = function @@ -201,90 +198,88 @@ module List = struct let rec split_n acc n = function | x :: xs when n > 0 -> split_n (x :: acc) (n - 1) xs - | xs -> List.rev acc, xs + | xs -> (List.rev acc, xs) let split_n n l = split_n [] n l let rec split3 xs ys zs = function - | (x,y,z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl - | [] -> List.rev xs, List.rev ys, List.rev zs + | (x, y, z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl + | [] -> (List.rev xs, List.rev ys, List.rev zs) let split3 l = split3 [] [] [] l - let rec unfold ~f a = match f a with + let rec unfold ~f a = + match f a with | None -> [] | Some a -> a :: unfold ~f a - let rec rev_unfold acc ~f a = match f a with + let rec rev_unfold acc ~f a = + match f a with | None -> acc | Some a -> rev_unfold (a :: acc) ~f a let rec fold_n_map ~f ~init = function - | [] -> init, [] + | [] -> (init, []) | x :: xs -> let acc, x' = f init x in let acc, xs' = fold_n_map ~f ~init:acc xs in - acc, (x' :: xs') + (acc, x' :: xs') module Lazy = struct - type 'a t = - | Nil - | Cons of 'a * 'a t lazy_t + type 'a t = Nil | Cons of 'a * 'a t lazy_t let rec map ~f = function | Nil -> Nil - | Cons (hd,tl) -> - Cons (f hd, lazy (map ~f (Lazy.force tl))) + | Cons (hd, tl) -> Cons (f hd, lazy (map ~f (Lazy.force tl))) let rec to_strict = function | Nil -> [] - | Cons (hd, lazy tl) -> hd :: to_strict tl + | Cons (hd, (lazy tl)) -> hd :: to_strict tl - let rec unfold f a = match f a with + let rec unfold f a = + match f a with | None -> Nil | Some a -> Cons (a, lazy (unfold f a)) let rec filter_map ~f = function | Nil -> Nil - | Cons (a, tl) -> match f a with + | Cons (a, tl) -> ( + match f a with | None -> filter_map ~f (Lazy.force tl) - | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl))) + | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl)))) end let rec last = function | [] -> None - | [x] -> Some x + | [ x ] -> Some x | _ :: l -> last l let rec group_by pred group acc = function | [] -> List.rev acc - | x :: xs -> + | x :: xs -> ( match group with - | (x' :: _) when pred x x' -> - group_by pred (x :: group) acc xs - | _ -> group_by pred [x] (group :: acc) xs + | x' :: _ when pred x x' -> group_by pred (x :: group) acc xs + | _ -> group_by pred [ x ] (group :: acc) xs) let group_by pred xs = match group_by pred [] [] xs with | [] :: xs | xs -> xs (* Merge sorted lists *) - let rec merge ~cmp l1 l2 = match l1, l2 with + let rec merge ~cmp l1 l2 = + match (l1, l2) with | l, [] | [], l -> l - | (x1 :: _), (x2 :: x2s) when cmp x1 x2 > 0 -> - x2 :: merge ~cmp l1 x2s - | x1 :: x1s, _ -> - x1 :: merge ~cmp x1s l2 + | x1 :: _, x2 :: x2s when cmp x1 x2 > 0 -> x2 :: merge ~cmp l1 x2s + | x1 :: x1s, _ -> x1 :: merge ~cmp x1s l2 let rec dedup_adjacent ~cmp = function | x1 :: (x2 :: _ as xs) when cmp x1 x2 = 0 -> dedup_adjacent ~cmp xs - | x :: xs -> x :: dedup_adjacent ~cmp xs + | x :: xs -> x :: dedup_adjacent ~cmp xs | [] -> [] (* [sort_uniq] does not need to maintain a set of seen entries because duplicates will be adjacent. *) let sort_uniq ~cmp l = dedup_adjacent ~cmp (sort ~cmp l) - let print f () l = - "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]" + let print f () l = "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]" end module Option = struct @@ -313,27 +308,29 @@ module Option = struct | None -> () | Some x -> f x - let cons o xs = match o with + let cons o xs = + match o with | None -> xs | Some x -> x :: xs module Infix = struct - let return x = Some x - let (>>=) x f = bind x ~f - let (>>|) x f = map x ~f + let return x = Some x + let ( >>= ) x f = bind x ~f + let ( >>| ) x f = map x ~f end include Infix let to_list = function | None -> [] - | Some x -> [x] + | Some x -> [ x ] let is_some = function | None -> false | _ -> true - let plus a b = match a with + let plus a b = + match a with | Some _ -> a | None -> b @@ -343,9 +340,7 @@ module Option = struct end module Result = struct - type ('a, 'e) t = ('a, 'e) result = - | Ok of 'a - | Error of 'e + type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e let map ~f r = Result.map f r let bind ~f r = Result.bind r f @@ -356,24 +351,21 @@ module String = struct let for_all f t = let len = String.length t in - let rec loop i = - i = len || (f t.[i] && loop (i + 1)) - in + let rec loop i = i = len || (f t.[i] && loop (i + 1)) in loop 0 - let reverse s1 = let len = length s1 in - let s2 = Bytes.make len 'a' in + let s2 = Bytes.make len 'a' in for i = 0 to len - 1 do Bytes.set s2 i s1.[len - i - 1] - done ; + done; Bytes.to_string s2 let common_prefix_len s1 s2 = let rec aux i = - if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i else - aux (succ i) + if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i + else aux (succ i) in aux 0 @@ -381,72 +373,85 @@ module String = struct let is_prefixed ~by = let l = String.length by in fun s -> - let l' = String.length s in - (l' >= l) && - (try for i = 0 to pred l do - if s.[i] <> by.[i] then - raise Not_found - done; - true - with Not_found -> false) + let l' = String.length s in + l' >= l + && + try + for i = 0 to pred l do + if s.[i] <> by.[i] then raise Not_found + done; + true + with Not_found -> false (* Drop characters from beginning of string *) let drop n s = sub s ~pos:n ~len:(length s - n) - module Set = struct - include MoreLabels.Set.Make (struct type t = string let compare = compare end) + include MoreLabels.Set.Make (struct + type t = string + let compare = compare + end) let of_list l = List.fold_left ~f:(fun s elt -> add elt s) l ~init:empty let to_list s = fold ~f:(fun x xs -> x :: xs) s ~init:[] end module Map = struct - include MoreLabels.Map.Make (struct type t = string let compare = compare end) + include MoreLabels.Map.Make (struct + type t = string + let compare = compare + end) let of_list l = - List.fold_left ~f:(fun m (k,v) -> add ~key:k ~data:v m) l ~init:empty - let to_list m = fold ~f:(fun ~key ~data xs -> (key,data) :: xs) m ~init:[] + List.fold_left ~f:(fun m (k, v) -> add ~key:k ~data:v m) l ~init:empty + let to_list m = fold ~f:(fun ~key ~data xs -> (key, data) :: xs) m ~init:[] - let keys m = fold ~f:(fun ~key ~data:_ xs -> key :: xs) m ~init:[] + let keys m = fold ~f:(fun ~key ~data:_ xs -> key :: xs) m ~init:[] let values m = fold ~f:(fun ~key:_ ~data xs -> data :: xs) m ~init:[] let add_multiple key data t = - let current = - try find key t - with Not_found -> [] - in + let current = try find key t with Not_found -> [] in let data = data :: current in add ~key ~data t end let mem c s = - try ignore (String.index s c : int); true + try + ignore (String.index s c : int); + true with Not_found -> false let first_double_underscore_end s = let len = String.length s in let rec aux i = - if i > len - 2 then raise Not_found else - if s.[i] = '_' && s.[i + 1] = '_' then i + 1 + if i > len - 2 then raise Not_found + else if s.[i] = '_' && s.[i + 1] = '_' then i + 1 else aux (i + 1) in aux 0 let no_double_underscore s = - try ignore (first_double_underscore_end s); false + try + ignore (first_double_underscore_end s); + false with Not_found -> true - let trim = function "" -> "" | str -> - let l = String.length str in - let is_space = function - | ' ' | '\n' | '\t' | '\r' -> true - | _ -> false - in - let r0 = ref 0 and rl = ref l in - while !r0 < l && is_space str.[!r0] do incr r0 done; - let r0 = !r0 in - while !rl > r0 && is_space str.[!rl - 1] do decr rl done; - let rl = !rl in - if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0) + let trim = function + | "" -> "" + | str -> + let l = String.length str in + let is_space = function + | ' ' | '\n' | '\t' | '\r' -> true + | _ -> false + in + let r0 = ref 0 and rl = ref l in + while !r0 < l && is_space str.[!r0] do + incr r0 + done; + let r0 = !r0 in + while !rl > r0 && is_space str.[!rl - 1] do + decr rl + done; + let rl = !rl in + if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0) let print () s = Printf.sprintf "%S" s @@ -462,11 +467,11 @@ module String = struct let split_on_char_ c s = match String.index s c with - | exception Not_found -> [s] + | exception Not_found -> [ s ] | p -> let rec loop i = match String.index_from s i c with - | exception Not_found -> [String.sub s i (String.length s - i)] + | exception Not_found -> [ String.sub s i (String.length s - i) ] | j -> let s0 = String.sub s i (j - i) in s0 :: loop (j + 1) @@ -484,25 +489,23 @@ module String = struct done; Some (String.sub text plen (tlen - plen)) with Not_found -> None - else - None + else None let next_occurrence ~pattern text from = let plen = String.length pattern in let last = String.length text - plen in let i = ref from and j = ref 0 in while !i <= last && !j < plen do - if text.[!i + !j] <> pattern.[!j] - then (incr i; j := 0) + if text.[!i + !j] <> pattern.[!j] then ( + incr i; + j := 0) else incr j done; - if !j < plen then - raise Not_found - else - !i + if !j < plen then raise Not_found else !i let replace_all ~pattern ~with_ text = - if pattern = "" then text else + if pattern = "" then text + else match next_occurrence ~pattern text 0 with | exception Not_found -> text | j0 -> @@ -530,9 +533,7 @@ module String = struct let len = String.length s in match from with | None -> len - 1 - | Some i -> - if i > len - 1 then failwith "rfindi: invalid from" - else i + | Some i -> if i > len - 1 then failwith "rfindi: invalid from" else i in loop s ~f from @@ -558,7 +559,7 @@ module Format = struct let default_width = ref 0 - let to_string ?(width= !default_width) () = + let to_string ?(width = !default_width) () = let b = Buffer.create 32 in let ppf = formatter_of_buffer b in let contents () = @@ -566,23 +567,22 @@ module Format = struct Buffer.contents b in pp_set_margin ppf width; - ppf, contents + (ppf, contents) end module Lexing = struct + type position = Lexing.position = + { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int } - type position = Lexing.position = { - pos_fname : string; - pos_lnum : int; - pos_bol : int; - pos_cnum : int; - } - - include (Lexing : module type of struct include Lexing end - with type position := position) + include ( + Lexing : + module type of struct + include Lexing + end + with type position := position) let move buf p = - buf.lex_abs_pos <- (p.pos_cnum - buf.lex_curr_pos); + buf.lex_abs_pos <- p.pos_cnum - buf.lex_curr_pos; buf.lex_curr_p <- p let from_strings ?empty ?position source refill = @@ -592,34 +592,35 @@ module Lexing = struct let lex_fun buf size = let count = min (!len - !pos) size in let count = - if count <= 0 then - begin - source := refill (); - len := String.length !source; - pos := 0; - min !len size - end + if count <= 0 then begin + source := refill (); + len := String.length !source; + pos := 0; + min !len size + end else count in if count <= 0 then 0 else begin - String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count; - pos := !pos + count; - (match empty with None -> () | Some r -> r := !pos >= !len); - count - end + String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count; + pos := !pos + count; + (match empty with + | None -> () + | Some r -> r := !pos >= !len); + count + end in let buf = from_function lex_fun in Option.iter ~f:(move buf) position; buf (* Manipulating position *) - let make_pos ?(pos_fname="") (pos_lnum, pos_cnum) = - { pos_fname ; pos_lnum ; pos_cnum ; pos_bol = 0 } + let make_pos ?(pos_fname = "") (pos_lnum, pos_cnum) = + { pos_fname; pos_lnum; pos_cnum; pos_bol = 0 } let column pos = pos.pos_cnum - pos.pos_bol - let set_column pos col = {pos with pos_cnum = pos.pos_bol + col} + let set_column pos col = { pos with pos_cnum = pos.pos_bol + col } let split_pos pos = (pos.pos_lnum, column pos) @@ -635,21 +636,18 @@ module Lexing = struct (* Current position in lexer, even if the buffer is in the middle of a refill operation *) let immediate_pos buf = - {buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos} + { buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos } let json_of_position pos = let line, col = split_pos pos in - `Assoc ["line", `Int line; "col", `Int col] + `Assoc [ ("line", `Int line); ("col", `Int col) ] - let min_pos p1 p2 = - if compare_pos p1 p2 <= 0 then p1 else p2 + let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2 - let max_pos p1 p2 = - if compare_pos p1 p2 >= 0 then p1 else p2 + let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2 end module Char = struct - (* FIXME: Remove once we drop support for 4.02 and replace the calls to [uppercase] and [lowercase] by their [_ascii] version. *) [@@@ocaml.warning "-3"] @@ -662,17 +660,11 @@ module Char = struct end module Glob : sig - type pattern = - | Wildwild - | Exact of string - | Regexp of Str.regexp + type pattern = Wildwild | Exact of string | Regexp of Str.regexp val compile_pattern : string -> pattern val match_pattern : pattern -> string -> bool end = struct - type pattern = - | Wildwild - | Exact of string - | Regexp of Str.regexp + type pattern = Wildwild | Exact of string | Regexp of Str.regexp let compile_pattern = function | "**" -> Wildwild @@ -682,27 +674,31 @@ end = struct let flush () = if Buffer.length chunk > 0 then ( Buffer.add_string regexp (Str.quote (Buffer.contents chunk)); - Buffer.clear chunk; - ) + Buffer.clear chunk) in let l = String.length pattern in let i = ref 0 in while !i < l do - begin match pattern.[!i] with - | '\\' -> incr i; if !i < l then Buffer.add_char chunk pattern.[!i] - | '*' -> flush (); Buffer.add_string regexp ".*"; - | '?' -> flush (); Buffer.add_char regexp '.'; + begin + match pattern.[!i] with + | '\\' -> + incr i; + if !i < l then Buffer.add_char chunk pattern.[!i] + | '*' -> + flush (); + Buffer.add_string regexp ".*" + | '?' -> + flush (); + Buffer.add_char regexp '.' | x -> Buffer.add_char chunk x end; incr i done; - if Buffer.length regexp = 0 then - Exact (Buffer.contents chunk) + if Buffer.length regexp = 0 then Exact (Buffer.contents chunk) else ( flush (); Buffer.add_char regexp '$'; - Regexp (Str.regexp (Buffer.contents regexp)) - ) + Regexp (Str.regexp (Buffer.contents regexp))) let match_pattern re str = match re with @@ -714,7 +710,7 @@ end let fprintf = Format.fprintf let lazy_eq a b = - match Lazy.is_val a, Lazy.is_val b with + match (Lazy.is_val a, Lazy.is_val b) with | true, true -> Lazy.force_val a == Lazy.force_val b | false, false -> a == b | _ -> false @@ -723,8 +719,12 @@ let let_ref r v f = let v' = !r in r := v; match f () with - | result -> r := v'; result - | exception exn -> r := v'; raise exn + | result -> + r := v'; + result + | exception exn -> + r := v'; + raise exn let failwithf fmt = Printf.ksprintf failwith fmt @@ -732,20 +732,19 @@ module Shell = struct let split_command str = let comps = ref [] in let dirty = ref false in - let buf = Buffer.create 16 in + let buf = Buffer.create 16 in let flush () = if !dirty then ( comps := Buffer.contents buf :: !comps; dirty := false; - Buffer.clear buf; - ) + Buffer.clear buf) in let i = ref 0 and len = String.length str in let unescape = function | 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' - | x -> x + | x -> x in while !i < len do let c = str.[!i] in @@ -756,26 +755,23 @@ module Shell = struct dirty := true; if !i < len then ( Buffer.add_char buf (unescape str.[!i]); - incr i - ) + incr i) | '\'' -> dirty := true; while !i < len && str.[!i] <> '\'' do Buffer.add_char buf str.[!i]; - incr i; + incr i done; incr i | '"' -> dirty := true; while !i < len && str.[!i] <> '"' do (match str.[!i] with - | '\\' -> - incr i; - if !i < len then - Buffer.add_char buf (unescape str.[!i]); - | x -> Buffer.add_char buf x - ); - incr i; + | '\\' -> + incr i; + if !i < len then Buffer.add_char buf (unescape str.[!i]) + | x -> Buffer.add_char buf x); + incr i done; incr i | x -> @@ -787,69 +783,75 @@ module Shell = struct end module System = struct - external windows_merlin_system_command : string -> cwd:string -> ?outfile:string -> int = - "ml_merlin_system_command" - - let run_in_directory - : (prog:string - -> prog_is_quoted:bool - -> args:string list - -> cwd:string - -> ?stdin:string - -> ?stdout:string - -> ?stderr:string - -> unit - -> [ `Finished of int | `Cancelled ]) ref = ref @@ - fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () -> - (* Currently we assume that [prog] is always quoted and might contain - arguments such as [-as-ppx]. This is due to the way Merlin gets its - configuration. Thus we cannot rely on [Filename.quote_command]. *) - let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in - (* Runned program should never output on stdout since it is the - channel used by Merlin to communicate with the editor *) - let args = - if Sys.win32 then args - else - let stdout = match stdout with - | Some file -> Filename.quote file - | None -> "&2" - in - Printf.sprintf "%s 1>%s" args stdout - in - let cmd = Format.sprintf "%s %s" prog args in - let exit_code = - if Sys.win32 then - (* Note: the following function will never output to stdout. - When [stdout = None], stdout is sent to stderr. *) - windows_merlin_system_command cmd ~cwd ?outfile:stdout - else - Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) - in - `Finished exit_code + external windows_merlin_system_command : + string -> cwd:string -> ?outfile:string -> int = "ml_merlin_system_command" + + let run_in_directory : + (prog:string -> + prog_is_quoted:bool -> + args:string list -> + cwd:string -> + ?stdin:string -> + ?stdout:string -> + ?stderr:string -> + unit -> + [ `Finished of int | `Cancelled ]) + ref = + ref + @@ fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () -> + (* Currently we assume that [prog] is always quoted and might contain + arguments such as [-as-ppx]. This is due to the way Merlin gets its + configuration. Thus we cannot rely on [Filename.quote_command]. *) + let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in + (* Runned program should never output on stdout since it is the + channel used by Merlin to communicate with the editor *) + let args = + if Sys.win32 then args + else + let stdout = + match stdout with + | Some file -> Filename.quote file + | None -> "&2" + in + Printf.sprintf "%s 1>%s" args stdout + in + let cmd = Format.sprintf "%s %s" prog args in + let exit_code = + if Sys.win32 then + (* Note: the following function will never output to stdout. + When [stdout = None], stdout is sent to stderr. *) + windows_merlin_system_command cmd ~cwd ?outfile:stdout + else Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) + in + `Finished exit_code end - (* [modules_in_path ~ext path] lists ocaml modules corresponding to - * filenames with extension [ext] in given [path]es. - * For instance, if there is file "a.ml","a.mli","b.ml" in ".": - * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], - * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) +(* [modules_in_path ~ext path] lists ocaml modules corresponding to + * filenames with extension [ext] in given [path]es. + * For instance, if there is file "a.ml","a.mli","b.ml" in ".": + * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], + * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) let modules_in_path ~ext path = let seen = Hashtbl.create 7 in List.fold_left ~init:[] path - ~f:begin fun results dir -> - try - Array.fold_left - begin fun results file -> - if Filename.check_suffix file ext - then let name = Filename.chop_extension file in - (if Hashtbl.mem seen name - then results - else - (Hashtbl.add seen name (); String.capitalize name :: results)) - else results - end results (Sys.readdir dir) - with Sys_error _ -> results - end + ~f: + begin + fun results dir -> + try + Array.fold_left + begin + fun results file -> + if Filename.check_suffix file ext then + let name = Filename.chop_extension file in + if Hashtbl.mem seen name then results + else ( + Hashtbl.add seen name (); + String.capitalize name :: results) + else results + end + results (Sys.readdir dir) + with Sys_error _ -> results + end let file_contents filename = let ic = open_in filename in @@ -872,15 +874,9 @@ let file_contents filename = external reraise : exn -> 'a = "%reraise" -type 'a with_workdir = { - workdir : string; - workval : 'a; -} (** Some value that must be interpreted with respect to a specific work directory. (e.g. for resolving relative paths or executing sub-commands *) +type 'a with_workdir = { workdir : string; workval : 'a } let dump_with_workdir f x : json = - `Assoc [ - "workdir", `String x.workdir; - "workval", f x.workval; - ] + `Assoc [ ("workdir", `String x.workdir); ("workval", f x.workval) ] From f5f686e66a3f7ed9b3622046eb11f1774c4e0776 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 16:02:04 +0200 Subject: [PATCH 24/42] Add commit to ignored revs --- .git-blame-ignore-revs | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 .git-blame-ignore-revs diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 0000000000..f1c18bf6f9 --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# git config blame.ignoreRevsFile .git-blame-ignore-revs +beb4b4c5ed38984534effc3cc8733db57820bc7b From cb0da02325898e01ab87d7c545407b30305ee0fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 16:04:35 +0200 Subject: [PATCH 25/42] [B] #1828 Search by type feature, a kind of sherlodoc in Merlin --- .ocamlformat | 2 +- CHANGES.md | 4 + doc/dev/PROTOCOL.md | 29 ++ emacs/merlin.el | 95 +++-- merlin-lib.opam | 1 + src/analysis/dune | 1 + src/analysis/polarity_search.ml | 33 ++ src/analysis/type_search.ml | 144 +++++++ src/analysis/type_search.mli | 57 +++ src/commands/new_commands.ml | 28 ++ src/commands/query_json.ml | 26 ++ src/frontend/dune | 1 + src/frontend/query_commands.ml | 48 ++- src/frontend/query_protocol.ml | 12 + src/sherlodoc/dune | 9 + src/sherlodoc/name_cost.ml | 102 +++++ src/sherlodoc/name_cost.mli | 42 ++ src/sherlodoc/query.ml | 94 +++++ src/sherlodoc/query.mli | 46 +++ src/sherlodoc/type_distance.ml | 188 +++++++++ src/sherlodoc/type_distance.mli | 33 ++ src/sherlodoc/type_expr.ml | 137 +++++++ src/sherlodoc/type_expr.mli | 57 +++ src/sherlodoc/type_lexer.mll | 15 + src/sherlodoc/type_parsed.ml | 40 ++ src/sherlodoc/type_parsed.mli | 44 +++ src/sherlodoc/type_parser.mly | 52 +++ src/sherlodoc/type_polarity.ml | 48 +++ src/sherlodoc/type_polarity.mli | 49 +++ src/utils/marg.ml | 6 + src/utils/marg.mli | 3 + tests/test-dirs/search/dune | 4 + ...rity-search-comparison-to-search-by-type.t | 145 +++++++ ...ch-by-type-comparison-to-polarity-search.t | 242 ++++++++++++ .../search/search-by-type.t/context.ml | 1 + tests/test-dirs/search/search-by-type.t/run.t | 365 ++++++++++++++++++ tests/test-units/sherldoc/dune | 3 + tests/test-units/sherldoc/name_cost_test.ml | 124 ++++++ tests/test-units/sherldoc/name_cost_test.mli | 1 + tests/test-units/sherldoc/query_test.ml | 125 ++++++ tests/test-units/sherldoc/query_test.mli | 1 + tests/test-units/sherldoc/sherlodoc_test.ml | 7 + .../test-units/sherldoc/type_distance_test.ml | 44 +++ .../sherldoc/type_distance_test.mli | 1 + tests/test-units/sherldoc/type_expr_test.ml | 145 +++++++ tests/test-units/sherldoc/type_expr_test.mli | 1 + 46 files changed, 2599 insertions(+), 56 deletions(-) create mode 100644 src/analysis/type_search.ml create mode 100644 src/analysis/type_search.mli create mode 100644 src/sherlodoc/dune create mode 100644 src/sherlodoc/name_cost.ml create mode 100644 src/sherlodoc/name_cost.mli create mode 100644 src/sherlodoc/query.ml create mode 100644 src/sherlodoc/query.mli create mode 100644 src/sherlodoc/type_distance.ml create mode 100644 src/sherlodoc/type_distance.mli create mode 100644 src/sherlodoc/type_expr.ml create mode 100644 src/sherlodoc/type_expr.mli create mode 100644 src/sherlodoc/type_lexer.mll create mode 100644 src/sherlodoc/type_parsed.ml create mode 100644 src/sherlodoc/type_parsed.mli create mode 100644 src/sherlodoc/type_parser.mly create mode 100644 src/sherlodoc/type_polarity.ml create mode 100644 src/sherlodoc/type_polarity.mli create mode 100644 tests/test-dirs/search/dune create mode 100644 tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t create mode 100644 tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t create mode 100644 tests/test-dirs/search/search-by-type.t/context.ml create mode 100644 tests/test-dirs/search/search-by-type.t/run.t create mode 100644 tests/test-units/sherldoc/dune create mode 100644 tests/test-units/sherldoc/name_cost_test.ml create mode 100644 tests/test-units/sherldoc/name_cost_test.mli create mode 100644 tests/test-units/sherldoc/query_test.ml create mode 100644 tests/test-units/sherldoc/query_test.mli create mode 100644 tests/test-units/sherldoc/sherlodoc_test.ml create mode 100644 tests/test-units/sherldoc/type_distance_test.ml create mode 100644 tests/test-units/sherldoc/type_distance_test.mli create mode 100644 tests/test-units/sherldoc/type_expr_test.ml create mode 100644 tests/test-units/sherldoc/type_expr_test.mli diff --git a/.ocamlformat b/.ocamlformat index 2f1d4222b2..10492f340e 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -8,4 +8,4 @@ dock-collection-brackets=false # Preserve begin/end exp-grouping=preserve module-item-spacing=preserve -parse-docstrings=false +parse-docstrings=false \ No newline at end of file diff --git a/CHANGES.md b/CHANGES.md index 14581d1e97..b251a41402 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -9,10 +9,14 @@ unreleased - Implement new expand-node command for expanding PPX annotations (#1745) - Implement new inlay-hints command for adding hints on a sourcetree (#1812) - Add `signature-help` command (#1720) + - Implement new search-by-type command for searching values by types (#1828) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) - emacs: Improve the way that result of polarity search is displayed (#1814) + - emacs: Add `merlin-search-by-type`, `merlin-search-by-polarity` and change the + behaviour of `merlin-search` to switch between `by-type` or `by-polarity` + depending on the query (#1828) merlin 4.16 =========== diff --git a/doc/dev/PROTOCOL.md b/doc/dev/PROTOCOL.md index 7d03d986f7..16fac57f0b 100644 --- a/doc/dev/PROTOCOL.md +++ b/doc/dev/PROTOCOL.md @@ -425,6 +425,35 @@ The result is returned as a list of: Returns the type of the expression when typechecked in the environment around the specified position. +### `search-by-polarity` -position -query + + -position Position to search + -query The query + +Returns a list (in the form of a completion list) of values matching the query. A query is defined by polarity (and does not support type parameters). Arguments are prefixed with `-` and the return type is prefixed with `+`. For example, to find a function that takes a string and returns an integer: `-string +int`. `-list +option` will returns every definition that take a list an option. + +### `search-by-type` -position -query -limit -with-doc + + -position Position to search + -query The query + -limit a maximum-size of the result set + -with-doc if doc should be included in the result + +Returns a list of values matching the query. A query is a type expression, ie: `string -> int option` will search every definition that take a string and returns an option of int. It is also possible to search by polarity. + +The result is returned as a list of: +```javascript +{ + 'file': filename, // the file where the definition is defined + 'start': position, + 'end': position, + 'name': string, // the name of the definition + 'type': string, // the type of the definition + 'cost': int, // the cost/distance of the definition and the query + 'doc': string | null // the docstring of the definition +} +``` + ### `check-configuration` diff --git a/emacs/merlin.el b/emacs/merlin.el index cf5dd0089e..c736a28018 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -137,10 +137,6 @@ a call to `merlin-occurrences'." See `merlin-debug'." :group 'merlin :type 'string) -(defcustom merlin-polarity-search-buffer-name "*merlin-polarity-search-result*" - "The name of the buffer displaying result of polarity search." - :group 'merlin :type 'string) - (defcustom merlin-favourite-caml-mode nil "The OCaml mode to use for the *merlin-types* buffer." :group 'merlin :type 'symbol) @@ -1094,51 +1090,70 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (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)))) +;;;;;;;;;;;; +;; SEARCH ;; +;;;;;;;;;;;; -(defun merlin--get-polarity-buff () - (get-buffer-create merlin-polarity-search-buffer-name)) +(defun merlin--search (query) + (merlin-call "search-by-type" + "-query" query + "-position" (merlin-unmake-point (point)))) -(defun merlin--render-polarity-result (name type) +(defun merlin--search-format-key (name type doc) (let ((plain-name (string-remove-prefix "Stdlib__" name))) (concat - (propertize "val " 'face (intern "font-lock-keyword-face")) (propertize plain-name 'face (intern "font-lock-function-name-face")) " : " - (propertize type 'face (intern "font-lock-doc-face"))))) - -(defun merlin--polarity-result-to-list (entry) - (let ((function-name (merlin-completion-entry-text "" entry)) - (function-type (merlin-completion-entry-short-description entry))) - (list function-name - (vector (merlin--render-polarity-result function-name function-type))))) + (propertize type 'face (intern "font-lock-doc-face")) + " " + (propertize doc 'face (intern "font-lock-comment-face"))))) + +(defun merlin--get-documentation-line-from-entry (entry) + (let* ((doc-entry (cdr (assoc 'doc entry))) + (doc (if (eq doc-entry 'null) "" doc-entry)) + (doc-lines (split-string doc "[\r\n]+"))) + (car doc-lines))) + +(defun merlin--search-entry-to-completion-entry (entry) + (let ((value-name (cdr (assoc 'name entry))) + (value-hole (cdr (assoc 'constructible entry))) + (value-type (cdr (assoc 'type entry))) + (value-docs (merlin--get-documentation-line-from-entry entry))) + (let ((key (merlin--search-format-key value-name value-type value-docs)) + (value value-hole)) + (cons key value)))) + +(defun merlin--search-select-completion-result (choices selected) + (alist-get selected choices nil nil #'equal)) + +(defun merlin--search-substitute-constructible (elt) + (progn + (when (region-active-p) + (delete-region (region-beginning) (region-end))) + (insert (concat "(" elt ")")))) + +(defun merlin--search-completion-presort (choices) + (lambda (string pred action) + (if (eq action 'metadata) + '(metadata (display-sort-function . identity) + (cycle-sort-function . identity)) + (complete-with-action action choices string pred)))) (defun merlin-search (query) - (interactive "sSearch pattern: ") - (let* ((result (merlin--search query)) - (entries (cdr (assoc 'entries result))) - (previous-buff (current-buffer))) - (let ((pol-buff (merlin--get-polarity-buff)) - (inhibit-read-only t)) - (with-current-buffer pol-buff - (switch-to-buffer-other-window pol-buff) - (goto-char 1) - (tabulated-list-mode) - (setq tabulated-list-format [("Polarity Search Result" 100 t)]) - (setq tabulated-list-entries (mapcar 'merlin--polarity-result-to-list entries)) - (setq tabulated-list-padding 2) - (face-spec-set 'header-line '((t :weight bold :height 1.2))) - (tabulated-list-init-header) - (tabulated-list-print t) - (setq buffer-read-only t) - (switch-to-buffer-other-window previous-buff))))) + "Search values by types or polarity" + (interactive "sSearch query: ") + (let* ((entries (merlin--search query)) + (choices + (mapcar #'merlin--search-entry-to-completion-entry entries))) + (let ((constructible + (merlin--search-select-completion-result + choices + (completing-read (concat "Candidates: ") + (merlin--search-completion-presort choices) + nil nil nil t)))) + (merlin--search-substitute-constructible constructible)))) + ;;;;;;;;;;;;;;;;; ;; TYPE BUFFER ;; diff --git a/merlin-lib.opam b/merlin-lib.opam index 1a9eb26aa1..72270d1c42 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -13,6 +13,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} + "alcotest" {with-test} "menhir" {dev & >= "20201216"} "menhirLib" {dev & >= "20201216"} "menhirSdk" {dev & >= "20201216"} diff --git a/src/analysis/dune b/src/analysis/dune index 1521f351e9..97924c241b 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -17,6 +17,7 @@ merlin_extend merlin_kernel merlin_utils + merlin_sherlodoc ocaml_parsing ocaml_preprocess query_protocol diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 33d68cd7cf..159f224b8a 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -80,6 +80,21 @@ let build_query ~positive ~negative env = pos_fun = !pos_fun } +let prepare_query env 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 + build_query env ~positive:(List.map pos ~f:prepare) + ~negative:(List.map neg ~f:prepare) + let directories ~global_modules env = let rec explore lident env = let add_module name _ md l = @@ -126,3 +141,21 @@ let execute_query query env dirs = acc in List.fold_left dirs ~init:(direct None []) ~f:recurse + +(* [execute_query_as_type_search] runs a standard polarity_search query and map + the result for compatibility with the type-search interface. *) +let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules () = + execute_query query env modules + |> List.map ~f:(fun (cost, path, desc) -> + let name = + Printtyp.wrap_printing_env env @@ fun () -> + let path = Printtyp.rewrite_double_underscore_paths env path in + Format.asprintf "%a" Printtyp.path path + in + let doc = None in + let loc = desc.Types.val_loc in + let typ = desc.Types.val_type in + let constructible = Type_search.make_constructible name typ in + Query_protocol.{ cost; name; typ; loc; doc; constructible }) + |> List.sort ~cmp:Type_search.compare_result + |> List.take_n limit diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml new file mode 100644 index 0000000000..48337219ca --- /dev/null +++ b/src/analysis/type_search.ml @@ -0,0 +1,144 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Frédéric Bour + Thomas Refis + Simon Castellan + Arthur Wendling + Xavier Van de Woestyne + + 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 sherlodoc_type_of env typ = + let open Merlin_sherlodoc in + let rec aux typ = + match Types.get_desc typ with + | Types.Tvar None -> Type_parsed.Wildcard + | Types.Tvar (Some ty) -> Type_parsed.Tyvar ty + | Types.Ttuple elts -> Type_parsed.tuple @@ List.map ~f:aux elts + | Types.Tarrow (_, a, b, _) -> Type_parsed.Arrow (aux a, aux b) + | Types.Tconstr (p, args, _) -> + let p = Printtyp.rewrite_double_underscore_paths env p in + let name = Format.asprintf "%a" Printtyp.path p in + Type_parsed.Tycon (name, List.map ~f:aux args) + | _ -> Type_parsed.Unhandled + in + typ |> aux |> Type_expr.normalize_type_parameters + +let make_constructible path desc = + let holes = + match Types.get_desc desc with + | Types.Tarrow (l, _, b, _) -> + let rec aux acc t = + match Types.get_desc t with + | Types.Tarrow (l, _, b, _) -> aux (acc ^ with_label l) b + | _ -> acc + and with_label l = + match l with + | Ocaml_parsing.Asttypes.Nolabel -> " _" + | Labelled s -> " ~" ^ s ^ ":_" + | Optional _ -> "" + in + aux (with_label l) b + | _ -> "" + in + path ^ holes + +let doc_to_option = function + | `Builtin doc | `Found doc -> Some doc + | _ -> None + +let get_doc ~config ~env ~local_defs ~comments ~pos name = + Locate.get_doc ~config ~env ~local_defs ~comments ~pos (`User_input name) + |> doc_to_option + +let compare_result Query_protocol.{ cost = cost_a; name = a; doc = doc_a; _ } + Query_protocol.{ cost = cost_b; name = b; doc = doc_b; _ } = + let c = Int.compare cost_a cost_b in + if Int.equal c 0 then + let c = Int.compare (String.length a) (String.length b) in + match (c, doc_a, doc_b) with + | 0, Some _, None -> 1 + | 0, None, Some _ -> -1 + | 0, Some doc_a, Some doc_b -> + let c = Int.compare (String.length doc_a) (String.length doc_b) in + (* Make default insertion determinist *) + if Int.equal 0 c then String.compare a b else c + | 0, None, None -> String.compare a b + | _ -> c + else c + +let compute_value query env _ path desc acc = + let open Merlin_sherlodoc in + let d = desc.Types.val_type in + let typ = sherlodoc_type_of env d in + let name = + Printtyp.wrap_printing_env env @@ fun () -> + let path = Printtyp.rewrite_double_underscore_paths env path in + Format.asprintf "%a" Printtyp.path path + in + let cost = Query.distance_for query ~path:name typ in + if cost >= 1000 then acc + else + let doc = None in + let loc = desc.Types.val_loc in + let typ = desc.Types.val_type in + let constructible = make_constructible name d in + Query_protocol.{ cost; name; typ; loc; doc; constructible } :: acc + +let compute_values query env lident acc = + Env.fold_values (compute_value query env) lident env acc + +let values_from_module query env lident acc = + let rec aux acc lident = + match Env.find_module_by_name lident env with + | exception _ -> acc + | _ -> + let acc = compute_values query env (Some lident) acc in + Env.fold_modules + (fun name _ mdl acc -> + match mdl.Types.md_type with + | Types.Mty_alias _ -> acc + | _ -> + let lident = Longident.Ldot (lident, name) in + aux acc lident) + (Some lident) env acc + in + aux acc lident + +let run ?(limit = 100) ~env ~query ~modules () = + let init = compute_values query env None [] in + modules + |> List.fold_left ~init ~f:(fun acc name -> + let lident = Longident.Lident name in + values_from_module query env lident acc) + |> List.sort ~cmp:compare_result + |> List.take_n limit + +let classify_query query = + let query = String.trim query in + match query.[0] with + | '+' | '-' -> `Polarity query + | _ -> `By_type query + | exception Invalid_argument _ -> `Polarity query diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli new file mode 100644 index 0000000000..8c3bcae14a --- /dev/null +++ b/src/analysis/type_search.mli @@ -0,0 +1,57 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Frédéric Bour + Thomas Refis + Simon Castellan + Arthur Wendling + Xavier Van de Woestyne + + 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. + + )* }}} *) + +(** Search by type in the current environment. *) + +(** Compute the list of candidates from a query inside a given environment. *) +val run : + ?limit:int -> + env:Env.t -> + query:Merlin_sherlodoc.Query.t -> + modules:string list -> + unit -> + Types.type_expr Query_protocol.type_search_result list + +val get_doc : + config:Mconfig.t -> + env:Env.t -> + local_defs:Mtyper.typedtree -> + comments:(string * Location.t) list -> + pos:Lexing.position -> + string -> + string option + +val make_constructible : string -> Types.type_expr -> string +val compare_result : + _ Query_protocol.type_search_result -> + _ Query_protocol.type_search_result -> + int + +val classify_query : string -> [ `By_type of string | `Polarity of string ] diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 02d23b99a3..836c3334f6 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -580,6 +580,34 @@ let all_commands = | #Msource.position as pos -> run buffer (Query_protocol.Polarity_search (query, pos)) end; + command "search-by-type" ~doc:"return a list of values that match a query" + ~spec: + [ arg "-position" " to complete" + (marg_position (fun pos (query, _pos, limit, with_doc) -> + (query, pos, limit, with_doc))); + arg "-query" " to request values" + (Marg.param "string" (fun query (_query, pos, limit, with_doc) -> + (Some query, pos, limit, with_doc))); + optional "-limit" + " the maximal amount of results (default is 100)" + (Marg.int (fun limit (query, pos, _limit, with_doc) -> + (query, pos, limit, with_doc))); + optional "-with-doc" " include docstring (default is false)" + (Marg.bool (fun with_doc (query, pos, limit, _with_doc) -> + (query, pos, limit, with_doc))) + ] + ~default:(None, `None, 100, false) + begin + fun buffer (query, pos, limit, with_doc) -> + match (query, pos) with + | None, `None -> + failwith "-position and -query are mandatory" + | None, _ -> failwith "-query is mandatory" + | _, `None -> failwith "-position is mandatory" + | Some query, (#Msource.position as pos) -> + run buffer + (Query_protocol.Type_search (query, pos, limit, with_doc)) + end; command "inlay-hints" ~doc:"return a list of inly-hints for additional client (like LSP)" ~spec: diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 30e1e73914..ebd527fa17 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -178,6 +178,13 @@ let dump (type a) : a t -> json = | Polarity_search (query, pos) -> mk "polarity-search" [ ("query", `String query); ("position", mk_position pos) ] + | Type_search (query, pos, limit, with_doc) -> + mk "type-search" + [ ("query", `String query); + ("position", mk_position pos); + ("limit", `Int limit); + ("with-doc", `Bool with_doc) + ] | Occurrences (`Ident_at pos, scope) -> mk "occurrences" [ ("kind", `String "identifiers"); @@ -372,6 +379,24 @@ let json_of_signature_help resp = ("activeSignature", `Int active_signature) ] +let json_of_search_result list = + let list = + List.map + ~f:(fun { name; typ; loc; cost; doc; constructible } -> + with_location ~with_file:true loc + [ ("name", `String name); + ("type", `String typ); + ("cost", `Int cost); + ( "doc", + match doc with + | Some x -> `String x + | None -> `Null ); + ("constructible", `String constructible) + ]) + list + in + `List list + let json_of_response (type a) (query : a t) (response : a) : json = match (query, response) with | Type_expr _, str -> `String str @@ -381,6 +406,7 @@ let json_of_response (type a) (query : a t) (response : a) : json = | Complete_prefix _, compl -> json_of_completions compl | Expand_prefix _, compl -> json_of_completions compl | Polarity_search _, compl -> json_of_completions compl + | Type_search _, result -> json_of_search_result result | Refactor_open _, locations -> `List (List.map locations ~f:(fun (name, loc) -> diff --git a/src/frontend/dune b/src/frontend/dune index 92776fa4f2..ac51d30fbf 100644 --- a/src/frontend/dune +++ b/src/frontend/dune @@ -29,4 +29,5 @@ merlin_specific merlin_config merlin_analysis + merlin_sherlodoc query_protocol)) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 20cf3172dd..b7ea91f4fd 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -445,21 +445,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function 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 query = Polarity_search.prepare_query env query 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 @@ -477,6 +463,38 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function { Compl.name; kind = `Value; desc; info = ""; deprecated = false }) in { Compl.entries; context = `Unknown } + | Type_search (query, pos, limit, with_doc) -> + let typer = Mpipeline.typer_result pipeline in + let pos = Mpipeline.get_lexing_pos pipeline pos in + let node = Mtyper.node_at typer pos in + let env, _ = Mbrowse.leaf_node node in + let config = Mpipeline.final_config pipeline in + let modules = Mconfig.global_modules config in + let verbosity = verbosity pipeline in + let results = + match Type_search.classify_query query with + | `By_type query -> + let query = Merlin_sherlodoc.Query.from_string query in + Type_search.run ~limit ~env ~query ~modules () + | `Polarity query -> + let query = Polarity_search.prepare_query env query in + let modules = Polarity_search.directories ~global_modules:modules env in + Polarity_search.execute_query_as_type_search ~limit ~env ~query ~modules + () + in + List.map results ~f:(fun ({ name; typ; doc; _ } as v) -> + let typ = + Printtyp.wrap_printing_env ~verbosity env @@ fun () -> + Format.asprintf "%a" (Type_utils.Printtyp.type_scheme env) typ + in + let doc = + if not with_doc then doc + else + let comments = Mpipeline.reader_comments pipeline in + let local_defs = Mtyper.get_typedtree typer in + Type_search.get_doc ~config ~env ~local_defs ~comments ~pos name + in + { v with typ; doc }) | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 911465d9e3..4ac5d92095 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -67,6 +67,15 @@ end type completions = Compl.t +type 'a type_search_result = + { name : string; + typ : 'a; + loc : Location_aux.t; + doc : string option; + cost : int; + constructible : string + } + type outline = item list and item = { outline_name : string; @@ -139,6 +148,9 @@ type _ t = string * Msource.position * Compl.kind list * [ `with_types ] _bool -> completions t | Polarity_search : string * Msource.position -> completions t + | Type_search : + string * Msource.position * int * bool + -> string type_search_result list t | Refactor_open : [ `Qualify | `Unqualify ] * Msource.position -> (string * Location.t) list t diff --git a/src/sherlodoc/dune b/src/sherlodoc/dune new file mode 100644 index 0000000000..bb11c8c41c --- /dev/null +++ b/src/sherlodoc/dune @@ -0,0 +1,9 @@ +(library + (name merlin_sherlodoc) + (public_name merlin-lib.sherlodoc)) + +(menhir + (modules type_parser) + (flags --explain)) + +(ocamllex type_lexer) diff --git a/src/sherlodoc/name_cost.ml b/src/sherlodoc/name_cost.ml new file mode 100644 index 0000000000..c69009cfce --- /dev/null +++ b/src/sherlodoc/name_cost.ml @@ -0,0 +1,102 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +let distance ?cutoff a b = + let len_a = String.length a and len_b = String.length b in + let cutoff = + let v = Int.max len_a len_b in + Option.fold ~none:v ~some:(Int.min v) cutoff + in + if abs (len_a - len_b) > cutoff then None + else + let matrix = Array.make_matrix (succ len_a) (succ len_b) (succ cutoff) in + let () = matrix.(0).(0) <- 0 in + let () = + for i = 1 to len_a do + matrix.(i).(0) <- i + done + in + let () = + for j = 1 to len_b do + matrix.(0).(j) <- j + done + in + let () = + for i = 1 to len_a do + for j = Int.max 1 (i - cutoff - 1) to Int.min len_b (i + cutoff + 1) do + let cost = if Char.equal a.[i - 1] b.[j - 1] then 0 else 1 in + let best = + Int.min + (1 + Int.min matrix.(i - 1).(j) matrix.(i).(j - 1)) + (matrix.(i - 1).(j - 1) + cost) + in + let best = + if + not + (i > i && j > 1 + && Char.equal a.[i - 1] b.[j - 2] + && Char.equal a.[i - 2] b.[j - 1]) + then best + else Int.min best (matrix.(i - 2).(j - 2) + cost) + in + matrix.(i).(j) <- best + done + done + in + let final_result = matrix.(len_a).(len_b) in + if final_result > cutoff then None else Some final_result + +let distance_of_substring ?cutoff query entry = + let len_e = String.length entry in + let len_q = String.length query in + let rec aux acc i = + if i = len_e then acc + else + let s = len_q |> Int.min (len_e - i) |> String.sub entry i in + let d = distance ?cutoff query s in + match (d, acc) with + | Some 0, _ -> Some 0 + | Some x, Some y -> aux (Some (Int.min (x * 4) y)) (succ i) + | Some x, _ | _, Some x -> aux (Some x) (succ i) + | None, None -> aux None (succ i) + in + let exact_match e = e + (abs (len_e - len_q) / 4) in + aux None 0 |> Option.map exact_match + +let best_distance ?cutoff words entry = + let rec aux acc = function + | [] -> acc |> Option.value ~default:0 + | x :: xs -> ( + match distance_of_substring ?cutoff x entry with + | None -> aux acc xs + | Some 0 -> 0 + | Some x -> + let acc = Int.min x (Option.value ~default:x acc) in + aux (Some acc) xs) + in + aux None words diff --git a/src/sherlodoc/name_cost.mli b/src/sherlodoc/name_cost.mli new file mode 100644 index 0000000000..51a7b90b09 --- /dev/null +++ b/src/sherlodoc/name_cost.mli @@ -0,0 +1,42 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Utilities for calculating distances between names. *) + +(** [distance ?cutoff a b] returns the + {{:https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance} + Damerau-Levenshtein} between [a] and [b]. *) +val distance : ?cutoff:int -> string -> string -> int option + +(** [distance_of_substring ?cutoff a b] compute the distance by extracting + relevant substring from [b] *) +val distance_of_substring : ?cutoff:int -> string -> string -> int option + +(** [best_distance ?cutoff words entry] compute the best distance of a list of + string according to a given string. *) +val best_distance : ?cutoff:int -> string list -> string -> int diff --git a/src/sherlodoc/query.ml b/src/sherlodoc/query.ml new file mode 100644 index 0000000000..8d81d50eae --- /dev/null +++ b/src/sherlodoc/query.ml @@ -0,0 +1,94 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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 = { words : string list; type_expr : Type_expr.t option } + +let equal { words = words_a; type_expr = type_expr_a } + { words = words_b; type_expr = type_expr_b } = + List.equal String.equal words_a words_b + && Option.equal Type_expr.equal type_expr_a type_expr_b + +let to_string { words; type_expr } = + let words = String.concat "; " words in + let type_expr = + type_expr + |> Option.map Type_expr.to_string + |> Option.value ~default:"" + in + "[" ^ words ^ "] " ^ type_expr + +let balance_parens len str = + let rec aux i open_parens close_parens = + if i >= len then (open_parens, close_parens) + else + match str.[i] with + | '(' -> aux (succ i) (succ open_parens) close_parens + | ')' when open_parens > 0 -> aux (succ i) (pred open_parens) close_parens + | ')' -> aux (succ i) open_parens (succ close_parens) + | _ -> aux (succ i) open_parens close_parens + in + let o, c = aux 0 0 0 in + let o = String.make c '(' and c = String.make o ')' in + o ^ str ^ c + +let naive_of_string str = + str |> String.split_on_char ' ' + |> List.filter (fun s -> not (String.equal s String.empty)) + +let guess_type_search len str = + len >= 1 + && (Char.equal str.[0] '\'' + || String.contains str '-' || String.contains str '(') + +let from_string str = + let len = String.length str in + let words, type_expr = + match String.index_opt str ':' with + | None -> + if guess_type_search len str then + let str = balance_parens len str in + ("", Type_expr.from_string str) + else (str, None) + | Some loc -> + let str_name = String.sub str 0 loc + and str_type = String.sub str (succ loc) (len - loc - 1) in + let len = String.length str_type in + let str_type = balance_parens len str_type in + (str_name, Type_expr.from_string str_type) + in + let words = naive_of_string words in + { words; type_expr } + +let distance_for { words; type_expr } ~path candidate = + let type_cost = + type_expr + |> Option.map (fun query -> Type_distance.compute ~query ~entry:candidate) + |> Option.value ~default:0 + in + let name_cost = Name_cost.best_distance words path in + name_cost + type_cost diff --git a/src/sherlodoc/query.mli b/src/sherlodoc/query.mli new file mode 100644 index 0000000000..2cd5cd3160 --- /dev/null +++ b/src/sherlodoc/query.mli @@ -0,0 +1,46 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Prepares a query based on a string of characters. A query acts on the + identifier of a function and its type.. *) + +(** Describes a search on an identifier and a type. *) +type t = { words : string list; type_expr : Type_expr.t option } + +(** Converts a string into a search query. *) +val from_string : string -> t + +(** Inspect a query (mostly for debugging purpose). *) +val to_string : t -> string + +(** Equality between queries. *) +val equal : t -> t -> bool + +(** [distance_for query ~path typexpr] returns a score for a [query] observing a + given value, (a [path] and a [type_expr]). *) +val distance_for : t -> path:string -> Type_expr.t -> int diff --git a/src/sherlodoc/type_distance.ml b/src/sherlodoc/type_distance.ml new file mode 100644 index 0000000000..7a3481dd13 --- /dev/null +++ b/src/sherlodoc/type_distance.ml @@ -0,0 +1,188 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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 step = + | Wildcard + | Tyname of string + | Tyvar of int + | Left_arrow + | Right_arrow + | Product of { position : int; length : int } + | Argument of { position : int; length : int } + +module P = Type_polarity + +let make_path t = + let rec aux prefix = function + | Type_expr.Unhandled -> [] + | Type_expr.Wildcard -> [ Wildcard :: prefix ] + | Type_expr.Tyvar x -> [ Tyvar x :: prefix ] + | Type_expr.Arrow (a, b) -> + List.rev_append + (aux (Left_arrow :: prefix) a) + (aux (Right_arrow :: prefix) b) + | Type_expr.Tycon (constr, []) -> [ Tyname constr :: prefix ] + | Type_expr.Tycon (constr, args) -> + let length = String.length constr in + let prefix = Tyname constr :: prefix in + args + |> List.mapi (fun position arg -> + let prefix = Argument { position; length } :: prefix in + aux prefix arg) + |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] + | Type_expr.Tuple args -> + let length = List.length args in + args + |> List.mapi (fun position arg -> + let prefix = Product { position; length } :: prefix in + aux prefix arg) + |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] + in + List.map List.rev (aux [] t) + +let make_cache xs ys = + let h = List.length xs |> succ + and w = List.length ys |> succ + and not_used = -1 in + Array.make_matrix h w not_used + +let skip_entry = 10 +let max_distance = 10_000 + +let distance xs ys = + let cache = make_cache xs ys in + let rec memo ~xpolarity ~ypolarity i j xs ys = + let cell = cache.(i).(j) in + if cell >= 0 then cell + else + let value = aux ~xpolarity ~ypolarity i j xs ys in + let () = cache.(i).(j) <- value in + value + and aux ~xpolarity ~ypolarity i j xs ys = + match (xs, ys) with + | [], _ -> 0 + | [ Wildcard ], _ -> 0 + | _, [] -> max_distance + | [ Tyvar _ ], [ Wildcard ] when P.equal xpolarity ypolarity -> 0 + | [ Tyvar x ], [ Tyvar y ] when P.equal xpolarity ypolarity -> + if Int.equal x y then 0 else 1 + | Left_arrow :: xs, Left_arrow :: ys -> + let xpolarity = P.negate xpolarity and ypolarity = P.negate ypolarity in + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys + | Left_arrow :: xs, _ -> + let xpolarity = P.negate xpolarity in + memo ~xpolarity ~ypolarity (succ i) j xs ys + | _, Left_arrow :: ys -> + let ypolarity = P.negate ypolarity in + memo ~xpolarity ~ypolarity i (succ j) xs ys + | _, Right_arrow :: ys -> memo ~xpolarity ~ypolarity i (succ j) xs ys + | Right_arrow :: xs, _ -> memo ~xpolarity ~ypolarity (succ i) j xs ys + | Product { length = a; _ } :: xs, Product { length = b; _ } :: ys + | Argument { length = a; _ } :: xs, Argument { length = b; _ } :: ys -> + let l = abs (a - b) in + l + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys + | Product _ :: xs, ys -> 1 + memo ~xpolarity ~ypolarity (succ i) j xs ys + | xs, Product _ :: ys -> 1 + memo ~xpolarity ~ypolarity i (succ j) xs ys + | Tyname x :: xs', Tyname y :: ys' when P.equal xpolarity ypolarity -> ( + match Name_cost.distance x y with + | None -> skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys' + | Some cost -> cost + memo ~xpolarity ~ypolarity (succ i) (succ j) xs' ys' + ) + | xs, Tyname _ :: ys -> + skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys + | xs, Argument _ :: ys -> memo ~xpolarity ~ypolarity i (succ j) xs ys + | _, (Wildcard | Tyvar _) :: _ -> max_distance + in + + let positive = P.positive in + aux ~xpolarity:positive ~ypolarity:positive 0 0 xs ys + +let make_array list = + list |> Array.of_list + |> Array.map (fun li -> + let li = List.mapi (fun i x -> (x, i)) li in + List.sort Stdlib.compare li) + +let init_heuristic list = + let used = Array.make List.(length @@ hd list) false in + let arr = make_array list in + let h = Array.make (succ @@ Array.length arr) 0 in + let () = Array.sort Stdlib.compare arr in + let () = + for i = Array.length h - 2 downto 0 do + let best = fst @@ List.hd arr.(i) in + h.(i) <- h.(i + 1) + best + done + in + (used, arr, h) + +let replace_score best score = best := Int.min score !best + +let minimize = function + | [] -> 0 + | list -> + let used, arr, heuristics = init_heuristic list in + let best = ref 1000 and limit = ref 0 in + let len_a = Array.length arr in + let rec aux rem acc i = + let () = incr limit in + if !limit > max_distance then false + else if rem <= 0 then + let score = acc + (1000 * (len_a - i)) in + let () = replace_score best score in + true + else if i >= len_a then + let score = acc + (5 * rem) in + let () = replace_score best score in + true + else if acc + heuristics.(i) >= !best then true + else + let rec find = function + | [] -> true + | (cost, j) :: rest -> + let continue = + if used.(j) then true + else + let () = used.(j) <- true in + let continue = aux (pred rem) (acc + cost) (succ i) in + let () = used.(j) <- false in + continue + in + if continue then find rest else false + in + find arr.(i) + in + let _ = aux (Array.length used) 0 0 in + !best + +let compute ~query ~entry = + let query = make_path query in + let path = make_path entry in + match (path, query) with + | _, [] | [], _ -> 1000 + | _ -> query |> List.map (fun p -> List.map (distance p) path) |> minimize diff --git a/src/sherlodoc/type_distance.mli b/src/sherlodoc/type_distance.mli new file mode 100644 index 0000000000..f492d0495e --- /dev/null +++ b/src/sherlodoc/type_distance.mli @@ -0,0 +1,33 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Calculate an approximation of the distance between two types. *) + +(** [compute a b] calculates an approximation of the distance between [query] + and [entry]. *) +val compute : query:Type_expr.t -> entry:Type_expr.t -> int diff --git a/src/sherlodoc/type_expr.ml b/src/sherlodoc/type_expr.ml new file mode 100644 index 0000000000..d613a80da8 --- /dev/null +++ b/src/sherlodoc/type_expr.ml @@ -0,0 +1,137 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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 = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of int + | Wildcard + | Unhandled + +let rec equal a b = + match (a, b) with + | Unhandled, Unhandled | Wildcard, Wildcard -> true + | Tyvar a, Tyvar b -> Int.equal a b + | Tuple a, Tuple b -> List.equal equal a b + | Tycon (ka, a), Tycon (kb, b) -> String.equal ka kb && List.equal equal a b + | Arrow (ia, oa), Arrow (ib, ob) -> equal ia ib && equal oa ob + | Arrow (_, _), _ + | Tycon (_, _), _ + | Tuple _, _ + | Tyvar _, _ + | Wildcard, _ + | Unhandled, _ -> false + +let parens x = "(" ^ x ^ ")" + +let tyvar_to_string x = + let rec aux acc i = + let c = Char.code 'a' + (i mod 26) |> Char.chr in + let acc = acc ^ String.make 1 c in + if i < 26 then acc else aux acc (i - 26) + in + aux "'" x + +let unhandled = "?" + +let rec to_string = function + | Unhandled -> unhandled + | Wildcard -> "_" + | Tyvar i -> tyvar_to_string i + | Tycon (constr, []) -> constr + | Tycon (constr, [ x ]) -> with_parens x ^ " " ^ constr + | Tycon (constr, xs) -> (xs |> as_list "" |> parens) ^ " " ^ constr + | Tuple xs -> as_tuple "" xs + | Arrow (a, b) -> with_parens a ^ " -> " ^ to_string b + +and with_parens = function + | (Arrow _ | Tuple _) as t -> t |> to_string |> parens + | t -> to_string t + +and as_list acc = function + | [] -> acc ^ unhandled + | [ x ] -> acc ^ to_string x + | x :: xs -> + let acc = acc ^ to_string x ^ ", " in + as_list acc xs + +and as_tuple acc = function + | [] -> acc ^ unhandled + | [ x ] -> acc ^ with_parens x + | x :: xs -> + let acc = acc ^ with_parens x ^ " * " in + as_tuple acc xs + +module SMap = Map.Make (String) + +let map_with_state f i map list = + let i, map, r = + list + |> List.fold_left + (fun (i, map, acc) x -> + let i, map, elt = f i map x in + (i, map, elt :: acc)) + (i, map, []) + in + (i, map, List.rev r) + +let normalize_type_parameters ty = + let rec aux i map = function + | Type_parsed.Unhandled -> (i, map, Unhandled) + | Type_parsed.Wildcard -> (i, map, Wildcard) + | Type_parsed.Arrow (a, b) -> + let i, map, a = aux i map a in + let i, map, b = aux i map b in + (i, map, Arrow (a, b)) + | Type_parsed.Tycon (s, r) -> + let i, map, r = map_with_state aux i map r in + (i, map, Tycon (s, r)) + | Type_parsed.Tuple r -> + let i, map, r = map_with_state aux i map r in + (i, map, Tuple r) + | Type_parsed.Tyvar var -> + let i, map, value = + match SMap.find_opt var map with + | Some value -> (i, map, value) + | None -> + let i = succ i in + let map = SMap.add var i map in + (i, map, i) + in + (i, map, Tyvar value) + in + let _, _, normalized = aux ~-1 SMap.empty ty in + normalized + +let from_string str = + try + str |> Lexing.from_string + |> Type_parser.main Type_lexer.token + |> normalize_type_parameters |> Option.some + with _ -> None diff --git a/src/sherlodoc/type_expr.mli b/src/sherlodoc/type_expr.mli new file mode 100644 index 0000000000..4130038974 --- /dev/null +++ b/src/sherlodoc/type_expr.mli @@ -0,0 +1,57 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** A representation of internal types, with superfluous information removed to + make it easier to compare them and calculate their distance. *) + +(** Type variables are indexed by integers calculated according to their + positions. For example, in the expression of type ['a -> 'b -> 'c], + respectively ['a] will have the value [1], ['b] will have the value [2] and + [’c] will have the value [3]. + + This makes ['a -> 'b -> 'c] isomorphic to [’foo -> 'bar -> 'baz]. *) +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of int + | Wildcard + | Unhandled + +(** [normalize_type_parameters ty] replace string based type variables to + integer based type variables. *) +val normalize_type_parameters : Type_parsed.t -> t + +(** Try deserializing a string into a typed expression. *) +val from_string : string -> t option + +(** Render a type to a string. *) +val to_string : t -> string + +(** Equality between types *) +val equal : t -> t -> bool diff --git a/src/sherlodoc/type_lexer.mll b/src/sherlodoc/type_lexer.mll new file mode 100644 index 0000000000..b1c798f22b --- /dev/null +++ b/src/sherlodoc/type_lexer.mll @@ -0,0 +1,15 @@ +{ + open Type_parser +} + +rule token = parse +| ' ' { token lexbuf } +| "->" { ARROW } +| "(" { PARENS_OPEN } +| ")" { PARENS_CLOSE } +| "," { COMMA } +| '_' { WILDCARD } +| '*' { STAR } +| "'" (['a'-'z' 'A'-'Z' '0'-'9' '\'' '_']* as p) { POLY p } +| ['a'-'z' 'A'-'Z' '0'-'9' '\'' '_' '.']+ as w { WORD w } +| eof { EOF } \ No newline at end of file diff --git a/src/sherlodoc/type_parsed.ml b/src/sherlodoc/type_parsed.ml new file mode 100644 index 0000000000..c7166998b6 --- /dev/null +++ b/src/sherlodoc/type_parsed.ml @@ -0,0 +1,40 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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 = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of string + | Wildcard + | Unhandled + +let tuple = function + | [] -> Tycon ("unit", []) + | [ x ] -> x + | xs -> Tuple xs diff --git a/src/sherlodoc/type_parsed.mli b/src/sherlodoc/type_parsed.mli new file mode 100644 index 0000000000..970796f66a --- /dev/null +++ b/src/sherlodoc/type_parsed.mli @@ -0,0 +1,44 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** A parsed type expression representation, where type variables are expressed + as strings and must be normalized in a {!type:Type_expr.t}. *) + +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of string + | Wildcard + | Unhandled + +(** Create a tuple using a rather naive heuristic: + - If the list is empty, it produces a type [unit] + - If the list contains only one element, that element is returned + - Otherwise, a tuple is constructed. *) +val tuple : t list -> t diff --git a/src/sherlodoc/type_parser.mly b/src/sherlodoc/type_parser.mly new file mode 100644 index 0000000000..a3c4a6bc72 --- /dev/null +++ b/src/sherlodoc/type_parser.mly @@ -0,0 +1,52 @@ +%token EOF +%token PARENS_OPEN PARENS_CLOSE +%token ARROW COMMA WILDCARD STAR +%token WORD +%token POLY + +%start main +%type main + +%% + +main: + | t=typ EOF { t } +; + +typ: + | t=typ2 { t } + | a=typ2 ARROW b=typ { Type_parsed.Arrow (a, b) } +; + +typ2: + | xs=list1(typ1, STAR) { Type_parsed.tuple xs } + ; + +typ1: + | { Type_parsed.Wildcard } + | ts=typs { Type_parsed.tuple ts } + | ts=typs w=WORD ws=list(WORD) + { + List.fold_left ( fun acc w -> + Type_parsed.Tycon (w, [acc])) (Type_parsed.Tycon (w, ts)) ws + } +; + +typ0: + | WILDCARD { Type_parsed.Wildcard } + | w=POLY { Type_parsed.Tyvar w } + | w=WORD { Type_parsed.Tycon (w, []) } +; + + +typs: + | t=typ0 { [t] } + | PARENS_OPEN ts=list1(typ, COMMA) PARENS_CLOSE { ts } +; + + +list1(term, separator): + | x=term { [x] } + | x=term separator xs=list1(term, separator) { x::xs } +; + diff --git a/src/sherlodoc/type_polarity.ml b/src/sherlodoc/type_polarity.ml new file mode 100644 index 0000000000..541cbebc33 --- /dev/null +++ b/src/sherlodoc/type_polarity.ml @@ -0,0 +1,48 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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 = Positive | Negative + +let positive = Positive +let negative = Negative + +let negate = function + | Positive -> Negative + | Negative -> Positive + +let to_string = function + | Negative -> "negative" + | Positive -> "positive" + +let compare a b = + match (a, b) with + | Negative, Positive -> -1 + | Positive, Negative -> 1 + | Positive, Positive | Negative, Negative -> 0 + +let equal a b = Int.equal 0 (compare a b) diff --git a/src/sherlodoc/type_polarity.mli b/src/sherlodoc/type_polarity.mli new file mode 100644 index 0000000000..99592b796f --- /dev/null +++ b/src/sherlodoc/type_polarity.mli @@ -0,0 +1,49 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Describes the polarity sign of a type [negative] for contravariant + parameters and [positive] for covariant parameters (the return of the + function). *) + +type t + +val positive : t +val negative : t + +(** [negate x] returns [positive] if [x] is [negative] and [negative] if [x] is + [positive]. *) +val negate : t -> t + +(** Equality between polarity sign. *) +val equal : t -> t -> bool + +(** A comparison that act that [negative < positive]. *) +val compare : t -> t -> int + +(** Simple printer for polarity sign. *) +val to_string : t -> string diff --git a/src/utils/marg.ml b/src/utils/marg.ml index 58ab0ad394..2d4e3a1303 100644 --- a/src/utils/marg.ml +++ b/src/utils/marg.ml @@ -26,6 +26,12 @@ let bool f = failwithf "expecting boolean (%s), got %S." "yes|y|Y|true|1 / no|n|N|false|0" str) +let int f = + param "int" (fun str -> + match int_of_string_opt str with + | None -> failwithf "expecting integer got %S." str + | Some x -> f x) + type docstring = string type 'a spec = string * docstring * 'a t diff --git a/src/utils/marg.mli b/src/utils/marg.mli index f867199694..1aba9a1ac7 100644 --- a/src/utils/marg.mli +++ b/src/utils/marg.mli @@ -25,6 +25,9 @@ val param : string -> (string -> 'acc -> 'acc) -> 'acc t (** Action consuming a boolean argument *) val bool : (bool -> 'acc -> 'acc) -> 'acc t +(** Action consuming an integer argument *) +val int : (int -> 'acc -> 'acc) -> 'acc t + (** Action doing nothing *) val unit_ignore : 'acc t diff --git a/tests/test-dirs/search/dune b/tests/test-dirs/search/dune new file mode 100644 index 0000000000..94800b26f0 --- /dev/null +++ b/tests/test-dirs/search/dune @@ -0,0 +1,4 @@ +(cram + (applies_to :whole_subtree) + (enabled_if + (<> %{os_type} Win32))) diff --git a/tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t b/tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t new file mode 100644 index 0000000000..896bb5486f --- /dev/null +++ b/tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t @@ -0,0 +1,145 @@ + $ cat >main.ml < let f x = succ x + > EOF + +1.) Looking for a function that convert a string to an integer (with +potential failures, so lifting the result in an int option). + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-string +option" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "Dynlink.unsafe_get_global_value", + "desc": "bytecode_or_asm_symbol:string -> Obj.t option" + } + { + "name": "bool_of_string_opt", + "desc": "string -> bool option" + } + { + "name": "bool_of_string_opt", + "desc": "string -> bool option" + } + { + "name": "float_of_string_opt", + "desc": "string -> float option" + } + { + "name": "float_of_string_opt", + "desc": "string -> float option" + } + { + "name": "int_of_string_opt", + "desc": "string -> int option" + } + { + "name": "int_of_string_opt", + "desc": "string -> int option" + } + { + "name": "Stdlib__Float.of_string_opt", + "desc": "string -> float option" + } + { + "name": "Stdlib__Int32.of_string_opt", + "desc": "string -> int32 option" + } + { + "name": "Stdlib__Int64.of_string_opt", + "desc": "string -> int64 option" + } + +2.) Looking for a function that take a list of list of flatten-it into +a list. + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-list +list" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "Stdlib__List.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.cons", + "desc": "'a -> 'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.cons", + "desc": "'a -> 'a list -> 'a list" + } + +3.) Looking for a function that take a list and produce a new list +applying a function on every element for the given list (formerly +map). + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-list -list +list" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "Stdlib__List.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.cons", + "desc": "'a -> 'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.cons", + "desc": "'a -> 'a list -> 'a list" + } diff --git a/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t new file mode 100644 index 0000000000..d59fc66539 --- /dev/null +++ b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t @@ -0,0 +1,242 @@ + $ cat >main.ml < let f x = succ x + > EOF + +1.) Looking for a function that convert a string to an integer (with +potential failures, so lifting the result in an int option). + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "string -> int option" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "int_of_string_opt", + "type": "string -> int option" + } + { + "name": "int_of_string_opt", + "type": "string -> int option" + } + { + "name": "Pervasives.int_of_string_opt", + "type": "string -> int option" + } + { + "name": "Int32.of_string_opt", + "type": "string -> int32 option" + } + { + "name": "Int64.of_string_opt", + "type": "string -> int64 option" + } + { + "name": "Sys.getenv_opt", + "type": "string -> string option" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option" + } + { + "name": "Float.of_string_opt", + "type": "string -> float option" + } + { + "name": "float_of_string_opt", + "type": "string -> float option" + } + +2.) Looking for a function that take a list of list of flatten-it into +a list. + + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "'a list list -> 'a list" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "List.concat", + "type": "'a list list -> 'a list" + } + { + "name": "List.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "ListLabels.concat", + "type": "'a list list -> 'a list" + } + { + "name": "ListLabels.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "Array.concat", + "type": "'a array list -> 'a array" + } + { + "name": "ArrayLabels.concat", + "type": "'a array list -> 'a array" + } + { + "name": "Seq.concat", + "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t" + } + { + "name": "Option.join", + "type": "'a option option -> 'a option" + } + { + "name": "Seq.transpose", + "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t" + } + { + "name": "Result.join", + "type": "(('a, 'e) result, 'e) result -> ('a, 'e) result" + } + +3.) Looking for a function that take a list and produce a new list +applying a function on every element for the given list (formerly +map). + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "'a list -> ('a -> 'b) -> 'b list" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "List.map", + "type": "('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "List.rev_map", + "type": "('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "ListLabels.map", + "type": "f:('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "ListLabels.rev_map", + "type": "f:('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "List.mapi", + "type": "(int -> 'a -> 'b) -> 'a list -> 'b list" + } + { + "name": "ListLabels.mapi", + "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Seq.map", + "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t" + } + { + "name": "List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list" + } + { + "name": "List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list" + } + { + "name": "ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list" + } + + +4.) Looking for a function that take a list of list of flatten-it into +a list. + + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "'a list list -> 'a list" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "List.concat", + "type": "'a list list -> 'a list" + } + { + "name": "List.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "ListLabels.concat", + "type": "'a list list -> 'a list" + } + { + "name": "ListLabels.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "Array.concat", + "type": "'a array list -> 'a array" + } + { + "name": "ArrayLabels.concat", + "type": "'a array list -> 'a array" + } + { + "name": "Seq.concat", + "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t" + } + { + "name": "Option.join", + "type": "'a option option -> 'a option" + } + { + "name": "Seq.transpose", + "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t" + } + { + "name": "Result.join", + "type": "(('a, 'e) result, 'e) result -> ('a, 'e) result" + } + +5.) Using polarity query inside search by type (result are a bit +different because type path are a little bit different) + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "-list -list +list" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "List.tl", + "type": "'a list -> 'a list" + } + { + "name": "List.rev", + "type": "'a list -> 'a list" + } + { + "name": "ListLabels.tl", + "type": "'a list -> 'a list" + } + { + "name": "ListLabels.rev", + "type": "'a list -> 'a list" + } + { + "name": "List.concat", + "type": "'a list list -> 'a list" + } + { + "name": "List.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "ListLabels.concat", + "type": "'a list list -> 'a list" + } + { + "name": "ListLabels.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "List.cons", + "type": "'a -> 'a list -> 'a list" + } + { + "name": "ListLabels.cons", + "type": "'a -> 'a list -> 'a list" + } diff --git a/tests/test-dirs/search/search-by-type.t/context.ml b/tests/test-dirs/search/search-by-type.t/context.ml new file mode 100644 index 0000000000..306831a004 --- /dev/null +++ b/tests/test-dirs/search/search-by-type.t/context.ml @@ -0,0 +1 @@ +let () = () diff --git a/tests/test-dirs/search/search-by-type.t/run.t b/tests/test-dirs/search/search-by-type.t/run.t new file mode 100644 index 0000000000..3f8f2b1e5e --- /dev/null +++ b/tests/test-dirs/search/search-by-type.t/run.t @@ -0,0 +1,365 @@ + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -query "string -> int option" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "Pervasives.int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "Int32.of_string_opt", + "type": "string -> int32 option", + "cost": 2, + "doc": null + } + { + "name": "Int64.of_string_opt", + "type": "string -> int64 option", + "cost": 2, + "doc": null + } + { + "name": "Sys.getenv_opt", + "type": "string -> string option", + "cost": 4, + "doc": null + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": null + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": null + } + { + "name": "Float.of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": null + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": null + } + + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -query "('a -> 'b) -> 'a list -> 'b list" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' + { + "name": "List.map", + "type": "('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "List.rev_map", + "type": "('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "ListLabels.map", + "type": "f:('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "ListLabels.rev_map", + "type": "f:('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "List.mapi", + "type": "(int -> 'a -> 'b) -> 'a list -> 'b list", + "cost": 5, + "doc": null + } + { + "name": "ListLabels.mapi", + "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list", + "cost": 5, + "doc": null + } + { + "name": "Seq.map", + "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t", + "cost": 10, + "doc": null + } + { + "name": "List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list", + "cost": 10, + "doc": null + } + { + "name": "List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list", + "cost": 10, + "doc": null + } + { + "name": "ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list", + "cost": 10, + "doc": null + } + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 \ + > -query "Hashtbl : ('f, 'g) Hashtbl.t -> 'f -> 'g -> unit" + { + "class": "return", + "value": [ + { + "file": "hashtbl.mli", + "start": { + "line": 82, + "col": 0 + }, + "end": { + "line": 82, + "col": 40 + }, + "name": "Hashtbl.add", + "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "cost": 1, + "doc": null, + "constructible": "Hashtbl.add _ _ _" + }, + { + "file": "hashtbl.mli", + "start": { + "line": 113, + "col": 0 + }, + "end": { + "line": 113, + "col": 44 + }, + "name": "Hashtbl.replace", + "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "cost": 2, + "doc": null, + "constructible": "Hashtbl.replace _ _ _" + }, + { + "file": "hashtbl.mli", + "start": { + "line": 262, + "col": 0 + }, + "end": { + "line": 262, + "col": 50 + }, + "name": "Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 24, + "doc": null, + "constructible": "Hashtbl.add_seq _ _" + }, + { + "file": "hashtbl.mli", + "start": { + "line": 266, + "col": 0 + }, + "end": { + "line": 266, + "col": 54 + }, + "name": "Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 25, + "doc": null, + "constructible": "Hashtbl.replace_seq _ _" + }, + { + "file": "either.mli", + "start": { + "line": 86, + "col": 0 + }, + "end": { + "line": 87, + "col": 73 + }, + "name": "Either.map", + "type": "left:('a1 -> 'a2) -> + right:('b1 -> 'b2) -> + ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", + "cost": 44, + "doc": null, + "constructible": "Either.map ~left:_ ~right:_ _" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 99, + "col": 2 + }, + "end": { + "line": 99, + "col": 51 + }, + "name": "MoreLabels.Hashtbl.add", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "cost": 47, + "doc": null, + "constructible": "MoreLabels.Hashtbl.add _ ~key:_ ~data:_" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 279, + "col": 2 + }, + "end": { + "line": 279, + "col": 52 + }, + "name": "MoreLabels.Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 48, + "doc": null, + "constructible": "MoreLabels.Hashtbl.add_seq _ _" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 130, + "col": 2 + }, + "end": { + "line": 130, + "col": 55 + }, + "name": "MoreLabels.Hashtbl.replace", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "cost": 48, + "doc": null, + "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 283, + "col": 2 + }, + "end": { + "line": 283, + "col": 56 + }, + "name": "MoreLabels.Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 49, + "doc": null, + "constructible": "MoreLabels.Hashtbl.replace_seq _ _" + }, + { + "file": "ephemeron.mli", + "start": { + "line": 388, + "col": 2 + }, + "end": { + "line": 388, + "col": 55 + }, + "name": "Ephemeron.K2.query", + "type": "('k1, 'k2, 'd) Stdlib__Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", + "cost": 53, + "doc": null, + "constructible": "Ephemeron.K2.query _ _ _" + } + ], + "notifications": [] + } + + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -with-doc true -query "string -> int option" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": "Convert the given string to an integer. The string is read in decimal (by default, or if the string begins with [0u]), in hexadecimal (if it begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), or in binary (if it begins with [0b] or [0B]). The [0u] prefix reads the input as an unsigned integer in the range [[0, 2*max_int+1]]. If the input exceeds {!max_int} it is converted to the signed integer [min_int + input - max_int - 1]. The [_] (underscore) character can appear anywhere in the string and is ignored. Return [None] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int]. @since 4.05" + } + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": "Convert the given string to an integer. The string is read in decimal (by default, or if the string begins with [0u]), in hexadecimal (if it begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), or in binary (if it begins with [0b] or [0B]). The [0u] prefix reads the input as an unsigned integer in the range [[0, 2*max_int+1]]. If the input exceeds {!max_int} it is converted to the signed integer [min_int + input - max_int - 1]. The [_] (underscore) character can appear anywhere in the string and is ignored. Return [None] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int]. @since 4.05" + } + { + "name": "Pervasives.int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "Int32.of_string_opt", + "type": "string -> int32 option", + "cost": 2, + "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" + } + { + "name": "Int64.of_string_opt", + "type": "string -> int64 option", + "cost": 2, + "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" + } + { + "name": "Sys.getenv_opt", + "type": "string -> string option", + "cost": 4, + "doc": "Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" + } + { + "name": "Float.of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": "Same as [of_string], but returns [None] instead of raising." + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" + } diff --git a/tests/test-units/sherldoc/dune b/tests/test-units/sherldoc/dune new file mode 100644 index 0000000000..f84c9d6d2c --- /dev/null +++ b/tests/test-units/sherldoc/dune @@ -0,0 +1,3 @@ +(test + (name sherlodoc_test) + (libraries fmt alcotest merlin-lib.sherlodoc)) diff --git a/tests/test-units/sherldoc/name_cost_test.ml b/tests/test-units/sherldoc/name_cost_test.ml new file mode 100644 index 0000000000..8d9befbb15 --- /dev/null +++ b/tests/test-units/sherldoc/name_cost_test.ml @@ -0,0 +1,124 @@ +open Merlin_sherlodoc + +let test_distance_1 = + let open Alcotest in + test_case "test distance - 1" `Quick (fun () -> + let expected = List.map Option.some [ 0; 1; 1; 1; 1; 2; 2; 2; 2 ] + and computed = + List.map + (Name_cost.distance "decode") + [ "decode"; + "decade"; + "decede"; + "decide"; + "recode"; + "bbcode"; + "become"; + "code"; + "derobe" + ] + in + check (list @@ option int) "should be equal" expected computed) + +let test_distance_2 = + let open Alcotest in + test_case "test distance - 2" `Quick (fun () -> + let expected = Some 1 + and computed = Name_cost.distance "Foo.Bar.Baz" "Foo_Bar.Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_3 = + let open Alcotest in + test_case "test distance - 3" `Quick (fun () -> + let expected = Some 2 + and computed = Name_cost.distance "Ltw_mutex" "Lwt_mutex" in + check (option int) "should be equal" expected computed) + +let test_distance_4 = + let open Alcotest in + test_case "test distance - 4" `Quick (fun () -> + let expected = Some 4 + and computed = Name_cost.distance "Foo_Bar_Baz" "Bar_Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_5 = + let open Alcotest in + test_case "test distance - 5" `Quick (fun () -> + let expected = None + and computed = + Name_cost.distance ~cutoff:16 "Ocaml_typing.Misc.f" "Bar_Baz" + in + check (option int) "should be equal" expected computed) + +let test_distance_substring_1 = + let open Alcotest in + test_case "test distance_substring - 1" `Quick (fun () -> + let expected = Some 2 + and computed = Name_cost.distance_of_substring "Foo" "Bar.Foo.Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_substring_2 = + let open Alcotest in + test_case "test distance_substring - 2" `Quick (fun () -> + let expected = Some 5 + and computed = Name_cost.distance_of_substring "Foo" "Bar.oFo.Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_substring_3 = + let open Alcotest in + test_case "test distance_substring - 3" `Quick (fun () -> + let expected = Some 0 + and computed = Name_cost.distance_of_substring "Foo" "Foo" in + check (option int) "should be equal" expected computed) + +let test_distance_substring_4 = + let open Alcotest in + test_case "test distance_substring - 4" `Quick (fun () -> + let expected = Some 4 + and computed = Name_cost.distance_of_substring "Foo" "Hashtblk" in + check (option int) "should be equal" expected computed) + +let test_best_distance_1 = + let open Alcotest in + test_case "test bast distance - 1" `Quick (fun () -> + let expected = 2 + and computed = + Name_cost.best_distance [ "bz"; "dddd"; "Foo" ] "Bar.Foo.Baz" + in + check int "should be equal" expected computed) + +let test_best_distance_2 = + let open Alcotest in + test_case "test bast distance - 2" `Quick (fun () -> + let expected = 4 + and computed = + Name_cost.best_distance [ "bz"; "dddd"; "oFo" ] "Bar.Foo.Baz" + in + check int "should be equal" expected computed) + +let test_best_distance_3 = + let open Alcotest in + test_case "test bast distance - 3" `Quick (fun () -> + let expected = 5 + and computed = + Name_cost.best_distance + [ "bsadsadz"; "dddd"; "moduleHassh" ] + "Bar.Foo.Baz" + in + check int "should be equal" expected computed) + +let cases = + ( "name_cost", + [ test_distance_1; + test_distance_2; + test_distance_3; + test_distance_4; + test_distance_5; + test_distance_substring_1; + test_distance_substring_2; + test_distance_substring_3; + test_distance_substring_4; + test_best_distance_1; + test_best_distance_2; + test_best_distance_3 + ] ) diff --git a/tests/test-units/sherldoc/name_cost_test.mli b/tests/test-units/sherldoc/name_cost_test.mli new file mode 100644 index 0000000000..bf105b099b --- /dev/null +++ b/tests/test-units/sherldoc/name_cost_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list diff --git a/tests/test-units/sherldoc/query_test.ml b/tests/test-units/sherldoc/query_test.ml new file mode 100644 index 0000000000..37be9f4e2b --- /dev/null +++ b/tests/test-units/sherldoc/query_test.ml @@ -0,0 +1,125 @@ +open Merlin_sherlodoc + +let test_distance_1 = + let open Alcotest in + test_case "test distance from a query - 1" `Quick (fun () -> + let query = "List.map" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 0 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_2 = + let open Alcotest in + test_case "test distance from a query - 2" `Quick (fun () -> + let query = "List.map : ('f -> 'g) -> 'f list -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 0 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_3 = + let open Alcotest in + test_case "test distance from a query - 3" `Quick (fun () -> + let query = "('f -> 'g) -> 'f list -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 0 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_4 = + let open Alcotest in + test_case "test distance from a query - 4" `Quick (fun () -> + let query = "map : ('f -> 'g) -> 'f list -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_5 = + let open Alcotest in + test_case "test distance from a query - 5" `Quick (fun () -> + let query = "map : 'f list -> ('f -> 'g) -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_6 = + let open Alcotest in + test_case "test distance from a query - 6" `Quick (fun () -> + let query = "map : 'f list * ('f -> 'g) -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 4 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_7 = + let open Alcotest in + test_case "test distance from a query - 7" `Quick (fun () -> + let query = "List : 'f list -> ('f -> 'g) -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_8 = + let open Alcotest in + test_case "test distance from a query - 8" `Quick (fun () -> + let query = "string -> int option" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1000 + and computed = + Query.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let cases = + ( "query-parser", + [ test_distance_1; + test_distance_2; + test_distance_3; + test_distance_4; + test_distance_5; + test_distance_6; + test_distance_7; + test_distance_8 + ] ) diff --git a/tests/test-units/sherldoc/query_test.mli b/tests/test-units/sherldoc/query_test.mli new file mode 100644 index 0000000000..bf105b099b --- /dev/null +++ b/tests/test-units/sherldoc/query_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list diff --git a/tests/test-units/sherldoc/sherlodoc_test.ml b/tests/test-units/sherldoc/sherlodoc_test.ml new file mode 100644 index 0000000000..d58b10d9f2 --- /dev/null +++ b/tests/test-units/sherldoc/sherlodoc_test.ml @@ -0,0 +1,7 @@ +let () = + Alcotest.run "merlin-lib.sherlodoc" + [ Type_expr_test.cases; + Name_cost_test.cases; + Type_distance_test.cases; + Query_test.cases + ] diff --git a/tests/test-units/sherldoc/type_distance_test.ml b/tests/test-units/sherldoc/type_distance_test.ml new file mode 100644 index 0000000000..2b47070929 --- /dev/null +++ b/tests/test-units/sherldoc/type_distance_test.ml @@ -0,0 +1,44 @@ +open Merlin_sherlodoc + +let expected_distance query entry expected = + let open Alcotest in + test_case + ("distance between `" ^ query ^ "` and `" ^ entry ^ "`") + `Quick + (fun () -> + let query = query |> Type_expr.from_string |> Option.get in + let entry = entry |> Type_expr.from_string |> Option.get in + let computed = Type_distance.compute ~query ~entry in + check int + ("distance should be " ^ string_of_int expected) + expected computed) + +let cases = + ( "type_distance", + [ expected_distance "int" "int" 0; + expected_distance "string" "string" 0; + expected_distance "string -> int" "string -> int" 0; + expected_distance "string -> int -> float" "string -> int -> float" 0; + expected_distance "int -> srting -> float" "int -> string -> float" 2; + expected_distance "('a -> 'b) -> 'a list -> 'b list" + "('a -> 'b) -> 'a list -> 'b list" 0; + expected_distance "('foo -> 'bar) -> 'foo list -> 'bar list" + "('a -> 'b) -> 'a list -> 'b list" 0; + expected_distance "'foo list -> ('foo -> 'bar) -> 'bar list" + "('a -> 'b) -> 'a list -> 'b list" 0; + expected_distance "foo -> bar -> baz" "int -> string" 1000; + expected_distance "('a -> 'b) * 'a list -> 'b list" + "('a -> 'b) -> 'a list -> 'b list" 3; + expected_distance "'a * 'b -> 'b" "'a * 'b -> 'a" 1; + expected_distance "'a * 'b -> 'a" "'a * 'b -> 'a" 0; + expected_distance + "'a -> 'b -> 'b -> 'a -> 'b -> 'c -> int -> string -> Bar.t -> 'b \ + option" + "'foo -> 'bar -> 'bar -> 'foo -> 'bar -> 'baz -> foo -> Bar.t -> int \ + -> 'bar option" + 6; + expected_distance "('a -> 'a) -> 'a list -> 'a list" + "('a -> 'b) -> 'a list -> 'b list" 2; + expected_distance "'a -> 'b option -> 'a option" + "'b option -> 'a -> 'a option" 3 + ] ) diff --git a/tests/test-units/sherldoc/type_distance_test.mli b/tests/test-units/sherldoc/type_distance_test.mli new file mode 100644 index 0000000000..bf105b099b --- /dev/null +++ b/tests/test-units/sherldoc/type_distance_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list diff --git a/tests/test-units/sherldoc/type_expr_test.ml b/tests/test-units/sherldoc/type_expr_test.ml new file mode 100644 index 0000000000..7034a802a6 --- /dev/null +++ b/tests/test-units/sherldoc/type_expr_test.ml @@ -0,0 +1,145 @@ +open Merlin_sherlodoc + +let type_testable = + let pp ppf x = Format.fprintf ppf "%s" (Type_expr.to_string x) in + Alcotest.testable pp Type_expr.equal + +let test_parse_simple_type_1 = + let open Alcotest in + test_case "parse a simple type expression - 1" `Quick (fun () -> + let expected = Some Type_expr.(Tycon ("int", [])) + and computed = Type_expr.from_string "int" in + check (option type_testable) "should be an integer" expected computed) + +let test_parse_simple_type_2 = + let open Alcotest in + test_case "parse a simple type expression - 2" `Quick (fun () -> + let expected = Some Type_expr.(Tycon ("Result.t", [ Tyvar 0; Tyvar 1 ])) + and computed = Type_expr.from_string "('foo, 'bar) Result.t" in + check (option type_testable) "should be a result" expected computed) + +let test_parse_simple_type_3 = + let open Alcotest in + test_case "parse a simple type expression - 3" `Quick (fun () -> + let expected = + Some + Type_expr.( + Arrow + ( Arrow (Tyvar 0, Tyvar 1), + Arrow (Tycon ("list", [ Tyvar 0 ]), Tycon ("list", [ Tyvar 1 ])) + )) + and computed = Type_expr.from_string "('a -> 'b) -> 'a list -> 'b list" in + check (option type_testable) "should be the map function" expected + computed) + +let test_parse_simple_type_4 = + let open Alcotest in + test_case "parse a simple type expression - 4" `Quick (fun () -> + let expected = Some Type_expr.(Arrow (Wildcard, Tycon ("Foo.bar", []))) + and computed = Type_expr.from_string "_ -> Foo.bar" in + check (option type_testable) "should be a simple query" expected computed) + +let test_simple_isomorphismic_poly_function_1 = + let open Alcotest in + test_case + "ensure that function equivalent function are parsed as the same function \ + - 1" + `Quick (fun () -> + let expected = Type_expr.from_string "('a -> 'b) -> 'a list -> 'b list" + and computed = + Type_expr.from_string "('foo -> 'bar) -> 'foo list -> 'bar list" + in + check (option type_testable) "should be equal" expected computed) + +let test_poly_identifier_1 = + let open Alcotest in + test_case "recompute type variables - 1" `Quick (fun () -> + let expected = + Some + "'a -> 'b -> 'a -> 'c -> 'd -> int -> ('a * 'c * string * 'b * 'c * \ + ('a, 'b) result) -> 'd t" + and computed = + "'foo -> 'bar -> 'foo -> 'baz -> 'rk -> int -> 'foo * 'baz * string * \ + 'bar * 'baz * ('foo, 'bar) result -> 'rk t" |> Type_expr.from_string + |> Option.map Type_expr.to_string + in + check (option string) "should be equal" expected computed) + +let test_long_poly_identifier_1 = + let open Alcotest in + test_case "check polymorphic variable identifier generation - 1" `Quick + (fun () -> + let expected = + Some + "'a -> 'b -> 'c -> 'b -> 'c -> 'c -> 'b -> 'd -> 'e -> 'f -> 'g -> \ + 'h -> 'i -> 'j -> int -> float -> 'k -> 'l -> 'm -> 'n -> 'o -> 'p \ + -> 'q -> 'r option -> 'b -> 's -> 't -> 'u -> 'a Option.t -> ('b, \ + 'c) Result.t -> 'a -> 'r -> 'v -> 'd -> 'e -> 'w -> 'f -> 'g -> 'x \ + -> 'y -> 'z -> 'aa -> 'bb -> 'cc -> 'dd -> 'ee -> 'ff -> 'gg -> 'hh \ + -> 'ii -> 'jj -> 'kk -> 'll -> 'mm -> 'nn -> 'oo -> 'pp -> 'qq -> \ + 'rr -> 'ss -> 'tt -> 'uu -> 'vv -> 'ww -> 'xx -> 'yy -> 'zz -> 'aaa \ + -> 'bbb -> 'ccc -> 'ddd -> 'eee -> 'fff -> 'ggg -> 'hhh -> 'k -> \ + 'iii -> 'jjj -> 'kkk -> 'lll -> 'mmm -> 'nnn -> 'ooo -> 'ppp -> \ + 'qqq -> 'rrr -> 'n -> 'sss -> 'ttt -> 'uuu -> 'vvv -> 'www -> 'o -> \ + 'xxx -> 'yyy -> 'zzz -> 'aaaa -> 'bbbb -> 'cccc -> 'dddd -> 'eeee \ + -> 'l -> 'ffff -> 'gggg -> 'hhhh -> 'iiii -> 'jjjj -> 'kkkk -> \ + 'llll -> 'mmmm -> 'nnnn -> 'oooo -> 'pppp -> 'p -> 'qqqq -> 'rrrr \ + -> 'ssss -> 'tttt -> 'uuuu -> 'vvvv -> 'wwww -> 'xxxx -> 'yyyy -> \ + 'zzzz -> 'aaaaa -> 'bbbbb -> 'ccccc -> 'm -> 'ddddd -> 'eeeee -> \ + 'fffff -> 'ggggg -> 'hhhhh -> 'iiiii -> 'jjjjj -> 'kkkkk -> 'lllll \ + -> 'mmmmm -> 'nnnnn -> 'ooooo -> 'ppppp -> 'qqqqq -> 'rrrrr -> \ + 'sssss -> 'ttttt -> 'uuuuu -> 'vvvvv -> 'wwwww -> 'xxxxx -> 'yyyyy \ + -> 'zzzzz -> 'aaaaaa -> 'bbbbbb -> 'cccccc -> 'dddddd -> 'eeeeee -> \ + 'ffffff -> 'gggggg -> 'hhhhhh -> 'iiiiii -> 'jjjjjj -> 'kkkkkk -> \ + 'llllll -> 'mmmmmm -> 'nnnnnn -> 'oooooo -> 'pppppp -> 'qqqqqq -> \ + 'rrrrrr -> 'ssssss -> 'tttttt -> 'uuuuuu -> 'vvvvvv -> 'wwwwww -> \ + 'xxxxxx -> 'yyyyyy -> 'zzzzzz -> 'aaaaaaa -> 'bbbbbbb -> 'ccccccc \ + -> 'ddddddd -> 'eeeeeee -> 'fffffff -> 'ggggggg -> 'hhhhhhh -> \ + 'iiiiiii -> 'jjjjjjj -> 'kkkkkkk -> 'lllllll -> 'mmmmmmm -> \ + 'nnnnnnn -> 'ooooooo -> 'ppppppp -> 'qqqqqqq -> 'rrrrrrr -> \ + 'sssssss -> 'ttttttt -> 'uuuuuuu -> 'vvvvvvv -> 'wwwwwww -> \ + 'xxxxxxx -> 'yyyyyyy -> 'zzzzzzz -> 'aaaaaaaa -> 'bbbbbbbb -> \ + 'cccccccc -> 'dddddddd -> 'eeeeeeee -> 'ffffffff -> 'gggggggg -> 'g" + and computed = + "'a -> 'foo -> 'bar -> 'foo -> 'bar -> 'bar -> 'foo -> 'd -> 'e -> 'g \ + -> 'h -> 't1 -> 't3 -> 't4 -> int -> float -> 'tt -> 'ttt -> 'tttt -> \ + 'eee -> 'kkk -> 'ffff -> 'aq -> 'b option -> 'foo -> 'aaaaaaaa -> 'f2 \ + -> 'f3 -> 'a Option.t -> ('foo, 'bar) Result.t -> 'a -> 'b -> 'c -> \ + 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k -> 'l -> 'm -> 'n -> 'o \ + -> 'p -> 'q -> 'r -> 's -> 't -> 'u -> 'v -> 'w -> 'x -> 'y -> 'z -> \ + 'aa -> 'bb -> 'cc -> 'dd -> 'ee -> 'ff -> 'gg -> 'hh -> 'ii -> 'jj -> \ + 'kk -> 'll -> 'mm -> 'nn -> 'oo -> 'pp -> 'qq -> 'rr -> 'ss -> 'tt -> \ + 'uu -> 'vv -> 'ww -> 'xx -> 'yy -> 'zz -> 'aaa -> 'bbb -> 'ccc -> \ + 'ddd -> 'eee -> 'fff -> 'ggg -> 'hhh -> 'iii -> 'jjj -> 'kkk -> 'lll \ + -> 'mmm -> 'nnn -> 'ooo -> 'ppp -> 'qqq -> 'rrr -> 'sss -> 'ttt -> \ + 'uuu -> 'vvv -> 'www -> 'xxx -> 'yyy -> 'zzz -> 'aaaa -> 'bbbb -> \ + 'cccc -> 'dddd -> 'eeee -> 'ffff -> 'gggg -> 'hhhh -> 'iiii -> 'jjjj \ + -> 'kkkk -> 'llll -> 'mmmm -> 'nnnn -> 'oooo -> 'pppp -> 'qqqq -> \ + 'rrrr -> 'ssss -> 'tttt -> 'uuuu -> 'vvvv -> 'wwww -> 'xxxx -> 'yyyy \ + -> 'zzzz -> 'aaaaa -> 'bbbbb -> 'ccccc -> 'ddddd -> 'eeeee -> 'fffff \ + -> 'ggggg -> 'hhhhh -> 'iiiii -> 'jjjjj -> 'kkkkk -> 'lllll -> 'mmmmm \ + -> 'nnnnn -> 'ooooo -> 'ppppp -> 'qqqqq -> 'rrrrr -> 'sssss -> 'ttttt \ + -> 'uuuuu -> 'vvvvv -> 'wwwww -> 'xxxxx -> 'yyyyy -> 'zzzzz -> \ + 'aaaaaa -> 'bbbbbb -> 'cccccc -> 'dddddd -> 'eeeeee -> 'ffffff -> \ + 'gggggg -> 'hhhhhh -> 'iiiiii -> 'jjjjjj -> 'kkkkkk -> 'llllll -> \ + 'mmmmmm -> 'nnnnnn -> 'oooooo -> 'pppppp -> 'qqqqqq -> 'rrrrrr -> \ + 'ssssss -> 'tttttt -> 'uuuuuu -> 'vvvvvv -> 'wwwwww -> 'xxxxxx -> \ + 'yyyyyy -> 'zzzzzz -> 'aaaaaaa -> 'bbbbbbb -> 'ccccccc -> 'ddddddd -> \ + 'eeeeeee -> 'fffffff -> 'ggggggg -> 'hhhhhhh -> 'iiiiiii -> 'jjjjjjj \ + -> 'kkkkkkk -> 'lllllll -> 'mmmmmmm -> 'nnnnnnn -> 'ooooooo -> \ + 'ppppppp -> 'qqqqqqq -> 'rrrrrrr -> 'sssssss -> 'ttttttt -> 'uuuuuuu \ + -> 'vvvvvvv -> 'wwwwwww -> 'xxxxxxx -> 'h" |> Type_expr.from_string + |> Option.map Type_expr.to_string + in + check (option string) "should be equal" expected computed) + +let cases = + ( "type_expr", + [ test_parse_simple_type_1; + test_parse_simple_type_2; + test_parse_simple_type_3; + test_parse_simple_type_4; + test_simple_isomorphismic_poly_function_1; + test_poly_identifier_1; + test_long_poly_identifier_1 + ] ) diff --git a/tests/test-units/sherldoc/type_expr_test.mli b/tests/test-units/sherldoc/type_expr_test.mli new file mode 100644 index 0000000000..bf105b099b --- /dev/null +++ b/tests/test-units/sherldoc/type_expr_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list From eaa241d3ce90ade01eb7397df0c012b8b6c59f99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 16:05:05 +0200 Subject: [PATCH 26/42] Promote fixed test after Dune upgrade --- .../test-dirs/locate/in-implicit-trans-dep.t/run.t | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t b/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t index d844c52eb1..57e61ef5dc 100644 --- a/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t +++ b/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t @@ -1,12 +1,17 @@ $ dune build @check -FIXME: When the deifinition is in one of the implicit transitive dependencies -Merlin does not found the file in the source path provided by Dune. One possible -fix would be for Dune to provide additional source path for "externatl" deps. +When the deifinition is in one of the implicit transitive dependencies Merlin +used to not find the file in the source path provided by Dune. $ $MERLIN single locate -look-for ml -position 1:15 \ > -filename bin/main.ml Date: Wed, 25 Sep 2024 16:06:20 +0200 Subject: [PATCH 27/42] Silence ld warnings in tests --- tests/test-dirs/expand_node/ppx-tests.t/run.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-dirs/expand_node/ppx-tests.t/run.t b/tests/test-dirs/expand_node/ppx-tests.t/run.t index 848f9a8c1e..5d7470b2b5 100644 --- a/tests/test-dirs/expand_node/ppx-tests.t/run.t +++ b/tests/test-dirs/expand_node/ppx-tests.t/run.t @@ -16,7 +16,7 @@ Type declaration in structure > end > EOF - $ dune build + $ dune build 2>/dev/null on module name "MyModule" $ $MERLIN single expand-ppx -position 1:11 -filename ./apt.ml < ./apt.ml From 78d96eeebc28aa5fd179d99bcb81385344116ea3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 17:12:35 +0200 Subject: [PATCH 28/42] Enable github CI --- .github/workflows/main.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 13122b8a88..10f7ba7736 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -6,7 +6,7 @@ name: CI # events but only for the master branch on: push: - branches: [ master ] + branches: [ '414' ] paths-ignore: - '**.md' - '**.txt' @@ -16,7 +16,7 @@ on: - 'vim/**' - '**/emacs-lint.yml' pull_request: - branches: [ master ] + branches: [ '414' ] paths-ignore: - '**.md' - '**.txt' @@ -38,7 +38,6 @@ jobs: os: - macos-latest - ubuntu-latest - - windows-latest ocaml-compiler: - 4.14.x # The type of runner that the job will run on From 59a67b4814c4b325ae548535a683a2076ee31298 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 17:18:31 +0200 Subject: [PATCH 29/42] [B] #1839 Fix ignorance of SOURCE_ROOT directive --- src/dot-merlin/dot_merlin_reader.ml | 3 +++ tests/test-dirs/config/dot-merlin-reader/load-config.t | 5 +++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e219bbf22b..ba889fe8e6 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -457,6 +457,9 @@ let postprocess cfg = cfg.stdlib |> Option.map ~f:(fun stdlib -> `STDLIB stdlib) |> Option.to_list; + cfg.source_root + |> Option.map ~f:(fun source_root -> `SOURCE_ROOT source_root) + |> Option.to_list; List.concat_map pkg_paths ~f:(fun p -> [ `B p; `S p ]); ppx; List.map failures ~f:(fun s -> `ERROR_MSG s) diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t index cd3b50f634..b765ff4fe7 100644 --- a/tests/test-dirs/config/dot-merlin-reader/load-config.t +++ b/tests/test-dirs/config/dot-merlin-reader/load-config.t @@ -6,12 +6,13 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59 > BH build-hidden/dir > SH source-hidden/dir > STDLIB /stdlib + > SOURCE_ROOT /root > EOF $ FILE=$(pwd)/test.ml; dot-merlin-reader < (4:File${#FILE}:$FILE) > EOF - ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:ERROR?:Unknown tag in .merlin?: BH)(?:ERROR?:Unknown tag in .merlin?: SH)(?:STDLIB?:/stdlib)) + ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:ERROR?:Unknown tag in .merlin?: BH)(?:ERROR?:Unknown tag in .merlin?: SH)(?:STDLIB?:/stdlib)(?:SOURCE_ROOT?:/root)) $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin' { @@ -36,7 +37,7 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59 } ], "stdlib": "/stdlib", - "source_root": null, + "source_root": "/root", "unit_name": null, "wrapping_prefix": null, "reader": [], From 16e46baa972fde08285487d5743399400ca19f73 Mon Sep 17 00:00:00 2001 From: Patrick Nicodemus Date: Wed, 25 Sep 2024 17:27:25 +0200 Subject: [PATCH 30/42] Make deps explicit --- src/analysis/dune | 3 ++- src/frontend/dune | 4 +++- src/frontend/ocamlmerlin/dune | 2 +- src/kernel/dune | 2 +- 4 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/analysis/dune b/src/analysis/dune index 97924c241b..5cda723852 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -22,4 +22,5 @@ ocaml_preprocess query_protocol ocaml_typing - ocaml_utils)) + ocaml_utils + str)) diff --git a/src/frontend/dune b/src/frontend/dune index ac51d30fbf..5f9a2207fa 100644 --- a/src/frontend/dune +++ b/src/frontend/dune @@ -23,6 +23,7 @@ (libraries merlin_utils merlin_kernel + merlin_extend ocaml_utils ocaml_parsing ocaml_typing @@ -30,4 +31,5 @@ merlin_config merlin_analysis merlin_sherlodoc - query_protocol)) + query_protocol + str)) diff --git a/src/frontend/ocamlmerlin/dune b/src/frontend/ocamlmerlin/dune index 409c71c0c2..c3ff186a51 100644 --- a/src/frontend/ocamlmerlin/dune +++ b/src/frontend/ocamlmerlin/dune @@ -18,7 +18,7 @@ (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 merlin-lib.commands)) + merlin-lib.ocaml_typing merlin-lib.ocaml_utils merlin-lib.commands unix)) (executable (name gen_ccflags) diff --git a/src/kernel/dune b/src/kernel/dune index af69229174..2aa7c05768 100644 --- a/src/kernel/dune +++ b/src/kernel/dune @@ -14,7 +14,7 @@ -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)) + merlin_extend merlin_specific merlin_utils merlin_dot_protocol str unix)) (rule (targets standard_library.ml) From e7ed700b83d5362d14001ef1ac92cc4d35270e8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 26 Sep 2024 18:14:21 +0200 Subject: [PATCH 31/42] [B] #1841 Document missing commands in PROTOCOL.md --- doc/dev/PROTOCOL.md | 148 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 133 insertions(+), 15 deletions(-) diff --git a/doc/dev/PROTOCOL.md b/doc/dev/PROTOCOL.md index 16fac57f0b..7e84bcd7e1 100644 --- a/doc/dev/PROTOCOL.md +++ b/doc/dev/PROTOCOL.md @@ -388,11 +388,13 @@ shape = ### `type-enclosing -position [ -expression ] [ -cursor ] [verbosity ] [ -index ]` - -position Position to complete - -expression Expression to type - -cursor Position of the cursor inside expression - -index Only print type of 'th result - -verbosity Verbosity level +``` + -position Position to complete + -expression Expression to type + -cursor Position of the cursor inside expression + -index Only print type of 'th result +-verbosity Verbosity level +``` 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`. @@ -420,24 +422,30 @@ The result is returned as a list of: ### `type-expression -position -expression ` - -position Position to complete - -expression Expression to type +``` + -position Position to complete + -expression Expression to type +``` Returns the type of the expression when typechecked in the environment around the specified position. -### `search-by-polarity` -position -query +### `search-by-polarity -position -query ` - -position Position to search - -query The query +``` +-position Position to search + -query The query +``` Returns a list (in the form of a completion list) of values matching the query. A query is defined by polarity (and does not support type parameters). Arguments are prefixed with `-` and the return type is prefixed with `+`. For example, to find a function that takes a string and returns an integer: `-string +int`. `-list +option` will returns every definition that take a list an option. -### `search-by-type` -position -query -limit -with-doc +### `search-by-type -position -query -limit -with-doc ` - -position Position to search - -query The query - -limit a maximum-size of the result set - -with-doc if doc should be included in the result +``` +-position Position to search + -query The query + -limit The maximum-size of the result set + -with-doc If true, values' documentation will be included in the result +``` Returns a list of values matching the query. A query is a type expression, ie: `string -> int option` will search every definition that take a string and returns an option of int. It is also possible to search by polarity. @@ -454,6 +462,116 @@ The result is returned as a list of: } ``` +### `refactor-open -postion -action ` + +``` + -position Position to refactor open +-action Direction of rewriting +``` + +Returns a list of `content` and `location` (the position referenced by the `location` must be replaced by the `content`). + +The result is returned as a list of: + +```javascript +{ + 'start': position, // the start of the region to be substituted + 'end': position, // the end of the region to be substituted + 'content' string // the content of the substitution +} +``` + +### `syntax-document -position ` + + -position The position of the keyword to be documented + +Returns the string `No documentation found` (if the position does not refer to any keyword) or the following object: + +```javascript +{ + 'name': string, // the name of the keyword under the position + 'description': string, // the description of the keyword under the position + 'url': string // a reference link in the OCaml manual +} +``` + +### `expand-ppx -position ` + + -position The position where to expand the ppx preprocessors + +Returns the string `No PPX deriver/extension node found on this position` (if the position does not refer to any keyword) or the following object: + +```javascript +{ + 'code': string, // the generated code by a ppx + 'deriver': { + 'start': position, // the start of the region expanded by the ppx + 'end': position, // the end of the region expanded by the ppx + } +} +``` + +### `locate-type -position ` + + -position The position of the type to be located + +Returns the location of the type at the given position. +If the type cannot be located (because the cursor is already at the right position, or because it is a referenced built-in type, or because the type cannot be found), the result is a string explaining why it cannot be located. +The type is defined in the same file, and the result will be the following object: + +```javascript +{ + 'pos': { + 'start': position, // the start of the region where the type is defined + 'end': position // the end of the region where the type is defined + } +} +``` + +The type is described in another file, and the result will be the following object: + +```javascript +{ + 'file': string, // the file where the type is defined + 'pos': { + 'start': position, // the start of the region where the type is defined + 'end': position // the end of the region where the type is defined + } +} +``` + +### `signature-help -position ` + + -position The position where to request additional information for signature help + +This command is essentially useful for an LSP server, as it can be used to return information additional to the completion of a function and its parameters. +If no help is found, the command returns an empty object, otherwise it returns a structured object with signatures and active parameters. +You can find more information here + +### `inlay-hints -start -end -let-binding -pattern-binding -avoid-ghost ` + +``` + -start the start of the region where to activate the inlay-hints + -end the end of the region where to activate the inlay-hints + -let-binding activate for `let-bindings +-pattern-binding activate for `pattern-bindings + -avoid-ghost deactivate for node attached with a ghost location (mainly for tests) +``` + +This command is essentially useful for an LSP server, and returns the list of inlay hints for a given region in a list of the following object: + +```javascript +{ + 'pos': { + 'start': position, // the start of the region where the hint should be attached + 'end': position // the end of the region where the hint should be attached + }, + 'label': string // the value fo the hint +} +``` + +You can find more information here + ### `check-configuration` From 611e0ec5bc599800b7f2c4be2f8f6cbed08482c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 26 Sep 2024 18:39:55 +0200 Subject: [PATCH 32/42] Prepare changelog for release 4.17-414 --- CHANGES.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index b251a41402..0afc4d1986 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,6 @@ -unreleased -========== +merlin 4.17 +=========== +Thu Sep 26 18:48:42 CEST 2024 + merlin binary - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin @@ -10,6 +11,8 @@ unreleased - Implement new inlay-hints command for adding hints on a sourcetree (#1812) - Add `signature-help` command (#1720) - Implement new search-by-type command for searching values by types (#1828) + - Fix dot-merlin-reader ignoring `SOURCE_ROOT` and `STDLIB` directives + (#1839, #1803) + editor modes - vim: fix python-3.12 syntax warnings in merlin.py (#1798) - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804) From 1d0b5a95cde20dba9d16cdfcba208d0c580224d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 27 Sep 2024 10:43:51 +0200 Subject: [PATCH 33/42] [B] Promote sherlodoc parser to sources --- src/sherlodoc/.ocamlformat-ignore | 2 + src/sherlodoc/dune | 4 +- src/sherlodoc/type_parser.ml | 548 ++++++++++++++++++++++++++++++ src/sherlodoc/type_parser.mli | 21 ++ 4 files changed, 574 insertions(+), 1 deletion(-) create mode 100644 src/sherlodoc/.ocamlformat-ignore create mode 100644 src/sherlodoc/type_parser.ml create mode 100644 src/sherlodoc/type_parser.mli diff --git a/src/sherlodoc/.ocamlformat-ignore b/src/sherlodoc/.ocamlformat-ignore new file mode 100644 index 0000000000..716cdf6985 --- /dev/null +++ b/src/sherlodoc/.ocamlformat-ignore @@ -0,0 +1,2 @@ +type_parser.ml +type_parser.mli diff --git a/src/sherlodoc/dune b/src/sherlodoc/dune index bb11c8c41c..4dd91f3c1e 100644 --- a/src/sherlodoc/dune +++ b/src/sherlodoc/dune @@ -4,6 +4,8 @@ (menhir (modules type_parser) - (flags --explain)) + (enabled_if (<> %{profile} "release")) + (mode promote) + (flags :standard --explain)) (ocamllex type_lexer) diff --git a/src/sherlodoc/type_parser.ml b/src/sherlodoc/type_parser.ml new file mode 100644 index 0000000000..7e2bb01f0a --- /dev/null +++ b/src/sherlodoc/type_parser.ml @@ -0,0 +1,548 @@ + +module MenhirBasics = struct + + exception Error + + type token = + | WORD of ( +# 4 "src/sherlodoc/type_parser.mly" + (string) +# 11 "src/sherlodoc/type_parser.ml" + ) + | WILDCARD + | STAR + | POLY of ( +# 5 "src/sherlodoc/type_parser.mly" + (string) +# 18 "src/sherlodoc/type_parser.ml" + ) + | PARENS_OPEN + | PARENS_CLOSE + | EOF + | COMMA + | ARROW + +end + +include MenhirBasics + +let _eRR = + MenhirBasics.Error + +type _menhir_env = { + _menhir_lexer: Lexing.lexbuf -> token; + _menhir_lexbuf: Lexing.lexbuf; + _menhir_token: token; + mutable _menhir_error: bool +} + +and _menhir_state = + | MenhirState19 + | MenhirState13 + | MenhirState11 + | MenhirState7 + | MenhirState6 + | MenhirState4 + | MenhirState0 + +let rec _menhir_goto_list1_typ_COMMA_ : _menhir_env -> 'ttv_tail -> _menhir_state -> (Type_parsed.t list) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_stack = (_menhir_stack, _menhir_s, _v) in + match _menhir_s with + | MenhirState19 -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let ((_menhir_stack, _menhir_s, (x : (Type_parsed.t))), _, (xs : (Type_parsed.t list))) = _menhir_stack in + let _2 = () in + let _v : (Type_parsed.t list) = +# 50 "src/sherlodoc/type_parser.mly" + ( x::xs ) +# 61 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_list1_typ_COMMA_ _menhir_env _menhir_stack _menhir_s _v + | MenhirState4 -> + let _menhir_stack = Obj.magic _menhir_stack in + assert (not _menhir_env._menhir_error); + let _tok = _menhir_env._menhir_token in + (match _tok with + | PARENS_CLOSE -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_env = _menhir_discard _menhir_env in + let _menhir_stack = Obj.magic _menhir_stack in + let ((_menhir_stack, _menhir_s), _, (ts : (Type_parsed.t list))) = _menhir_stack in + let _3 = () in + let _1 = () in + let _v : (Type_parsed.t list) = +# 44 "src/sherlodoc/type_parser.mly" + ( ts ) +# 79 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typs _menhir_env _menhir_stack _menhir_s _v + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s) + | _ -> + _menhir_fail () + +and _menhir_goto_list_WORD_ : _menhir_env -> 'ttv_tail -> _menhir_state -> (string list) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + match _menhir_s with + | MenhirState7 -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (xs : (string list)) = _v in + let (_menhir_stack, _menhir_s, (x : ( +# 4 "src/sherlodoc/type_parser.mly" + (string) +# 101 "src/sherlodoc/type_parser.ml" + ))) = _menhir_stack in + let _v : (string list) = +# 213 "" + ( x :: xs ) +# 106 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_list_WORD_ _menhir_env _menhir_stack _menhir_s _v + | MenhirState6 -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (ws : (string list)) = _v in + let ((_menhir_stack, _menhir_s, (ts : (Type_parsed.t list))), (w : ( +# 4 "src/sherlodoc/type_parser.mly" + (string) +# 116 "src/sherlodoc/type_parser.ml" + ))) = _menhir_stack in + let _v : (Type_parsed.t) = +# 29 "src/sherlodoc/type_parser.mly" + ( + List.fold_left ( fun acc w -> + Type_parsed.Tycon (w, [acc])) (Type_parsed.Tycon (w, ts)) ws + ) +# 124 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ1 _menhir_env _menhir_stack _menhir_s _v + | _ -> + _menhir_fail () + +and _menhir_fail : unit -> 'a = + fun () -> + Printf.fprintf stderr "Internal failure -- please contact the parser generator's developers.\n%!"; + assert false + +and _menhir_goto_typ : _menhir_env -> 'ttv_tail -> _menhir_state -> (Type_parsed.t) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_stack = (_menhir_stack, _menhir_s, _v) in + match _menhir_s with + | MenhirState11 -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let ((_menhir_stack, _menhir_s, (a : (Type_parsed.t))), _, (b : (Type_parsed.t))) = _menhir_stack in + let _2 = () in + let _v : (Type_parsed.t) = +# 18 "src/sherlodoc/type_parser.mly" + ( Type_parsed.Arrow (a, b) ) +# 147 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ _menhir_env _menhir_stack _menhir_s _v + | MenhirState19 | MenhirState4 -> + let _menhir_stack = Obj.magic _menhir_stack in + assert (not _menhir_env._menhir_error); + let _tok = _menhir_env._menhir_token in + (match _tok with + | COMMA -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + (match _tok with + | PARENS_OPEN -> + _menhir_run4 _menhir_env (Obj.magic _menhir_stack) MenhirState19 + | POLY _v -> + _menhir_run3 _menhir_env (Obj.magic _menhir_stack) MenhirState19 _v + | WILDCARD -> + _menhir_run2 _menhir_env (Obj.magic _menhir_stack) MenhirState19 + | WORD _v -> + _menhir_run1 _menhir_env (Obj.magic _menhir_stack) MenhirState19 _v + | ARROW | COMMA | PARENS_CLOSE | STAR -> + _menhir_reduce13 _menhir_env (Obj.magic _menhir_stack) MenhirState19 + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) MenhirState19) + | PARENS_CLOSE -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, (x : (Type_parsed.t))) = _menhir_stack in + let _v : (Type_parsed.t list) = +# 49 "src/sherlodoc/type_parser.mly" + ( [x] ) +# 180 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_list1_typ_COMMA_ _menhir_env _menhir_stack _menhir_s _v + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s) + | MenhirState0 -> + let _menhir_stack = Obj.magic _menhir_stack in + assert (not _menhir_env._menhir_error); + let _tok = _menhir_env._menhir_token in + (match _tok with + | EOF -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, (t : (Type_parsed.t))) = _menhir_stack in + let _2 = () in + let _v : (Type_parsed.t) = +# 13 "src/sherlodoc/type_parser.mly" + ( t ) +# 202 "src/sherlodoc/type_parser.ml" + in + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (_1 : (Type_parsed.t)) = _v in + Obj.magic _1 + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s) + | _ -> + _menhir_fail () + +and _menhir_reduce1 : _menhir_env -> 'ttv_tail -> _menhir_state -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s -> + let _v : (string list) = +# 211 "" + ( [] ) +# 222 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_list_WORD_ _menhir_env _menhir_stack _menhir_s _v + +and _menhir_run7 : _menhir_env -> 'ttv_tail -> _menhir_state -> ( +# 4 "src/sherlodoc/type_parser.mly" + (string) +# 229 "src/sherlodoc/type_parser.ml" +) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_stack = (_menhir_stack, _menhir_s, _v) in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + match _tok with + | WORD _v -> + _menhir_run7 _menhir_env (Obj.magic _menhir_stack) MenhirState7 _v + | ARROW | COMMA | EOF | PARENS_CLOSE | STAR -> + _menhir_reduce1 _menhir_env (Obj.magic _menhir_stack) MenhirState7 + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) MenhirState7 + +and _menhir_goto_list1_typ1_STAR_ : _menhir_env -> 'ttv_tail -> _menhir_state -> (Type_parsed.t list) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + match _menhir_s with + | MenhirState13 -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (xs : (Type_parsed.t list)) = _v in + let (_menhir_stack, _menhir_s, (x : (Type_parsed.t))) = _menhir_stack in + let _2 = () in + let _v : (Type_parsed.t list) = +# 50 "src/sherlodoc/type_parser.mly" + ( x::xs ) +# 257 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_list1_typ1_STAR_ _menhir_env _menhir_stack _menhir_s _v + | MenhirState0 | MenhirState4 | MenhirState19 | MenhirState11 -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (xs : (Type_parsed.t list)) = _v in + let _v : (Type_parsed.t) = +# 22 "src/sherlodoc/type_parser.mly" + ( Type_parsed.tuple xs ) +# 267 "src/sherlodoc/type_parser.ml" + in + let _menhir_stack = (_menhir_stack, _menhir_s, _v) in + let _menhir_stack = Obj.magic _menhir_stack in + assert (not _menhir_env._menhir_error); + let _tok = _menhir_env._menhir_token in + (match _tok with + | ARROW -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + (match _tok with + | PARENS_OPEN -> + _menhir_run4 _menhir_env (Obj.magic _menhir_stack) MenhirState11 + | POLY _v -> + _menhir_run3 _menhir_env (Obj.magic _menhir_stack) MenhirState11 _v + | WILDCARD -> + _menhir_run2 _menhir_env (Obj.magic _menhir_stack) MenhirState11 + | WORD _v -> + _menhir_run1 _menhir_env (Obj.magic _menhir_stack) MenhirState11 _v + | ARROW | COMMA | EOF | PARENS_CLOSE | STAR -> + _menhir_reduce13 _menhir_env (Obj.magic _menhir_stack) MenhirState11) + | COMMA | EOF | PARENS_CLOSE -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, (t : (Type_parsed.t))) = _menhir_stack in + let _v : (Type_parsed.t) = +# 17 "src/sherlodoc/type_parser.mly" + ( t ) +# 295 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ _menhir_env _menhir_stack _menhir_s _v + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s) + | _ -> + _menhir_fail () + +and _menhir_goto_typs : _menhir_env -> 'ttv_tail -> _menhir_state -> (Type_parsed.t list) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_stack = (_menhir_stack, _menhir_s, _v) in + let _menhir_stack = Obj.magic _menhir_stack in + assert (not _menhir_env._menhir_error); + let _tok = _menhir_env._menhir_token in + match _tok with + | WORD _v -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = (_menhir_stack, _v) in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + (match _tok with + | WORD _v -> + _menhir_run7 _menhir_env (Obj.magic _menhir_stack) MenhirState6 _v + | ARROW | COMMA | EOF | PARENS_CLOSE | STAR -> + _menhir_reduce1 _menhir_env (Obj.magic _menhir_stack) MenhirState6 + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) MenhirState6) + | ARROW | COMMA | EOF | PARENS_CLOSE | STAR -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, (ts : (Type_parsed.t list))) = _menhir_stack in + let _v : (Type_parsed.t) = +# 27 "src/sherlodoc/type_parser.mly" + ( Type_parsed.tuple ts ) +# 334 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ1 _menhir_env _menhir_stack _menhir_s _v + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + +and _menhir_goto_typ1 : _menhir_env -> 'ttv_tail -> _menhir_state -> (Type_parsed.t) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_stack = (_menhir_stack, _menhir_s, _v) in + let _menhir_stack = Obj.magic _menhir_stack in + assert (not _menhir_env._menhir_error); + let _tok = _menhir_env._menhir_token in + match _tok with + | STAR -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + (match _tok with + | PARENS_OPEN -> + _menhir_run4 _menhir_env (Obj.magic _menhir_stack) MenhirState13 + | POLY _v -> + _menhir_run3 _menhir_env (Obj.magic _menhir_stack) MenhirState13 _v + | WILDCARD -> + _menhir_run2 _menhir_env (Obj.magic _menhir_stack) MenhirState13 + | WORD _v -> + _menhir_run1 _menhir_env (Obj.magic _menhir_stack) MenhirState13 _v + | ARROW | COMMA | EOF | PARENS_CLOSE | STAR -> + _menhir_reduce13 _menhir_env (Obj.magic _menhir_stack) MenhirState13) + | ARROW | COMMA | EOF | PARENS_CLOSE -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, (x : (Type_parsed.t))) = _menhir_stack in + let _v : (Type_parsed.t list) = +# 49 "src/sherlodoc/type_parser.mly" + ( [x] ) +# 372 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_list1_typ1_STAR_ _menhir_env _menhir_stack _menhir_s _v + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + +and _menhir_goto_typ0 : _menhir_env -> 'ttv_tail -> _menhir_state -> (Type_parsed.t) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_stack = Obj.magic _menhir_stack in + let _menhir_stack = Obj.magic _menhir_stack in + let (t : (Type_parsed.t)) = _v in + let _v : (Type_parsed.t list) = +# 43 "src/sherlodoc/type_parser.mly" + ( [t] ) +# 390 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typs _menhir_env _menhir_stack _menhir_s _v + +and _menhir_errorcase : _menhir_env -> 'ttv_tail -> _menhir_state -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s -> + match _menhir_s with + | MenhirState19 -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + | MenhirState13 -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + | MenhirState11 -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + | MenhirState7 -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s, _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + | MenhirState6 -> + let _menhir_stack = Obj.magic _menhir_stack in + let ((_menhir_stack, _menhir_s, _), _) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + | MenhirState4 -> + let _menhir_stack = Obj.magic _menhir_stack in + let (_menhir_stack, _menhir_s) = _menhir_stack in + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) _menhir_s + | MenhirState0 -> + let _menhir_stack = Obj.magic _menhir_stack in + raise _eRR + +and _menhir_reduce13 : _menhir_env -> 'ttv_tail -> _menhir_state -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s -> + let _v : (Type_parsed.t) = +# 26 "src/sherlodoc/type_parser.mly" + ( Type_parsed.Wildcard ) +# 430 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ1 _menhir_env _menhir_stack _menhir_s _v + +and _menhir_run1 : _menhir_env -> 'ttv_tail -> _menhir_state -> ( +# 4 "src/sherlodoc/type_parser.mly" + (string) +# 437 "src/sherlodoc/type_parser.ml" +) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_env = _menhir_discard _menhir_env in + let _menhir_stack = Obj.magic _menhir_stack in + let (w : ( +# 4 "src/sherlodoc/type_parser.mly" + (string) +# 445 "src/sherlodoc/type_parser.ml" + )) = _v in + let _v : (Type_parsed.t) = +# 38 "src/sherlodoc/type_parser.mly" + ( Type_parsed.Tycon (w, []) ) +# 450 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ0 _menhir_env _menhir_stack _menhir_s _v + +and _menhir_run2 : _menhir_env -> 'ttv_tail -> _menhir_state -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s -> + let _menhir_env = _menhir_discard _menhir_env in + let _menhir_stack = Obj.magic _menhir_stack in + let _1 = () in + let _v : (Type_parsed.t) = +# 36 "src/sherlodoc/type_parser.mly" + ( Type_parsed.Wildcard ) +# 462 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ0 _menhir_env _menhir_stack _menhir_s _v + +and _menhir_run3 : _menhir_env -> 'ttv_tail -> _menhir_state -> ( +# 5 "src/sherlodoc/type_parser.mly" + (string) +# 469 "src/sherlodoc/type_parser.ml" +) -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s _v -> + let _menhir_env = _menhir_discard _menhir_env in + let _menhir_stack = Obj.magic _menhir_stack in + let (w : ( +# 5 "src/sherlodoc/type_parser.mly" + (string) +# 477 "src/sherlodoc/type_parser.ml" + )) = _v in + let _v : (Type_parsed.t) = +# 37 "src/sherlodoc/type_parser.mly" + ( Type_parsed.Tyvar w ) +# 482 "src/sherlodoc/type_parser.ml" + in + _menhir_goto_typ0 _menhir_env _menhir_stack _menhir_s _v + +and _menhir_run4 : _menhir_env -> 'ttv_tail -> _menhir_state -> 'ttv_return = + fun _menhir_env _menhir_stack _menhir_s -> + let _menhir_stack = (_menhir_stack, _menhir_s) in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + match _tok with + | PARENS_OPEN -> + _menhir_run4 _menhir_env (Obj.magic _menhir_stack) MenhirState4 + | POLY _v -> + _menhir_run3 _menhir_env (Obj.magic _menhir_stack) MenhirState4 _v + | WILDCARD -> + _menhir_run2 _menhir_env (Obj.magic _menhir_stack) MenhirState4 + | WORD _v -> + _menhir_run1 _menhir_env (Obj.magic _menhir_stack) MenhirState4 _v + | ARROW | COMMA | PARENS_CLOSE | STAR -> + _menhir_reduce13 _menhir_env (Obj.magic _menhir_stack) MenhirState4 + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) MenhirState4 + +and _menhir_discard : _menhir_env -> _menhir_env = + fun _menhir_env -> + let lexer = _menhir_env._menhir_lexer in + let lexbuf = _menhir_env._menhir_lexbuf in + let _tok = lexer lexbuf in + { + _menhir_lexer = lexer; + _menhir_lexbuf = lexbuf; + _menhir_token = _tok; + _menhir_error = false; + } + +and main : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Type_parsed.t) = + fun lexer lexbuf -> + let _menhir_env = { + _menhir_lexer = lexer; + _menhir_lexbuf = lexbuf; + _menhir_token = Obj.magic (); + _menhir_error = false; + } in + Obj.magic (let _menhir_stack = ((), _menhir_env._menhir_lexbuf.Lexing.lex_curr_p) in + let _menhir_env = _menhir_discard _menhir_env in + let _tok = _menhir_env._menhir_token in + match _tok with + | PARENS_OPEN -> + _menhir_run4 _menhir_env (Obj.magic _menhir_stack) MenhirState0 + | POLY _v -> + _menhir_run3 _menhir_env (Obj.magic _menhir_stack) MenhirState0 _v + | WILDCARD -> + _menhir_run2 _menhir_env (Obj.magic _menhir_stack) MenhirState0 + | WORD _v -> + _menhir_run1 _menhir_env (Obj.magic _menhir_stack) MenhirState0 _v + | ARROW | EOF | STAR -> + _menhir_reduce13 _menhir_env (Obj.magic _menhir_stack) MenhirState0 + | _ -> + assert (not _menhir_env._menhir_error); + _menhir_env._menhir_error <- true; + _menhir_errorcase _menhir_env (Obj.magic _menhir_stack) MenhirState0) + +# 269 "" + + +# 549 "src/sherlodoc/type_parser.ml" diff --git a/src/sherlodoc/type_parser.mli b/src/sherlodoc/type_parser.mli new file mode 100644 index 0000000000..52b543feb0 --- /dev/null +++ b/src/sherlodoc/type_parser.mli @@ -0,0 +1,21 @@ + +(* The type of tokens. *) + +type token = + | WORD of (string) + | WILDCARD + | STAR + | POLY of (string) + | PARENS_OPEN + | PARENS_CLOSE + | EOF + | COMMA + | ARROW + +(* This exception is raised by the monolithic API functions. *) + +exception Error + +(* The monolithic API. *) + +val main: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Type_parsed.t) From b17f7d1f5e50f23a167ce5aba30d8d2557bf8e99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 27 Sep 2024 10:46:08 +0200 Subject: [PATCH 34/42] Update changelog for release 4.17.1 --- CHANGES.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 0afc4d1986..14cbf0d40a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,6 @@ -merlin 4.17 -=========== -Thu Sep 26 18:48:42 CEST 2024 +merlin 4.17.1 +============= +Fri Sep 27 12:02:42 CEST 2024 + merlin binary - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin From 44c112461cab98b9279798271d003fccda2badba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 27 Sep 2024 10:57:00 +0200 Subject: [PATCH 35/42] Update opam deps --- dot-merlin-reader.opam | 4 ++-- merlin.opam | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 48ead45bf7..41d4f6330e 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -11,9 +11,9 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "4.08" & < "5.0"} + "ocaml" {>= "4.14"} "dune" {>= "2.9.0"} - "merlin-lib" {>= "4.9"} + "merlin-lib" {>= "4.17"} "ocamlfind" {>= "1.6.0"} ] description: diff --git a/merlin.opam b/merlin.opam index 907a1b3aa8..afa0566dbd 100644 --- a/merlin.opam +++ b/merlin.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "merlin-lib" {= version} - "dot-merlin-reader" {>= "4.9"} + "dot-merlin-reader" {>= "4.17"} "yojson" {>= "2.0.0"} "conf-jq" {with-test} "ppxlib" {with-test} From 3e61631402c9b16093f18c111e27dd501d8cd895 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 26 Nov 2024 15:08:44 +0100 Subject: [PATCH 36/42] [B] #1854 Fix `EXCLUDE_QUERY_DIR` for cmt files from liam923/exclude-query-dir-fix Changelog entry for #1854 --- CHANGES.md | 8 +++++ src/kernel/mconfig.ml | 29 +++++++--------- tests/test-dirs/config/dune | 2 +- tests/test-dirs/config/exclude-query-dir.t | 40 ++++++++++++++++++++++ 4 files changed, 61 insertions(+), 18 deletions(-) create mode 100644 tests/test-dirs/config/exclude-query-dir.t diff --git a/CHANGES.md b/CHANGES.md index 14cbf0d40a..84f1ea2ad5 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +unreleased +========== + + + merlin binary + - Respect the `EXCLUDE_QUERY_DIR` configuration directive when looking for + cmt files (#1854) + + merlin 4.17.1 ============= Fri Sep 27 12:02:42 CEST 2024 diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 222c119411..3e70898236 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -744,14 +744,14 @@ let source_path config = List.concat [ [ config.query.directory ]; stdlib; config.merlin.source_path ] |> List.filter_dup -let build_path config = +let collect_paths ~log_title ~config paths = 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 dirs = paths @ 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 @@ -760,23 +760,18 @@ let build_path config = 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 result = List.filter_dup result in + log ~title:log_title "%d items in path, %d after deduplication" + (List.length result) (List.length result); + result + +let build_path config = + collect_paths ~log_title:"build_path" ~config + (config.merlin.cmi_path @ config.merlin.build_path) 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 + collect_paths ~log_title:"cmt_path" ~config + (config.merlin.cmt_path @ config.merlin.build_path) let global_modules ?(include_current = false) config = let modules = Misc.modules_in_path ~ext:".cmi" (build_path config) in diff --git a/tests/test-dirs/config/dune b/tests/test-dirs/config/dune index 3afbf37cb4..487c3246d9 100755 --- a/tests/test-dirs/config/dune +++ b/tests/test-dirs/config/dune @@ -1,5 +1,5 @@ (cram - (applies_to path-expansion) + (applies_to path-expansion exclude-query-dir) (enabled_if (<> %{os_type} Win32))) diff --git a/tests/test-dirs/config/exclude-query-dir.t b/tests/test-dirs/config/exclude-query-dir.t new file mode 100644 index 0000000000..162fcf5bcc --- /dev/null +++ b/tests/test-dirs/config/exclude-query-dir.t @@ -0,0 +1,40 @@ +Test the EXCLUDE_QUERY_DIR directive, which tells Merlin not to look for build artifacts +in the directory of the file being queried on. To test, we create a/test.ml, which depends +on b/foo.ml. The folder b contains a .cmt for the Foo module, and Merlin is configured to +look there. We also include a malformatted foo.cmt in the query directory. + $ mkdir a + $ mkdir b + + $ cat > a/test.ml << EOF + > let x = Foo.bar + > EOF + + $ cat > b/foo.ml << EOF + > let bar = 10 + > EOF + +Create the proper and malformatted .cmt files + $ $OCAMLC -c -bin-annot b/foo.ml + $ touch a/foo.cmt + +Configure Merlin + $ cat > a/.merlin << EOF + > S . + > B ../b + > S ../b + > EXCLUDE_QUERY_DIR + > EOF + +Perform the query + $ $MERLIN single locate -position 1:13 -filename a/test.ml < a/test.ml + { + "class": "return", + "value": { + "file": "$TESTCASE_ROOT/b/foo.ml", + "pos": { + "line": 1, + "col": 4 + } + }, + "notifications": [] + } From f6ea6711b465b052817f645de24fb3577c04a001 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 26 Nov 2024 15:15:00 +0100 Subject: [PATCH 37/42] [B] #1856 Fix 1852 packaging issues from xvw/fix-1852-packaging-issues --- .github/workflows/changelog.yml | 2 +- dot-merlin-reader.opam | 2 +- merlin-lib.opam | 2 +- tests/test-units/sherldoc/dune | 1 + 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/workflows/changelog.yml b/.github/workflows/changelog.yml index 6d9daf7bbb..5ba83ec6b7 100644 --- a/.github/workflows/changelog.yml +++ b/.github/workflows/changelog.yml @@ -2,7 +2,7 @@ name: Changelog check on: pull_request: - branches: [ master ] + branches: [ main ] types: [ opened, synchronize, reopened, labeled, unlabeled ] jobs: diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 41d4f6330e..3bc54e2f8e 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -12,7 +12,7 @@ build: [ ] depends: [ "ocaml" {>= "4.14"} - "dune" {>= "2.9.0"} + "dune" {>= "3.0.0"} "merlin-lib" {>= "4.17"} "ocamlfind" {>= "1.6.0"} ] diff --git a/merlin-lib.opam b/merlin-lib.opam index 72270d1c42..a3a98730a9 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -13,7 +13,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} - "alcotest" {with-test} + "alcotest" {with-test & >= "1.3.0" } "menhir" {dev & >= "20201216"} "menhirLib" {dev & >= "20201216"} "menhirSdk" {dev & >= "20201216"} diff --git a/tests/test-units/sherldoc/dune b/tests/test-units/sherldoc/dune index f84c9d6d2c..e6ebc33cfd 100644 --- a/tests/test-units/sherldoc/dune +++ b/tests/test-units/sherldoc/dune @@ -1,3 +1,4 @@ (test (name sherlodoc_test) + (package merlin-lib) (libraries fmt alcotest merlin-lib.sherlodoc)) From 614add9e25888bb4ffb382637d75ca3e0f0b4aa2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 26 Nov 2024 15:17:28 +0100 Subject: [PATCH 38/42] [B] #1858 from xvw/fix-1113 Fix #1113 --- CHANGES.md | 1 + src/analysis/polarity_search.ml | 6 +- src/commands/new_commands.ml | 6 +- tests/test-dirs/search/issue1113.t | 101 +++++++++++++++++++++++++++++ 4 files changed, 111 insertions(+), 3 deletions(-) create mode 100644 tests/test-dirs/search/issue1113.t diff --git a/CHANGES.md b/CHANGES.md index 84f1ea2ad5..8a6113c0ca 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,7 @@ unreleased + merlin binary - Respect the `EXCLUDE_QUERY_DIR` configuration directive when looking for cmt files (#1854) + - Fix exception in polarity search (#1858 fixes #1113) merlin 4.17.1 diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 159f224b8a..79b6b6b837 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -68,8 +68,10 @@ let build_query ~positive ~negative env = incr r; None) else - let set, _ = Env.find_type_by_name l env in - Some (normalize_path env set) + try + let set, _ = Env.find_type_by_name l env in + Some (normalize_path env set) + with Not_found -> None in let pos_fun = ref 0 and neg_fun = ref 0 in let positive = List.filter_map positive ~f:(prepare pos_fun) in diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 836c3334f6..67a11911e1 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -569,7 +569,11 @@ let all_commands = ~spec: [ arg "-position" " Position to complete" (marg_position (fun pos (query, _pos) -> (query, pos))); - arg "-query" " Query of the form TODO" + arg "-query" + " Query of the form every input parameters prefixed by `-` \ + and output parameters prefixed by `+`. In example: -string \ + +option will fetch function that takes string and returns an \ + option. (You can't parametrize types in polarity queries)" (Marg.param "string" (fun query (_prefix, pos) -> (query, pos))) ] ~default:("", `None) diff --git a/tests/test-dirs/search/issue1113.t b/tests/test-dirs/search/issue1113.t new file mode 100644 index 0000000000..2c87dcd63c --- /dev/null +++ b/tests/test-dirs/search/issue1113.t @@ -0,0 +1,101 @@ + $ cat >main.ml < let f x = succ x + > EOF + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-ezfnifzen +ezfzef" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "CamlinternalOO.dummy_table", + "desc": "CamlinternalOO.table" + } + { + "name": "CamlinternalOO.params", + "desc": "CamlinternalOO.params" + } + { + "name": "__FILE__", + "desc": "string" + } + { + "name": "__FILE__", + "desc": "string" + } + { + "name": "__FUNCTION__", + "desc": "string" + } + { + "name": "__FUNCTION__", + "desc": "string" + } + { + "name": "__LINE__", + "desc": "int" + } + { + "name": "__LINE__", + "desc": "int" + } + { + "name": "__LOC__", + "desc": "string" + } + { + "name": "__LOC__", + "desc": "string" + } + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "ezfnifzen -> ezfzef" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost}' + { + "name": "Gc.major", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "Gc.minor", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "Sys.time", + "type": "unit -> float", + "cost": 13 + } + { + "name": "read_int", + "type": "unit -> int", + "cost": 13 + } + { + "name": "read_int", + "type": "unit -> int", + "cost": 13 + } + { + "name": "flush_all", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "flush_all", + "type": "unit -> unit", + "cost": 13 + } + { + "name": "read_line", + "type": "unit -> string", + "cost": 13 + } + { + "name": "read_line", + "type": "unit -> string", + "cost": 13 + } + { + "name": "Bytes.copy", + "type": "bytes -> bytes", + "cost": 13 + } From 758f8390367548c7b2a7000cbd2bbd6035f96e78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 26 Nov 2024 15:23:58 +0100 Subject: [PATCH 39/42] [B] #1864 Fix type enclosing deduplication from voodoos/fix-type-enclosing-deduplication Change entry for #1854 --- CHANGES.md | 2 + src/analysis/misc_utils.ml | 52 +++ src/analysis/misc_utils.mli | 8 + src/analysis/type_enclosing.ml | 32 +- src/analysis/type_enclosing.mli | 3 + src/frontend/query_commands.ml | 148 +++------ tests/test-dirs/issue1109.t/run.t | 4 +- tests/test-dirs/misc/load_path.t | 12 + tests/test-dirs/search/issue1113.t | 26 +- .../constructors_and_paths.t/run.t | 38 ++- .../test-dirs/type-enclosing/generic-types.t | 297 ++++++++++++++++++ .../type-enclosing/github1003.t/run.t | 12 + tests/test-dirs/type-enclosing/issue1477.t | 12 + tests/test-dirs/type-enclosing/letop.t/run.t | 16 +- .../test-dirs/type-enclosing/mod-type.t/run.t | 16 +- .../test-dirs/type-enclosing/objects.t/run.t | 4 +- tests/test-dirs/type-enclosing/record.t/run.t | 8 +- .../type-enclosing/te-413-features.t | 6 +- tests/test-dirs/type-enclosing/te-modules.t | 232 ++++++++++++++ tests/test-dirs/type-enclosing/types.t/run.t | 12 + 20 files changed, 793 insertions(+), 147 deletions(-) create mode 100644 tests/test-dirs/type-enclosing/generic-types.t create mode 100644 tests/test-dirs/type-enclosing/te-modules.t diff --git a/CHANGES.md b/CHANGES.md index 8a6113c0ca..79b9a484e0 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,8 @@ unreleased - Respect the `EXCLUDE_QUERY_DIR` configuration directive when looking for cmt files (#1854) - Fix exception in polarity search (#1858 fixes #1113) + - Fix type-enclosing results instability. This reverts some overly + aggressive deduplication that should be done on the client side. (#1864) merlin 4.17.1 diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 7c372f6548..c86b6449fe 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -59,3 +59,55 @@ let parse_identifier (config, source) pos = "paths: [%s]" (String.concat ~sep:";" (List.map path ~f:(fun l -> l.Location.txt))); path + +let reconstruct_identifier pipeline pos = function + | None -> + let config = Mpipeline.input_config pipeline in + let source = Mpipeline.raw_source pipeline in + let path = parse_identifier (config, source) pos in + 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 diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 7fdab690e3..0d508244ff 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -29,3 +29,11 @@ val parenthesize_name : string -> string the location of each of its components. *) val parse_identifier : Mconfig.t * Msource.t -> Lexing.position -> string Location.loc list + +(** [reconstruct_identifier pipeline pos] returns growing ranges around [pos] and the + associated identifier. *) +val reconstruct_identifier : + Mpipeline.t -> + Lexing.position -> + (string * int) option -> + string Location.loc list diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml index 096ad2d571..2b1435e9c0 100644 --- a/src/analysis/type_enclosing.ml +++ b/src/analysis/type_enclosing.ml @@ -1,4 +1,5 @@ open Std +open Type_utils let log_section = "type-enclosing" let { Logger.log } = Logger.for_section log_section @@ -7,11 +8,34 @@ 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 + | Type_constr of Env.t * Types.constructor_description | String of string type typed_enclosings = (Location.t * type_info * Query_protocol.is_tail_position) list +let print_type ~verbosity type_info = + let ppf = Format.str_formatter in + let wrap_printing_env = Printtyp.wrap_printing_env ~verbosity in + match type_info with + | Type (env, t) -> + wrap_printing_env env (fun () -> + print_type_with_decl ~verbosity env ppf t; + Format.flush_str_formatter ()) + | Type_decl (env, id, t) -> + wrap_printing_env env (fun () -> + Printtyp.type_declaration env id ppf t; + Format.flush_str_formatter ()) + | Type_constr (env, cd) -> + wrap_printing_env env (fun () -> + print_constr ~verbosity env ppf cd; + Format.flush_str_formatter ()) + | Modtype (env, m) -> + wrap_printing_env env (fun () -> + Printtyp.modtype env ppf m; + Format.flush_str_formatter ()) + | String s -> s + let from_nodes ~path = let aux (env, node, tail) = let open Browse_raw in @@ -89,14 +113,10 @@ let from_reconstructed ~nodes ~cursor ~verbosity exprs = (* 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 (loc, Type_constr (env, cd), `No) | Some (Context.Label { lbl_name; lbl_arg; _ }) -> log ~title:"from_reconstructed" "ctx: label %s" lbl_name; - let ppf, to_string = Format.to_string () in - Type_utils.print_type_with_decl ~verbosity env ppf lbl_arg; - Some (loc, String (to_string ()), `No) + Some (loc, Type (env, lbl_arg), `No) | Some Context.Constant -> None | _ -> ( let context = Option.value ~default:Context.Expr context in diff --git a/src/analysis/type_enclosing.mli b/src/analysis/type_enclosing.mli index 50a408b46a..87538b63e0 100644 --- a/src/analysis/type_enclosing.mli +++ b/src/analysis/type_enclosing.mli @@ -38,11 +38,14 @@ 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 + | Type_constr of Env.t * Types.constructor_description | String of string type typed_enclosings = (Location.t * type_info * Query_protocol.is_tail_position) list +val print_type : verbosity:Mconfig.Verbosity.t -> type_info -> string + val from_nodes : path:(Env.t * Browse_raw.node * Query_protocol.is_tail_position) list -> typed_enclosings diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index b7ea91f4fd..c52bb81a65 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -199,65 +199,6 @@ let dump pipeline = function 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 @@ -282,10 +223,29 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | browse -> Browse_misc.annotate_tail_calls browse in - let result = Type_enclosing.from_nodes ~path in + (* Type enclosing results come from two sources: 1. the typedtree nodes + aroung the cursor's position and 2. the result of reconstructing the + identifier around the cursor and typing the resulting paths. + + Having the results from 2 is useful because ot is finer-grained than the + typedtree's nodes and can provide types for modules appearing in paths. + + This introduces two possible sources of duplicate results: + - Sometimes the typedtree nodes in 1 overlaps and we simply remove these. + - The last reconstructed enclosing usually overlaps with the first + typedtree node but the printed types are not always the same (generic / + specialized types). Because systematically printing these types to + compare them can be very expensive in the presence of large modules, we + defer this deduplication to the clients. + *) + let enclosing_nodes = + let cmp (loc1, _, _) (loc2, _, _) = Location_aux.compare loc1 loc2 in + (* There might be duplicates in the list: we remove them *) + Type_enclosing.from_nodes ~path |> List.dedup_adjacent ~cmp + in - (* enclosings of cursor in given expression *) - let exprs = reconstruct_identifier pipeline pos expro in + (* Enclosings of cursor in given expression *) + let exprs = Misc_utils.reconstruct_identifier pipeline pos expro in let () = Logger.log ~section:Type_enclosing.log_section ~title:"reconstruct identifier" "%a" Logger.json (fun () -> @@ -309,42 +269,30 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function (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 + let all_results = List.concat [ small_enclosings; enclosing_nodes ] in + let index = + (* Clamp the index to [0; number_of_results[ *) + let number_of_results = List.length all_results in + match index with + | Some index when index < 0 -> Some 0 + | Some index when index >= number_of_results -> + Some (number_of_results - 1) + | index -> index + in + List.mapi all_results ~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_info -> + if print then + let printed_type = Type_enclosing.print_type ~verbosity type_info in + ret (`String printed_type) + else ret (`Index i)) | Enclosing pos -> let typer = Mpipeline.typer_result pipeline in let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in @@ -510,7 +458,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function match patho with | Some p -> p | None -> - let path = reconstruct_identifier pipeline pos None in + let path = Misc_utils.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 @@ -546,7 +494,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function match patho with | Some p -> p | None -> - let path = reconstruct_identifier pipeline pos None in + let path = Misc_utils.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 diff --git a/tests/test-dirs/issue1109.t/run.t b/tests/test-dirs/issue1109.t/run.t index 37e5a134a9..fa6598f9d6 100644 --- a/tests/test-dirs/issue1109.t/run.t +++ b/tests/test-dirs/issue1109.t/run.t @@ -20,9 +20,9 @@ }, "end": { "line": 5, - "col": 16 + "col": 14 }, - "type": "'a", + "type": "'a -> 'a", "tail": "no" } ] diff --git a/tests/test-dirs/misc/load_path.t b/tests/test-dirs/misc/load_path.t index 19bffb07f6..3e5dbc2fb9 100644 --- a/tests/test-dirs/misc/load_path.t +++ b/tests/test-dirs/misc/load_path.t @@ -16,6 +16,18 @@ Here is what merlin sees: { "class": "return", "value": [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "int", + "tail": "no" + }, { "start": { "line": 1, diff --git a/tests/test-dirs/search/issue1113.t b/tests/test-dirs/search/issue1113.t index 2c87dcd63c..0730986c43 100644 --- a/tests/test-dirs/search/issue1113.t +++ b/tests/test-dirs/search/issue1113.t @@ -13,6 +13,10 @@ "name": "CamlinternalOO.params", "desc": "CamlinternalOO.params" } + { + "name": "Dynlink.is_native", + "desc": "bool" + } { "name": "__FILE__", "desc": "string" @@ -41,10 +45,6 @@ "name": "__LOC__", "desc": "string" } - { - "name": "__LOC__", - "desc": "string" - } $ $MERLIN single search-by-type -filename ./main.ml \ > -position 5:25 -limit 10 -query "ezfnifzen -> ezfzef" | @@ -75,8 +75,13 @@ "cost": 13 } { - "name": "flush_all", - "type": "unit -> unit", + "name": "Unix.fork", + "type": "unit -> int", + "cost": 13 + } + { + "name": "Unix.time", + "type": "unit -> float", "cost": 13 } { @@ -85,8 +90,8 @@ "cost": 13 } { - "name": "read_line", - "type": "unit -> string", + "name": "flush_all", + "type": "unit -> unit", "cost": 13 } { @@ -94,8 +99,3 @@ "type": "unit -> string", "cost": 13 } - { - "name": "Bytes.copy", - "type": "bytes -> bytes", - "cost": 13 - } diff --git a/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t b/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t index 23f040870b..54e6705bf4 100644 --- a/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t +++ b/tests/test-dirs/type-enclosing/constructors_and_paths.t/run.t @@ -4,6 +4,18 @@ Various parts of the cons.ml: $ $MERLIN single type-enclosing -position 4:14 -verbosity 0 \ > -filename ./cons.ml < ./cons.ml| jq ".value[0:2]" [ + { + "start": { + "line": 4, + "col": 13 + }, + "end": { + "line": 4, + "col": 14 + }, + "type": "t", + "tail": "no" + }, { "start": { "line": 4, @@ -37,14 +49,14 @@ Various parts of the cons.ml: }, { "start": { - "line": 7, - "col": 2 + "line": 8, + "col": 4 }, "end": { "line": 8, - "col": 11 + "col": 5 }, - "type": "unit", + "type": "t", "tail": "no" } ] @@ -127,13 +139,13 @@ Various parts of the cons.ml: { "start": { "line": 15, - "col": 6 + "col": 12 }, "end": { "line": 15, - "col": 22 + "col": 15 }, - "type": "unit -> M.t", + "type": "M.t", "tail": "no" } ] @@ -233,6 +245,18 @@ the expression reconstructed from (M|.A 3). $ $MERLIN single type-enclosing -position 26:11 -verbosity 0 \ > -filename ./cons.ml < ./cons.ml | jq ".value[0:2]" [ + { + "start": { + "line": 26, + "col": 8 + }, + "end": { + "line": 26, + "col": 11 + }, + "type": "int", + "tail": "no" + }, { "start": { "line": 26, diff --git a/tests/test-dirs/type-enclosing/generic-types.t b/tests/test-dirs/type-enclosing/generic-types.t new file mode 100644 index 0000000000..b3ed43681a --- /dev/null +++ b/tests/test-dirs/type-enclosing/generic-types.t @@ -0,0 +1,297 @@ + $ cat >main.ml <<'EOF' + > let _ = List.map Fun.id [3] + > EOF + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 1:14 -index 0 \ + > -filename ./main.ml < ./main.ml | jq '.value[0,1]' + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "('a -> 'b) -> 'a list -> 'b list", + "tail": "no" + } + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": 1, + "tail": "no" + } + +With index 1 only the second is shown (the first is a string so it is always shown): + $ $MERLIN single type-enclosing -position 1:14 -index 1 \ + > -filename ./main.ml < ./main.ml | jq '.value[0,1]' + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "('a -> 'b) -> 'a list -> 'b list", + "tail": "no" + } + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + } + + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 1:10 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 12 + }, + "type": "(module Stdlib__List)", + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + +With index 1 only the second is shown (the first is a string so it is always shown): +FIXME? We don't see the generic version + $ $MERLIN single type-enclosing -short-paths -position 1:10 -index 1 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 12 + }, + "type": "(module List)", + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + + $ cat >main.ml <<'EOF' + > module List = struct let map : (int -> int) -> int list -> int list = List.map end + > let _ = List.map Fun.id [3] + > EOF + +With index 0 only the first type is shown. The next enclosing is not +deduplicated as intended, this should be done by the client. + $ $MERLIN single type-enclosing -position 2:14 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + +And with index=1 the correct type is shown + $ $MERLIN single type-enclosing -position 2:14 -index 1 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 27 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + +And with index>=3 Merlin sticks to the last item + $ $MERLIN single type-enclosing -position 2:14 -index 7 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "(int -> int) -> int list -> int list", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 27 + }, + "type": "int list", + "tail": "no" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/type-enclosing/github1003.t/run.t b/tests/test-dirs/type-enclosing/github1003.t/run.t index dd4730cc33..6b79d9f057 100644 --- a/tests/test-dirs/type-enclosing/github1003.t/run.t +++ b/tests/test-dirs/type-enclosing/github1003.t/run.t @@ -1,6 +1,18 @@ $ $MERLIN single type-enclosing -position 5:14 -verbosity 0 \ > -filename ./issue1003.ml < ./issue1003.ml | jq ".value[0:2]" [ + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 16 + }, + "type": "int", + "tail": "no" + }, { "start": { "line": 5, diff --git a/tests/test-dirs/type-enclosing/issue1477.t b/tests/test-dirs/type-enclosing/issue1477.t index 1b1e06ff72..78e3633aca 100644 --- a/tests/test-dirs/type-enclosing/issue1477.t +++ b/tests/test-dirs/type-enclosing/issue1477.t @@ -19,6 +19,18 @@ "type": "int -> int", "tail": "no" }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 9 + }, + "type": "int -> int", + "tail": "no" + }, { "start": { "line": 2, diff --git a/tests/test-dirs/type-enclosing/letop.t/run.t b/tests/test-dirs/type-enclosing/letop.t/run.t index 29b94b5433..62fa2c86a3 100644 --- a/tests/test-dirs/type-enclosing/letop.t/run.t +++ b/tests/test-dirs/type-enclosing/letop.t/run.t @@ -86,9 +86,9 @@ Various parts of the letop: }, "end": { "line": 4, - "col": 37 + "col": 29 }, - "type": "'a option", + "type": "('a, 'b) Hashtbl.t -> 'a -> 'b option", "tail": "no" } ] @@ -111,13 +111,13 @@ Various parts of the letop: { "start": { "line": 4, - "col": 13 + "col": 30 }, "end": { "line": 4, - "col": 37 + "col": 33 }, - "type": "'a option", + "type": "('a, 'b) Hashtbl.t", "tail": "no" } ] @@ -140,13 +140,13 @@ Various parts of the letop: { "start": { "line": 4, - "col": 13 + "col": 34 }, "end": { "line": 4, "col": 37 }, - "type": "'a option", + "type": "'a", "tail": "no" } ] @@ -175,7 +175,7 @@ Various parts of the letop: }, "end": { "line": 5, - "col": 9 + "col": 5 }, "type": "int", "tail": "no" diff --git a/tests/test-dirs/type-enclosing/mod-type.t/run.t b/tests/test-dirs/type-enclosing/mod-type.t/run.t index 2506d0adc5..41013d081f 100644 --- a/tests/test-dirs/type-enclosing/mod-type.t/run.t +++ b/tests/test-dirs/type-enclosing/mod-type.t/run.t @@ -32,6 +32,18 @@ Get the type of a module type with the same name as a module: $ $MERLIN single type-enclosing -position 5:9 -verbosity 2 \ > -filename ./module_type.mli < ./module_type.mli | jq ".value[0:2]" [ + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 9 + }, + "type": "sig type a end", + "tail": "no" + }, { "start": { "line": 5, @@ -64,7 +76,7 @@ Get the type of a module type with the same name as a module: { "start": { "line": 7, - "col": 8 + "col": 23 }, "end": { "line": 7, @@ -93,7 +105,7 @@ Get the type of a module type with the same name as a module: { "start": { "line": 7, - "col": 8 + "col": 23 }, "end": { "line": 7, diff --git a/tests/test-dirs/type-enclosing/objects.t/run.t b/tests/test-dirs/type-enclosing/objects.t/run.t index a29e9d65ed..7fab615004 100644 --- a/tests/test-dirs/type-enclosing/objects.t/run.t +++ b/tests/test-dirs/type-enclosing/objects.t/run.t @@ -112,9 +112,9 @@ }, "end": { "line": 14, - "col": 14 + "col": 9 }, - "type": "int -> unit", + "type": "< pop : int option; push : int -> unit >", "tail": "no" } ] diff --git a/tests/test-dirs/type-enclosing/record.t/run.t b/tests/test-dirs/type-enclosing/record.t/run.t index aee28c9d48..49eb8f5c0b 100644 --- a/tests/test-dirs/type-enclosing/record.t/run.t +++ b/tests/test-dirs/type-enclosing/record.t/run.t @@ -95,9 +95,9 @@ }, "end": { "line": 8, - "col": 17 + "col": 9 }, - "type": "unit", + "type": "t", "tail": "no" } ] @@ -124,9 +124,9 @@ }, "end": { "line": 8, - "col": 17 + "col": 9 }, - "type": "type unit = ()", + "type": "type t = { mutable b : float; }", "tail": "no" } ] diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t index da5ab50a03..d091b4df86 100644 --- a/tests/test-dirs/type-enclosing/te-413-features.t +++ b/tests/test-dirs/type-enclosing/te-413-features.t @@ -21,13 +21,13 @@ Named existentials in patterns { "start": { "line": 3, - "col": 51 + "col": 59 }, "end": { "line": 3, - "col": 65 + "col": 60 }, - "type": "unit", + "type": "a", "tail": "no" } ] diff --git a/tests/test-dirs/type-enclosing/te-modules.t b/tests/test-dirs/type-enclosing/te-modules.t new file mode 100644 index 0000000000..6d38e257a5 --- /dev/null +++ b/tests/test-dirs/type-enclosing/te-modules.t @@ -0,0 +1,232 @@ + $ cat >main.ml <<'EOF' + > module M = struct module N = struct let x = () let y = () end end + > module B = M.N + > EOF + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 2:7 -verbosity 0 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 7 + }, + "end": { + "line": 2, + "col": 8 + }, + "type": "(module M.N)", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + } + ], + "notifications": [] + } + + $ $MERLIN single type-enclosing -position 2:7 -verbosity 1 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 7 + }, + "end": { + "line": 2, + "col": 8 + }, + "type": "sig val x : unit val y : unit end", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + } + ], + "notifications": [] + } + + $ cat >main.ml <<'EOF' + > module M = struct module N = List end + > module B = M.N + > EOF + +With index 0 only the first type is shown: + $ $MERLIN single type-enclosing -position 2:13 -verbosity 0 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": "(module List)", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } + + $ $MERLIN single type-enclosing -position 2:13 -verbosity 1 -index 0 \ + > -filename ./main.ml < ./main.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": "sig + type 'a t = 'a list = [] | (::) of 'a * 'a list + val length : 'a list -> int + val compare_lengths : 'a list -> 'b list -> int + val compare_length_with : 'a list -> int -> int + val cons : 'a -> 'a list -> 'a list + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val nth_opt : 'a list -> int -> 'a option + val rev : 'a list -> 'a list + val init : int -> (int -> 'a) -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool + val compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int + val iter : ('a -> unit) -> 'a list -> unit + val iteri : (int -> 'a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val filter_map : ('a -> 'b option) -> 'a list -> 'b list + val concat_map : ('a -> 'b list) -> 'a list -> 'b list + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val find_opt : ('a -> bool) -> 'a list -> 'a option + val find_map : ('a -> 'b option) -> 'a list -> 'b option + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val filteri : (int -> 'a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val partition_map : + ('a -> ('b, 'c) Either.t) -> 'a list -> 'b list * 'c list + val assoc : 'a -> ('a * 'b) list -> 'b + val assoc_opt : 'a -> ('a * 'b) list -> 'b option + val assq : 'a -> ('a * 'b) list -> 'b + val assq_opt : 'a -> ('a * 'b) list -> 'b option + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + val to_seq : 'a list -> 'a Seq.t + val of_seq : 'a Seq.t -> 'a list + end", + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 1, + "tail": "no" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": 2, + "tail": "no" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/type-enclosing/types.t/run.t b/tests/test-dirs/type-enclosing/types.t/run.t index d86ca72e2c..cf9d7175a1 100644 --- a/tests/test-dirs/type-enclosing/types.t/run.t +++ b/tests/test-dirs/type-enclosing/types.t/run.t @@ -30,6 +30,18 @@ $ $MERLIN single type-enclosing -position 5:11 -verbosity 1 \ > -filename ./types.ml < ./types.ml | jq ".value" [ + { + "start": { + "line": 5, + "col": 10 + }, + "end": { + "line": 5, + "col": 11 + }, + "type": "type x = Foo", + "tail": "no" + }, { "start": { "line": 5, From 162aa667132c897c2b7b0fbe425fc3efdabe38f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 26 Nov 2024 17:15:46 +0100 Subject: [PATCH 40/42] Prepare release 4.18-414 --- CHANGES.md | 5 +++-- merlin.opam | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 79b9a484e0..ab2a6b5b64 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,6 @@ -unreleased -========== +merlin 4.18 +=========== +Tue Nov 26 17:30:42 CET 2024 + merlin binary - Respect the `EXCLUDE_QUERY_DIR` configuration directive when looking for diff --git a/merlin.opam b/merlin.opam index afa0566dbd..ce139c5f55 100644 --- a/merlin.opam +++ b/merlin.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "merlin-lib" {= version} - "dot-merlin-reader" {>= "4.17"} + "dot-merlin-reader" {= "4.17.1-414"} "yojson" {>= "2.0.0"} "conf-jq" {with-test} "ppxlib" {with-test} From ee816ec3b811e4acc59abf251d8f94598769330e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 26 Nov 2024 17:25:20 +0100 Subject: [PATCH 41/42] Remove strict dependency on dot-merlin-reader --- merlin.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/merlin.opam b/merlin.opam index ce139c5f55..1b9f0a718e 100644 --- a/merlin.opam +++ b/merlin.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "merlin-lib" {= version} - "dot-merlin-reader" {= "4.17.1-414"} + "dot-merlin-reader" {>= "4.17.1"} "yojson" {>= "2.0.0"} "conf-jq" {with-test} "ppxlib" {with-test} From e09ade6d40dfb7f5c566bc3366057b27f05ca628 Mon Sep 17 00:00:00 2001 From: Jonah Beckford <9566106-jonahbeckford@users.noreply.gitlab.com> Date: Sat, 30 Nov 2024 18:43:30 -0800 Subject: [PATCH 42/42] Presence of .merlin.skip-if-not-cwd skips config in dir Mitigation for https://github.com/ocaml/merlin/issues 1869 --- src/kernel/mconfig_dot.ml | 41 +++++++++++++++++++++++++------------- src/kernel/mconfig_dot.mli | 10 +++++++++- 2 files changed, 36 insertions(+), 15 deletions(-) diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index d7817f7b2a..19280cd166 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -404,25 +404,38 @@ let find_project_context start_dir = then Some dir else None in + let cwd = Sys.getcwd () in + let cwd = Misc.canonicalize_filename ~cwd cwd 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] + (List.find_map [ + ".merlin.skip-if-not-cwd"; + ".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 ( + (* Special case: + 1. exists .merlin.skip-if-not-cwd + 2. not cwd (aka. `cwd <> dir`) *) + if f = ".merlin.skip-if-not-cwd" then ( + if cwd <> Misc.canonicalize_filename ~cwd dir then + raise Not_found + else None) + else + (* 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)) + 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 diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 6afdd8026c..116bf8e738 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -80,6 +80,14 @@ val get_config : context -> string -> config * string list - 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. + 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. + + The presence of the file [".merlin.skip-if-not-cwd"] in a directory means + that the three (3) project configuration files are {b not} checked if the + directory containing [".merlin.skip-if-not-cwd"] is not the current + working directory. *) val find_project_context : string -> (context * string) option