Skip to content

Commit

Permalink
[B] Fix type enclosing for binding operators ocaml#1653
Browse files Browse the repository at this point in the history
test: test enclosing type for let+ ... and+ ... in expression
from Alizter/ps/branch/test__test_enclosing_type_for_let______and______in_expression
  • Loading branch information
voodoos committed Aug 24, 2023
1 parent d238347 commit b7973d5
Show file tree
Hide file tree
Showing 9 changed files with 80 additions and 19 deletions.
1 change: 1 addition & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ unreleased
definitions (#1645)
- Support parsing negative numbers in sexps (#1655)
- Fix construct not working with inline records (#1658)
- Improve behavior of `type-enclosing` on let/and operators (#1653)
+ editor modes
- emacs: call merlin-client-logger with "interrupted" if the
merlin binary itself is interrupted, not just the parsing of the
Expand Down
3 changes: 2 additions & 1 deletion src/analysis/completion.ml
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,7 @@ let classify_node = function
| Class_structure _ -> `Expression
| Class_field _ -> `Expression
| Class_field_kind _ -> `Expression
| Binding_op _ -> `Expression
| Module_expr _ -> `Module
| Module_type_constraint _ -> `Module_type
| Structure _ -> `Structure
Expand Down Expand Up @@ -176,7 +177,7 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty =
| `Mod m ->
begin try
if not exact then raise Exit;
let verbosity =
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;
Expand Down
1 change: 1 addition & 0 deletions src/analysis/type_enclosing.ml
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,7 @@ let from_nodes ~path =
| 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))
| _ -> None
in
List.filter_map ~f:aux path
Expand Down
11 changes: 6 additions & 5 deletions src/analysis/type_utils.ml
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,10 @@ open Std

module Verbosity = Mconfig.Verbosity

let protect expr =
Pprintast.protect_ident (Format.str_formatter) expr;
Format.flush_str_formatter ()

let parse_expr ?(keywords=Lexer_raw.keywords []) expr =
let lexbuf = Lexing.from_string expr in
let state = Lexer_raw.make keywords in
Expand All @@ -42,10 +46,7 @@ let parse_expr ?(keywords=Lexer_raw.keywords []) expr =
Parser_raw.parse_expression lexer lexbuf

let parse_longident lid =
let protected_lid =
Pprintast.protect_ident (Format.str_formatter) lid;
Format.flush_str_formatter ()
in
let protected_lid = protect lid in
let lexbuf = Lexing.from_string protected_lid in
let state = Lexer_raw.make @@ Lexer_raw.keywords [] in
let rec lexer = function
Expand Down Expand Up @@ -292,7 +293,7 @@ let type_in_env ?(verbosity=Verbosity.default) ?keywords ~context env ppf expr =
in
Printtyp.wrap_printing_env env ~verbosity @@ fun () ->
Msupport.uncatch_errors @@ fun () ->
match parse_expr ?keywords expr with
match parse_expr ?keywords @@ protect expr with
| exception exn -> print_exn ppf exn; false

| e ->
Expand Down
24 changes: 19 additions & 5 deletions src/ocaml/merlin_specific/browse_raw.ml
Original file line number Diff line number Diff line change
Expand Up @@ -71,6 +71,7 @@ type node =
| 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
Expand Down Expand Up @@ -111,6 +112,7 @@ let node_update_env env0 = function
| Class_type_declaration _ | Class_type_field _
| Include_description _ | Include_declaration _
| Open_description _ | Open_declaration _
| Binding_op _
-> env0

let node_real_loc loc0 = function
Expand Down Expand Up @@ -143,6 +145,7 @@ let node_real_loc loc0 = function
| 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
Expand Down Expand Up @@ -273,8 +276,8 @@ let of_constructor_arguments = function
| Cstr_tuple cts -> list_fold of_core_type cts
| Cstr_record lbls -> list_fold of_label_declaration lbls

let of_bop { bop_op_path = _; bop_op_val = _; bop_exp; _ } =
of_expression bop_exp
let of_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 ->
Expand Down Expand Up @@ -370,9 +373,17 @@ let of_expression_desc loc = function
| Texp_unreachable | Texp_extension_constructor _ ->
id_fold
| Texp_letop { let_; ands; body; _ } ->
of_bop let_ **
list_fold of_bop ands **
of_case body
let rec flatten_patterns acc pat =
match pat.pat_desc with
| Tpat_tuple [ tuple; pat ] ->
flatten_patterns (pat :: acc) tuple
| _ -> List.rev (pat :: acc)
in
let bindops = let_ :: ands in
let patterns = flatten_patterns [] 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

Expand Down Expand Up @@ -673,6 +684,8 @@ let of_node = function
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
Expand Down Expand Up @@ -719,6 +732,7 @@ let string_of_node = function
| 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"
Expand Down
1 change: 1 addition & 0 deletions src/ocaml/merlin_specific/browse_raw.mli
Original file line number Diff line number Diff line change
Expand Up @@ -84,6 +84,7 @@ type node =
| 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
Expand Down
16 changes: 8 additions & 8 deletions tests/test-dirs/type-enclosing/letop.t/run.t
Original file line number Diff line number Diff line change
Expand Up @@ -11,22 +11,22 @@ Various parts of the letop:
"col": 2
},
"end": {
"line": 5,
"col": 9
"line": 4,
"col": 6
},
"type": "('a -> 'b) -> 'a option -> 'b option",
"type": "'a -> 'b -> ('c -> 'd) -> 'c option -> 'd option",
"tail": "no"
},
{
"start": {
"line": 3,
"col": 17
"line": 4,
"col": 2
},
"end": {
"line": 5,
"col": 9
"line": 4,
"col": 6
},
"type": "'a -> ('b -> 'c) -> 'b option -> 'c option",
"type": "'a option -> (int -> int) -> ('b -> 'c) -> 'b option -> 'c option",
"tail": "no"
}
]
Expand Down
11 changes: 11 additions & 0 deletions tests/test-dirs/type-enclosing/letop2.t/letop.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,11 @@
let (let+) x f = Option.map f x

let (and+) x y =
Option.bind x @@ fun x ->
Option.map (fun y -> (x, y)) y

let minus_three (tbl1, tbl2) (key1, key2) =
let+ foo = Hashtbl.find_opt tbl1 key1
and+ bar = Hashtbl.find_opt tbl2 key2
and+ man = Hashtbl.find_opt tbl2 key2 in
foo + bar - man
31 changes: 31 additions & 0 deletions tests/test-dirs/type-enclosing/letop2.t/run.t
Original file line number Diff line number Diff line change
@@ -0,0 +1,31 @@
Various parts of the letop together with andop:

- The let+ operator:
$ $MERLIN single type-enclosing -position 8:4 -verbosity 0 \
> -filename ./letop.ml < ./letop.ml | jq ".value[0:2]"
[
{
"start": {
"line": 8,
"col": 2
},
"end": {
"line": 8,
"col": 6
},
"type": "'a option -> ('a -> 'b) -> 'b option",
"tail": "no"
},
{
"start": {
"line": 8,
"col": 2
},
"end": {
"line": 8,
"col": 6
},
"type": "((int * int) * int) option -> ((int * int) * int -> int) -> int option",
"tail": "no"
}
]

0 comments on commit b7973d5

Please sign in to comment.