Skip to content

Commit a97ee80

Browse files
JulowJulow
authored
Merge pull request #1073 from Julow/remove-predef-types
Ident_env: Assume unknown types are core types
2 parents 9aface1 + 6b106ec commit a97ee80

File tree

4 files changed

+66
-531
lines changed

4 files changed

+66
-531
lines changed

‎src/loader/ident_env.cppo.ml

Lines changed: 10 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,6 @@
1515
*)
1616

1717
open Odoc_model
18-
open Predefined
1918
open Names
2019

2120
module Id = Paths.Identifier
@@ -84,9 +83,6 @@ type items =
8483
| `Include of item list
8584
]
8685

87-
let builtin_idents = List.map snd Predef.builtin_idents
88-
89-
9086
let rec extract_signature_type_items items =
9187
let open Compat in
9288
match items with
@@ -659,22 +655,17 @@ let find_extension_identifier env id =
659655
let find_value_identifier env id =
660656
Ident.find_same id env.values
661657

658+
(** Lookup a type in the environment. If it isn't found, it's assumed to be a
659+
core type. *)
662660
let find_type env id =
663-
try
664-
(Ident.find_same id env.types :> Id.Path.Type.t)
665-
with Not_found ->
666-
try
667-
(Ident.find_same id env.classes :> Id.Path.Type.t)
668-
with Not_found ->
669-
try
670-
(Ident.find_same id env.class_types :> Id.Path.Type.t)
661+
try (Ident.find_same id env.types :> Id.Path.Type.t)
662+
with Not_found -> (
663+
try (Ident.find_same id env.classes :> Id.Path.Type.t)
664+
with Not_found -> (
665+
try (Ident.find_same id env.class_types :> Id.Path.Type.t)
671666
with Not_found ->
672-
if List.mem id builtin_idents then
673-
match core_type_identifier (Ident.name id) with
674-
| Some id -> (id :> type_ident)
675-
| None -> raise Not_found
676-
else raise Not_found
677-
667+
(Paths.Identifier.Mk.core_type (Ident.name id) :> type_ident)))
668+
678669
let find_class_type env id =
679670
try
680671
(Ident.find_same id env.classes :> Id.Path.ClassType.t)
@@ -704,9 +695,7 @@ module Path = struct
704695
with Not_found -> assert false
705696

706697
let read_type_ident env id =
707-
try
708-
`Identifier (find_type env id, false)
709-
with Not_found -> assert false
698+
`Identifier (find_type env id, false)
710699

711700
let read_value_ident env id : Paths.Path.Value.t =
712701
`Identifier (find_value_identifier env id, false)

‎src/model/predefined.ml

Lines changed: 45 additions & 254 deletions
Original file line numberDiff line numberDiff line change
@@ -39,35 +39,16 @@ let mk_type ?(doc = empty_doc) ?(eq = nullary_equation) ?repr id =
3939
let locs = locations and canonical = None in
4040
{ TypeDecl.id; locs; doc; canonical; equation = eq; representation = repr }
4141

42-
let mk_exn ~args id =
43-
let locs = locations
44-
and doc = empty_doc
45-
and args = TypeDecl.Constructor.Tuple args
46-
and res = None in
47-
{ Exception.id; locs; doc; args; res }
48-
4942
let mk_constr ?(args = TypeDecl.Constructor.Tuple []) id =
5043
{ TypeDecl.Constructor.id; doc = empty_doc; args; res = None }
5144

5245
module Mk = Paths.Identifier.Mk
5346

5447
let bool_identifier = Mk.core_type "bool"
55-
let int_identifier = Mk.core_type "int"
56-
let char_identifier = Mk.core_type "char"
57-
let bytes_identifier = Mk.core_type "bytes"
58-
let string_identifier = Mk.core_type "string"
59-
let float_identifier = Mk.core_type "float"
6048
let unit_identifier = Mk.core_type "unit"
6149
let exn_identifier = Mk.core_type "exn"
62-
let array_identifier = Mk.core_type "array"
6350
let list_identifier = Mk.core_type "list"
6451
let option_identifier = Mk.core_type "option"
65-
let int32_identifier = Mk.core_type "int32"
66-
let int64_identifier = Mk.core_type "int64"
67-
let nativeint_identifier = Mk.core_type "nativeint"
68-
let lazy_t_identifier = Mk.core_type "lazy_t"
69-
let extension_constructor_identifier = Mk.core_type "extension_constructor"
70-
let floatarray_identifier = Mk.core_type "floatarray"
7152

7253
let false_identifier =
7354
Mk.constructor (bool_identifier, ConstructorName.make_std "false")
@@ -90,138 +71,8 @@ let none_identifier =
9071
let some_identifier =
9172
Mk.constructor (option_identifier, ConstructorName.make_std "Some")
9273

93-
let match_failure_identifier = Mk.core_exception "Match_failure"
94-
let assert_failure_identifier = Mk.core_exception "Assert_failure"
95-
let invalid_argument_identifier = Mk.core_exception "Invalid_argument"
96-
let failure_identifier = Mk.core_exception "Failure"
97-
let not_found_identifier = Mk.core_exception "Not_found"
98-
let out_of_memory_identifier = Mk.core_exception "Out_of_memory"
99-
let stack_overflow_identifier = Mk.core_exception "Stack_overflow"
100-
let sys_error_identifier = Mk.core_exception "Sys_error"
101-
let end_of_file_identifier = Mk.core_exception "End_of_file"
102-
let division_by_zero_identifier = Mk.core_exception "Division_by_zero"
103-
let sys_blocked_io_identifier = Mk.core_exception "Sys_blocked_io"
104-
105-
let undefined_recursive_module_identifier =
106-
Mk.core_exception "Undefined_recursive_module"
107-
108-
let core_type_identifier = function
109-
| "int" -> Some int_identifier
110-
| "char" -> Some char_identifier
111-
| "bytes" -> Some bytes_identifier
112-
| "string" -> Some string_identifier
113-
| "float" -> Some float_identifier
114-
| "bool" -> Some bool_identifier
115-
| "unit" -> Some unit_identifier
116-
| "exn" -> Some exn_identifier
117-
| "array" -> Some array_identifier
118-
| "list" -> Some list_identifier
119-
| "option" -> Some option_identifier
120-
| "int32" -> Some int32_identifier
121-
| "int64" -> Some int64_identifier
122-
| "nativeint" -> Some nativeint_identifier
123-
| "lazy_t" -> Some lazy_t_identifier
124-
| "extension_constructor" -> Some extension_constructor_identifier
125-
| "floatarray" -> Some floatarray_identifier
126-
| _ -> None
127-
128-
let core_exception_identifier = function
129-
| "Match_failure" -> Some match_failure_identifier
130-
| "Out_of_memory" -> Some out_of_memory_identifier
131-
| "Invalid_argument" -> Some invalid_argument_identifier
132-
| "Failure" -> Some failure_identifier
133-
| "Not_found" -> Some not_found_identifier
134-
| "Sys_error" -> Some sys_error_identifier
135-
| "End_of_file" -> Some end_of_file_identifier
136-
| "Division_by_zero" -> Some division_by_zero_identifier
137-
| "Stack_overflow" -> Some stack_overflow_identifier
138-
| "Sys_blocked_io" -> Some sys_blocked_io_identifier
139-
| "Assert_failure" -> Some assert_failure_identifier
140-
| "Undefined_recursive_module" -> Some undefined_recursive_module_identifier
141-
| _ -> None
142-
143-
let core_constructor_identifier = function
144-
| "false" -> Some false_identifier
145-
| "true" -> Some true_identifier
146-
| "()" -> Some void_identifier
147-
| "[]" -> Some nil_identifier
148-
| "([])" -> Some nil_identifier
149-
| "::" -> Some cons_identifier
150-
| "(::)" -> Some cons_identifier
151-
| "None" -> Some none_identifier
152-
| "Some" -> Some some_identifier
153-
| _ -> None
154-
155-
let bool_path = `Resolved (`Identifier bool_identifier)
156-
let int_path = `Resolved (`Identifier int_identifier)
157-
let char_path = `Resolved (`Identifier char_identifier)
158-
let bytes_path = `Resolved (`Identifier bytes_identifier)
159-
let string_path = `Resolved (`Identifier string_identifier)
160-
let float_path = `Resolved (`Identifier float_identifier)
161-
let unit_path = `Resolved (`Identifier unit_identifier)
16274
let exn_path = `Resolved (`Identifier exn_identifier)
163-
let array_path = `Resolved (`Identifier array_identifier)
16475
let list_path = `Resolved (`Identifier list_identifier)
165-
let option_path = `Resolved (`Identifier option_identifier)
166-
let int32_path = `Resolved (`Identifier int32_identifier)
167-
let int64_path = `Resolved (`Identifier int64_identifier)
168-
let nativeint_path = `Resolved (`Identifier nativeint_identifier)
169-
let lazy_t_path = `Resolved (`Identifier lazy_t_identifier)
170-
171-
let extension_constructor_path =
172-
`Resolved (`Identifier extension_constructor_identifier)
173-
174-
let _floatarray_path = `Resolved (`Identifier floatarray_identifier)
175-
let bool_reference = `Resolved (`Identifier bool_identifier)
176-
let int_reference = `Resolved (`Identifier int_identifier)
177-
let char_reference = `Resolved (`Identifier char_identifier)
178-
let bytes_reference = `Resolved (`Identifier bytes_identifier)
179-
let string_reference = `Resolved (`Identifier string_identifier)
180-
let float_reference = `Resolved (`Identifier float_identifier)
181-
let unit_reference = `Resolved (`Identifier unit_identifier)
182-
let exn_reference = `Resolved (`Identifier exn_identifier)
183-
let array_reference = `Resolved (`Identifier array_identifier)
184-
let list_reference = `Resolved (`Identifier list_identifier)
185-
let option_reference = `Resolved (`Identifier option_identifier)
186-
let int32_reference = `Resolved (`Identifier int32_identifier)
187-
let int64_reference = `Resolved (`Identifier int64_identifier)
188-
let nativeint_reference = `Resolved (`Identifier nativeint_identifier)
189-
let lazy_t_reference = `Resolved (`Identifier lazy_t_identifier)
190-
191-
let extension_constructor_reference =
192-
`Resolved (`Identifier extension_constructor_identifier)
193-
194-
let _floatarray_reference = `Resolved (`Identifier floatarray_identifier)
195-
let false_reference = `Resolved (`Identifier false_identifier)
196-
let true_reference = `Resolved (`Identifier true_identifier)
197-
let void_reference = `Resolved (`Identifier void_identifier)
198-
let nil_reference = `Resolved (`Identifier nil_identifier)
199-
let cons_reference = `Resolved (`Identifier cons_identifier)
200-
let none_reference = `Resolved (`Identifier none_identifier)
201-
let some_reference = `Resolved (`Identifier some_identifier)
202-
let match_failure_reference = `Resolved (`Identifier match_failure_identifier)
203-
let assert_failure_reference = `Resolved (`Identifier assert_failure_identifier)
204-
205-
let invalid_argument_reference =
206-
`Resolved (`Identifier invalid_argument_identifier)
207-
208-
let failure_reference = `Resolved (`Identifier failure_identifier)
209-
let not_found_reference = `Resolved (`Identifier not_found_identifier)
210-
let out_of_memory_reference = `Resolved (`Identifier out_of_memory_identifier)
211-
let stack_overflow_reference = `Resolved (`Identifier stack_overflow_identifier)
212-
let sys_error_reference = `Resolved (`Identifier sys_error_identifier)
213-
let end_of_file_reference = `Resolved (`Identifier end_of_file_identifier)
214-
215-
let division_by_zero_reference =
216-
`Resolved (`Identifier division_by_zero_identifier)
217-
218-
let sys_blocked_io_reference = `Resolved (`Identifier sys_blocked_io_identifier)
219-
220-
let undefined_recursive_module_reference =
221-
`Resolved (`Identifier undefined_recursive_module_identifier)
222-
223-
let string_expr = TypeExpr.Constr (string_path, [])
224-
let int_expr = TypeExpr.Constr (int_path, [])
22576

22677
let false_decl = mk_constr ~args:(Tuple []) false_identifier
22778
let true_decl = mk_constr ~args:(Tuple []) true_identifier
@@ -236,115 +87,55 @@ let cons_decl =
23687
let none_decl = mk_constr ~args:(Tuple []) none_identifier
23788
let some_decl = mk_constr ~args:(Tuple [ TypeExpr.Var "'a" ]) some_identifier
23889

239-
let int_decl = mk_type int_identifier
240-
let char_decl = mk_type char_identifier
241-
let bytes_decl = mk_type bytes_identifier
242-
let string_decl = mk_type string_identifier
243-
let float_decl = mk_type float_identifier
244-
let bool_decl =
245-
mk_type ~repr:(Variant [ false_decl; true_decl ]) bool_identifier
246-
let unit_decl = mk_type ~repr:(Variant [ void_decl ]) unit_identifier
247-
let exn_decl = mk_type ~repr:Extensible exn_identifier
248-
let array_decl = mk_type ~eq:invariant_equation array_identifier
249-
250-
let list_decl =
251-
mk_type ~eq:covariant_equation
252-
~repr:(Variant [ nil_decl; cons_decl ])
253-
list_identifier
254-
255-
let option_decl =
256-
mk_type ~eq:covariant_equation
257-
~repr:(Variant [ none_decl; some_decl ])
258-
option_identifier
90+
(** The type representation for known core types. *)
91+
let type_repr_of_core_type =
92+
let open TypeDecl.Representation in
93+
function
94+
| "bool" -> Some (Variant [ false_decl; true_decl ])
95+
| "unit" -> Some (Variant [ void_decl ])
96+
| "exn" -> Some Extensible
97+
| "option" -> Some (Variant [ none_decl; some_decl ])
98+
| "list" -> Some (Variant [ nil_decl; cons_decl ])
99+
| _ -> None
259100

260-
let int32_decl = mk_type int32_identifier
261-
let int64_decl = mk_type int64_identifier
262-
let nativeint_decl = mk_type nativeint_identifier
263-
let lazy_t_decl = mk_type ~eq:covariant_equation lazy_t_identifier
264-
let extension_constructor_decl =
265-
mk_type ~eq:covariant_equation extension_constructor_identifier
101+
let type_eq_of_core_type = function
102+
| "lazy_t" | "extension_constructor" -> Some covariant_equation
103+
| "array" -> Some invariant_equation
104+
| _ -> None
266105

267-
let floatarray_decl =
106+
let doc_of_core_type =
107+
let elt x = Location_.at predefined_location x in
268108
let words ss =
269109
ss
270-
|> List.rev_map (fun s -> [ `Space; `Word s ])
110+
|> List.rev_map (fun s -> [ elt `Space; elt (`Word s) ])
271111
|> List.flatten |> List.tl |> List.rev
272112
in
273-
let doc =
274-
[
275-
`Paragraph
276-
(words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ]
277-
@ [
278-
`Space;
279-
`Reference
280-
( `Module
281-
(`Root ("Array", `TModule), ModuleName.make_std "Floatarray"),
282-
[] );
283-
`Space;
284-
]
285-
@ words [ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ]
286-
|> List.map (Location_.at predefined_location));
287-
]
288-
|> List.map (Location_.at predefined_location)
289-
in
290-
mk_type ~doc ~eq:covariant_equation floatarray_identifier
291-
292-
let match_failure_decl =
293-
mk_exn
294-
~args:[ TypeExpr.Tuple [ string_expr; int_expr; int_expr ] ]
295-
match_failure_identifier
296-
let assert_failure_decl =
297-
mk_exn
298-
~args:[ TypeExpr.Tuple [ string_expr; int_expr; int_expr ] ]
299-
assert_failure_identifier
300-
let invalid_argument_decl =
301-
mk_exn ~args:[ string_expr ] invalid_argument_identifier
302-
let failure_decl = mk_exn ~args:[ string_expr ] failure_identifier
303-
let not_found_decl = mk_exn ~args:[] not_found_identifier
304-
let out_of_memory_decl = mk_exn ~args:[] out_of_memory_identifier
305-
let stack_overflow_decl = mk_exn ~args:[] stack_overflow_identifier
306-
let sys_error_decl = mk_exn ~args:[ string_expr ] sys_error_identifier
307-
let end_of_file_decl = mk_exn ~args:[] end_of_file_identifier
308-
let division_by_zero_decl = mk_exn ~args:[] division_by_zero_identifier
309-
let sys_blocked_io_decl = mk_exn ~args:[] sys_blocked_io_identifier
310-
let undefined_recursive_module_decl =
311-
mk_exn
312-
~args:[ TypeExpr.Tuple [ string_expr; int_expr; int_expr ] ]
313-
undefined_recursive_module_identifier
314-
315-
let core_types =
316-
[
317-
int_decl;
318-
char_decl;
319-
bytes_decl;
320-
string_decl;
321-
float_decl;
322-
bool_decl;
323-
unit_decl;
324-
exn_decl;
325-
array_decl;
326-
list_decl;
327-
option_decl;
328-
int32_decl;
329-
int64_decl;
330-
nativeint_decl;
331-
lazy_t_decl;
332-
extension_constructor_decl;
333-
floatarray_decl;
334-
]
113+
let paragraph x = elt (`Paragraph x) in
114+
function
115+
| "floatarray" ->
116+
Some
117+
[
118+
paragraph
119+
(words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ]
120+
@ [
121+
elt `Space;
122+
elt
123+
(`Reference
124+
( `Module
125+
( `Root ("Array", `TModule),
126+
ModuleName.make_std "Floatarray" ),
127+
[] ));
128+
elt `Space;
129+
]
130+
@ words
131+
[ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ]
132+
);
133+
]
134+
| _ -> None
335135

336-
let core_exceptions =
337-
[
338-
match_failure_decl;
339-
assert_failure_decl;
340-
invalid_argument_decl;
341-
failure_decl;
342-
not_found_decl;
343-
out_of_memory_decl;
344-
stack_overflow_decl;
345-
sys_error_decl;
346-
end_of_file_decl;
347-
division_by_zero_decl;
348-
sys_blocked_io_decl;
349-
undefined_recursive_module_decl;
350-
]
136+
let type_of_core_type name =
137+
let identifier = Mk.core_type name
138+
and repr = type_repr_of_core_type name
139+
and eq = type_eq_of_core_type name
140+
and doc = doc_of_core_type name in
141+
mk_type ?doc ?repr ?eq identifier

0 commit comments

Comments
 (0)