Source file type_enclosing.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
open Std
open Type_utils

let log_section = "type-enclosing"
let { Logger.log } = Logger.for_section log_section

type type_info =
  | Modtype of Env.t * Types.module_type
  | Type of Env.t * Types.type_expr
  | Type_decl of Env.t * Ident.t * Types.type_declaration
  | Type_constr of Env.t * Types.constructor_description
  | String of string

type typed_enclosings =
  (Location.t * type_info * Query_protocol.is_tail_position) list

let print_type ~verbosity type_info =
  let ppf = Format.str_formatter in
  let wrap_printing_env = Printtyp.wrap_printing_env ~verbosity in
  match type_info with
  | Type (env, t) ->
    wrap_printing_env env (fun () ->
        print_type_with_decl ~verbosity env ppf t;
        Format.flush_str_formatter ())
  | Type_decl (env, id, t) ->
    wrap_printing_env env (fun () ->
        Printtyp.type_declaration env id ppf t;
        Format.flush_str_formatter ())
  | Type_constr (env, cd) ->
    wrap_printing_env env (fun () ->
        print_constr ~verbosity env ppf cd;
        Format.flush_str_formatter ())
  | Modtype (env, m) ->
    wrap_printing_env env (fun () ->
        Printtyp.modtype env ppf m;
        Format.flush_str_formatter ())
  | String s -> s

let from_nodes ~path =
  let aux (env, node, tail) =
    let open Browse_raw in
    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 = 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
    | 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 }) } ->
      ret (Type (env, 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))
    | _ -> None
  in
  List.filter_map ~f:aux path

let from_reconstructed ~nodes ~cursor ~verbosity exprs =
  let open Browse_raw in
  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
    | 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 get_context lident =
    Context.inspect_browse_tree ~cursor (Longident.parse lident) [ nodes ]
  in

  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;
      Some (loc, Type_constr (env, cd), `No)
    | Some (Context.Label { lbl_name; lbl_arg; _ }) ->
      log ~title:"from_reconstructed" "ctx: label %s" lbl_name;
      Some (loc, Type (env, lbl_arg), `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