Source file `locate_types.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
open Std

module Type_tree = struct
  type node_data =
    | Arrow
    | Tuple
    | Unboxed_tuple
    | Object
    | Poly_variant
    | Type_ref of { path : Path.t; ty : Types.type_expr }
    | Other of Types.type_expr

  type t = { data : node_data; children : t list }
end

let rec flatten_arrow ret_ty =
  match Types.get_desc ret_ty with
  | Tarrow ((label, _, _), ty1, ty2, _) ->
    let ty1 =
      match label with
      | Optional _ ->
        let rec strip_option ty =
          match Types.get_desc ty with
          | Tconstr (path, [ ty ], _) when Path.same path Predef.path_option ->
            ty
          | Tpoly (ty, vars) ->
            Types.newty3 ~level:(Types.get_level ty) ~scope:(Types.get_scope ty)
              (Tpoly (strip_option ty, vars))
          | _ -> ty
        in
        strip_option ty1
      | _ -> ty1
    in
    ty1 :: flatten_arrow ty2
  | _ -> [ ret_ty ]

let rec create_type_tree ty : Type_tree.t =
  match Types.get_desc ty with
  | Tarrow _ ->
    let tys = flatten_arrow ty in
    let children = List.map tys ~f:create_type_tree in
    { data = Arrow; children }
  | Ttuple tys ->
    let tys = List.map ~f:snd tys in
    let children = List.map tys ~f:create_type_tree in
    { data = Tuple; children }
  | Tunboxed_tuple tys ->
    let tys = List.map ~f:snd tys in
    let children = List.map tys ~f:create_type_tree in
    { data = Unboxed_tuple; children }
  | Tconstr (path, arg_tys, abbrev_memo) ->
    let ty_without_args = Btype.newgenty (Tconstr (path, [], abbrev_memo)) in
    let children = List.map arg_tys ~f:create_type_tree in
    { data = Type_ref { path; ty = ty_without_args }; children }
  | Tlink ty | Tpoly (ty, _) | Trepr (ty, _) -> create_type_tree ty
  | Tobject (fields_type, _) ->
    let rec extract_field_types (ty : Types.type_expr) =
      match Types.get_desc ty with
      | Tfield (_, _, ty, rest) -> ty :: extract_field_types rest
      | _ -> []
    in
    let field_types = List.rev (extract_field_types fields_type) in
    let children = List.map field_types ~f:create_type_tree in
    { data = Object; children }
  | Tvariant row_desc ->
    let fields = Types.row_fields row_desc in
    let children =
      List.filter_map fields ~f:(fun (_, row_field) ->
          match Types.row_field_repr row_field with
          | Rpresent (Some ty) -> Some (create_type_tree ty)
          | Reither (_, tys, _) ->
            (* If there are multiple types in [tys], they are types that are meant to
               unify with each other (it'd be a type error if not, see
               [Ctype.collapse_conj]). So just using the head of the list seems fine
               (using the entire list results in types being duplicated). *)
            List.hd_opt tys |> Option.map ~f:create_type_tree
          | Rpresent None | Rabsent -> None)
    in
    { data = Poly_variant; children }
  | Tquote_eval ty ->
    (* CR-someday liam923: Use a different constructor than Type_ref to represent this
       case. *)
    let ty_without_args =
      Btype.newgenty (Tconstr (Predef.path_eval, [], ref Types.Mnil))
    in
    let children = [ create_type_tree ty ] in
    { data = Type_ref { path = Predef.path_eval; ty = ty_without_args };
      children
    }
  | Tquote ty ->
    (* CR-someday liam923: Wrap this in something to indicate that it's inside a
       Tquote. *)
    create_type_tree ty
  | Tnil
  | Tvar _
  | Tsubst _
  | Tunivar _
  | Tpackage _
  | Tfield _
  | Tsplice _
  | Tof_kind _ -> { data = Other ty; children = [] }
Source file locate_types.ml

Source file `locate_types.ml`
