diff --git a/src/model/predefined.ml b/src/model/predefined.ml index 6c629eff5b..9ef5d9d280 100644 --- a/src/model/predefined.ml +++ b/src/model/predefined.ml @@ -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") @@ -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 diff --git a/src/model/predefined.mli b/src/model/predefined.mli index aee61671c0..98c125b17e 100644 --- a/src/model/predefined.mli +++ b/src/model/predefined.mli @@ -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. *) diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 5c1507df00..a13c46a98c 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -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 = @@ -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)