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

# 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 _ | `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

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 _ -> 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"
let lookup_shape : Env.t -> Shape.t -> Identifier.SourceLocation.t option =
 fun env query ->
  
# 133 "shape_tools.cppo.ml"
  let module Reduce = Shape.Make_reduce (struct
    type env = unit
    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
    let find_shape _ _ = raise Not_found
  end) in
  let result = try Some (Reduce.reduce () query) with Not_found -> None in
  result >>= fun result ->
  result.uid >>= fun uid ->
  
# 162 "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)