jon.recoil.org
this repo has no description
1open Odoc_model.Names
2open Odoc_model.Paths
3
4(* For simplicity keep a global counter *)
5let counter = ref 0
6
7type module_ = [ `LModule of ModuleName.t * int ]
8
9type module_type = [ `LModuleType of ModuleTypeName.t * int ]
10
11type type_ = [ `LType of TypeName.t * int ]
12
13type constructor = [ `LConstructor of ConstructorName.t * int ]
14
15type field = [ `LField of FieldName.t * int ]
16
17type unboxed_field = [ `LUnboxedField of UnboxedFieldName.t * int ]
18
19type extension = [ `LExtension of ExtensionName.t * int ]
20
21type exception_ = [ `LException of ExceptionName.t * int ]
22
23type value = [ `LValue of ValueName.t * int ]
24
25type method_ = [ `LMethod of MethodName.t * int ]
26
27type instance_variable = [ `LInstanceVariable of InstanceVariableName.t * int ]
28
29type label = [ `LLabel of LabelName.t * int ]
30
31type page = [ `LPage of PageName.t * int ]
32
33type any =
34 [ module_
35 | module_type
36 | type_
37 | constructor
38 | field
39 | unboxed_field
40 | extension
41 | exception_
42 | value
43 | method_
44 | instance_variable
45 | label
46 | page ]
47
48let fresh_int () =
49 let n = !counter in
50 incr counter;
51 n
52
53let int_of_any : any -> int = function
54 | `LModule (_, i)
55 | `LException (_, i)
56 | `LConstructor (_, i)
57 | `LMethod (_, i)
58 | `LType (_, i)
59 | `LValue (_, i)
60 | `LInstanceVariable (_, i)
61 | `LField (_, i)
62 | `LUnboxedField (_, i)
63 | `LLabel (_, i)
64 | `LModuleType (_, i)
65 | `LPage (_, i)
66 | `LExtension (_, i) ->
67 i
68
69module Of_Identifier = struct
70 open Identifier
71
72 let type_ : Type.t -> type_ =
73 fun t ->
74 let i = fresh_int () in
75 match t.iv with `Type (_, n) -> `LType (n, i)
76
77 let module_ : Module.t -> module_ = function
78 | { iv = `Module (_, n) | `Root (_, n); _ } ->
79 let i = fresh_int () in
80 `LModule (n, i)
81 | { iv = `Parameter (_, n); _ } ->
82 let i = fresh_int () in
83 `LModule (n, i)
84
85 let functor_parameter : FunctorParameter.t -> module_ =
86 fun { iv = `Parameter (_, n); _ } -> `LModule (n, fresh_int ())
87
88 let module_type : ModuleType.t -> module_type =
89 fun m ->
90 let i = fresh_int () in
91 match m.iv with `ModuleType (_, n) -> `LModuleType (n, i)
92
93 let extension : Extension.t -> extension =
94 fun e -> match e.iv with `Extension (_, n) -> `LExtension (n, fresh_int ())
95
96 let exception_ : Exception.t -> exception_ =
97 fun e -> match e.iv with `Exception (_, n) -> `LException (n, fresh_int ())
98
99 let value : Value.t -> value =
100 fun v -> match v.iv with `Value (_, n) -> `LValue (n, fresh_int ())
101
102 let class_ : Class.t -> type_ =
103 fun c -> match c.iv with `Class (_, n) -> `LType (n, fresh_int ())
104
105 let class_type : ClassType.t -> type_ =
106 fun c -> match c.iv with `ClassType (_, n) -> `LType (n, fresh_int ())
107
108 let method_ : Method.t -> method_ =
109 fun c -> match c.iv with `Method (_, n) -> `LMethod (n, fresh_int ())
110
111 let instance_variable : InstanceVariable.t -> instance_variable =
112 fun i ->
113 match i.iv with
114 | `InstanceVariable (_, n) -> `LInstanceVariable (n, fresh_int ())
115
116 let label : Label.t -> label =
117 fun l -> match l.iv with `Label (_, n) -> `LLabel (n, fresh_int ())
118end
119
120module Name = struct
121 let typed_module : module_ -> ModuleName.t = function `LModule (n, _) -> n
122 let module_ m = ModuleName.to_string (typed_module m)
123
124 let unsafe_module m = ModuleName.to_string_unsafe (typed_module m)
125
126 let typed_type : type_ -> TypeName.t = function `LType (n, _) -> n
127 let type_ t = TypeName.to_string (typed_type t)
128
129 let unsafe_type : type_ -> string = function
130 | `LType (n, _) -> TypeName.to_string_unsafe n
131
132 let module_type : module_type -> string = function
133 | `LModuleType (n, _) -> ModuleTypeName.to_string n
134
135 let unsafe_module_type : module_type -> string = function
136 | `LModuleType (n, _) -> ModuleTypeName.to_string_unsafe n
137
138 let typed_module_type : module_type -> ModuleTypeName.t = function
139 | `LModuleType (n, _) -> n
140
141 let exception_ : exception_ -> string = function
142 | `LException (n, _) -> ExceptionName.to_string n
143
144 let typed_exception : exception_ -> ExceptionName.t = function
145 | `LException (n, _) -> n
146
147 let value : value -> string = function
148 | `LValue (n, _) -> ValueName.to_string n
149
150 let typed_value : value -> ValueName.t = function `LValue (n, _) -> n
151
152 let label : label -> string = function
153 | `LLabel (n, _) -> LabelName.to_string n
154
155 let typed_label : label -> LabelName.t = function `LLabel (n, _) -> n
156
157 let method_ : method_ -> string = function
158 | `LMethod (n, _) -> MethodName.to_string n
159
160 let typed_method : method_ -> MethodName.t = function `LMethod (n, _) -> n
161
162 let instance_variable : instance_variable -> string = function
163 | `LInstanceVariable (n, _) -> InstanceVariableName.to_string n
164
165 let typed_instance_variable : instance_variable -> InstanceVariableName.t =
166 function
167 | `LInstanceVariable (n, _) -> n
168end
169
170module Rename = struct
171 let module_ : module_ -> module_ = function
172 | `LModule (n, _) -> `LModule (n, fresh_int ())
173
174 let module_type : module_type -> module_type = function
175 | `LModuleType (n, _) -> `LModuleType (n, fresh_int ())
176
177 let type_ : type_ -> type_ = function
178 | `LType (n, _) -> `LType (n, fresh_int ())
179
180 let exception_ : exception_ -> exception_ = function
181 | `LException (n, _) -> `LException (n, fresh_int ())
182
183 let value : value -> value = function
184 | `LValue (n, _) -> `LValue (n, fresh_int ())
185end
186
187let hash : any -> int = Hashtbl.hash
188
189let compare : any -> any -> int = fun a b -> int_of_any a - int_of_any b
190
191let reset () = counter := 0
192
193let fmt_aux (id : any) : string * int =
194 match id with
195 | `LModule (n, i) -> (ModuleName.to_string n, i)
196 | `LModuleType (n, i) -> (ModuleTypeName.to_string n, i)
197 | `LType (n, i) -> (TypeName.to_string n, i)
198 | `LConstructor (n, i) -> (ConstructorName.to_string n, i)
199 | `LField (n, i) -> (FieldName.to_string n, i)
200 | `LUnboxedField (n, i) -> (UnboxedFieldName.to_string n, i)
201 | `LExtension (n, i) -> (ExtensionName.to_string n, i)
202 | `LException (n, i) -> (ExceptionName.to_string n, i)
203 | `LValue (n, i) -> (ValueName.to_string n, i)
204 | `LMethod (n, i) -> (MethodName.to_string n, i)
205 | `LInstanceVariable (n, i) -> (InstanceVariableName.to_string n, i)
206 | `LLabel (n, i) -> (LabelName.to_string n, i)
207 | `LPage (n, i) -> (PageName.to_string n, i)
208
209let fmt : Format.formatter -> [< any ] -> unit =
210 fun ppf id ->
211 let n, i = fmt_aux (id :> any) in
212 Format.fprintf ppf "%s/%d" n i
213
214let short_fmt : Format.formatter -> [< any ] -> unit =
215 fun ppf id ->
216 let n, _i = fmt_aux (id :> any) in
217 Format.fprintf ppf "%s" n
218
219let rename (s, _) = (s, fresh_int ())