From 7bc2141fec4541405f8adffe9d5338c100a80cb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 11 Feb 2020 11:56:36 +0100 Subject: [PATCH 1/2] Extract module `Context` from `Locate` --- src/analysis/context.ml | 131 +++++++++++++++++++++++++++++++++++++++ src/analysis/context.mli | 46 ++++++++++++++ src/analysis/locate.ml | 102 ------------------------------ 3 files changed, 177 insertions(+), 102 deletions(-) create mode 100644 src/analysis/context.ml create mode 100644 src/analysis/context.mli diff --git a/src/analysis/context.ml b/src/analysis/context.ml new file mode 100644 index 0000000000..2c1533432d --- /dev/null +++ b/src/analysis/context.ml @@ -0,0 +1,131 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +open Std + +let {Logger. log} = Logger.for_section "context" + +type t = + | Constructor of Types.constructor_description + (* We attach the constructor description here so in the case of + disambiguated constructors we actually directly look for the type + path (cf. #486, #794). *) + | Expr + | Label of Types.label_description (* Similar to constructors. *) + | Module_path + | Module_type + | Patt + | Type + | Unknown + +let to_string = function + | Constructor cd -> Printf.sprintf "constructor %s" cd.cstr_name + | Expr -> "expression" + | Label lbl -> Printf.sprintf "record field %s" lbl.lbl_name + | Module_path -> "module path" + | Module_type -> "module type" + | Patt -> "pattern" + | Type -> "type" + | Unknown -> "unknown" + +(* Distinguish between "Mo[d]ule.Constructor" and "Module.Cons[t]ructor" *) +let cursor_on_constructor_name ~cursor:pos + ~cstr_token:{ Asttypes.loc; txt = lid } cd = + match lid with + | Longident.Lident _ -> true + | _ -> + let end_offset = loc.loc_end.pos_cnum in + let constr_pos = + { loc.loc_end + with pos_cnum = end_offset - String.length cd.Types.cstr_name } + in + Lexing.compare_pos pos constr_pos >= 0 + +let inspect_pattern ~pos ~lid p = + let open Typedtree in + log ~title:"inspect_context" "%a" Logger.fmt + (fun fmt -> Format.fprintf fmt "current pattern is: %a" + (Printtyped.pattern 0) p); + match p.pat_desc with + | Tpat_any when Longident.last lid = "_" -> None + | Tpat_var (_, str_loc) when (Longident.last lid) = str_loc.txt -> + None + | Tpat_alias (_, _, str_loc) + when (Longident.last lid) = str_loc.txt -> + (* Assumption: if [Browse.enclosing] stopped on this node and not on the + subpattern, then it must mean that the cursor is on the alias. *) + None + | Tpat_construct (lid_loc, cd, _) + when cursor_on_constructor_name ~cursor:pos ~cstr_token:lid_loc cd + && (Longident.last lid) = (Longident.last lid_loc.txt) -> + (* Assumption: if [Browse.enclosing] stopped on this node and not on the + subpattern, then it must mean that the cursor is on the constructor + itself. *) + Some (Constructor cd) + | _ -> + Some Patt + +let inspect_expression ~pos ~lid e : t = + match e.Typedtree.exp_desc with + | Texp_construct (lid_loc, cd, _) + when cursor_on_constructor_name ~cursor:pos ~cstr_token:lid_loc cd + && (Longident.last lid) = (Longident.last lid_loc.txt) -> + Constructor cd + | _ -> + Expr + +let inspect_browse_tree browse lid pos : t option = + match Mbrowse.enclosing pos browse with + | [] -> + log ~title:"inspect_context" + "no enclosing around: %a" Lexing.print_position pos; + Some Unknown + | enclosings -> + let open Browse_raw in + let node = Browse_tree.of_browse enclosings in + log ~title:"inspect_context" "current node is: %s" + (string_of_node node.Browse_tree.t_node); + match node.Browse_tree.t_node with + | Pattern p -> inspect_pattern ~pos ~lid p + | Value_description _ + | Type_declaration _ + | Extension_constructor _ + | Module_binding_name _ + | Module_declaration_name _ -> + None + | Module_expr _ + | Open_description _ -> Some Module_path + | Module_type _ -> Some Module_type + | Core_type _ -> Some Type + | Record_field (_, lbl, _) when (Longident.last lid) = lbl.lbl_name -> + (* if we stopped here, then we're on the label itself, and whether or + not punning is happening is not important *) + Some (Label lbl) + | Expression e -> Some (inspect_expression ~pos ~lid e) + | _ -> + Some Unknown diff --git a/src/analysis/context.mli b/src/analysis/context.mli new file mode 100644 index 0000000000..9a438fb21f --- /dev/null +++ b/src/analysis/context.mli @@ -0,0 +1,46 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +type t = + | Constructor of Types.constructor_description + (* We attach the constructor description here so in the case of + disambiguated constructors we actually directly look for the type + path (cf. #486, #794). *) + | Expr + | Label of Types.label_description (* Similar to constructors. *) + | Module_path + | Module_type + | Patt + | Type + | Unknown + +val to_string : t -> string + +val inspect_browse_tree : + Mbrowse.t list -> Longident.t -> + Std.Lexing.position -> t option diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index dd8fa62a27..d9e1202413 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -310,108 +310,6 @@ module Utils = struct | CMT _ | CMTI _ -> !loadpath end -module Context = struct - type t = - | Constructor of Types.constructor_description - (* We attach the constructor description here so in the case of - disambiguated constructors we actually directly look for the type - path (cf. #486, #794). *) - | Expr - | Label of Types.label_description (* Similar to constructors. *) - | Module_path - | Module_type - | Patt - | Type - | Unknown - - let to_string = function - | Constructor cd -> Printf.sprintf "constructor %s" cd.cstr_name - | Expr -> "expression" - | Label lbl -> Printf.sprintf "record field %s" lbl.lbl_name - | Module_path -> "module path" - | Module_type -> "module type" - | Patt -> "pattern" - | Type -> "type" - | Unknown -> "unknown" - - (* Distinguish between "Mo[d]ule.Constructor" and "Module.Cons[t]ructor" *) - let cursor_on_constructor_name ~cursor:pos - ~cstr_token:{ Asttypes.loc; txt = lid } cd = - match lid with - | Longident.Lident _ -> true - | _ -> - let end_offset = loc.loc_end.pos_cnum in - let constr_pos = - { loc.loc_end - with pos_cnum = end_offset - String.length cd.Types.cstr_name } - in - Lexing.compare_pos pos constr_pos >= 0 - - let inspect_pattern ~pos ~lid p = - let open Typedtree in - log ~title:"inspect_context" "%a" Logger.fmt - (fun fmt -> Format.fprintf fmt "current pattern is: %a" - (Printtyped.pattern 0) p); - match p.pat_desc with - | Tpat_any when Longident.last lid = "_" -> None - | Tpat_var (_, str_loc) when (Longident.last lid) = str_loc.txt -> - None - | Tpat_alias (_, _, str_loc) - when (Longident.last lid) = str_loc.txt -> - (* Assumption: if [Browse.enclosing] stopped on this node and not on the - subpattern, then it must mean that the cursor is on the alias. *) - None - | Tpat_construct (lid_loc, cd, _) - when cursor_on_constructor_name ~cursor:pos ~cstr_token:lid_loc cd - && (Longident.last lid) = (Longident.last lid_loc.txt) -> - (* Assumption: if [Browse.enclosing] stopped on this node and not on the - subpattern, then it must mean that the cursor is on the constructor - itself. *) - Some (Constructor cd) - | _ -> - Some Patt - - let inspect_expression ~pos ~lid e : t = - match e.Typedtree.exp_desc with - | Texp_construct (lid_loc, cd, _) - when cursor_on_constructor_name ~cursor:pos ~cstr_token:lid_loc cd - && (Longident.last lid) = (Longident.last lid_loc.txt) -> - Constructor cd - | _ -> - Expr - - let inspect_browse_tree browse lid pos : t option = - match Mbrowse.enclosing pos browse with - | [] -> - log ~title:"inspect_context" - "no enclosing around: %a" Lexing.print_position pos; - Some Unknown - | enclosings -> - let open Browse_raw in - let node = Browse_tree.of_browse enclosings in - log ~title:"inspect_context" "current node is: %s" - (string_of_node node.Browse_tree.t_node); - match node.Browse_tree.t_node with - | Pattern p -> inspect_pattern ~pos ~lid p - | Value_description _ - | Type_declaration _ - | Extension_constructor _ - | Module_binding_name _ - | Module_declaration_name _ -> - None - | Module_expr _ - | Open_description _ -> Some Module_path - | Module_type _ -> Some Module_type - | Core_type _ -> Some Type - | Record_field (_, lbl, _) when (Longident.last lid) = lbl.lbl_name -> - (* if we stopped here, then we're on the label itself, and whether or - not punning is happening is not important *) - Some (Label lbl) - | Expression e -> Some (inspect_expression ~pos ~lid e) - | _ -> - Some Unknown -end - exception Cmt_cache_store of Typedtrie.t let trie_of_cmt root = From f3d9ec11a34fff6a978645e75b12077923d2716b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 11 Feb 2020 14:19:51 +0100 Subject: [PATCH 2/2] Move type enclosing to analysis --- src/analysis/type_enclosing.ml | 90 ++++++++++++++++++++++++++++++++ src/frontend/query_commands.ml | 95 +++------------------------------- 2 files changed, 96 insertions(+), 89 deletions(-) create mode 100644 src/analysis/type_enclosing.ml diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml new file mode 100644 index 0000000000..c11fc5d37d --- /dev/null +++ b/src/analysis/type_enclosing.ml @@ -0,0 +1,90 @@ +open Std + +let from_nodes path = + let aux (env, node, tail) = + let open Browse_raw in + let ret x = Some (Mbrowse.node_loc node, x, tail) in + match[@ocaml.warning "-9"] node with + | Expression {exp_type = t} + | Pattern {pat_type = t} + | Core_type {ctyp_type = t} + | Value_description { val_desc = { ctyp_type = t } } -> + ret (`Type (env, t)) + | Type_declaration { typ_id = id; typ_type = t} -> + ret (`Type_decl (env, id, t)) + | Module_expr {mod_type = 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)) + | _ -> None + in + List.filter_map ~f:aux path + +let from_node env node = + let longident_to_string id = try + String.concat ~sep:"." (Longident.flatten id) + with Misc.Fatal_error _ -> "" + in + let ret typ = Mbrowse.node_loc node, `Type (env, typ), `No in + match node with + | Expression e -> + (match e.exp_desc with + | Texp_construct ({ Location. txt; loc=_ }, cdesc, _) -> + Some(longident_to_string txt, ret cdesc.cstr_res) + | Texp_ident (_, { Location. txt; loc=_ }, vdes) -> + Some(longident_to_string txt, ret vdes.val_type) + | _ -> None) + | Pattern p -> + (match p.pat_desc with + | Tpat_construct ({ Location. txt; loc=_ }, cdesc, _) -> + Some(longident_to_string txt, ret cdesc.cstr_res) + | _ -> None) + | _ -> None + +let from_reconstructed verbosity exprs env node = + let open Browse_raw in + let ident_opt = from_node env node in + let include_lident = match node with + | Pattern _ -> false + | _ -> true + in + let include_uident = match node with + | Module_binding _ + | Module_binding_name _ + | Module_declaration _ + | Module_declaration_name _ + | Module_type_declaration _ + | Module_type_declaration_name _ + -> false + | _ -> true + in + let f = + fun {Location. txt = source; loc} -> + match ident_opt with + | Some (ident, typ) when ident = source -> + (* Retrieve the type from the AST when it is possible *) + Some typ + | _ -> + (* Else use the reconstructed identifier *) + match source with + | "" -> None + | source when not include_lident && Char.is_lowercase source.[0] -> + None + | source when not include_uident && Char.is_uppercase source.[0] -> + None + | source -> + try + let ppf, to_string = Format.to_string () in + if Type_utils.type_in_env ~verbosity env ppf source then + Some (loc, `String (to_string ()), `No) + else + None + with _ -> + None + in + List.filter_map exprs ~f diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 3e2fe7d791..feb8183e7b 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -247,7 +247,6 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = to_string () | Type_enclosing (expro, pos, index) -> - let open Typedtree in let typer = Mpipeline.typer_result pipeline in let verbosity = verbosity pipeline in let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in @@ -256,95 +255,13 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | [] -> [] | browse -> Browse_misc.annotate_tail_calls browse in - let aux (env, node, tail) = - let open Browse_raw in - let ret x = Some (Mbrowse.node_loc node, x, tail) in - match[@ocaml.warning "-9"] node with - | Expression {exp_type = t} - | Pattern {pat_type = t} - | Core_type {ctyp_type = t} - | Value_description { val_desc = { ctyp_type = t } } -> - ret (`Type (env, t)) - | Type_declaration { typ_id = id; typ_type = t} -> - ret (`Type_decl (env, id, t)) - | Module_expr {mod_type = 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)) - | _ -> None - in - let result = List.filter_map ~f:aux path in + let result = Type_enclosing.from_nodes path in + (* enclosings of cursor in given expression *) - let small_enclosings = - let exprs = reconstruct_identifier pipeline pos expro in - let env, node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in - let open Browse_raw in - let ident_opt = - let longident_to_string id = try - String.concat ~sep:"." (Longident.flatten id) - with Misc.Fatal_error _ -> "" - in - let ret typ = Mbrowse.node_loc node, `Type (env, typ), `No in - match node with - | Expression e -> - (match e.exp_desc with - | Texp_construct ({ Location. txt; loc=_ }, cdesc, _) -> - Some(longident_to_string txt, ret cdesc.cstr_res) - | Texp_ident (_, { Location. txt; loc=_ }, vdes) -> - Some(longident_to_string txt, ret vdes.val_type) - | _ -> None) - | Pattern p -> - (match p.pat_desc with - | Tpat_construct ({ Location. txt; loc=_ }, cdesc, _) -> - Some(longident_to_string txt, ret cdesc.cstr_res) - | _ -> None) - | _ -> None - in - let include_lident = match node with - | Pattern _ -> false - | _ -> true - in - let include_uident = match node with - | Module_binding _ - | Module_binding_name _ - | Module_declaration _ - | Module_declaration_name _ - | Module_type_declaration _ - | Module_type_declaration_name _ - -> false - | _ -> true - in - let f = - fun {Location. txt = source; loc} -> - match ident_opt with - | Some (ident, typ) when ident = source -> - (* Retrieve the type from the AST when it is possible *) - Some typ - | _ -> - (* Else use the reconstructed identifier *) - match source with - | "" -> None - | source when not include_lident && Char.is_lowercase source.[0] -> - None - | source when not include_uident && Char.is_uppercase source.[0] -> - None - | source -> - try - let ppf, to_string = Format.to_string () in - if Type_utils.type_in_env ~verbosity env ppf source then - Some (loc, `String (to_string ()), `No) - else - None - with _ -> - None - in - List.filter_map exprs ~f - in + let exprs = reconstruct_identifier pipeline pos expro in + let env, node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in + let small_enclosings = Type_enclosing.from_reconstructed verbosity exprs env node in + let normalize ({Location. loc_start; loc_end; _}, text, _tail) = Lexing.split_pos loc_start, Lexing.split_pos loc_end, text in let all_items =