From 48c0d742824c01b36a20428cfc8f87ad7381870b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 23 Sep 2024 12:15:23 +0200 Subject: [PATCH 1/7] Add ocamlformat configuration and CI check. --- .github/workflows/main.yml | 7 +++++++ .ocamlformat | 11 +++++++++++ .ocamlformat-ignore | 3 +++ dune-project | 2 +- 4 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 .ocamlformat create mode 100644 .ocamlformat-ignore diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 76cb71a02..cd1822c4d 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -81,3 +81,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 000000000..2f1d4222b --- /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 000000000..c3c00a5b6 --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1,3 @@ +src/ocaml/** +src/utils/** +upstream/** diff --git a/dune-project b/dune-project index 429aa69d7..c9dc32f34 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) From b07f50c21633f89c419a3ad4abae2fab34a002a8 Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Tue, 24 Sep 2024 14:41:43 +0200 Subject: [PATCH 2/7] Allow whitelisting files to be formatted --- .ocamlformat-ignore | 2 -- src/ocaml/.ocamlformat | 1 + src/ocaml/typing/.ocamlformat-enable | 2 ++ src/utils/.ocamlformat | 1 + src/utils/.ocamlformat-enable | 2 ++ 5 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 src/ocaml/.ocamlformat create mode 100644 src/ocaml/typing/.ocamlformat-enable create mode 100644 src/utils/.ocamlformat create mode 100644 src/utils/.ocamlformat-enable diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore index c3c00a5b6..3de980a47 100644 --- a/.ocamlformat-ignore +++ b/.ocamlformat-ignore @@ -1,3 +1 @@ -src/ocaml/** -src/utils/** upstream/** diff --git a/src/ocaml/.ocamlformat b/src/ocaml/.ocamlformat new file mode 100644 index 000000000..e3346c163 --- /dev/null +++ b/src/ocaml/.ocamlformat @@ -0,0 +1 @@ +disable=true diff --git a/src/ocaml/typing/.ocamlformat-enable b/src/ocaml/typing/.ocamlformat-enable new file mode 100644 index 000000000..a7338db29 --- /dev/null +++ b/src/ocaml/typing/.ocamlformat-enable @@ -0,0 +1,2 @@ +msupport.ml +msupport.mli diff --git a/src/utils/.ocamlformat b/src/utils/.ocamlformat new file mode 100644 index 000000000..e3346c163 --- /dev/null +++ b/src/utils/.ocamlformat @@ -0,0 +1 @@ +disable=true diff --git a/src/utils/.ocamlformat-enable b/src/utils/.ocamlformat-enable new file mode 100644 index 000000000..a7338db29 --- /dev/null +++ b/src/utils/.ocamlformat-enable @@ -0,0 +1,2 @@ +msupport.ml +msupport.mli From 580d26a379a198bed352f5e67342bccd6b71d318 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 24 Sep 2024 14:42:41 +0200 Subject: [PATCH 3/7] Format more of Merlin's specific files --- src/ocaml/.ocamlformat-enable | 1 + src/ocaml/parsing/.ocamlformat-enable | 1 + src/utils/.ocamlformat | 1 - src/utils/.ocamlformat-enable | 2 -- src/utils/.ocamlformat-ignore | 4 ++++ 5 files changed, 6 insertions(+), 3 deletions(-) create mode 100644 src/ocaml/.ocamlformat-enable create mode 100644 src/ocaml/parsing/.ocamlformat-enable delete mode 100644 src/utils/.ocamlformat delete mode 100644 src/utils/.ocamlformat-enable create mode 100644 src/utils/.ocamlformat-ignore diff --git a/src/ocaml/.ocamlformat-enable b/src/ocaml/.ocamlformat-enable new file mode 100644 index 000000000..23f379d2c --- /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 000000000..34e266974 --- /dev/null +++ b/src/ocaml/parsing/.ocamlformat-enable @@ -0,0 +1 @@ +msupport_parsing.ml diff --git a/src/utils/.ocamlformat b/src/utils/.ocamlformat deleted file mode 100644 index e3346c163..000000000 --- a/src/utils/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable=true diff --git a/src/utils/.ocamlformat-enable b/src/utils/.ocamlformat-enable deleted file mode 100644 index a7338db29..000000000 --- a/src/utils/.ocamlformat-enable +++ /dev/null @@ -1,2 +0,0 @@ -msupport.ml -msupport.mli diff --git a/src/utils/.ocamlformat-ignore b/src/utils/.ocamlformat-ignore new file mode 100644 index 000000000..430454161 --- /dev/null +++ b/src/utils/.ocamlformat-ignore @@ -0,0 +1,4 @@ +misc.ml +misc.mli +stamped_hashtable.ml +stamped_hashtable.mli From 2824c76101f3c533554628e6e0360362435539fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 23 Sep 2024 17:14:10 +0200 Subject: [PATCH 4/7] Fix some comment blocking ocamlformat --- src/analysis/construct.ml | 2 +- src/analysis/destruct.ml | 4 ++-- src/kernel/mbrowse.ml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index 3af7fa775..bbbc3d4ce 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -477,8 +477,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/analysis/destruct.ml b/src/analysis/destruct.ml index 6306f4a30..bb83fde07 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -301,9 +301,9 @@ let rec get_every_pattern loc = function when Ident.name id = "*type-error*" -> raise (Ill_typed) | Expression { exp_desc = Typedtree.Texp_function (params, _body); _ } -> - (* So we need to deal with the case where we're either in the body of a - function, or in a function parameter. *) begin + (* So we need to deal with the case where we're either in the body of a + function, or in a function parameter. *) match List.find_some ~f:(fun param -> Location_aux.included ~into:param.Typedtree.fp_loc loc diff --git a/src/kernel/mbrowse.ml b/src/kernel/mbrowse.ml index 9ee7c27f8..6fbea1c95 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 From 40e0cdb95ff31b81212109fada6e0ff93b6eefee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 24 Sep 2024 15:00:06 +0200 Subject: [PATCH 5/7] Format the codebase --- src/analysis/ast_iterators.ml | 236 +-- src/analysis/browse_misc.ml | 182 +- src/analysis/browse_tree.ml | 81 +- src/analysis/browse_tree.mli | 65 +- src/analysis/completion.ml | 846 ++++----- src/analysis/completion.mli | 92 +- src/analysis/construct.ml | 484 +++--- src/analysis/construct.mli | 14 +- src/analysis/context.ml | 116 +- src/analysis/context.mli | 44 +- src/analysis/destruct.ml | 792 +++++---- src/analysis/destruct.mli | 49 +- src/analysis/env_lookup.ml | 189 +- src/analysis/env_lookup.mli | 42 +- src/analysis/expansion.ml | 64 +- src/analysis/index_occurrences.ml | 116 +- src/analysis/inlay_hints.ml | 154 +- src/analysis/inlay_hints.mli | 14 +- src/analysis/jump.ml | 204 +-- src/analysis/jump.mli | 48 +- src/analysis/locate.ml | 832 ++++----- src/analysis/locate.mli | 156 +- src/analysis/misc_utils.ml | 37 +- src/analysis/misc_utils.mli | 6 +- src/analysis/ocamldoc.ml | 65 +- src/analysis/occurrences.ml | 233 +-- src/analysis/occurrences.mli | 19 +- src/analysis/outline.ml | 207 +-- src/analysis/outline.mli | 40 +- src/analysis/polarity_search.ml | 119 +- src/analysis/ppx_expand.ml | 141 +- src/analysis/ptyp_of_type.ml | 203 +-- 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 | 126 +- src/analysis/tail_analysis.mli | 46 +- src/analysis/type_enclosing.ml | 166 +- src/analysis/type_utils.ml | 318 ++-- src/analysis/type_utils.mli | 93 +- src/analysis/typedtree_utils.ml | 51 +- src/analysis/typedtree_utils.mli | 10 +- 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 | 538 +++--- src/dot-protocol/merlin_dot_protocol.ml | 123 +- 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 | 36 +- 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 | 750 ++++---- src/frontend/query_commands.mli | 41 +- src/frontend/query_protocol.ml | 385 ++-- src/frontend/test/ocamlmerlin_test.ml | 215 ++- src/index-format/index_format.ml | 28 +- src/index-format/index_format.mli | 27 +- src/kernel/extension.ml | 163 +- src/kernel/extension.mli | 57 +- src/kernel/mbrowse.ml | 200 +-- src/kernel/mbrowse.mli | 50 +- src/kernel/mconfig.ml | 1254 +++++++------- src/kernel/mconfig.mli | 130 +- src/kernel/mconfig_dot.ml | 467 +++-- src/kernel/mconfig_dot.mli | 96 +- src/kernel/mocaml.ml | 105 +- src/kernel/mocaml.mli | 3 +- src/kernel/mpipeline.ml | 406 ++--- src/kernel/mpipeline.mli | 2 +- src/kernel/mppx.ml | 25 +- 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 | 240 +-- src/kernel/mtyper.mli | 23 +- src/kernel/phase_cache.ml | 54 +- src/kernel/phase_cache.mli | 18 +- src/ocaml-index/bin/ocaml_index.ml | 93 +- src/ocaml-index/lib/index.ml | 107 +- src/ocaml-index/lib/log.ml | 5 +- src/ocaml/merlin_specific/browse_raw.ml | 1215 ++++++------- src/ocaml/merlin_specific/browse_raw.mli | 147 +- src/ocaml/merlin_specific/tast_helper.ml | 14 +- src/ocaml/merlin_specific/typer_raw.ml | 45 +- src/ocaml/merlin_specific/typer_raw.mli | 40 +- src/ocaml/parsing/msupport_parsing.ml | 6 +- src/ocaml/typing/msupport.ml | 141 +- 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 | 580 +++---- 134 files changed, 10432 insertions(+), 10763 deletions(-) diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml index 97aba7677..8f9e0feaf 100644 --- a/src/analysis/ast_iterators.ml +++ b/src/analysis/ast_iterators.ml @@ -1,124 +1,144 @@ open Std open Typedtree -let {Logger. log} = Logger.for_section "iterators" +let { Logger.log } = Logger.for_section "iterators" (* Sometimes we do not want to iterate on nodes that do not correspond to actual syntax such as the ones introduced by PPXes with the `merlin.hide` attribute. *) let iter_only_visible iter = let has_attribute ~name attrs = - List.exists ~f:(fun a -> - let (str,_) = Ast_helper.Attr.as_tuple a in - str.Location.txt = name - ) attrs - in - let not_hidden attrs = - not (has_attribute ~name:"merlin.hide" attrs) + List.exists + ~f:(fun a -> + let str, _ = Ast_helper.Attr.as_tuple a in + str.Location.txt = name) + attrs in + let not_hidden attrs = not (has_attribute ~name:"merlin.hide" attrs) in let not_hidden_node node = not (Browse_raw.has_attr ~name:"merlin.hide" node) in - Tast_iterator.{ iter with - class_declaration = (fun sub ({ ci_attributes; _ } as cl) -> - if not_hidden ci_attributes then iter.class_declaration sub cl); - class_description = (fun sub ({ ci_attributes; _ } as cl) -> - if not_hidden ci_attributes then iter.class_description sub cl); - class_expr = (fun sub ({ cl_attributes; _ } as cl) -> - if not_hidden cl_attributes then iter.class_expr sub cl); - class_field = (fun sub ({ cf_attributes; _ } as cl) -> - if not_hidden cf_attributes then iter.class_field sub cl); - class_type = (fun sub ({ cltyp_attributes; _ } as cl) -> - if not_hidden cltyp_attributes then iter.class_type sub cl); - class_type_declaration = (fun sub ({ ci_attributes; _ } as cl) -> - if not_hidden ci_attributes then iter.class_type_declaration sub cl); - class_type_field = (fun sub ({ ctf_attributes; _ } as cl) -> - if not_hidden ctf_attributes then iter.class_type_field sub cl); - - expr = (fun sub ({ exp_attributes; _ } as e) -> - if not_hidden exp_attributes then iter.expr sub e); - extension_constructor = (fun sub ({ ext_attributes; _ } as e) -> - if not_hidden ext_attributes then iter.extension_constructor sub e); - - include_description = (fun sub ({ incl_attributes; _ } as incl) -> - if not_hidden incl_attributes then iter.include_description sub incl); - include_declaration = (fun sub ({ incl_attributes; _ } as incl) -> - if not_hidden incl_attributes then iter.include_declaration sub incl); - - module_binding = (fun sub ({ mb_attributes; _ } as mb) -> - if not_hidden mb_attributes then iter.module_binding sub mb); - module_declaration = (fun sub ({ md_attributes; _ } as m) -> - if not_hidden md_attributes then iter.module_declaration sub m); - module_substitution = (fun sub ({ ms_attributes; _ } as m) -> - if not_hidden ms_attributes then iter.module_substitution sub m); - module_expr = (fun sub ({ mod_attributes; _ } as m) -> - if not_hidden mod_attributes then iter.module_expr sub m); - module_type = (fun sub ({ mty_attributes; _ } as m) -> - if not_hidden mty_attributes then iter.module_type sub m); - module_type_declaration = (fun sub ({ mtd_attributes; _ } as m) -> - if not_hidden mtd_attributes then iter.module_type_declaration sub m); - - pat = (fun sub ({ pat_attributes; _ } as p) -> - if not_hidden pat_attributes then iter.pat sub p); - row_field = (fun sub ({ rf_attributes; _ } as p) -> - if not_hidden rf_attributes then iter.row_field sub p); - object_field = (fun sub ({ of_attributes; _ } as p) -> - if not_hidden of_attributes then iter.object_field sub p); - - open_declaration = (fun sub ({ open_attributes; _ } as p) -> - if not_hidden open_attributes then iter.open_declaration sub p); - open_description = (fun sub ({ open_attributes; _ } as p) -> - if not_hidden open_attributes then iter.open_description sub p); - - signature_item = (fun sub si -> - if not_hidden_node (Signature_item (si, Env.empty)) then - iter.signature_item sub si); - structure_item = (fun sub si -> - if not_hidden_node (Structure_item (si, Env.empty)) then - iter.structure_item sub si); - - typ = (fun sub ({ ctyp_attributes; _ } as t) -> - if not_hidden ctyp_attributes then iter.typ sub t); - type_declaration = (fun sub ({ typ_attributes; _ } as t) -> - if not_hidden typ_attributes then iter.type_declaration sub t); - type_extension = (fun sub ({ tyext_attributes; _ } as t) -> - if not_hidden tyext_attributes then iter.type_extension sub t); - type_exception = (fun sub ({ tyexn_attributes; _ } as t) -> - if not_hidden tyexn_attributes then iter.type_exception sub t); - - value_binding = (fun sub ({ vb_attributes; _ } as vb) -> - if not_hidden vb_attributes then iter.value_binding sub vb); - value_description = (fun sub ({ val_attributes; _ } as vb) -> - if not_hidden val_attributes then iter.value_description sub vb); - } + Tast_iterator. + { iter with + class_declaration = + (fun sub ({ ci_attributes; _ } as cl) -> + if not_hidden ci_attributes then iter.class_declaration sub cl); + class_description = + (fun sub ({ ci_attributes; _ } as cl) -> + if not_hidden ci_attributes then iter.class_description sub cl); + class_expr = + (fun sub ({ cl_attributes; _ } as cl) -> + if not_hidden cl_attributes then iter.class_expr sub cl); + class_field = + (fun sub ({ cf_attributes; _ } as cl) -> + if not_hidden cf_attributes then iter.class_field sub cl); + class_type = + (fun sub ({ cltyp_attributes; _ } as cl) -> + if not_hidden cltyp_attributes then iter.class_type sub cl); + class_type_declaration = + (fun sub ({ ci_attributes; _ } as cl) -> + if not_hidden ci_attributes then iter.class_type_declaration sub cl); + class_type_field = + (fun sub ({ ctf_attributes; _ } as cl) -> + if not_hidden ctf_attributes then iter.class_type_field sub cl); + expr = + (fun sub ({ exp_attributes; _ } as e) -> + if not_hidden exp_attributes then iter.expr sub e); + extension_constructor = + (fun sub ({ ext_attributes; _ } as e) -> + if not_hidden ext_attributes then iter.extension_constructor sub e); + include_description = + (fun sub ({ incl_attributes; _ } as incl) -> + if not_hidden incl_attributes then iter.include_description sub incl); + include_declaration = + (fun sub ({ incl_attributes; _ } as incl) -> + if not_hidden incl_attributes then iter.include_declaration sub incl); + module_binding = + (fun sub ({ mb_attributes; _ } as mb) -> + if not_hidden mb_attributes then iter.module_binding sub mb); + module_declaration = + (fun sub ({ md_attributes; _ } as m) -> + if not_hidden md_attributes then iter.module_declaration sub m); + module_substitution = + (fun sub ({ ms_attributes; _ } as m) -> + if not_hidden ms_attributes then iter.module_substitution sub m); + module_expr = + (fun sub ({ mod_attributes; _ } as m) -> + if not_hidden mod_attributes then iter.module_expr sub m); + module_type = + (fun sub ({ mty_attributes; _ } as m) -> + if not_hidden mty_attributes then iter.module_type sub m); + module_type_declaration = + (fun sub ({ mtd_attributes; _ } as m) -> + if not_hidden mtd_attributes then iter.module_type_declaration sub m); + pat = + (fun sub ({ pat_attributes; _ } as p) -> + if not_hidden pat_attributes then iter.pat sub p); + row_field = + (fun sub ({ rf_attributes; _ } as p) -> + if not_hidden rf_attributes then iter.row_field sub p); + object_field = + (fun sub ({ of_attributes; _ } as p) -> + if not_hidden of_attributes then iter.object_field sub p); + open_declaration = + (fun sub ({ open_attributes; _ } as p) -> + if not_hidden open_attributes then iter.open_declaration sub p); + open_description = + (fun sub ({ open_attributes; _ } as p) -> + if not_hidden open_attributes then iter.open_description sub p); + signature_item = + (fun sub si -> + if not_hidden_node (Signature_item (si, Env.empty)) then + iter.signature_item sub si); + structure_item = + (fun sub si -> + if not_hidden_node (Structure_item (si, Env.empty)) then + iter.structure_item sub si); + typ = + (fun sub ({ ctyp_attributes; _ } as t) -> + if not_hidden ctyp_attributes then iter.typ sub t); + type_declaration = + (fun sub ({ typ_attributes; _ } as t) -> + if not_hidden typ_attributes then iter.type_declaration sub t); + type_extension = + (fun sub ({ tyext_attributes; _ } as t) -> + if not_hidden tyext_attributes then iter.type_extension sub t); + type_exception = + (fun sub ({ tyexn_attributes; _ } as t) -> + if not_hidden tyexn_attributes then iter.type_exception sub t); + value_binding = + (fun sub ({ vb_attributes; _ } as vb) -> + if not_hidden vb_attributes then iter.value_binding sub vb); + value_description = + (fun sub ({ val_attributes; _ } as vb) -> + if not_hidden val_attributes then iter.value_description sub vb) + } (* The compiler contains an iterator that aims to gather definitions but -ignores local values like let-in expressions and local type definition. To -provide occurrences in the active buffer we extend the compiler's iterator with -these cases. *) + ignores local values like let-in expressions and local type definition. To + provide occurrences in the active buffer we extend the compiler's iterator with + these cases. *) let iter_on_defs ~uid_to_locs_tbl = let log = log ~title:"iter_on_defs" in let register_uid uid fragment = let loc = Typedtree_utils.location_of_declaration ~uid fragment in - Option.iter loc ~f:(fun loc -> - Types.Uid.Tbl.add uid_to_locs_tbl uid loc) + Option.iter loc ~f:(fun loc -> Types.Uid.Tbl.add uid_to_locs_tbl uid loc) in let iter_decl = Cmt_format.iter_on_declarations ~f:register_uid in - let register_uid uid loc = - Types.Uid.Tbl.add uid_to_locs_tbl uid loc - in + let register_uid uid loc = Types.Uid.Tbl.add uid_to_locs_tbl uid loc in { iter_decl with - expr = (fun sub ({ exp_extra; _ } as expr) -> - List.iter exp_extra ~f:(fun (exp_extra, _loc, _attr) -> - match exp_extra with - | Texp_newtype' (typ_id, typ_name, uid) -> - log "Found newtype %s wit id %a (%a)\n%!" typ_name.txt - Logger.fmt (Fun.flip Ident.print_with_scope typ_id) - Logger.fmt (fun fmt -> Location.print_loc fmt typ_name.loc); - register_uid uid typ_name; - () - | _ -> ()); - iter_decl.expr sub expr); + expr = + (fun sub ({ exp_extra; _ } as expr) -> + List.iter exp_extra ~f:(fun (exp_extra, _loc, _attr) -> + match exp_extra with + | Texp_newtype' (typ_id, typ_name, uid) -> + log "Found newtype %s wit id %a (%a)\n%!" typ_name.txt Logger.fmt + (Fun.flip Ident.print_with_scope typ_id) Logger.fmt (fun fmt -> + Location.print_loc fmt typ_name.loc); + register_uid uid typ_name; + () + | _ -> ()); + iter_decl.expr sub expr) } let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () = @@ -126,19 +146,21 @@ let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () = Types.Uid.Tbl.create 64 in let iter = iter_on_defs ~uid_to_locs_tbl in - begin match local_defs with - | `Interface sign -> - iter.signature iter sign - | `Implementation str -> - iter.structure iter str end; + begin + match local_defs with + | `Interface sign -> iter.signature iter sign + | `Implementation str -> iter.structure iter str + end; uid_to_locs_tbl let iter_on_usages ~f (local_defs : Mtyper.typedtree) = let occ_iter = Cmt_format.iter_on_occurrences ~f in let iter = iter_only_visible occ_iter in - begin match local_defs with - | `Interface signature -> iter.signature iter signature - | `Implementation structure -> iter.structure iter structure end + begin + match local_defs with + | `Interface signature -> iter.signature iter signature + | `Implementation structure -> iter.structure iter structure + end let iterator_on_usages ~f = let occ_iter = Cmt_format.iter_on_occurrences ~f in diff --git a/src/analysis/browse_misc.ml b/src/analysis/browse_misc.ml index 3b81949b2..596888579 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 65f205b54..e7c85cd8e 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,31 +54,31 @@ 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 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 48c1c33d3..cbf8981cb 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,6 +41,7 @@ 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 diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml index f3d66c683..9e8753589 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 -> Shape.Sig_component_kind.Value | `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,66 +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 ~fixed:false lbl in - begin try - Ctype.unify_var env ty lbl_res; - with _ -> () + 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 @@ -685,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 @@ -698,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. @@ -803,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 7d379295d..d86dd890d 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 Env_lookup.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 Env_lookup.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 bbbc3d4ce..19745acea 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,74 +327,73 @@ 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 let make_param arg_label pat = - { - Parsetree.pparam_loc = Location.none; + { Parsetree.pparam_loc = Location.none; pparam_desc = Pparam_val (arg_label, None, pat) - } in match label with | Labelled s | Optional s -> - (* Pun for labelled arguments *) - make_param label (Ast_helper.Pat.var (Location.mknoloc s)), s - | Nolabel -> begin match get_desc ty with + (* Pun for labelled arguments *) + (make_param label (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 - make_param label (Ast_helper.Pat.var (Location.mknoloc name)), name - | _ -> make_param label (Ast_helper.Pat.any ()), "_" end + (make_param label (Ast_helper.Pat.var (Location.mknoloc name)), name) + | _ -> (make_param label (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 - Keep_existentials_flexible - cstr_descr + let ty_args, ty_res, _ = + Ctype.instance_constructor Keep_existentials_flexible 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 @@ -402,10 +407,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. @@ -416,105 +421,98 @@ 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 ~fixed: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 ~fixed: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 _ -> let rec left_types acc env ty = match get_desc ty with | Tarrow (label, tyleft, tyright, _) -> let arg, 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 left_types (arg :: acc) env tyright - | _ -> List.rev acc, ty, env - in + | _ -> (List.rev acc, ty, env) + in let arguments, body_type, env = left_types [] env rtyp in let exps = arrow_rhs env body_type in List.map exps ~f:(fun e -> - Ast_helper.Exp.function_ arguments None (Pfunction_body e)) + Ast_helper.Exp.function_ arguments None (Pfunction_body e)) | 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 @@ -530,7 +528,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 @@ -538,22 +537,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 = @@ -565,43 +566,36 @@ module Gen = struct List.append constructed_from_type matching_values end -let needs_parentheses e = match e.Parsetree.pexp_desc with - | Pexp_function _ - | Pexp_lazy _ - | Pexp_apply _ +let needs_parentheses e = + match e.Parsetree.pexp_desc with + | Pexp_function _ | 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 668e18685..68d0e8b9e 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 cdcdc9f4e..9af52030e 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" @@ -155,17 +138,14 @@ let inspect_browse_tree ~cursor lid browse : t option = | Module_binding_name _ | Module_declaration_name _ | Label_declaration _ - | Constructor_declaration _ -> - None - | Module_expr _ - | Open_description _ -> Some Module_path + | Constructor_declaration _ -> 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 6884f8d32..d6707abb1 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 bb83fde07..bae8b20ab 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,80 +35,76 @@ 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 - (Uid.internal_not_actually_unique) - 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 Uid.internal_not_actually_unique env type_expr + (mk_var lbl_descr.lbl_name) )) in [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ] | Type_variant (constructors, _) -> @@ -122,215 +118,218 @@ let rec gen_patterns ?(recurse=true) env type_expr = let snap = Btype.snapshot () in let res = try - ignore ( - let pattern_env = Ctype.Pattern_env.make env - ~equations_scope:0 - ~allow_recursive_equations:true - in - Ctype.unify_gadt pattern_env type_expr typ - ); + ignore + (let pattern_env = + Ctype.Pattern_env.make env ~equations_scope:0 + ~allow_recursive_equations:true + in + Ctype.unify_gadt pattern_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. *) + (* We are after the "in" keyword, we need to look at the parent of the + binding. *) | Texp_function (_, Tfunction_body _) - (* The assumption here is that we're not in a [function ... | ...] - situation but either in [fun param] or [let name param]. *) - -> + (* 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 loc, patterns + 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) let collect_function_pattern loc param_pattern = match param_pattern.Typedtree.fp_kind with - | Typedtree.Tparam_pat pattern -> - loc, [pattern] - | Typedtree.Tparam_optional_default _ -> - raise (Not_allowed "value_binding") + | Typedtree.Tparam_pat pattern -> (loc, [ pattern ]) + | Typedtree.Tparam_optional_default _ -> raise (Not_allowed "value_binding") let rec get_every_pattern loc = 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 loc 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 { exp_desc = Typedtree.Texp_function (params, _body); _ } -> - begin - (* So we need to deal with the case where we're either in the body of a - function, or in a function parameter. *) - match - List.find_some ~f:(fun param -> - Location_aux.included ~into:param.Typedtree.fp_loc loc - ) params with - | Some pattern -> - (* In parameter case *) - collect_function_pattern loc pattern - | None -> - (* In function body *) - collect_every_pattern_for_expression parent - end + begin + (* So we need to deal with the case where we're either in the body of a + function, or in a function parameter. *) + match + List.find_some + ~f:(fun param -> + Location_aux.included ~into:param.Typedtree.fp_loc loc) + params + with + | Some pattern -> + (* In parameter case *) + collect_function_pattern loc pattern + | None -> + (* In function body *) + collect_every_pattern_for_expression parent + end | 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 @@ -339,77 +338,69 @@ 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,uid) -> - { patt with pat_desc = Tpat_alias (f p, x, y,uid) } - | 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, uid) -> + { patt with pat_desc = Tpat_alias (f p, x, y, uid) } + | 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,uid) -> - { patt with pat_desc = Tpat_alias (f p, x, y,uid) } - | 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, uid) -> + { patt with pat_desc = Tpat_alias (f p, x, y, uid) } + | 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 = @@ -420,19 +411,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 *) - let (_, labels) = unmangling_tables in - (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))) + let _, labels = unmangling_tables in + 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)) in let closed = if List.length labels > 0 then @@ -450,19 +437,21 @@ let rec qualify_constructors ~unmangling_tables f pat = (* Un-mangle *) let name = let constrs, _ = unmangling_tables in - (match Hashtbl.find_opt constrs name with - | Some cstr_des -> cstr_des.Types.cstr_name - | None -> name) + match Hashtbl.find_opt constrs name with + | Some cstr_des -> cstr_des.Types.cstr_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 @@ -474,33 +463,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 Nothing_to_do - | 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 @@ -509,20 +492,21 @@ 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 (* conversion from Typedtree.pattern to Parsetree.pattern list *) module Conv = struct @@ -543,75 +527,70 @@ module Conv = struct let labels = Hashtbl.create 7 in let rec loop pat = match pat.pat_desc with - Tpat_or (pa,pb,_) -> - mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"; _} as nm), _) -> (* PR#7330 *) - mkpat (Ppat_var nm) - | Tpat_any - | Tpat_var _ -> - mkpat Ppat_any - | Tpat_constant c -> - mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p,_,_,_) -> loop p - | Tpat_tuple lst -> - mkpat (Ppat_tuple (List.map ~f:loop lst)) + | Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb)) + | Tpat_var (_, ({ txt = "*extension*"; _ } as nm), _) -> + (* PR#7330 *) + mkpat (Ppat_var nm) + | Tpat_any | Tpat_var _ -> mkpat Ppat_any + | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) + | Tpat_alias (p, _, _, _) -> loop p + | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map ~f:loop lst)) | Tpat_construct (cstr_lid, cstr, lst, _) -> - let id = fresh cstr.cstr_name in - let lid = { cstr_lid with txt = Longident.Lident id } in - Hashtbl.add constrs id cstr; - let arg = - match List.map ~f:loop lst with - | [] -> None - | [p] -> Some ([], p) - | lst -> Some ([], mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct(lid, arg)) - | Tpat_variant(label,p_opt,_row_desc) -> - let arg = Option.map ~f:loop p_opt in - mkpat (Ppat_variant(label, arg)) + let id = fresh cstr.cstr_name in + let lid = { cstr_lid with txt = Longident.Lident id } in + Hashtbl.add constrs id cstr; + let arg = + match List.map ~f:loop lst with + | [] -> None + | [ p ] -> Some ([], p) + | lst -> Some ([], mkpat (Ppat_tuple lst)) + in + mkpat (Ppat_construct (lid, arg)) + | Tpat_variant (label, p_opt, _row_desc) -> + let arg = Option.map ~f:loop p_opt in + mkpat (Ppat_variant (label, arg)) | Tpat_record (subpatterns, _closed_flag) -> - let fields = - List.map - ~f:(fun (_, lbl, p) -> - let id = fresh lbl.lbl_name in - Hashtbl.add labels id lbl; - (mknoloc (Longident.Lident id), loop p)) - subpatterns - in - mkpat (Ppat_record (fields, Open)) - | Tpat_array lst -> - mkpat (Ppat_array (List.map ~f:loop lst)) - | Tpat_lazy p -> - mkpat (Ppat_lazy (loop p)) + let fields = + List.map + ~f:(fun (_, lbl, p) -> + let id = fresh lbl.lbl_name in + Hashtbl.add labels id lbl; + (mknoloc (Longident.Lident id), loop p)) + subpatterns + in + mkpat (Ppat_record (fields, Open)) + | Tpat_array lst -> mkpat (Ppat_array (List.map ~f:loop lst)) + | Tpat_lazy p -> mkpat (Ppat_lazy (loop p)) in let ps = loop typed in (ps, constrs, labels) end 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 } @@ -624,54 +603,58 @@ 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 -> - let _pat, constrs, labels = Conv.conv pat in - let unmangling_tables = constrs, labels in - (* 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 -> + let _pat, constrs, labels = Conv.conv pat in + let unmangling_tables = (constrs, labels) in + (* 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 parents patt config source 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 sub_patterns = let rev_before, after, top_patt = find_branch patterns patt in @@ -682,75 +665,72 @@ let refine_and_generate_branches patt config source patterns sub_patterns = 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) parents (patt: a Typedtree.general_pattern) +let refine_complete_match (type a) parents (patt : a Typedtree.general_pattern) config source 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 parents patt config source 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 loc 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 parents patt config source 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 + loc parents = let last_case_loc, patterns = get_every_pattern loc 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 in + let pred = + 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 parents patt config source 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 + | Expression expr -> destruct_expression loc config source parents expr | Pattern patt -> destruct_pattern patt config source loc parents - | node -> - raise (Not_allowed (string_of_node node)) + | node -> raise (Not_allowed (string_of_node node)) diff --git a/src/analysis/destruct.mli b/src/analysis/destruct.mli index c1958ffd3..f7f22df02 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/env_lookup.ml b/src/analysis/env_lookup.ml index 929ee982b..741b46056 100644 --- a/src/analysis/env_lookup.ml +++ b/src/analysis/env_lookup.ml @@ -1,5 +1,5 @@ open! Std -let {Logger. log} = Logger.for_section "env-lookup" +let { Logger.log } = Logger.for_section "env-lookup" module Namespace = struct type t = Shape.Sig_component_kind.t @@ -8,7 +8,8 @@ module Namespace = struct type under_type = [ `Constr | `Labels ] - type inferred_basic = (* TODO: share with [Namespace.t] *) + type inferred_basic = + (* TODO: share with [Namespace.t] *) [ `Type | `Mod | `Modtype | `Vals | under_type ] type inferred = @@ -17,22 +18,21 @@ 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 -type item = { - uid: Shape.Uid.t; - loc: Location.t; - namespace: Shape.Sig_component_kind.t -} +type item = + { uid : Shape.Uid.t; + loc : Location.t; + namespace : Shape.Sig_component_kind.t + } let by_path path (namespace : Namespace.t) env = try @@ -40,119 +40,112 @@ let by_path path (namespace : Namespace.t) env = match namespace with | Value -> let vd = Env.find_value path env in - vd.val_loc, vd.val_uid, Value - | (Type | Extension_constructor | Constructor | Label) -> + (vd.val_loc, vd.val_uid, Value) + | Type | Extension_constructor | Constructor | Label -> let td = Env.find_type path env in - td.type_loc, td.type_uid, Type + (td.type_loc, td.type_uid, Type) | Module -> let md = Env.find_module path env in - md.md_loc, md.md_uid, Module + (md.md_loc, md.md_uid, Module) | Module_type -> let mtd = Env.find_modtype path env in - mtd.mtd_loc, mtd.mtd_uid, Module_type + (mtd.mtd_loc, mtd.mtd_uid, Module_type) | Class -> let cty = Env.find_class path env in - cty.cty_loc, cty.cty_uid, Class + (cty.cty_loc, cty.cty_uid, Class) | Class_type -> let clty = Env.find_cltype path env in - clty.clty_loc, clty.clty_uid, Class + (clty.clty_loc, clty.clty_uid, Class) in Some { uid; loc; namespace } - with - Not_found -> None + 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 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 let by_longident (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 - log ~title:"lookup" "found path: %a" - Logger.fmt (fun fmt -> Path.print fmt path); - let path = Path.Pdot (path, cd.cstr_name) - in - raise (Found (path, Constructor, 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 - let path = Path.Pdot (path, cd.cstr_name) in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Constructor,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 - let path = Path.Pdot (path, lbl.lbl_name) - in - raise (Found (path, Label, 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 + log ~title:"lookup" "found path: %a" Logger.fmt (fun fmt -> + Path.print fmt path); + let path = Path.Pdot (path, cd.cstr_name) in + raise (Found (path, Constructor, 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 + let path = Path.Pdot (path, cd.cstr_name) in + (* TODO: Use [`Constr] here instead of [`Type] *) + raise (Found (path, Constructor, 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 + let path = Path.Pdot (path, lbl.lbl_name) in + raise (Found (path, Label, 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) -> - log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a" - Logger.fmt (fun fmt -> Path.print fmt path) + log ~title:"env_lookup" + "found: '%a' in namespace %s with decl_uid %a\nat loc %a" Logger.fmt + (fun fmt -> Path.print fmt path) (Shape.Sig_component_kind.to_string namespace) - Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid) - Logger.fmt (fun fmt -> Location.print_loc fmt loc); + Logger.fmt + (fun fmt -> Shape.Uid.print fmt decl_uid) + Logger.fmt + (fun fmt -> Location.print_loc fmt loc); Some (path, { uid = decl_uid; loc; namespace }) diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli index cca3499e5..514031416 100644 --- a/src/analysis/env_lookup.mli +++ b/src/analysis/env_lookup.mli @@ -13,36 +13,24 @@ module Namespace : sig val to_string : t -> string type under_type = [ `Constr | `Labels ] - type inferred_basic = - [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ] + type inferred_basic = [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ] type inferred = - [ `Constr - | `Labels - | `Mod - | `Modtype - | `This_cstr of Types.constructor_description - | `This_label of Types.label_description - | `Type - | `Vals ] + [ `Constr + | `Labels + | `Mod + | `Modtype + | `This_cstr of Types.constructor_description + | `This_label of Types.label_description + | `Type + | `Vals ] (** Returns potential namespaces given the context of an expression *) val from_context : Context.t -> inferred list end -type item = { - uid: Shape.Uid.t; - loc: Location.t; - namespace: Namespace.t -} - -val by_path - : Path.t - -> Namespace.t - -> Env.t - -> item option - -val by_longident - : Namespace.inferred list - -> Longident.t - -> Env.t - -> (Path.t * item) option +type item = { uid : Shape.Uid.t; loc : Location.t; namespace : Namespace.t } + +val by_path : Path.t -> Namespace.t -> Env.t -> item option + +val by_longident : + Namespace.inferred list -> Longident.t -> Env.t -> (Path.t * item) option diff --git a/src/analysis/expansion.ml b/src/analysis/expansion.ml index 05b905676..2c1cc7824 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/index_occurrences.ml b/src/analysis/index_occurrences.ml index 67d936bf7..0f5b00860 100644 --- a/src/analysis/index_occurrences.ml +++ b/src/analysis/index_occurrences.ml @@ -1,96 +1,96 @@ open Std module Lid_set = Index_format.Lid_set -let {Logger. log} = Logger.for_section "index-occurrences" +let { Logger.log } = Logger.for_section "index-occurrences" let set_fname ~file (loc : Location.t) = let pos_fname = file in { loc with - loc_start = { loc.loc_start with pos_fname }; - loc_end = { loc.loc_end with pos_fname }} + loc_start = { loc.loc_start with pos_fname }; + loc_end = { loc.loc_end with pos_fname } + } let decl_of_path_or_lid env namespace path lid = match (namespace : Shape.Sig_component_kind.t) with - | Constructor -> - begin match Env.find_constructor_by_name lid env with + | Constructor -> begin + match Env.find_constructor_by_name lid env with | exception Not_found -> None - | {cstr_uid; cstr_loc; _ } -> + | { cstr_uid; cstr_loc; _ } -> Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace } - end - | Label -> - begin match Env.find_label_by_name lid env with + end + | Label -> begin + match Env.find_label_by_name lid env with | exception Not_found -> None - | {lbl_uid; lbl_loc; _ } -> + | { lbl_uid; lbl_loc; _ } -> Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace } - end + end | _ -> Env_lookup.by_path path namespace env let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid = - let add uid loc = - Stamped_hashtable.add index ~stamp (uid, loc) () - in - let f ~namespace env path (lid : Longident.t Location.loc) = + let add uid loc = Stamped_hashtable.add index ~stamp (uid, loc) () in + let f ~namespace env path (lid : Longident.t Location.loc) = log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path); let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in let index_decl () = - begin match decl_of_path_or_lid env namespace path lid.txt with - | exception _ | None -> log ~title:"index_buffer" "Declaration not found" - | Some decl -> - log ~title:"index_buffer" "Found declaration: %a" - Logger.fmt (Fun.flip Location.print_loc decl.loc); - add decl.uid lid + begin + match decl_of_path_or_lid env namespace path lid.txt with + | (exception _) | None -> + log ~title:"index_buffer" "Declaration not found" + | Some decl -> + log ~title:"index_buffer" "Found declaration: %a" Logger.fmt + (Fun.flip Location.print_loc decl.loc); + add decl.uid lid end in - if not_ghost lid then + if not_ghost lid then match Env.shape_of_path ~namespace env path with | exception Not_found -> () | path_shape -> - log ~title:"index_buffer" "Shape of path: %a" - Logger.fmt (Fun.flip Shape.print path_shape); + log ~title:"index_buffer" "Shape of path: %a" Logger.fmt + (Fun.flip Shape.print path_shape); let result = reduce_for_uid env path_shape in - begin match Locate.uid_of_result ~traverse_aliases:false result with - | Some uid, false -> - log ~title:"index_buffer" "Found %a (%a) wiht uid %a" - Logger.fmt (Fun.flip Pprintast.longident lid.txt) - Logger.fmt (Fun.flip Location.print_loc lid.loc) - Logger.fmt (Fun.flip Shape.Uid.print uid); - add uid lid - | Some uid, true -> - log ~title:"index_buffer" "Shape is approximative, found uid: %a" - Logger.fmt (Fun.flip Shape.Uid.print uid); - index_decl () - | None, _ -> - log ~title:"index_buffer" "Reduction failed: missing uid"; - index_decl () + begin + match Locate.uid_of_result ~traverse_aliases:false result with + | Some uid, false -> + log ~title:"index_buffer" "Found %a (%a) wiht uid %a" Logger.fmt + (Fun.flip Pprintast.longident lid.txt) + Logger.fmt + (Fun.flip Location.print_loc lid.loc) + Logger.fmt + (Fun.flip Shape.Uid.print uid); + add uid lid + | Some uid, true -> + log ~title:"index_buffer" "Shape is approximative, found uid: %a" + Logger.fmt + (Fun.flip Shape.Uid.print uid); + index_decl () + | None, _ -> + log ~title:"index_buffer" "Reduction failed: missing uid"; + index_decl () end in Ast_iterators.iterator_on_usages ~f let items ~index ~stamp (config : Mconfig.t) items = - let module Shape_reduce = - Shape_reduce.Make (struct - let fuel = 10 + let module Shape_reduce = Shape_reduce.Make (struct + let fuel = 10 - let read_unit_shape ~unit_name = - log ~title:"read_unit_shape" "inspecting %s" unit_name; - let cmt = Format.sprintf "%s.cmt" unit_name in - match Cmt_cache.read (Load_path.find_normalized cmt) with - | { cmt_infos = { cmt_impl_shape; _ }; _ } -> - log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; - cmt_impl_shape - | exception _ -> - log ~title:"read_unit_shape" "failed to find %s" unit_name; - None - end) - in + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + let cmt = Format.sprintf "%s.cmt" unit_name in + match Cmt_cache.read (Load_path.find_normalized cmt) with + | { cmt_infos = { cmt_impl_shape; _ }; _ } -> + log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; + cmt_impl_shape + | exception _ -> + log ~title:"read_unit_shape" "failed to find %s" unit_name; + None + end) in let current_buffer_path = Filename.concat config.query.directory config.query.filename in let reduce_for_uid = Shape_reduce.reduce_for_uid in let iterator = iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid in match items with - | `Impl items -> - List.iter ~f:(iterator.structure_item iterator) items - | `Intf items -> - List.iter ~f:(iterator.signature_item iterator) items - + | `Impl items -> List.iter ~f:(iterator.structure_item iterator) items + | `Intf items -> List.iter ~f:(iterator.signature_item iterator) items diff --git a/src/analysis/inlay_hints.ml b/src/analysis/inlay_hints.ml index 26dfb4c34..9cec399ff 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 + | Typedtree.Tpat_unpack -> false) + pattern.pat_extra -let structure_iterator - hint_let_binding - hint_pattern_binding - avoid_ghost_location - typedtree - range - callback = - +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 @@ -72,9 +63,17 @@ let structure_iterator 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 (_, Tfunction_cases {cases = [ - { c_rhs = { exp_desc = Texp_let (_, [ {vb_pat; _} ], body); _ }; _ } - ]; _}) -> + | Texp_function + ( _, + Tfunction_cases + { cases = + [ { c_rhs = + { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ }; + _ + } + ]; + _ + } ) -> let () = log ~title:"expression" "on function" in let () = iterator.pat iterator vb_pat in iterator.expr iterator body @@ -90,8 +89,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 @@ -100,15 +99,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 @@ -118,56 +117,49 @@ let structure_iterator 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 + + 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 2bf52c953..575f8b777 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 246b4f85c..fd6ae9a4e 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 f42a950e9..8c244f92f 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 8b9a50b03..e1a06ee6a 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -1,57 +1,54 @@ (* {{{ 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" -type config = { - mconfig: Mconfig.t; - ml_or_mli: [ `ML | `MLI ]; - traverse_aliases: bool; -} +type config = + { mconfig : Mconfig.t; ml_or_mli : [ `ML | `MLI ]; traverse_aliases : bool } -type result = { - uid: Shape.Uid.t; - decl_uid: Shape.Uid.t; - file: string; - location: Location.t; - approximated: bool; -} +type result = + { uid : Shape.Uid.t; + decl_uid : Shape.Uid.t; + file : string; + location : Location.t; + approximated : bool + } 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 @@ -65,86 +62,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 @@ -165,13 +161,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 @@ -184,10 +180,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 @@ -200,14 +193,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 (* Reuse the code of [Misc.find_in_path_uncap] but returns all the files matching, instead of the first one. This is only used when looking for ml @@ -220,16 +212,17 @@ module Utils = struct let find_all_in_path_uncap ?src_suffix_pair ~with_fallback path file = let name = File.with_ext ?src_suffix_pair file in log ~title:"find_all_in_path_uncap" "Looking for file %S in path:\n%a" name - Logger.fmt (fun fmt -> Format.pp_print_list Format.pp_print_string fmt path); + Logger.fmt (fun fmt -> + Format.pp_print_list Format.pp_print_string fmt path); let uname = String.uncapitalize name in let fallback, ufallback = let alt = File.alternate file in let fallback = File.with_ext ?src_suffix_pair alt in - fallback, String.uncapitalize fallback + (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 = @@ -240,23 +233,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 @@ -264,8 +258,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_normalized ?fallback path fname) @@ -273,14 +266,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.cmt_path config + find_file_with_path ~config ?with_fallback file + @@ + match file with + | ML _ | MLI _ | MLL _ -> Mconfig.source_path config + | CMT _ | CMTI _ -> Mconfig.cmt_path config end let move_to filename cmt_infos = @@ -288,40 +281,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 ?(with_fallback = true) comp_unit = Preferences.set config.ml_or_mli; - let file = - Preferences.build comp_unit - in + let file = Preferences.build comp_unit in match Utils.find_file ~config:config.mconfig ~with_fallback 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 = @@ -329,11 +321,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 @@ -341,11 +332,11 @@ 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 @@ -358,7 +349,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 = @@ -384,78 +375,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 @@ -465,31 +452,34 @@ 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 : find_source_result) with | Found src -> `Found (src, loc) | 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) (** [find_loc_of_uid] uid's location are given by tables stored int he cmt files for external compilation units or computed by Merlin for the current buffer. @@ -497,33 +487,43 @@ let find_source ~config loc path = let find_loc_of_uid ~config ~local_defs uid comp_unit = let title = "find_loc_of_uid" in let loc_of_decl ~uid def = - match Typedtree_utils.location_of_declaration ~uid def with + match Typedtree_utils.location_of_declaration ~uid def with | Some loc -> - log ~title "Found location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc); + log ~title "Found location: %a" Logger.fmt (fun fmt -> + Location.print_loc fmt loc.loc); `Some (uid, loc.loc) - | None -> log ~title "The declaration has no location."; `None + | None -> + log ~title "The declaration has no location."; + `None in 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); - log ~title "Looking for %a in the uid_to_loc table" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + log ~title "We look for %a in the current compilation unit." Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + log ~title "Looking for %a in the uid_to_loc table" Logger.fmt (fun fmt -> + Shape.Uid.print fmt uid); let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in match Shape.Uid.Tbl.find_opt tbl uid with | Some { Location.loc; _ } -> `Some (uid, loc) - | None -> log ~title "Uid not found in the local table."; `None - end else begin + | None -> + log ~title "Uid not found in the local table."; + `None + end + else begin log ~title "Loading the cmt file for unit %S" comp_unit; match load_cmt ~config comp_unit with | Ok (_pos_fname, cmt) -> - log ~title "Shapes successfully loaded, looking for %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with + log ~title "Shapes successfully loaded, looking for %a" Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + begin + match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with | Some decl -> loc_of_decl ~uid decl - | None -> log ~title "Uid not found in the cmt's table."; `None + | None -> + log ~title "Uid not found in the cmt's table."; + `None end - | _ -> log ~title "Failed to load the cmt file"; `None + | _ -> + log ~title "Failed to load the cmt file"; + `None end let find_loc_of_comp_unit ~config uid comp_unit = @@ -532,97 +532,104 @@ let find_loc_of_comp_unit ~config uid comp_unit = match load_cmt ~config comp_unit 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 (uid, loc) - | _ -> log ~title "Failed to load the CU's cmt"; `None + | _ -> + log ~title "Failed to load the CU's cmt"; + `None let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = let namespace = decl.namespace in let module Reduce = Shape_reduce.Make (struct - let fuel = 10 - - let read_unit_shape ~unit_name = - log ~title:"read_unit_shape" "inspecting %s" unit_name; - match - load_cmt ~config:({config with ml_or_mli = `ML}) - ~with_fallback:false unit_name - 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 - end) - in + let fuel = 10 + + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + match + load_cmt + ~config:{ config with ml_or_mli = `ML } + ~with_fallback:false unit_name + 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 + end) in let shape = Env.shape_of_path ~namespace env path in - log ~title:"shape_of_path" "initial: %a" - Logger.fmt (Fun.flip Shape.print shape); - let reduced = Reduce.reduce_for_uid env shape - in - log ~title:"shape_of_path" "reduced: %a" - Logger.fmt (fun fmt -> Shape_reduce.print_result fmt reduced); + log ~title:"shape_of_path" "initial: %a" Logger.fmt + (Fun.flip Shape.print shape); + let reduced = Reduce.reduce_for_uid env shape in + log ~title:"shape_of_path" "reduced: %a" Logger.fmt (fun fmt -> + Shape_reduce.print_result fmt reduced); reduced let rec uid_of_result ~traverse_aliases = function - | Shape_reduce.Resolved uid -> - Some uid, false - | Resolved_alias ((Item { comp_unit; _ } | Compilation_unit comp_unit), - ((Resolved_alias (Compilation_unit comp_unit', _) - | Resolved (Compilation_unit comp_unit') ) as rest)) - when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' -> - (* Always traverse dune-wrapper aliases *) - log ~title:"uid_of_result" - "Traversing wrapping alias: %s__ %s" comp_unit comp_unit'; - uid_of_result ~traverse_aliases rest + | Shape_reduce.Resolved uid -> (Some uid, false) + | Resolved_alias + ( (Item { comp_unit; _ } | Compilation_unit comp_unit), + (( Resolved_alias (Compilation_unit comp_unit', _) + | Resolved (Compilation_unit comp_unit') ) as rest) ) + when let by = comp_unit ^ "__" in + String.is_prefixed ~by comp_unit' -> + (* Always traverse dune-wrapper aliases *) + log ~title:"uid_of_result" "Traversing wrapping alias: %s__ %s" comp_unit + comp_unit'; + uid_of_result ~traverse_aliases rest | Resolved_alias (_alias, rest) when traverse_aliases -> - uid_of_result ~traverse_aliases rest - | Resolved_alias (alias, _rest) -> - Some alias, false + uid_of_result ~traverse_aliases rest + | Resolved_alias (alias, _rest) -> (Some alias, false) | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } -> - Some uid, approximated - | Approximated _ | Unresolved _ | Internal_error_missing_uid -> - None, true + (Some uid, approximated) + | Approximated _ | Unresolved _ | Internal_error_missing_uid -> (None, true) (** This is the main function here *) let from_path ~config ~env ~local_defs ~decl path = let title = "from_path" in let unalias (decl : Env_lookup.item) = - if not config.traverse_aliases then decl.uid else - let namespace = decl.namespace in - let uid = scrape_alias ~fallback_uid:decl.uid ~env ~namespace path in - if uid <> decl.uid then - log ~title:"uid_of_path" "Unaliased declaration uid: %a -> %a" - Logger.fmt (Fun.flip Shape.Uid.print decl.uid) - Logger.fmt (Fun.flip Shape.Uid.print uid); - uid + if not config.traverse_aliases then decl.uid + else + let namespace = decl.namespace in + let uid = scrape_alias ~fallback_uid:decl.uid ~env ~namespace path in + if uid <> decl.uid then + log ~title:"uid_of_path" "Unaliased declaration uid: %a -> %a" + Logger.fmt + (Fun.flip Shape.Uid.print decl.uid) + Logger.fmt + (Fun.flip Shape.Uid.print uid); + uid in (* Step 1: Path => Uid *) - let decl : Env_lookup.item = { decl with uid = (unalias decl) } in - let uid, approximated = match config.ml_or_mli with - | `MLI -> decl.uid, false - | `ML -> + let decl : Env_lookup.item = { decl with uid = unalias decl } in + let uid, approximated = + match config.ml_or_mli with + | `MLI -> (decl.uid, false) + | `ML -> ( let traverse_aliases = config.traverse_aliases in let result = find_definition_uid ~config ~env ~decl path in match uid_of_result ~traverse_aliases result with - | Some uid, approx -> uid, approx + | Some uid, approx -> (uid, approx) | None, _approx -> - log ~title "No definition uid, falling back to the declaration uid: %a" - Logger.fmt (Fun.flip Shape.Uid.print decl.uid); - decl.uid, true + log ~title "No definition uid, falling back to the declaration uid: %a" + Logger.fmt + (Fun.flip Shape.Uid.print decl.uid); + (decl.uid, true)) in (* Step 2: Uid => Location *) - let loc = match uid with + let loc = + match uid with | Predef s -> `Builtin (uid, s) | Internal -> `Builtin (uid, "") - | Item {comp_unit; _} -> find_loc_of_uid ~config ~local_defs uid comp_unit + | Item { comp_unit; _ } -> find_loc_of_uid ~config ~local_defs uid comp_unit | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit in - let loc = match loc with + let loc = + match loc with | `None -> - log ~title "Falling back to the declaration's location: %a" - Logger.fmt (Fun.flip Location.print_loc decl.loc); + log ~title "Falling back to the declaration's location: %a" Logger.fmt + (Fun.flip Location.print_loc decl.loc); `Some (decl.uid, decl.loc) | other -> other in @@ -630,21 +637,18 @@ let from_path ~config ~env ~local_defs ~decl path = match loc with | `None -> assert false | `Builtin _ as err -> err - | `Some (uid, loc) -> + | `Some (uid, loc) -> ( match find_source ~config:config.mconfig loc (Path.name path) with | `Found (file, location) -> - log ~title:"find_source" "Found file: %s (%a)" file - Logger.fmt (Fun.flip Location.print_loc location); - `Found { - uid; - decl_uid = decl.uid; - file; location; approximated } - | `File_not_found _ as otherwise -> otherwise + log ~title:"find_source" "Found file: %s (%a)" file Logger.fmt + (Fun.flip Location.print_loc location); + `Found { uid; decl_uid = decl.uid; file; location; approximated } + | `File_not_found _ as otherwise -> otherwise) let from_longident ~config ~env ~local_defs nss 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.by_longident nss ident env with | None -> `Not_in_env str_ident @@ -659,30 +663,28 @@ let from_path ~config ~env ~local_defs ~namespace path = let infer_namespace ?namespaces ~pos lid browse is_label = match namespaces with | Some nss -> - if not is_label - then `Ok (nss :> Env_lookup.Namespace.inferred list) + if not is_label then `Ok (nss :> Env_lookup.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 (Env_lookup.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 path = File_switching.reset (); @@ -694,54 +696,63 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces path = | `Error e -> e | `Ok nss -> log ~title:"from_string" - "looking for the source of '%s' (prioritizing %s files)" - path (match config.ml_or_mli with `ML -> ".ml" | `MLI -> ".mli"); + "looking for the source of '%s' (prioritizing %s files)" path + (match config.ml_or_mli with + | `ML -> ".ml" + | `MLI -> ".mli"); from_longident ~config ~env ~local_defs nss ident in Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid - let find_doc_attribute 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)) + 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 let find_compunit_doc_in_typedtree cmt_infos = let first_item_attribute = log ~title:"doc_from_uid" "Itering on the typedtree"; match cmt_infos.Cmt_format.cmt_annots with - | Interface - { sig_items = { sig_desc = Tsig_attribute attr; _} :: _; _} -> Some attr + | Interface { sig_items = { sig_desc = Tsig_attribute attr; _ } :: _; _ } -> + Some attr | Implementation - { str_items = { str_desc = Tstr_attribute attr; _} :: _; _} -> Some attr + { str_items = { str_desc = Tstr_attribute attr; _ } :: _; _ } -> + Some attr | _ -> None in match first_item_attribute with | None -> `No_documentation | Some attr -> log ~title:"doc_from_uid" "Found attributes for this uid"; - begin match find_doc_attribute [attr] with - | Some (doc, _) -> `Found_doc (doc |> String.trim) - | None -> `No_documentation end + begin + match find_doc_attribute [ attr ] with + | Some (doc, _) -> `Found_doc (doc |> String.trim) + | None -> `No_documentation + end let doc_of_item_declaration decl = - let attributes = match decl with + let attributes = + match decl with | Typedtree.Value { val_attributes; _ } -> val_attributes | Value_binding { vb_attributes; _ } -> vb_attributes | Type { typ_attributes; _ } -> typ_attributes | Constructor { cd_attributes; _ } -> cd_attributes - | Extension_constructor { ext_attributes; _ } -> ext_attributes + | Extension_constructor { ext_attributes; _ } -> ext_attributes | Label { ld_attributes; _ } -> ld_attributes | Module { md_attributes; _ } -> md_attributes | Module_substitution { ms_attributes; _ } -> ms_attributes | Module_binding { mb_attributes; _ } -> mb_attributes | Module_type { mtd_attributes; _ } -> mtd_attributes - | Class { ci_attributes; _ } - | Class_type { ci_attributes; _ } -> ci_attributes + | Class { ci_attributes; _ } | Class_type { ci_attributes; _ } -> + ci_attributes in match find_doc_attribute attributes with | Some (doc, _) -> `Found_doc (doc |> String.trim) @@ -757,43 +768,47 @@ let find_uid_doc_in_cmt cmt_infos uid = (* For module doc we need to look at the first items in the typedtree *) find_compunit_doc_in_typedtree cmt_infos | _ -> begin - let decl = - Shape.Uid.Tbl.find_opt cmt_infos.Cmt_format.cmt_uid_to_decl uid - in - match decl with - | None -> `No_documentation - | Some decl -> - begin match doc_of_item_declaration decl with - | `Found_doc d -> `Found_doc d - | `No_documentation -> `Found_decl (uid, decl, cmt_infos.cmt_comments) - end + let decl = + Shape.Uid.Tbl.find_opt cmt_infos.Cmt_format.cmt_uid_to_decl uid + in + match decl with + | None -> `No_documentation + | Some decl -> begin + match doc_of_item_declaration decl with + | `Found_doc d -> `Found_doc d + | `No_documentation -> `Found_decl (uid, decl, cmt_infos.cmt_comments) end + end let doc_from_uid ~config ~loc uid = - begin match uid with - | Shape.Uid.Item { comp_unit; _ } - | Shape.Uid.Compilation_unit comp_unit - 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; + begin + match uid with + | (Shape.Uid.Item { comp_unit; _ } | Shape.Uid.Compilation_unit comp_unit) + 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; log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; - begin match load_cmt ~config:({config with ml_or_mli = `MLI}) comp_unit with - | Error _ -> `No_documentation - | Ok (_, cmt_infos) -> - log ~title:"doc_from_uid" "Cmt loaded for %s" (Option.value ~default:"<>" cmt_infos.cmt_sourcefile); - find_uid_doc_in_cmt cmt_infos uid + begin + match load_cmt ~config:{ config with ml_or_mli = `MLI } comp_unit with + | Error _ -> `No_documentation + | Ok (_, cmt_infos) -> + log ~title:"doc_from_uid" "Cmt loaded for %s" + (Option.value ~default:"<>" cmt_infos.cmt_sourcefile); + find_uid_doc_in_cmt cmt_infos uid end - | _ -> - (* 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 + | _ -> + (* 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 ~after_only ~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 -> @@ -801,91 +816,90 @@ let doc_from_comment_list ~after_only ~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" - ); - match - Ocamldoc.associate_comment ~after_only comments loc !last_location - with - | None, _ -> `No_documentation + Format.fprintf fmt " (%S, %a);\n" c Location.print_loc l); + Format.fprintf fmt "]\n"); + match Ocamldoc.associate_comment ~after_only comments loc !last_location with + | None, _ -> `No_documentation | Some doc, _ -> `Found doc (* Get doc relies on different heuristics depending on the situation: - - First it locates the declaration. - - If a Uid is found that belongs to another compilation unit: - - [doc_from_uid] The cmt file for that compilation unit is loaded - - If the Uid is the one of a compilation unit we look in the typetree - - else a lookup is performed in the [uid_to_decl] table - - If the uid-based search failed we fallback on the [doc_from_comment_list] - heuristic that uses location to select comments in a list. *) + - First it locates the declaration. + - If a Uid is found that belongs to another compilation unit: + - [doc_from_uid] The cmt file for that compilation unit is loaded + - If the Uid is the one of a compilation unit we look in the typetree + - else a lookup is performed in the [uid_to_decl] table + - If the uid-based search failed we fallback on the [doc_from_comment_list] + heuristic that uses location to select comments in a list. *) let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos = File_switching.reset (); fun path -> - let_ref last_location Location.none @@ fun () -> - let config = { mconfig; ml_or_mli = `MLI; traverse_aliases = true; } in - 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 ~local_defs ~namespace path in - begin match from_path with - | `Found { uid; location = loc; _ } -> - 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 path with - | `Found { uid; location = loc; _ } -> - 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 _ | `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_decl (uid, decl, comments) -> - (match Typedtree_utils.location_of_declaration ~uid decl with + let_ref last_location Location.none @@ fun () -> + let config = { mconfig; ml_or_mli = `MLI; traverse_aliases = true } in + 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 ~local_defs ~namespace path in + begin + match from_path with + | `Found { uid; location = loc; _ } -> 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 path with + | `Found { uid; location = loc; _ } -> 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 _ | `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_decl (uid, decl, comments) -> ( + match Typedtree_utils.location_of_declaration ~uid decl with | None -> `No_documentation | Some loc -> - let after_only = match decl with + let after_only = + match decl with | Typedtree.Constructor _ | Label _ -> true | _ -> false in doc_from_comment_list ~after_only ~buffer_comments:comments loc.loc) - | `Found_loc loc -> + | `Found_loc loc -> (* based on https://v2.ocaml.org/manual/doccomments.html#ss:label-comments: *) 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 - 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 + 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 doc_from_comment_list ~after_only ~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 0d201bcd8..226e5d767 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -1,97 +1,91 @@ (* {{{ 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 -type config = { - mconfig: Mconfig.t; - ml_or_mli: [ `ML | `MLI ]; - traverse_aliases: bool; -} +type config = + { mconfig : Mconfig.t; ml_or_mli : [ `ML | `MLI ]; traverse_aliases : bool } -type result = { - uid: Shape.Uid.t; - decl_uid: Shape.Uid.t; - file: string; - location: Location.t; - approximated: bool; -} +type result = + { uid : Shape.Uid.t; + decl_uid : Shape.Uid.t; + file : string; + location : Location.t; + approximated : bool + } -val uid_of_result - : traverse_aliases:bool - -> Shape_reduce.result - -> Shape.Uid.t option * bool +val uid_of_result : + traverse_aliases:bool -> Shape_reduce.result -> Shape.Uid.t option * bool -val find_source - : config: Mconfig.t - -> Warnings.loc - -> string - -> [> `File_not_found of string - | `Found of string * Location.t ] +val find_source : + config:Mconfig.t -> + Warnings.loc -> + string -> + [> `File_not_found of string | `Found of string * Location.t ] -val from_path - : config:config - -> env:Env.t - -> local_defs:Mtyper.typedtree - -> namespace:Env_lookup.Namespace.t - -> Path.t - -> [> `File_not_found of string - | `Found of result - | `Builtin of Shape.Uid.t * string - | `Not_in_env of string - | `Not_found of string * string option ] +val from_path : + config:config -> + env:Env.t -> + local_defs:Mtyper.typedtree -> + namespace:Env_lookup.Namespace.t -> + Path.t -> + [> `File_not_found of string + | `Found of result + | `Builtin of Shape.Uid.t * string + | `Not_in_env of string + | `Not_found of string * string option ] -val from_string - : config:config - -> env:Env.t - -> local_defs:Mtyper.typedtree - -> pos:Lexing.position - -> ?namespaces:Env_lookup.Namespace.inferred_basic list - -> string - -> [> `File_not_found of string - | `Found of result - | `Builtin of Shape.Uid.t * string - | `Missing_labels_namespace - | `Not_found of string * string option - | `Not_in_env of string - | `At_origin ] +val from_string : + config:config -> + env:Env.t -> + local_defs:Mtyper.typedtree -> + pos:Lexing.position -> + ?namespaces:Env_lookup.Namespace.inferred_basic list -> + string -> + [> `File_not_found of string + | `Found of result + | `Builtin of Shape.Uid.t * 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 Env_lookup.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 Env_lookup.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 9d3b705e6..7c372f654 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 11355c3ec..812441a4e 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -16,7 +16,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 @@ -28,4 +30,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 -> modname Location.loc list + Mconfig.t * Msource.t -> Lexing.position -> modname Location.loc list diff --git a/src/analysis/ocamldoc.ml b/src/analysis/ocamldoc.ml index 3383b4250..0979c1e5c 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/occurrences.ml b/src/analysis/occurrences.ml index f0db4a9a1..5df848307 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -1,17 +1,19 @@ open Std module Lid_set = Index_format.Lid_set -let {Logger. log} = Logger.for_section "occurrences" +let { Logger.log } = Logger.for_section "occurrences" -type t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status } +type t = + { locs : Warnings.loc list; status : Query_protocol.occurrences_status } let () = Mtyper.set_index_items Index_occurrences.items let set_fname ~file (loc : Location.t) = let pos_fname = file in { loc with - loc_start = { loc.loc_start with pos_fname }; - loc_end = { loc.loc_end with pos_fname }} + loc_start = { loc.loc_start with pos_fname }; + loc_end = { loc.loc_end with pos_fname } + } (* A longident can have the form: A.B.x Right now we are only interested in values, but we will eventually want to index all occurrences of modules in @@ -23,7 +25,7 @@ let set_fname ~file (loc : Location.t) = However, we can safely deduce the location of the last part of the lid only when the ident does not require parenthesis. In that case the loc sie differs from the name size in a way that depends on the concrete syntax which is - lost. *) + lost. *) let last_loc (loc : Location.t) lid = match lid with | Longident.Lident _ -> loc @@ -33,44 +35,39 @@ let last_loc (loc : Location.t) lid = if not needs_parens then let last_size = last_segment |> String.length in { loc with - loc_start = { loc.loc_end with - pos_cnum = loc.loc_end.pos_cnum - last_size; - } + loc_start = + { loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - last_size } } - else - loc + else loc let uid_and_loc_of_node env node = let open Browse_raw in - log ~title:"occurrences" "Looking for uid of node %s" - @@ string_of_node node; + log ~title:"occurrences" "Looking for uid of node %s" @@ string_of_node node; match node with | Module_binding_name { mb_id = Some ident; mb_name; _ } -> let md = Env.find_module (Pident ident) env in Some (md.md_uid, mb_name.loc) - | Pattern { pat_desc = - Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid); _ } -> - Some (uid, name.loc) + | Pattern + { pat_desc = Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid); _ } + -> Some (uid, name.loc) | Type_declaration { typ_type; typ_name; _ } -> - Some (typ_type.type_uid, typ_name.loc) - | Label_declaration { ld_uid; ld_name ; _ } -> - Some (ld_uid, ld_name.loc) - | Constructor_declaration { cd_uid; cd_name ; _ } -> - Some (cd_uid, cd_name.loc) + Some (typ_type.type_uid, typ_name.loc) + | Label_declaration { ld_uid; ld_name; _ } -> Some (ld_uid, ld_name.loc) + | Constructor_declaration { cd_uid; cd_name; _ } -> Some (cd_uid, cd_name.loc) | Value_description { val_val; val_name; _ } -> - Some (val_val.val_uid, val_name.loc) + Some (val_val.val_uid, val_name.loc) | _ -> None let comp_unit_of_uid = function - | Shape.Uid.Compilation_unit comp_unit - | Item { comp_unit; _ } -> Some comp_unit + | Shape.Uid.Compilation_unit comp_unit | Item { comp_unit; _ } -> + Some comp_unit | Internal | Predef _ -> None module Stat_check : sig type t - val create: cache_size:int -> Index_format.index -> t - val check: t -> file:string -> bool - val get_outdated_files: t -> String.Set.t + val create : cache_size:int -> Index_format.index -> t + val check : t -> file:string -> bool + val get_outdated_files : t -> String.Set.t end = struct type t = { index : Index_format.index; cache : (string, bool) Hashtbl.t } @@ -87,12 +84,12 @@ end = struct | None -> log ~title:"stat_check" "No stats found for file %S." file; true - | Some { size; _ } -> + | Some { size; _ } -> ( try let stats = Unix.stat file in let equal = (* This is fast but approximative. A better option would be to check - [mtime] and then [source_digest] if the times differ. *) + [mtime] and then [source_digest] if the times differ. *) Int.equal stats.st_size size in if not equal then @@ -101,10 +98,13 @@ end = struct equal with Unix.Unix_error _ -> log ~title:"stat_check" "Could not stat file %S" file; - false + false) let check t ~file = - let cache_and_return b = Hashtbl.add t.cache file b; b in + let cache_and_return b = + Hashtbl.add t.cache file b; + b + in match Hashtbl.find_opt t.cache file with | Some result -> result | None -> cache_and_return (stat t file) @@ -114,23 +114,21 @@ let get_buffer_locs result uid = Stamped_hashtable.fold (fun (uid', loc) () acc -> if Shape.Uid.equal uid uid' then Lid_set.add loc acc else acc) - (Mtyper.get_index result) - Lid_set.empty + (Mtyper.get_index result) Lid_set.empty let is_in_interface (config : Mconfig.t) (loc : Warnings.loc) = let extension = Filename.extension loc.loc_start.pos_fname in - List.exists config.merlin.suffixes - ~f:(fun (_impl, intf) -> String.equal extension intf) + List.exists config.merlin.suffixes ~f:(fun (_impl, intf) -> + String.equal extension intf) let locs_of ~config ~env ~typer_result ~pos ~scope path = - log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" - path + log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); let local_defs = Mtyper.get_typedtree typer_result in let locate_result = Locate.from_string - ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} - ~env ~local_defs ~pos path + ~config:{ mconfig = config; traverse_aliases = false; ml_or_mli = `ML } + ~env ~local_defs ~pos path in (* When we fail to find an exact definition we restrict scope to `Buffer *) let def, scope = @@ -139,7 +137,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = log ~title:"locs_of" "Cursor is on definition / declaration"; (* We are on a definition / declaration so we look for the node's uid *) let browse = Mbrowse.of_typedtree local_defs in - let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [browse]) in + let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [ browse ]) in let node_uid_loc = uid_and_loc_of_node env node in let scope = match node_uid_loc with @@ -152,109 +150,114 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = `Buffer | _ -> scope in - node_uid_loc, scope + (node_uid_loc, scope) | `Found { uid; location; approximated = false; _ } -> - log ~title:"locs_of" "Found definition uid using locate: %a " - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - (* There is no way to distinguish uids from interfaces from uids of - implementations. We fallback on buffer occurrences in that case. - TODO: we should be able to improve on that situation when we will be - able to distinguish between impl/intf uids and know which declaration - are actually linked. *) - let scope = - if is_in_interface config location then `Buffer - else scope - in - Some (uid, location), scope + log ~title:"locs_of" "Found definition uid using locate: %a " Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid); + (* There is no way to distinguish uids from interfaces from uids of + implementations. We fallback on buffer occurrences in that case. + TODO: we should be able to improve on that situation when we will be + able to distinguish between impl/intf uids and know which declaration + are actually linked. *) + let scope = if is_in_interface config location then `Buffer else scope in + (Some (uid, location), scope) | `Found { decl_uid; location; approximated = true; _ } -> - log ~title:"locs_of" "Approx. definition: %a " - Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - Some (decl_uid, location), `Buffer + log ~title:"locs_of" "Approx. definition: %a " Logger.fmt (fun fmt -> + Shape.Uid.print fmt decl_uid); + (Some (decl_uid, location), `Buffer) | `Builtin (uid, s) -> - log ~title:"locs_of" "Locate found a builtin: %s" s; - Some (uid, Location.none), scope + log ~title:"locs_of" "Locate found a builtin: %s" s; + (Some (uid, Location.none), scope) | _ -> - log ~title:"locs_of" "Locate failed to find a definition."; - None, `Buffer + log ~title:"locs_of" "Locate failed to find a definition."; + (None, `Buffer) in let current_buffer_path = Filename.concat config.query.directory config.query.filename in match def with | Some (def_uid, def_loc) -> - log ~title:"locs_of" "Definition has uid %a (%a)" - Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid) - Logger.fmt (fun fmt -> Location.print_loc fmt def_loc); + log ~title:"locs_of" "Definition has uid %a (%a)" Logger.fmt + (fun fmt -> Shape.Uid.print fmt def_uid) + Logger.fmt + (fun fmt -> Location.print_loc fmt def_loc); log ~title:"locs_of" "Indexing current buffer"; let buffer_locs = get_buffer_locs typer_result def_uid in let external_locs = if scope = `Buffer then [] - else List.filter_map config.merlin.index_files ~f:(fun file -> - let external_locs = try - let external_index = Index_cache.read file in - Index_format.Uid_map.find_opt def_uid external_index.defs - |> Option.map ~f:(fun uid_locs -> external_index, uid_locs) - with - | Index_format.Not_an_index _ | Sys_error _ -> - log ~title:"external_index" "Could not load index %s" file; - None - in - Option.map external_locs ~f:(fun (index, locs) -> - let stats = Stat_check.create ~cache_size:128 index in - Lid_set.filter (fun {loc; _} -> - (* We ignore external results that concern the current buffer *) - let file = loc.Location.loc_start.Lexing.pos_fname in - let file, buf = - match config.merlin.source_root with - | Some root -> Filename.concat root file, current_buffer_path - | None -> file, config.query.filename - in - if String.equal file buf then false - else begin - (* We ignore external results if their source was modified *) - let check = Stat_check.check stats ~file in - if not check then - log ~title:"locs_of" "File %s might be out-of-sync." file; - check - end) locs, - Stat_check.get_outdated_files stats)) + else + List.filter_map config.merlin.index_files ~f:(fun file -> + let external_locs = + try + let external_index = Index_cache.read file in + Index_format.Uid_map.find_opt def_uid external_index.defs + |> Option.map ~f:(fun uid_locs -> (external_index, uid_locs)) + with Index_format.Not_an_index _ | Sys_error _ -> + log ~title:"external_index" "Could not load index %s" file; + None + in + Option.map external_locs ~f:(fun (index, locs) -> + let stats = Stat_check.create ~cache_size:128 index in + ( Lid_set.filter + (fun { loc; _ } -> + (* We ignore external results that concern the current buffer *) + let file = loc.Location.loc_start.Lexing.pos_fname in + let file, buf = + match config.merlin.source_root with + | Some root -> + (Filename.concat root file, current_buffer_path) + | None -> (file, config.query.filename) + in + if String.equal file buf then false + else begin + (* We ignore external results if their source was modified *) + let check = Stat_check.check stats ~file in + if not check then + log ~title:"locs_of" "File %s might be out-of-sync." + file; + check + end) + locs, + Stat_check.get_outdated_files stats ))) in let external_locs, out_of_sync_files = - List.fold_left ~init:(Lid_set.empty, String.Set.empty) + List.fold_left + ~init:(Lid_set.empty, String.Set.empty) ~f:(fun (acc_locs, acc_files) (locs, files) -> (Lid_set.union acc_locs locs, String.Set.union acc_files files)) - (external_locs) + external_locs in let locs = Lid_set.union buffer_locs external_locs in let locs = log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs); Lid_set.elements locs - |> List.filter_map ~f:(fun {Location.txt; loc} -> - let lid = try Longident.head txt with _ -> "not flat lid" in - log ~title:"occurrences" "Found occ: %s %a" - lid Logger.fmt (Fun.flip Location.print_loc loc); - let loc = last_loc loc txt in - let fname = loc.Location.loc_start.Lexing.pos_fname in - if not (Filename.is_relative fname) then Some loc else - match config.merlin.source_root with - | Some path -> - let file = Filename.concat path loc.loc_start.pos_fname in - Some (set_fname ~file loc) - | None -> - begin - match Locate.find_source ~config loc fname with - | `Found (file, _) -> Some (set_fname ~file loc) - | `File_not_found msg -> - log ~title:"occurrences" "%s" msg; - None - end) + |> List.filter_map ~f:(fun { Location.txt; loc } -> + let lid = try Longident.head txt with _ -> "not flat lid" in + log ~title:"occurrences" "Found occ: %s %a" lid Logger.fmt + (Fun.flip Location.print_loc loc); + let loc = last_loc loc txt in + let fname = loc.Location.loc_start.Lexing.pos_fname in + if not (Filename.is_relative fname) then Some loc + else + match config.merlin.source_root with + | Some path -> + let file = Filename.concat path loc.loc_start.pos_fname in + Some (set_fname ~file loc) + | None -> begin + match Locate.find_source ~config loc fname with + | `Found (file, _) -> Some (set_fname ~file loc) + | `File_not_found msg -> + log ~title:"occurrences" "%s" msg; + None + end) in let def_uid_is_in_current_unit = let uid_comp_unit = comp_unit_of_uid def_uid in Option.value_map ~default:false uid_comp_unit ~f:(String.equal @@ Env.get_unit_name ()) in - let status = match scope, String.Set.to_list out_of_sync_files with + let status = + match (scope, String.Set.to_list out_of_sync_files) with | `Project, [] -> `Included | `Project, l -> `Out_of_sync l | `Buffer, _ -> `Not_requested @@ -262,5 +265,5 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = if not def_uid_is_in_current_unit then { locs; status } else let locs = set_fname ~file:current_buffer_path def_loc :: locs in - { locs; status } - | None -> { locs = []; status = `No_def} + { locs; status } + | None -> { locs = []; status = `No_def } diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index 8a04da910..d41d4d407 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,10 +1,11 @@ -type t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status } +type t = + { locs : Warnings.loc list; status : Query_protocol.occurrences_status } -val locs_of - : config:Mconfig.t - -> env:Env.t - -> typer_result:Mtyper.result - -> pos:Lexing.position - -> scope:[`Project | `Buffer] - -> string - -> t +val locs_of : + config:Mconfig.t -> + env:Env.t -> + typer_result:Mtyper.result -> + pos:Lexing.position -> + scope:[ `Project | `Buffer ] -> + string -> + t diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml index 54a64a0e7..6b9a39750 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 20ae50e53..cf1c04771 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 43ff256cc..4f23bceef 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -2,36 +2,32 @@ 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 - || (match decl.Types.type_kind with - | Types.Type_abstract _ -> false - | _ -> true) -> - begin match Types.get_desc body with + | Some body + when decl.Types.type_private = Asttypes.Public + || + match decl.Types.type_kind with + | Types.Type_abstract _ -> false + | _ -> true -> 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 @@ -41,57 +37,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 = @@ -105,25 +94,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 2982ea78d..2e0445964 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 8c71b5640..371e3f8aa 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, 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, 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,69 +168,75 @@ 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 -> - group (Item item :: acc) rest - | Sig_class_type _ as item :: _ :: rest -> - group (Item item :: acc) rest + | (Sig_class _ as item) :: _ :: _ :: rest -> group (Item item :: acc) rest + | (Sig_class_type _ as item) :: _ :: rest -> group (Item item :: acc) rest | item :: rest -> group (Item item :: acc) rest | [] -> List.rev acc in diff --git a/src/analysis/ptyp_of_type.mli b/src/analysis/ptyp_of_type.mli index 26fb46eb8..2a35aae27 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 8d9afc78a..162636d86 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 9a4f2cb43..17a4e5890 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 048263825..3f84261b9 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 f7c7738de..0aa665762 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 9b1299973..6b1bb28eb 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,148 +78,139 @@ 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 _) :: (_, 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 17adafbca..452806ea8 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 d05e2ac37..ab5648334 100644 --- a/src/analysis/tail_analysis.ml +++ b/src/analysis/tail_analysis.ml @@ -1,74 +1,94 @@ (* {{{ 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 @@ -86,5 +106,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 6e29c3808..e66b6ebeb 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 6d8e05bf9..096ad2d57 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 20e7861ae..799d8222a 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.ident_of_name (Format.str_formatter) expr; + Pprintast.ident_of_name 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,25 +217,23 @@ 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.Pident ident -> ident - | Path.Pdot _ | Path.Pextra_ty _ -> - Ident.create_persistent (Path.last path) - 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.Pident ident -> ident + | Path.Pdot _ | Path.Pextra_ty _ -> + Ident.create_persistent (Path.last path) + in + Printtyp.type_declaration env ident ppf decl + end | _ -> Printtyp.type_scheme env ppf typ end @@ -249,11 +243,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 = @@ -263,41 +256,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 @@ -306,58 +296,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 @@ -367,8 +360,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 73ad9e7a3..b0630438f 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 e4f440530..abcccfb10 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,20 +22,19 @@ 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 location_of_declaration ~uid = let of_option name = @@ -46,10 +43,9 @@ let location_of_declaration ~uid = | None -> None in let of_value_binding vb = - let bound_idents = Typedtree.let_bound_idents_full [vb] in + let bound_idents = Typedtree.let_bound_idents_full [ vb ] in ListLabels.find_map - ~f:(fun (_, loc, _, uid') -> - if uid = uid' then Some loc else None) + ~f:(fun (_, loc, _, uid') -> if uid = uid' then Some loc else None) bound_idents in function @@ -66,14 +62,11 @@ let location_of_declaration ~uid = | Class cd -> Some cd.ci_id_name | Class_type ctd -> Some ctd.ci_id_name - 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) | _ -> None - diff --git a/src/analysis/typedtree_utils.mli b/src/analysis/typedtree_utils.mli index 3cb089901..91ed0859b 100644 --- a/src/analysis/typedtree_utils.mli +++ b/src/analysis/typedtree_utils.mli @@ -14,9 +14,7 @@ val let_bound_vars : (** Extracts the location of a [uid] from a [Typedtree.item_declaration] *) val location_of_declaration : - uid:Shape.Uid.t -> - Typedtree.item_declaration -> - string Location.loc option + uid:Shape.Uid.t -> Typedtree.item_declaration -> string Location.loc option (** [pat_var_id_and_loc] try to extract the [id] and the [location] of pattern variable. *) @@ -25,6 +23,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 1713d1b9d..02d23b99a 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 7c62b49d8..0cb3ad5b2 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 9162c71e1..de1b60831 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, _project) -> 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 99fa4ceee..688132aff 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 | `OCaml_5_0_0 | `OCaml_5_1_0 | `OCaml_5_2_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 270b4f640..4900814db 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,132 +32,123 @@ 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:"BH " line then - tell (`BH (String.drop 3 line)) - else if String.is_prefixed ~by:"S " line then - tell (`S (String.drop 2 line)) - else if String.is_prefixed ~by:"SH " line then - tell (`SH (String.drop 3 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:"INDEX " line then - tell (`INDEX (String.drop 6 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:"BH " line then + tell (`BH (String.drop 3 line)) + else if String.is_prefixed ~by:"S " line then + tell (`S (String.drop 2 line)) + else if String.is_prefixed ~by:"SH " line then + tell (`SH (String.drop 3 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:"INDEX " line then + tell (`INDEX (String.drop 6 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 + 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 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 @@ -166,24 +157,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 = @@ -192,74 +183,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 @@ -274,113 +270,115 @@ 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 _ | `BH _ | `SH _ | `CMI _ | `CMT _ | `INDEX _ 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 _ | `BH _ | `SH _ | `CMI _ | `CMT _ | `INDEX _) 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) @@ -391,9 +389,7 @@ let process_one ~cfg {path;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 @@ -407,44 +403,46 @@ 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) - | `BH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `BH p) - | `SH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `SH 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) - | `INDEX path -> - List.map (expand ~stdlib dir path) ~f:(fun p -> `INDEX 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) + | `BH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `BH p) + | `SH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `SH 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) + | `INDEX path -> + List.map (expand ~stdlib dir path) ~f:(fun p -> `INDEX 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 9953e5290..cf7244a3e 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 @@ -37,7 +37,7 @@ module Directive = struct | `SH of string | `CMI of string | `CMT of string - | `INDEX of string] + | `INDEX of string ] type no_processing_required = [ `EXT of string list @@ -55,9 +55,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 @@ -78,39 +76,43 @@ 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 - | "SH" -> `SH value - | "BH" -> `BH value - | "CMI" -> `CMI value - | "CMT" -> `CMT value - | "INDEX" -> `INDEX 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 + | "SH" -> `SH value + | "BH" -> `BH value + | "CMI" -> `CMI value + | "CMT" -> `CMT value + | "INDEX" -> `INDEX 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 @@ -142,8 +144,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) @@ -151,9 +153,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 @@ -203,13 +203,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 @@ -232,9 +232,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 e949e3648..2f960402f 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 = @@ -67,9 +67,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 @@ -84,9 +82,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 @@ -126,12 +122,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 076621a41..d2b6ff94a 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 baf7f6ed4..a87fb391b 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 8aedb35cd..8c751d3ee 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 3488b4f58..638ce6433 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 d7363d674..b09505bb1 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 05020198c..c33ff2ee7 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 b7c522dc3..835cec433 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 509525840..5bbf386b2 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 94e5923b2..558f666d4 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 c74beb922..d93236fc6 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 6139a201a..78e13d9c3 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 e183ab6fd..35ca8a3a6 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml @@ -1,10 +1,8 @@ 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 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 @@ -22,15 +20,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 @@ -44,7 +40,8 @@ module Server = struct let rec loop merlinid server = match server_accept merlinid server with - | None -> (* Timeout *) + | None -> + (* Timeout *) () | Some client -> let continue = @@ -56,8 +53,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; @@ -71,16 +67,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" @@ -89,7 +85,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 1cf342209..1ef04be4e 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 dbf9cf38b..2c92b90cb 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 ca0751687..829729315 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 d478106cf..27537db2d 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 621168802..ae7273bd3 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 96a5f3b11..9ca6b50a6 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 95d22cd71..0ffe4b0d1 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,136 +71,133 @@ 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 -> @@ -208,16 +205,19 @@ let reconstruct_identifier pipeline pos = function let source = Mpipeline.raw_source pipeline in let path = Misc_utils.parse_identifier (config, source) pos in 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 @@ -235,25 +235,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 @@ -263,14 +261,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 @@ -281,124 +281,121 @@ 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 local_defs = Mtyper.get_typedtree typer in let structures = Mbrowse.of_typedtree local_defs 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); - let config = Locate.{ - mconfig = Mpipeline.final_config pipeline; - ml_or_mli = `MLI; - traverse_aliases = true - } + let config = + Locate. + { mconfig = Mpipeline.final_config pipeline; + ml_or_mli = `MLI; + traverse_aliases = true + } in - match Locate.from_path - ~config - ~env - ~local_defs - ~namespace:Type - path with + match + Locate.from_path ~config ~env ~local_defs ~namespace:Type path + with | `Builtin (_, s) -> `Builtin s | `Not_in_env _ as s -> s | `Not_found _ as s -> s | `Found { file; location; _ } -> `Found (Some file, location.loc_start) - | `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 @@ -408,13 +405,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 = @@ -422,13 +421,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 @@ -437,26 +436,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 @@ -464,24 +464,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 @@ -495,22 +493,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 @@ -518,11 +514,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 @@ -534,88 +529,88 @@ 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 - let config = Locate.{ - mconfig = Mpipeline.final_config pipeline; - ml_or_mli; - traverse_aliases = true - } - in - begin match Locate.from_string ~config ~env ~local_defs ~pos path with - | `Found { file; location; _ } -> - Locate.log ~title:"result" - "found: %s" file; - `Found (Some file, location.loc_start) - | `Missing_labels_namespace -> - (* Can't happen because we haven't passed a namespace as input. *) - assert false - | `Builtin (_, s) -> - Locate.log ~title:"result" "found builtin %s" s; - `Builtin s - | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _) as - otherwise -> - Locate.log ~title:"result" "not found"; - otherwise - end - + if path = "" then `Invalid_context + else + let config = + Locate. + { mconfig = Mpipeline.final_config pipeline; + ml_or_mli; + traverse_aliases = true + } + in + begin + match Locate.from_string ~config ~env ~local_defs ~pos path with + | `Found { file; location; _ } -> + Locate.log ~title:"result" "found: %s" file; + `Found (Some file, location.loc_start) + | `Missing_labels_namespace -> + (* Can't happen because we haven't passed a namespace as input. *) + assert false + | `Builtin (_, s) -> + Locate.log ~title:"result" "found builtin %s" s; + `Builtin s + | (`Not_found _ | `At_origin | `Not_in_env _ | `File_not_found _) 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 @@ -625,26 +620,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 @@ -653,45 +645,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 @@ -701,37 +694,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 @@ -739,14 +739,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 = @@ -758,55 +757,47 @@ 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_normalized (Mconfig.source_path config) x - with Not_found -> try - find_in_path_normalized (Mconfig.build_path config) x - with Not_found -> - aux xs + | x :: xs -> ( + try find_in_path_normalized (Mconfig.source_path config) x + with Not_found -> ( + try find_in_path_normalized (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 @ config.merlin.hidden_build_path) - | Path_list `Source -> let config = Mpipeline.final_config pipeline in Mconfig.(config.merlin.source_path @ config.merlin.hidden_source_path) - | Occurrences (`Ident_at pos, scope) -> let config = Mpipeline.final_config pipeline in let typer_result = Mpipeline.typer_result pipeline in @@ -815,7 +806,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let path = 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 @@ -823,33 +814,23 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let { Occurrences.locs; status } = Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path in - locs, status - - | Inlay_hints ( - start, - stop, - hint_let_binding, - hint_pattern_binding, - avoid_ghost_location - ) -> + (locs, status) + | 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 @@ -860,25 +841,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 7663d00ed..9db02f23f 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 1c0e3332a..911465d9e 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -1,260 +1,209 @@ (* {{{ 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 -type occurrences_status = [ - | `Not_requested - | `Out_of_sync of string list - | `No_def - | `Included -] +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 f458058cb..524c1826f 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/index-format/index_format.ml b/src/index-format/index_format.ml index e85560b16..541455cc6 100644 --- a/src/index-format/index_format.ml +++ b/src/index-format/index_format.ml @@ -19,20 +19,22 @@ module Lid_set = Set.Make (Lid) module Uid_map = Shape.Uid.Map module Stats = Map.Make (String) -let add map uid locs = Uid_map.update uid (function - | None -> Some locs - | Some locs' -> Some (Lid_set.union locs' locs)) - map +let add map uid locs = + Uid_map.update uid + (function + | None -> Some locs + | Some locs' -> Some (Lid_set.union locs' locs)) + map type stat = { mtime : float; size : int; source_digest : string option } -type index = { - defs : Lid_set.t Uid_map.t; - approximated : Lid_set.t Uid_map.t; - cu_shape : (string, Shape.t) Hashtbl.t; - stats : stat Stats.t; - root_directory: string option; -} +type index = + { defs : Lid_set.t Uid_map.t; + approximated : Lid_set.t Uid_map.t; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; + root_directory : string option + } let pp_partials (fmt : Format.formatter) (partials : Lid_set.t Uid_map.t) = Format.fprintf fmt "{@["; @@ -101,4 +103,6 @@ let read ~file = else Unknown) let read_exn ~file = - match read ~file with Index index -> index | _ -> raise (Not_an_index file) + match read ~file with + | Index index -> index + | _ -> raise (Not_an_index file) diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli index 822acbae1..a69da5bc1 100644 --- a/src/index-format/index_format.mli +++ b/src/index-format/index_format.mli @@ -8,19 +8,15 @@ module Lid_set : Set.S with type elt = Lid.t module Stats : Map.S with type key = String.t module Uid_map = Shape.Uid.Map -type stat = { - mtime : float; - size : int; - source_digest : string option -} - -type index = { - defs : Lid_set.t Uid_map.t; - approximated : Lid_set.t Uid_map.t; - cu_shape : (string, Shape.t) Hashtbl.t; - stats : stat Stats.t; - root_directory: string option; -} +type stat = { mtime : float; size : int; source_digest : string option } + +type index = + { defs : Lid_set.t Uid_map.t; + approximated : Lid_set.t Uid_map.t; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; + root_directory : string option + } val pp : Format.formatter -> index -> unit @@ -28,10 +24,7 @@ val pp : Format.formatter -> index -> unit key is already present the locations are merged. *) val add : Lid_set.t Uid_map.t -> Shape.Uid.t -> Lid_set.t -> Lid_set.t Uid_map.t -type file_content = - | Cmt of Cmt_format.cmt_infos - | Index of index - | Unknown +type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown val write : file:string -> index -> unit val read : file:string -> file_content diff --git a/src/kernel/extension.ml b/src/kernel/extension.ml index cd9173a19..3ce0d45d9 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 @@ -47,60 +47,55 @@ let ident = Ident.create_persistent "_" (** Definition of each extension *) -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_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_meta] +let registry = [ 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 @@ -116,16 +111,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 @@ -150,18 +146,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 b46fd50fa..f27c2722e 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 6fbea1c95..18050a75f 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 4dc10b558..a0bedc4ce 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 7afd5c993..77c0d9d95 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -2,149 +2,142 @@ open Std (** {1 OCaml commandline parsing} *) -let {Logger. log} = Logger.for_section "Mconfig" - -type ocaml = { - include_dirs : string list; - hidden_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; - 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; + hidden_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; + 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); - "hidden_dirs" , `List (List.map ~f:Json.string x.hidden_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; - "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)); + ("hidden_dirs", `List (List.map ~f:Json.string x.hidden_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); + ("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; - hidden_build_path : string list; - hidden_source_path : string list; - cmi_path : string list; - cmt_path : string list; - index_files : 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; + hidden_build_path : string list; + hidden_source_path : string list; + cmi_path : string list; + cmt_path : string list; + index_files : 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); - "hidden_build_path" , `List (List.map ~f:Json.string x.hidden_build_path); - "hidden_source_path", `List (List.map ~f:Json.string x.hidden_source_path); - "cmi_path" , `List (List.map ~f:Json.string x.cmi_path); - "cmt_path" , `List (List.map ~f:Json.string x.cmt_path); - "index_files" , `List (List.map ~f:Json.string x.index_files); - "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)); + ("hidden_build_path", `List (List.map ~f:Json.string x.hidden_build_path)); + ( "hidden_source_path", + `List (List.map ~f:Json.string x.hidden_source_path) ); + ("cmi_path", `List (List.map ~f:Json.string x.cmi_path)); + ("cmt_path", `List (List.map ~f:Json.string x.cmt_path)); + ("index_files", `List (List.map ~f:Json.string x.index_files)); + ("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 @@ -160,78 +153,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 @@ -240,9 +239,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 @@ -263,16 +261,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 = @@ -285,200 +279,249 @@ 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" - ); - ( - "-hidden-build-path", - marg_path (fun dir merlin -> - {merlin with hidden_build_path = dir :: merlin.hidden_build_path}), - " Add to merlin hidden build path" - ); - ( - "-hidden-source-path", - marg_path (fun dir merlin -> - {merlin with hidden_source_path = dir :: merlin.hidden_source_path}), - " Add to merlin hidden 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" - ); - ( - "-index-file", - marg_path (fun file merlin -> - {merlin with index_files = file :: merlin.index_files}), - " Add to the index files used by merlin" - ); - ( - "-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"; "-cmi-file"; -] +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" ); + ( "-hidden-build-path", + marg_path (fun dir merlin -> + { merlin with hidden_build_path = dir :: merlin.hidden_build_path }), + " Add to merlin hidden build path" ); + ( "-hidden-source-path", + marg_path (fun dir merlin -> + { merlin with hidden_source_path = dir :: merlin.hidden_source_path }), + " Add to merlin hidden 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" ); + ( "-index-file", + marg_path (fun file merlin -> + { merlin with index_files = file :: merlin.index_files }), + " Add to the index files used by merlin" ); + ( "-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"; + "-cmi-file" + ] 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')) @@ -487,283 +530,231 @@ 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" - ); - ( - "-H", - marg_path (fun dir ocaml -> - {ocaml with hidden_dirs = dir :: ocaml.hidden_dirs}), - " Add to the list of \"hidden\" include directories\n\ - \ (Like -I, but the program can not directly reference these dependencies)" - ); - ( - "-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" - ); - ( - "-safe-string", - Marg.unit (fun ocaml -> ocaml), - " Default to true unconditionally since 5.00" - ); - ( - "-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" ); + ( "-H", + marg_path (fun dir ocaml -> + { ocaml with hidden_dirs = dir :: ocaml.hidden_dirs }), + " Add to the list of \"hidden\" include directories\n\ + \ (Like -I, but the program can not directly reference these \ + dependencies)" ); + ( "-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" ); + ( "-safe-string", + Marg.unit (fun ocaml -> ocaml), + " Default to true unconditionally since 5.00" ); + ( "-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 = []; - hidden_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; - nopervasives = false; - strict_formats = false; - open_modules = []; - ppx = []; - pp = None; - warnings = Warnings.backup (); - }; - merlin = { - build_path = []; - source_path = []; - hidden_build_path = []; - hidden_source_path = []; - cmi_path = []; - cmt_path = []; - index_files = []; - 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 = []; + hidden_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; + nopervasives = false; + strict_formats = false; + open_modules = []; + ppx = []; + pp = None; + warnings = Warnings.backup () + }; + merlin = + { build_path = []; + source_path = []; + hidden_build_path = []; + hidden_source_path = []; + cmi_path = []; + cmt_path = []; + index_files = []; + 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"; @@ -771,50 +762,45 @@ 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 + let stdlib = if config.ocaml.no_std_include then [] else [ stdlib config ] in List.concat - [[config.query.directory]; - stdlib; - config.merlin.source_path; - config.merlin.hidden_source_path] + [ [ config.query.directory ]; + stdlib; + config.merlin.source_path; + config.merlin.hidden_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 hidden_build_path config = config.merlin.hidden_build_path @ config.ocaml.hidden_dirs -let cmt_path config = ( +let cmt_path config = let dirs = match config.ocaml.threads with | `None -> config.ocaml.include_dirs @@ -822,26 +808,21 @@ let cmt_path config = ( | `Vmthreads -> "+vmthreads" :: config.ocaml.include_dirs in let dirs = - config.merlin.cmt_path @ - config.merlin.build_path @ - config.merlin.hidden_build_path @ - dirs + config.merlin.cmt_path @ config.merlin.build_path + @ config.merlin.hidden_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} *) @@ -852,7 +833,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 87b33d2b4..1b4430b4a 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -2,62 +2,57 @@ open Std (** {1 OCaml commandline parsing} *) -type ocaml = { - include_dirs : string list; - hidden_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; - 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; + hidden_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; + 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; - hidden_build_path : string list; - hidden_source_path : string list; - cmi_path : string list; - cmt_path : string list; - index_files : 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; + hidden_build_path : string list; + hidden_source_path : string list; + cmi_path : string list; + cmt_path : string list; + index_files : 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 @@ -76,28 +71,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 @@ -107,8 +101,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 aad310e9d..0a42a1d3f 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -1,76 +1,76 @@ (* {{{ 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; - hidden_build_path : string list; - hidden_source_path : string list; - cmi_path : string list; - cmt_path : string list; - index_files : 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 = []; - hidden_build_path =[]; - hidden_source_path = []; - source_path = []; - cmi_path = []; - cmt_path = []; - index_files = []; - 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; + hidden_build_path : string list; + hidden_source_path : string list; + cmi_path : string list; + cmt_path : string list; + index_files : 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 = []; + hidden_build_path = []; + hidden_source_path = []; + source_path = []; + cmi_path = []; + cmt_path = []; + index_files = []; + 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]+" @@ -78,21 +78,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 @@ -100,13 +100,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 @@ -116,15 +116,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 @@ -134,19 +130,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 = @@ -154,10 +147,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 @@ -182,8 +175,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 @@ -192,7 +184,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; @@ -203,11 +195,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 @@ -221,8 +211,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; @@ -236,94 +225,87 @@ 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 - | `BH path -> {config with hidden_build_path = path :: config.hidden_build_path}, errors - | `SH path -> {config with hidden_source_path = path :: config.hidden_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 - | `INDEX file -> - {config with index_files = file :: config.index_files}, 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) + | `BH path -> + ( { config with hidden_build_path = path :: config.hidden_build_path }, + errors ) + | `SH path -> + ( { config with hidden_source_path = path :: config.hidden_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) + | `INDEX file -> + ({ config with index_files = file :: config.index_files }, 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; - hidden_build_path = clean config.hidden_build_path; + { build_path = clean config.build_path; + source_path = clean config.source_path; + hidden_build_path = clean config.hidden_build_path; hidden_source_path = clean config.hidden_source_path; - cmi_path = clean config.cmi_path; - cmt_path = clean config.cmt_path; - index_files = clean config.index_files; - extensions = clean config.extensions; - suffixes = clean config.suffixes; - flags = clean config.flags; - stdlib = config.stdlib; + cmi_path = clean config.cmi_path; + cmt_path = clean config.cmt_path; + index_files = clean config.index_files; + 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 @@ -339,16 +321,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 @@ -358,8 +340,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 @@ -368,96 +349,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 5452d73df..4b66317df 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -1,58 +1,56 @@ (* {{{ 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; - hidden_build_path : string list; - hidden_source_path : string list; - cmi_path : string list; - cmt_path : string list; - index_files : 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; + hidden_build_path : string list; + hidden_source_path : string list; + cmi_path : string list; + cmt_path : string list; + index_files : 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 @@ -60,12 +58,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] *) @@ -75,7 +73,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, @@ -88,3 +85,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 7eedd99b8..4f9fc0fa5 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -16,102 +16,99 @@ 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 ; - 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; + nopervasives := ocaml.nopervasives; + strict_formats := ocaml.strict_formats; + open_modules := ocaml.open_modules + +let setup_typer_config config = setup_reader_config config; let visible = Mconfig.build_path config in let hidden = Mconfig.hidden_build_path config in - Load_path.(init ~auto_include:no_auto_include ~visible ~hidden); -) + Load_path.(init ~auto_include:no_auto_include ~visible ~hidden) (** 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 (); Merlin_index_format.Index_cache.flush ?older_than () -) diff --git a/src/kernel/mocaml.mli b/src/kernel/mocaml.mli index 3a8fb6d55..62b45e552 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 cbfedbe79..2180675a7 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 58355efdc..f6f1d21df 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 43bb0f0d1..2a26d5384 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 ~visible_path ~hidden_path f = let saved_visible = !Clflags.include_dirs in @@ -13,12 +13,10 @@ let with_include_dir ~visible_path ~hidden_path f = Clflags.hidden_include_dirs := hidden_path; let result = begin - try - f () - with - | e -> - restore (); - raise e + try f () + with e -> + restore (); + raise e end in restore (); @@ -27,8 +25,7 @@ let with_include_dir ~visible_path ~hidden_path f = let rewrite parsetree cfg = let ppx = cfg.ocaml.ppx in (* add include path attribute to the parsetree *) - with_include_dir - ~visible_path:(Mconfig.build_path cfg) + with_include_dir ~visible_path:(Mconfig.build_path cfg) ~hidden_path:(Mconfig.hidden_build_path cfg) @@ fun () -> match @@ -37,11 +34,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 61a238eec..bec0e36a7 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 2594d65c8..7a940e146 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 83c5186dd..6e7cbcb8f 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 b5c59a53e..39cd0beec 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 01ee90fa4..8c38c9cc3 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 c889790b3..28d77d259 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 f9236a72f..c671e98dc 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 f05ec067e..5f3f32efb 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 d2b9ebff0..4a14af248 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 401590503..d13314cbb 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 5cf5c0a2d..c71b4d591 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 eebad4edb..b975cc556 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 b7f4d47c6..ff0b72b9e 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 47c0a477d..942a1808d 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -1,59 +1,55 @@ open Std open Local_store -let {Logger. log} = Logger.for_section "Mtyper" +let { Logger.log } = Logger.for_section "Mtyper" -let index_changelog = - Local_store.s_table Stamped_hashtable.create_changelog () +let index_changelog = Local_store.s_table Stamped_hashtable.create_changelog () type index_tbl = (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t (* Forward ref to be filled by analysis.Occurrences *) let index_items : - (index:index_tbl - -> stamp:int - -> Mconfig.t - -> [ `Impl of Typedtree.structure_item list - | `Intf of Typedtree.signature_item list ] - -> unit) ref = + (index:index_tbl -> + stamp:int -> + Mconfig.t -> + [ `Impl of Typedtree.structure_item list + | `Intf of Typedtree.signature_item list ] -> + unit) + ref = ref (fun ~index:_ ~stamp:_ _config _item -> ()) let set_index_items f = index_items := f -type ('p,'t) item = { - parsetree_item: 'p; - typedtree_items: 't list * Types.signature_item list; - part_snapshot : Types.snapshot; - part_stamp : int; - part_uid : int; - part_env : Env.t; - part_errors : exn list; - part_checks : Typecore.delayed_check list; - part_warnings : Warnings.state; -} +type ('p, 't) item = + { parsetree_item : 'p; + typedtree_items : 't list * Types.signature_item list; + part_snapshot : Types.snapshot; + part_stamp : int; + part_uid : 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 typedtree = + [ `Interface of Typedtree.signature | `Implementation of Typedtree.structure ] -type typedtree_items = [ - | `Interface of - (Parsetree.signature_item, Typedtree.signature_item) item list +type typedtree_items = + [ `Interface of (Parsetree.signature_item, Typedtree.signature_item) item list | `Implementation of - (Parsetree.structure_item, Typedtree.structure_item) item list -] + (Parsetree.structure_item, Typedtree.structure_item) item list ] type typer_cache_stats = Miss | Hit of { reused : int; typed : int } -type 'a cache_result = { - env : Env.t; - snapshot : Types.snapshot; - ident_stamp : int; - uid_stamp : int; - value : 'a; - index : (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t; -} +type 'a cache_result = + { env : Env.t; + snapshot : Types.snapshot; + ident_stamp : int; + uid_stamp : int; + value : 'a; + index : (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t + } let cache : typedtree_items option cache_result option ref = s_ref None @@ -71,23 +67,23 @@ let get_cache config = | Some _ | None -> let env, snapshot, ident_stamp, uid_stamp = fresh_env config in let index = Stamped_hashtable.create !index_changelog 256 in - { env; snapshot; ident_stamp; uid_stamp; value = None; index } + { env; snapshot; ident_stamp; uid_stamp; value = None; index } let return_and_cache status = - cache := Some ({ status with value = Some status.value }); + cache := Some { status with value = Some status.value }; status -type result = { - config : Mconfig.t; - initial_env : Env.t; - initial_snapshot : Types.snapshot; - initial_stamp : int; - stamp : int; - initial_uid_stamp : int; - typedtree : typedtree_items; - index : (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t; - cache_stat : typer_cache_stats -} +type result = + { config : Mconfig.t; + initial_env : Env.t; + initial_snapshot : Types.snapshot; + initial_stamp : int; + stamp : int; + initial_uid_stamp : int; + typedtree : typedtree_items; + index : (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t; + cache_stat : typer_cache_stats + } let initial_env res = res.initial_env @@ -95,52 +91,60 @@ 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_uid = Shape.Uid.get_current_stamp (); - 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_uid = Shape.Uid.get_current_stamp (); + 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_uid = Shape.Uid.get_current_stamp (); - 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_uid = Shape.Uid.get_current_stamp (); + part_errors = !caught; + part_checks = !Typecore.delayed_checks; + part_warnings = Warnings.backup () + } + in item :: type_signature caught part_env rest | [] -> [] @@ -153,7 +157,8 @@ let type_implementation config caught parsetree = | Some (`Implementation items) -> compatible_prefix items parsetree | Some (`Interface _) | None -> ([], parsetree, Miss) in - let env', snap', stamp', uid_stamp', warn' = match prefix with + let env', snap', stamp', uid_stamp', warn' = + match prefix with | [] -> (env, snapshot, ident_stamp, uid_stamp, Warnings.backup ()) | x :: _ -> caught := x.part_errors; @@ -169,13 +174,15 @@ let type_implementation config caught parsetree = Shape.Uid.restore_stamp uid_stamp'; let suffix = type_structure caught env' parsetree in let () = - List.iteri ~f:(fun i { typedtree_items = (items, _); _ } -> - let stamp = stamp + i + 1 in - !index_items ~index ~stamp config (`Impl items)) suffix + List.iteri + ~f:(fun i { typedtree_items = items, _; _ } -> + let stamp = stamp + i + 1 in + !index_items ~index ~stamp config (`Impl items)) + suffix in let value = `Implementation (List.rev_append prefix suffix) in - return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index }, - cache_stats + ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index }, + cache_stats ) let type_interface config caught parsetree = let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } = @@ -186,7 +193,8 @@ let type_interface config caught parsetree = | Some (`Interface items) -> compatible_prefix items parsetree | Some (`Implementation _) | None -> ([], parsetree, Miss) in - let env', snap', stamp', uid_stamp', warn' = match prefix with + let env', snap', stamp', uid_stamp', warn' = + match prefix with | [] -> (env, snapshot, ident_stamp, uid_stamp, Warnings.backup ()) | x :: _ -> caught := x.part_errors; @@ -202,13 +210,15 @@ let type_interface config caught parsetree = Shape.Uid.restore_stamp uid_stamp'; let suffix = type_signature caught env' parsetree in let () = - List.iteri ~f:(fun i { typedtree_items = (items, _); _ } -> - let stamp = stamp + i + 1 in - !index_items ~index ~stamp config (`Intf items)) suffix + List.iteri + ~f:(fun i { typedtree_items = items, _; _ } -> + let stamp = stamp + i + 1 in + !index_items ~index ~stamp config (`Intf items)) + suffix in let value = `Interface (List.rev_append prefix suffix) in - return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index}, - cache_stats + ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index }, + cache_stats ) let run config parsetree = if not (Env.check_state_consistency ()) then ( @@ -218,19 +228,18 @@ let run config parsetree = Mocaml.flush_caches (); Local_store.reset (); Load_path.reset (); - Load_path.(init ~auto_include:no_auto_include ~visible ~hidden); - ); + Load_path.(init ~auto_include:no_auto_include ~visible ~hidden)); let caught = ref [] in Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> Typecore.reset_delayed_checks (); - let cached_result, cache_stat = match parsetree with + let cached_result, cache_stat = + match parsetree with | `Implementation parsetree -> type_implementation config caught parsetree | `Interface parsetree -> type_interface config caught parsetree in let stamp = Ident.get_currentstamp () in Typecore.reset_delayed_checks (); - { - config; + { config; initial_env = cached_result.env; initial_snapshot = cached_result.snapshot; initial_stamp = cached_result.ident_stamp; @@ -238,30 +247,30 @@ let run config parsetree = initial_uid_stamp = cached_result.uid_stamp; typedtree = cached_result.value; index = cached_result.index; - cache_stat; + 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 = @@ -271,29 +280,28 @@ 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 get_index t = t.index let get_stamp t = t.stamp -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 21ed0ca98..5723b721c 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 } @@ -20,13 +18,13 @@ type index_tbl = (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t val set_index_items : - (index:index_tbl - -> stamp:int - -> Mconfig.t - -> [ `Impl of Typedtree.structure_item list - | `Intf of Typedtree.signature_item list ] - -> unit) - -> unit + (index:index_tbl -> + stamp:int -> + Mconfig.t -> + [ `Impl of Typedtree.structure_item list + | `Intf of Typedtree.signature_item list ] -> + unit) -> + unit val run : Mconfig.t -> Mreader.parsetree -> result @@ -58,5 +56,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 eb8c2de4c..f08b5c2da 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 14a86f746..739084160 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-index/bin/ocaml_index.ml b/src/ocaml-index/bin/ocaml_index.ml index 708d19397..ce2f5970c 100644 --- a/src/ocaml-index/bin/ocaml_index.ml +++ b/src/ocaml-index/bin/ocaml_index.ml @@ -28,16 +28,15 @@ let command = ref None let anon_fun arg = match !command with | None -> ( - match parse_command arg with - | Some cmd -> command := Some cmd - | None -> - command := Some Aggregate; - input_files := arg :: !input_files) + match parse_command arg with + | Some cmd -> command := Some cmd + | None -> + command := Some Aggregate; + input_files := arg :: !input_files) | Some _ -> input_files := arg :: !input_files let speclist = - [ - ("--verbose", Arg.Set verbose, "Output more information"); + [ ("--verbose", Arg.Set verbose, "Output more information"); ("--debug", Arg.Set debug, "Output debugging information"); ("-o", Arg.Set_string output_file, "Set output file name"); ( "--root", @@ -50,19 +49,21 @@ let speclist = Arg.Set store_shapes, "Aggregate input-indexes shapes and store them in the new index" ); ( "-I", - Arg.String (fun arg -> - build_path_rev := { !build_path_rev with - visible = arg :: !build_path_rev.visible }), + Arg.String + (fun arg -> + build_path_rev := + { !build_path_rev with visible = arg :: !build_path_rev.visible }), "An extra directory to add to the load path" ); ( "-H", - Arg.String (fun arg -> - build_path_rev := { !build_path_rev with - hidden = arg :: !build_path_rev.hidden }), + Arg.String + (fun arg -> + build_path_rev := + { !build_path_rev with hidden = arg :: !build_path_rev.hidden }), "An extra hidden directory to add to the load path" ); ( "--no-cmt-load-path", Arg.Set do_not_use_cmt_loadpath, "Do not initialize the load path with the paths found in the first input \ - cmt file" ); + cmt file" ) ] let set_log_level debug verbose = @@ -75,39 +76,39 @@ let () = set_log_level !debug !verbose; (match !command with | Some Aggregate -> - let root = if String.equal "" !root then None else Some !root in - Index.from_files ~store_shapes:!store_shapes ~root - ~rewrite_root:!rewrite_root ~output_file:!output_file - ~build_path:{ visible = List.rev !build_path_rev.visible; - hidden = List.rev !build_path_rev.hidden } - ~do_not_use_cmt_loadpath:!do_not_use_cmt_loadpath !input_files + let root = if String.equal "" !root then None else Some !root in + Index.from_files ~store_shapes:!store_shapes ~root + ~rewrite_root:!rewrite_root ~output_file:!output_file + ~build_path: + { visible = List.rev !build_path_rev.visible; + hidden = List.rev !build_path_rev.hidden + } + ~do_not_use_cmt_loadpath:!do_not_use_cmt_loadpath !input_files | Some Dump -> - List.iter - (fun file -> - Index_format.( - read_exn ~file |> pp Format.std_formatter)) - !input_files + List.iter + (fun file -> Index_format.(read_exn ~file |> pp Format.std_formatter)) + !input_files | Some Stats -> - List.iter - (fun file -> - let open Merlin_index_format.Index_format in - let { defs; approximated; cu_shape; root_directory; _ } = - read_exn ~file - in - Printf.printf - "Index %S contains:\n\ - - %i definitions\n\ - - %i locations\n\ - - %i approximated definitions\n\ - - %i compilation units shapes\n\ - - root dir: %s\n\n" - file (Uid_map.cardinal defs) - (Uid_map.fold - (fun _uid locs acc -> acc + Lid_set.cardinal locs) - defs 0) - (Uid_map.cardinal approximated) - (Hashtbl.length cu_shape) - (Option.value ~default:"none" root_directory)) - !input_files + List.iter + (fun file -> + let open Merlin_index_format.Index_format in + let { defs; approximated; cu_shape; root_directory; _ } = + read_exn ~file + in + Printf.printf + "Index %S contains:\n\ + - %i definitions\n\ + - %i locations\n\ + - %i approximated definitions\n\ + - %i compilation units shapes\n\ + - root dir: %s\n\n" + file (Uid_map.cardinal defs) + (Uid_map.fold + (fun _uid locs acc -> acc + Lid_set.cardinal locs) + defs 0) + (Uid_map.cardinal approximated) + (Hashtbl.length cu_shape) + (Option.value ~default:"none" root_directory)) + !input_files | _ -> Printf.printf "Nothing to do.\n%!"); exit 0 diff --git a/src/ocaml-index/lib/index.ml b/src/ocaml-index/lib/index.ml index 9c59082ec..cbdbd6e62 100644 --- a/src/ocaml-index/lib/index.ml +++ b/src/ocaml-index/lib/index.ml @@ -2,22 +2,22 @@ module Kind = Shape.Sig_component_kind open Index_format let with_root ?root file = - match root with None -> file | Some root -> Filename.concat root file + match root with + | None -> file + | Some root -> Filename.concat root file let add_root ~root (lid : Longident.t Location.loc) = match root with | None -> lid | Some root -> - let pos_fname = Filename.concat root lid.loc.loc_start.pos_fname in - { - lid with - loc = - { - lid.loc with - loc_start = { lid.loc.loc_start with pos_fname }; - loc_end = { lid.loc.loc_end with pos_fname }; - }; - } + let pos_fname = Filename.concat root lid.loc.loc_start.pos_fname in + { lid with + loc = + { lid.loc with + loc_start = { lid.loc.loc_start with pos_fname }; + loc_end = { lid.loc.loc_end with pos_fname } + } + } let merge m m' = Shape.Uid.Map.union @@ -34,9 +34,9 @@ let gather_locs_from_fragments ~root ~rewrite_root map fragments = match Typedtree_utils.location_of_declaration ~uid fragment with | None -> acc | Some lid -> - let lid = to_located_lid lid in - let lid = if rewrite_root then add_root ~root lid else lid in - Shape.Uid.Map.add uid (Lid_set.singleton lid) acc + let lid = to_located_lid lid in + let lid = if rewrite_root then add_root ~root lid else lid in + Shape.Uid.Map.add uid (Lid_set.singleton lid) acc in Shape.Uid.Tbl.fold add_loc fragments map @@ -47,12 +47,12 @@ module Reduce_conf = struct let cmt = Format.sprintf "%s.cmt" unit_name in match Cmt_cache.read (Load_path.find_normalized cmt) with | cmt_item -> - Log.debug "Loaded CMT %s" cmt; - cmt_item.cmt_infos.cmt_impl_shape + Log.debug "Loaded CMT %s" cmt; + cmt_item.cmt_infos.cmt_impl_shape | exception Not_found -> - Log.warn "Failed to load file %S in load_path: @[%s@]\n%!" cmt - @@ String.concat "; " (Load_path.get_path_list ()); - None + Log.warn "Failed to load file %S in load_path: @[%s@]\n%!" cmt + @@ String.concat "; " (Load_path.get_path_list ()); + None let read_unit_shape ~unit_name = Log.debug "Read unit shape: %s\n%!" unit_name; @@ -74,17 +74,16 @@ let init_load_path_once ~do_not_use_cmt_loadpath = let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath cmt_infos = - let { - Cmt_format.cmt_loadpath; - cmt_impl_shape; - cmt_modname; - cmt_uid_to_decl; - cmt_ident_occurrences; - cmt_initial_env; - cmt_sourcefile; - cmt_source_digest; - _; - } = + let { Cmt_format.cmt_loadpath; + cmt_impl_shape; + cmt_modname; + cmt_uid_to_decl; + cmt_ident_occurrences; + cmt_initial_env; + cmt_sourcefile; + cmt_source_digest; + _ + } = cmt_infos in init_load_path_once ~do_not_use_cmt_loadpath ~dirs:build_path cmt_loadpath; @@ -106,10 +105,10 @@ let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath match item with | Unresolved shape -> Reduce.reduce_for_uid cmt_initial_env shape | Resolved _ when Option.is_none cmt_impl_shape -> - (* Right now, without additional information we cannot take the - risk to mix uids from interfaces with the ones from - implementations. We simply ignore items defined in an interface. *) - Internal_error_missing_uid + (* Right now, without additional information we cannot take the + risk to mix uids from interfaces with the ones from + implementations. We simply ignore items defined in an interface. *) + Internal_error_missing_uid | result -> result in match Locate.uid_of_result ~traverse_aliases:false resolved with @@ -125,17 +124,16 @@ let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath match cmt_sourcefile with | None -> Stats.empty | Some src -> ( - let rooted_src = with_root ?root src in - try - let stats = Unix.stat rooted_src in - let src = if rewrite_root then rooted_src else src in - Stats.singleton src - { - mtime = stats.st_mtime; - size = stats.st_size; - source_digest = cmt_source_digest; - } - with Unix.Unix_error _ -> Stats.empty) + let rooted_src = with_root ?root src in + try + let stats = Unix.stat rooted_src in + let src = if rewrite_root then rooted_src else src in + Stats.singleton src + { mtime = stats.st_mtime; + size = stats.st_size; + source_digest = cmt_source_digest + } + with Unix.Unix_error _ -> Stats.empty) in { defs; approximated; cu_shape; stats; root_directory = None } @@ -151,12 +149,11 @@ let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath files = Log.debug "Debug log is enabled"; let initial_index = - { - defs = Shape.Uid.Map.empty; + { defs = Shape.Uid.Map.empty; approximated = Shape.Uid.Map.empty; cu_shape = Hashtbl.create 64; stats = Stats.empty; - root_directory = root; + root_directory = root } in let final_index = @@ -167,14 +164,14 @@ let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path let index = match Cmt_cache.read file with | cmt_item -> - index_of_cmt ~root ~rewrite_root ~build_path - ~do_not_use_cmt_loadpath cmt_item.cmt_infos + index_of_cmt ~root ~rewrite_root ~build_path + ~do_not_use_cmt_loadpath cmt_item.cmt_infos | exception _ -> ( - match read ~file with - | Index index -> index - | _ -> - Log.error "Unknown file type: %s" file; - exit 1) + match read ~file with + | Index index -> index + | _ -> + Log.error "Unknown file type: %s" file; + exit 1) in merge_index ~store_shapes index ~into) initial_index files diff --git a/src/ocaml-index/lib/log.ml b/src/ocaml-index/lib/log.ml index ecce9f5ed..c235e2dac 100644 --- a/src/ocaml-index/lib/log.ml +++ b/src/ocaml-index/lib/log.ml @@ -1,7 +1,10 @@ module Level = struct type t = Debug | Warning | Error - let int_of_t = function Debug -> 0 | Warning -> 1 | Error -> 2 + let int_of_t = function + | Debug -> 0 + | Warning -> 1 + | Error -> 2 let string_of_t = function | Debug -> "debug" diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 4d6fe4ac7..33040443b 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,99 @@ 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 rec 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_variant (_, None) + | Texp_new _ | Texp_hole -> id_fold + | Texp_let (_, vbs, e) -> of_expression e ** list_fold of_value_binding vbs | Texp_function (params, body) -> list_fold of_function_param params ** of_function_body body - | 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_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_uid=Shape.Uid.internal_not_actually_unique } + { mb_id; + mb_name; + mb_expr; + mb_loc = Location.none; + mb_attributes = []; + mb_presence; + mb_uid = Shape.Uid.internal_not_actually_unique + } 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,150 +413,108 @@ let rec 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_function_param fp = of_function_param_kind fp.fp_kind and of_function_param_kind = function | Tparam_pat pat -> of_pattern pat - | Tparam_optional_default (pat, exp) -> - of_pattern pat ** of_expression exp + | Tparam_optional_default (pat, exp) -> of_pattern pat ** of_expression exp and of_function_body = function | Tfunction_body exp -> of_expression exp | Tfunction_cases fc -> list_fold of_case fc.cases 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_apply_unit (me1) -> - of_module_expr me1 - | 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_apply_unit me1 -> of_module_expr me1 + | 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 -> @@ -545,271 +529,224 @@ and of_signature_item_desc = function and of_core_type_desc = function | Ttyp_any | Ttyp_var _ -> id_fold - | Ttyp_open (_,_,ct) -> of_core_type ct - | Ttyp_arrow (_,ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Ttyp_tuple cts | Ttyp_constr (_,_,cts) | Ttyp_class (_,_,cts) -> + | Ttyp_open (_, _, ct) -> of_core_type ct + | 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}, _uid) -> - [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)] - | Tpat_alias (_,id,loc, _uid) -> - [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] + | Tpat_var (id, { Location.loc; txt }, _uid) -> + [ (mkloc (Path.Pident id) loc, Some (Longident.Lident txt)) ] + | Tpat_alias (_, id, loc, _uid) -> + [ (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 } = @@ -817,130 +754,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 | _ -> [] @@ -948,58 +889,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 06d2b1cec..0495a0018 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 d9dead492..066620141 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, uid) 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 26926f668..83a956f1b 100644 --- a/src/ocaml/merlin_specific/typer_raw.ml +++ b/src/ocaml/merlin_specific/typer_raw.ml @@ -1,40 +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. -)* }}} *) + )* }}} *) open Std 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") diff --git a/src/ocaml/merlin_specific/typer_raw.mli b/src/ocaml/merlin_specific/typer_raw.mli index b6550aa7b..fe218286a 100644 --- a/src/ocaml/merlin_specific/typer_raw.mli +++ b/src/ocaml/merlin_specific/typer_raw.mli @@ -1,29 +1,29 @@ (* {{{ 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 diff --git a/src/ocaml/parsing/msupport_parsing.ml b/src/ocaml/parsing/msupport_parsing.ml index 567e5e28e..0a3fa6228 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 0e5980988..4623a4f66 100644 --- a/src/ocaml/typing/msupport.ml +++ b/src/ocaml/typing/msupport.ml @@ -1,62 +1,58 @@ (* {{{ 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 RawTypeHash = Hashtbl.Make(Types.TransientTypeOps) +module RawTypeHash = Hashtbl.Make (Types.TransientTypeOps) let errors : (exn list ref * unit RawTypeHash.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 @@ -68,33 +64,31 @@ let catch_errors warnings caught f = let warnings' = Warnings.backup () in let errors' = !errors in Warnings.restore warnings; - errors := (Some (caught,RawTypeHash.create 3)); - Misc.try_finally f - ~always:(fun () -> - errors := errors'; - Warnings.restore warnings') + errors := Some (caught, RawTypeHash.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) -> RawTypeHash.replace h te () + | Some (_, h) -> RawTypeHash.replace h te () | None -> () let erroneous_type_check te = let te = Types.Transient_expr.coerce te in match !errors with - | Some (_,h) -> RawTypeHash.mem h te + | Some (_, h) -> RawTypeHash.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 @@ -102,27 +96,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 @@ -136,23 +131,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 @@ -164,13 +160,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 43d049350..a5e8935be 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 d5d762403..b6b3137d1 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 0ce83ef54..ad464082a 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 5ea735405..3a82c7f5a 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 bcf9e6eeb..70069ca74 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 d045375c0..88cf3eaf4 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 493124178..566f9c9c6 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 7516d49be..2725672f0 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 c24d126f4..f695e7eb0 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 13bbc22de..4b50468da 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 4b6641866..58ab0ad39 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 ae3fb2765..f86719969 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 885a3241b..e426bd9cf 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 b1758c9de..e3517c3ec 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 ddff64148..85f4f7b18 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 3801f3ead..bd738b036 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 465a95ec7..0457d87a3 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,98 +198,98 @@ 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') let rec iteri2 i ~f l1 l2 = match (l1, l2) with - ([], []) -> () - | (a1::l1, a2::l2) -> f i a1 a2; iteri2 (i + 1) ~f l1 l2 - | (_, _) -> raise (Invalid_argument "iteri2") + | [], [] -> () + | a1 :: l1, a2 :: l2 -> + f i a1 a2; + iteri2 (i + 1) ~f l1 l2 + | _, _ -> raise (Invalid_argument "iteri2") let iteri2 ~f l1 l2 = iteri2 0 ~f l1 l2 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 @@ -321,27 +318,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 @@ -362,24 +361,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 @@ -387,72 +383,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 @@ -464,11 +473,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) @@ -486,25 +495,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 -> @@ -532,9 +539,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 @@ -560,7 +565,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 () = @@ -568,23 +573,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 = @@ -594,34 +598,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) @@ -637,21 +642,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"] @@ -664,17 +666,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 @@ -684,27 +680,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 @@ -716,7 +716,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 @@ -725,8 +725,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 @@ -734,20 +738,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 @@ -758,26 +761,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 -> @@ -789,69 +789,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 @@ -874,15 +880,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 406c764b341530c928963bfb03190a88f58a6b82 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 24 Sep 2024 15:01:12 +0200 Subject: [PATCH 6/7] 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 000000000..0eb30218f --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# git config blame.ignoreRevsFile .git-blame-ignore-revs +40e0cdb95ff31b81212109fada6e0ff93b6eefee From 7c5da09b48e63a65c7019060f8fc4a864f9e5853 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 24 Sep 2024 15:08:36 +0200 Subject: [PATCH 7/7] Mention the use of ocamlformat in the contributing guide. --- CONTRIBUTING.md | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 339c19b73..e3fcb323b 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -38,11 +38,9 @@ issue has not already been submitted. ### Styleguides -As of today, Merlin's codebase does not use a code formatter. When contributing -code to an existing module, one should adopt the style of the surrounding code. -Please keep lines under 80 characters. - -We plan to move the codebase to ocamlformat in a near future. +Merlin uses ocamlformat. When contributing code, please always format it by +running `dune fmt` before submitting a PR. The required version of ocamlformat +can be found in the `.ocamlformat` configuration file. Changes unrelated to the issue addressed by a PR should be made in a separate PR. Additionally, formatting changes in parts of the code not concerned by a