Source file `shape_tools.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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234

# 3 "shape_tools.cppo.ml"
open Odoc_model.Paths
open Odoc_model.Names
module Kind = Shape.Sig_component_kind

open Odoc_utils.OptionMonad

type t = Shape.t * Odoc_model.Paths.Identifier.SourceLocation.t Shape.Uid.Map.t

(** Project an identifier into a shape. *)
let rec shape_of_id env :
    [< Identifier.NonSrc.t_pv ] Identifier.id -> Shape.t option =
  let proj parent kind name =
    let item = Shape.Item.make name kind in
    match shape_of_id env (parent :> Identifier.NonSrc.t) with
    | Some shape -> Some (Shape.proj shape item)
    | None -> None
  in
  fun id ->
    if Identifier.is_hidden id then None else 
    match id.iv with
    | `Root (_, name) -> (
        match Env.lookup_impl (ModuleName.to_string_unsafe name) env with
        | Some impl -> (
            match impl.shape_info with
            | Some (shape, _) -> Some shape
            | None -> None)
        | _ -> None)
    | `Module (parent, name) ->
        proj parent Kind.Module (ModuleName.to_string_unsafe name)
    | `Result parent ->
        (* Apply the functor to an empty signature. This doesn't seem to cause
           any problem, as the shape would stop resolve on an item inside the
           result of the function, which is what we want. *)
        shape_of_id env (parent :> Identifier.NonSrc.t) >>= fun parent ->
        Some (Shape.app parent ~arg:(Shape.str Shape.Item.Map.empty))
    | `ModuleType (parent, name) ->
        proj parent Kind.Module_type (ModuleTypeName.to_string_unsafe name)
    | `Type (parent, name) -> proj parent Kind.Type (TypeName.to_string_unsafe name)
    | `Value (parent, name) -> proj parent Kind.Value (ValueName.to_string_unsafe name)
    | `Extension (parent, name) ->
        proj parent Kind.Extension_constructor (ExtensionName.to_string name)
    | `ExtensionDecl (parent, name, _) ->
        proj parent Kind.Extension_constructor (ExtensionName.to_string name)
    | `Exception (parent, name) ->
        proj parent Kind.Extension_constructor (ExceptionName.to_string name)
    | `Class (parent, name) -> proj parent Kind.Class (TypeName.to_string_unsafe name)
    | `ClassType (parent, name) ->
        proj parent Kind.Class_type (TypeName.to_string_unsafe name)
    | `Page _ | `LeafPage _ | `Label _
    | `Constructor _ | `Field _ | `UnboxedField _ | `Method _ | `InstanceVariable _ | `Parameter _
      ->
        (* Not represented in shapes. *)
        None

let rec shape_of_module_path env : _ -> Shape.t option =
  let proj parent kind name =
    let item = Shape.Item.make name kind in
    match
      shape_of_module_path env (parent :> Odoc_model.Paths.Path.Module.t)
    with
    | Some shape -> Some (Shape.proj shape item)
    | None -> None
  in
  fun (path : Odoc_model.Paths.Path.Module.t) ->
    match path with
    | `Resolved _ -> None
    | `Root name -> (
        match Env.lookup_impl (ModuleName.to_string name) env with
        | Some impl -> (
            match impl.shape_info with
            | Some (shape, _) -> Some shape
            | None -> None)
        | _ -> None)
    | `Forward _ -> None
    | `Dot (parent, name) ->
        proj (parent :> Odoc_model.Paths.Path.Module.t) Kind.Module (ModuleName.to_string_unsafe name)
    | `Apply (parent, arg) ->
        shape_of_module_path env (parent :> Odoc_model.Paths.Path.Module.t)
        >>= fun parent ->
        shape_of_module_path env (arg :> Odoc_model.Paths.Path.Module.t)
        >>= fun arg -> Some (Shape.app parent ~arg)
    | `Identifier (id, _) ->
        shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t)
    | `Substituted m ->
        shape_of_module_path env m
    | `Module _ | `LocalMod _ -> None

let rec shape_of_kind_path env kind :
    Odoc_model.Paths.Path.t -> Shape.t option =
  let proj parent kind name =
    let item = Shape.Item.make name kind in
    match shape_of_module_path env parent with
    | Some shape -> Some (Shape.proj shape item)
    | None -> None
  in
  fun path ->
    match path with
    | `Resolved _ -> None
    | `DotT (parent, name) -> proj parent kind (TypeName.to_string_unsafe name)
    | `DotMT (parent, name) -> proj parent kind (ModuleTypeName.to_string_unsafe name)
    | `DotV (parent, name) -> proj parent kind (ValueName.to_string_unsafe name)
    | `SubstitutedT t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
    | `SubstitutedMT t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
    | `SubstitutedCT t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
    | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t)
    | `Substituted t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
    | `Forward _
    | `Dot _
    | `Root _
    | `Apply _
    | `Module _
    | `LocalMod _
    | `LocalTy _
    | `ModuleType _
    | `LocalModTy _
    | `Type _
    | `LocalVal _ -> None
    
module MkId = Identifier.Mk

let unit_of_uid uid =
  match uid with
  | Shape.Uid.Compilation_unit s -> Some s
  | Item { comp_unit; _ } -> Some comp_unit
  | Predef _ -> None
  | Internal -> None
  
# 130 "shape_tools.cppo.ml"
  | Unboxed_version _ -> None

# 134 "shape_tools.cppo.ml"
let rec traverse_aliases = function
   | Shape_reduce.Resolved uid -> Some uid
   | Approximated id -> id
   | Resolved_alias (_,x) -> traverse_aliases x
   | _ -> None

# 141 "shape_tools.cppo.ml"
(* Cache the per-env shape reducer. [Shape_reduce.Make] allocates a lot of
   internal hashtables; we only want to do that once per env. Since the same
   env is used for a whole link traversal, caching by physical equality on
   env hits almost every call. *)
type cached_reduce_t = {
  env : Env.t;
  
# 150 "shape_tools.cppo.ml"
  reducer : Shape.t -> Shape_reduce.result;
# 152 "shape_tools.cppo.ml"
}

let cached_reduce : cached_reduce_t option ref = ref None

let get_reducer env =
  match !cached_reduce with
  | Some c when c.env == env -> c.reducer
  | _ ->
    
# 175 "shape_tools.cppo.ml"
    let module Reduce = Shape_reduce.Make(struct
      let fuel = 10
      let read_unit_shape ~unit_name =
        match Env.lookup_impl unit_name env with
        | Some impl -> (
            match impl.shape_info with
            | Some (shape, _) -> Some shape
            | None -> None)
         | _ -> None
      
# 185 "shape_tools.cppo.ml"
      let fuel () = Misc.Maybe_bounded.of_int fuel
      let projection_rules_for_merlin_enabled = false
      let fuel_for_compilation_units = fuel
      let max_shape_reduce_steps_per_variable = fuel
      let max_compilation_unit_depth = fuel
      let read_unit_shape ~diagnostics:_ ~unit_name = read_unit_shape ~unit_name
    
# 192 "shape_tools.cppo.ml"
    end) in
    let reducer query = Reduce.reduce_for_uid Ocaml_env.empty query in
    
# 195 "shape_tools.cppo.ml"
    cached_reduce := Some { env; reducer };
    reducer

let lookup_shape : Env.t -> Shape.t -> Identifier.SourceLocation.t option =
 fun env query ->
  let reducer = get_reducer env in
  
# 206 "shape_tools.cppo.ml"
  let result = try Some (reducer query) with Not_found -> None in
  result >>= traverse_aliases >>= fun uid ->
  
# 209 "shape_tools.cppo.ml"
  unit_of_uid uid >>= fun unit_name ->
  match Env.lookup_impl unit_name env with
  | Some { shape_info ; id = Some id ; _} -> (
      let uid_to_id =
        match shape_info with
        | Some (_, uid_to_id) -> uid_to_id
        | None -> Odoc_model.Compat.empty_map
      in
      match Shape.Uid.Map.find_opt uid uid_to_id with
      | Some x -> Some x
      | None ->  Some (MkId.source_location_mod id))
  | None
  | Some { id = None ; _} -> None

let lookup_def :
    Env.t -> Identifier.NonSrc.t -> Identifier.SourceLocation.t option =
 fun env id ->
  match shape_of_id env id with
  | None -> None
  | Some query -> lookup_shape env query

let lookup_module_path env path =
  match shape_of_module_path env path with
  | None -> None
  | Some query -> lookup_shape env query

let lookup_kind_path kind env (path : Odoc_model.Paths.Path.t) =
  match shape_of_kind_path env kind path with
  | None -> None
  | Some query -> lookup_shape env query

let lookup_value_path env p = lookup_kind_path Kind.Value env (p : Odoc_model.Paths.Path.Value.t :> Odoc_model.Paths.Path.t)

let lookup_type_path env p = lookup_kind_path Kind.Type env (p : Odoc_model.Paths.Path.Type.t :> Odoc_model.Paths.Path.t)

let lookup_module_type_path env p = lookup_kind_path Kind.Module_type env (p : Odoc_model.Paths.Path.ModuleType.t :> Odoc_model.Paths.Path.t)

let lookup_class_type_path env p = lookup_kind_path Kind.Class_type env (p : Odoc_model.Paths.Path.ClassType.t :> Odoc_model.Paths.Path.t)
Source file shape_tools.ml

Source file `shape_tools.ml`
