Skip to content

Commit

Permalink
Don't fail on core type lookup
Browse files Browse the repository at this point in the history 
Core type are no longer predefined and are instead assumed to be
resolved and constructed on the fly.

This replaces the pre-definition of all the core type with the
`type_of_core_type` function, which construct core types when needed and
only hardcode the representation of known core types.
It doesn't fail.
  • Loading branch information
@Julow
Julow committed Jan 23, 2024
1 parent 6d30b7a commit 6b106ec
Show file tree
Hide file tree
Showing 3 changed files with 59 additions and 97 deletions.
129 changes: 48 additions & 81 deletions src/model/predefined.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,22 +45,10 @@ let mk_constr ?(args = TypeDecl.Constructor.Tuple []) id =
module Mk = Paths.Identifier.Mk

let bool_identifier = Mk.core_type "bool"
let int_identifier = Mk.core_type "int"
let char_identifier = Mk.core_type "char"
let bytes_identifier = Mk.core_type "bytes"
let string_identifier = Mk.core_type "string"
let float_identifier = Mk.core_type "float"
let unit_identifier = Mk.core_type "unit"
let exn_identifier = Mk.core_type "exn"
let array_identifier = Mk.core_type "array"
let list_identifier = Mk.core_type "list"
let option_identifier = Mk.core_type "option"
let int32_identifier = Mk.core_type "int32"
let int64_identifier = Mk.core_type "int64"
let nativeint_identifier = Mk.core_type "nativeint"
let lazy_t_identifier = Mk.core_type "lazy_t"
let extension_constructor_identifier = Mk.core_type "extension_constructor"
let floatarray_identifier = Mk.core_type "floatarray"

let false_identifier =
Mk.constructor (bool_identifier, ConstructorName.make_std "false")
Expand Down Expand Up @@ -99,76 +87,55 @@ let cons_decl =
let none_decl = mk_constr ~args:(Tuple []) none_identifier
let some_decl = mk_constr ~args:(Tuple [ TypeExpr.Var "'a" ]) some_identifier

let int_decl = mk_type int_identifier
let char_decl = mk_type char_identifier
let bytes_decl = mk_type bytes_identifier
let string_decl = mk_type string_identifier
let float_decl = mk_type float_identifier
let bool_decl =
mk_type ~repr:(Variant [ false_decl; true_decl ]) bool_identifier
let unit_decl = mk_type ~repr:(Variant [ void_decl ]) unit_identifier
let exn_decl = mk_type ~repr:Extensible exn_identifier
let array_decl = mk_type ~eq:invariant_equation array_identifier

let list_decl =
mk_type ~eq:covariant_equation
~repr:(Variant [ nil_decl; cons_decl ])
list_identifier

let option_decl =
mk_type ~eq:covariant_equation
~repr:(Variant [ none_decl; some_decl ])
option_identifier

let int32_decl = mk_type int32_identifier
let int64_decl = mk_type int64_identifier
let nativeint_decl = mk_type nativeint_identifier
let lazy_t_decl = mk_type ~eq:covariant_equation lazy_t_identifier
let extension_constructor_decl =
mk_type ~eq:covariant_equation extension_constructor_identifier

let floatarray_decl =
(** The type representation for known core types. *)
let type_repr_of_core_type =
let open TypeDecl.Representation in
function
| "bool" -> Some (Variant [ false_decl; true_decl ])
| "unit" -> Some (Variant [ void_decl ])
| "exn" -> Some Extensible
| "option" -> Some (Variant [ none_decl; some_decl ])
| "list" -> Some (Variant [ nil_decl; cons_decl ])
| _ -> None

let type_eq_of_core_type = function
| "lazy_t" | "extension_constructor" -> Some covariant_equation
| "array" -> Some invariant_equation
| _ -> None

let doc_of_core_type =
let elt x = Location_.at predefined_location x in
let words ss =
ss
|> List.rev_map (fun s -> [ `Space; `Word s ])
|> List.rev_map (fun s -> [ elt `Space; elt (`Word s) ])
|> List.flatten |> List.tl |> List.rev
in
let doc =
[
`Paragraph
(words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ]
@ [
`Space;
`Reference
( `Module
(`Root ("Array", `TModule), ModuleName.make_std "Floatarray"),
[] );
`Space;
]
@ words [ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ]
|> List.map (Location_.at predefined_location));
]
|> List.map (Location_.at predefined_location)
in
mk_type ~doc ~eq:covariant_equation floatarray_identifier

let core_types =
[
int_decl;
char_decl;
bytes_decl;
string_decl;
float_decl;
bool_decl;
unit_decl;
exn_decl;
array_decl;
list_decl;
option_decl;
int32_decl;
int64_decl;
nativeint_decl;
lazy_t_decl;
extension_constructor_decl;
floatarray_decl;
]
let paragraph x = elt (`Paragraph x) in
function
| "floatarray" ->
Some
[
paragraph
(words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ]
@ [
elt `Space;
elt
(`Reference
( `Module
( `Root ("Array", `TModule),
ModuleName.make_std "Floatarray" ),
[] ));
elt `Space;
]
@ words
[ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ]
);
]
| _ -> None

let type_of_core_type name =
let identifier = Mk.core_type name
and repr = type_repr_of_core_type name
and eq = type_eq_of_core_type name
and doc = doc_of_core_type name in
mk_type ?doc ?repr ?eq identifier
7 changes: 2 additions & 5 deletions src/model/predefined.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,10 +16,7 @@

open Paths

(** {3 Paths} *)

val exn_path : Path.Type.t

(** {3 Declarations} *)

val core_types : Lang.TypeDecl.t list
val type_of_core_type : string -> Lang.TypeDecl.t
(** The type declaration of a core type given its name. *)
20 changes: 9 additions & 11 deletions src/xref2/tools.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -91,14 +91,6 @@ let canonical_helper :
let find_fn (r, _) = get_identifier r = fallback_id in
try Some (List.find find_fn resolved) with _ -> None)

let core_types =
let open Odoc_model.Lang.TypeDecl in
let open Odoc_model.Paths in
List.map
(fun decl ->
(Identifier.name decl.id, Component.Of_Lang.(type_decl (empty ()) decl)))
Odoc_model.Predefined.core_types

let prefix_substitution path sg =
let open Component.Signature in
let rec get_sub sub' is =
Expand Down Expand Up @@ -806,9 +798,15 @@ and lookup_type_gpath :
let res =
match p with
| `Identifier { iv = `CoreType name; _ } ->
(* CoreTypes aren't put into the environment, so they can't be handled by the
next clause. We just look them up here in the list of core types *)
Ok (`FType (name, List.assoc (TypeName.to_string name) core_types))
(* CoreTypes aren't put into the environment, so they can't be handled
by the next clause. They are already resolved. *)
Ok
(`FType
( name,
Component.Of_Lang.(
type_decl (empty ())
(Odoc_model.Predefined.type_of_core_type
(TypeName.to_string name))) ))
| `Identifier ({ iv = `Type _; _ } as i) ->
of_option ~error:(`Lookup_failureT i)
(Env.(lookup_by_id s_datatype) i env)
Expand Down

0 comments on commit 6b106ec

Please sign in to comment.