Skip to content

Commit

Permalink
Merge pull request #1110 from voodoos/split2
Browse files Browse the repository at this point in the history 
Make `Context` from `Locate` and some `Type_enclosing` logic standalone
  • Loading branch information
@trefis
trefis authored Mar 4, 2020
2 parents 9a3fd38 + f3d9ec1 commit 14bd0ce
Show file tree
Hide file tree
Showing 5 changed files with 273 additions and 191 deletions.
131 changes: 131 additions & 0 deletions src/analysis/context.ml
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,131 @@
(* {{{ COPYING *(
This file is part of Merlin, an helper for ocaml editors
Copyright (C) 2013 - 2015 Frédéric Bour <frederic.bour(_)lakaban.net>
Thomas Refis <refis.thomas(_)gmail.com>
Simon Castellan <simon.castellan(_)iuwt.fr>
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation the
rights to use, copy, modify, merge, publish, distribute, sublicense, and/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
46 changes: 46 additions & 0 deletions src/analysis/context.mli
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,46 @@
(* {{{ COPYING *(
This file is part of Merlin, an helper for ocaml editors
Copyright (C) 2013 - 2015 Frédéric Bour <frederic.bour(_)lakaban.net>
Thomas Refis <refis.thomas(_)gmail.com>
Simon Castellan <simon.castellan(_)iuwt.fr>
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation the
rights to use, copy, modify, merge, publish, distribute, sublicense, and/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
102 changes: 0 additions & 102 deletions src/analysis/locate.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
90 changes: 90 additions & 0 deletions src/analysis/type_enclosing.ml
View file
Original file line number Diff line number Diff line change
@@ -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
Loading

0 comments on commit 14bd0ce

Please sign in to comment.