From 030d1731d5e359653935b675a4dceba7a66d8cfa Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 18 Jun 2024 11:57:57 +0100 Subject: [PATCH 1/3] Simplify idents Use 'type_' idents instead of 'class_' and 'class_type'. Use 'module_' instead of 'functor_parameter' and 'result'. This allows to remove some code. --- src/xref2/component.ml | 84 ++++++----------- src/xref2/component.mli | 34 +++---- src/xref2/cpath.ml | 12 +-- src/xref2/env.ml | 6 +- src/xref2/errors.ml | 6 +- src/xref2/expand_tools.ml | 6 +- src/xref2/find.ml | 42 ++++----- src/xref2/ident.ml | 192 ++++---------------------------------- src/xref2/lang_of.ml | 68 ++++++-------- src/xref2/lang_of.mli | 4 +- src/xref2/strengthen.ml | 2 +- src/xref2/subst.ml | 136 ++++++++++----------------- src/xref2/subst.mli | 12 +-- src/xref2/tools.ml | 24 ++--- 14 files changed, 194 insertions(+), 434 deletions(-) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index df2e00586a..c72c5b94a1 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -12,32 +12,14 @@ module TypeMap = Map.Make (struct let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) end) -module PathModuleMap = Map.Make (struct - type t = Ident.path_module - - let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) -end) - module ModuleTypeMap = Map.Make (struct type t = Ident.module_type let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) end) -module PathTypeMap = Map.Make (struct - type t = Ident.path_type - - let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) -end) - -module PathValueMap = Map.Make (struct - type t = Ident.path_value - - let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) -end) - -module PathClassTypeMap = Map.Make (struct - type t = Ident.path_class_type +module ValueMap = Map.Make (struct + type t = Ident.value let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) end) @@ -182,7 +164,7 @@ end = Exception and FunctorParameter : sig - type parameter = { id : Ident.functor_parameter; expr : ModuleType.expr } + type parameter = { id : Ident.module_; expr : ModuleType.expr } type t = Named of parameter | Unit end = @@ -320,8 +302,8 @@ and Signature : sig | Exception of Ident.exception_ * Exception.t | TypExt of Extension.t | Value of Ident.value * Value.t Delayed.t - | Class of Ident.class_ * recursive * Class.t - | ClassType of Ident.class_type * recursive * ClassType.t + | Class of Ident.type_ * recursive * Class.t + | ClassType of Ident.type_ * recursive * ClassType.t | Include of Include.t | Open of Open.t | Comment of CComment.docs_or_stop @@ -440,28 +422,27 @@ and Substitution : sig type subst_module = [ `Prefixed of Cpath.module_ * Cpath.Resolved.module_ | `Substituted - | `Renamed of Ident.path_module ] + | `Renamed of Ident.module_ ] type subst_module_type = [ `Prefixed of Cpath.module_type * Cpath.Resolved.module_type | `Renamed of Ident.module_type ] type subst_type = - [ `Prefixed of Cpath.type_ * Cpath.Resolved.type_ - | `Renamed of Ident.path_type ] + [ `Prefixed of Cpath.type_ * Cpath.Resolved.type_ | `Renamed of Ident.type_ ] type subst_class_type = [ `Prefixed of Cpath.class_type * Cpath.Resolved.class_type - | `Renamed of Ident.path_class_type ] + | `Renamed of Ident.type_ ] type t = { - module_ : subst_module PathModuleMap.t; + module_ : subst_module ModuleMap.t; module_type : subst_module_type ModuleTypeMap.t; - type_ : subst_type PathTypeMap.t; - class_type : subst_class_type PathClassTypeMap.t; - type_replacement : (TypeExpr.t * TypeDecl.Equation.t) PathTypeMap.t; + type_ : subst_type TypeMap.t; + class_type : subst_class_type TypeMap.t; + type_replacement : (TypeExpr.t * TypeDecl.Equation.t) TypeMap.t; module_type_replacement : ModuleType.expr ModuleTypeMap.t; - path_invalidating_modules : Ident.path_module list; + path_invalidating_modules : Ident.module_ list; unresolve_opaque_paths : bool; } end = @@ -1815,14 +1796,12 @@ module Of_Lang = struct type map = { modules : Ident.module_ Paths.Identifier.Maps.Module.t; module_types : Ident.module_type Paths.Identifier.Maps.ModuleType.t; - functor_parameters : - Ident.functor_parameter Paths.Identifier.Maps.FunctorParameter.t; + functor_parameters : Ident.module_ Paths.Identifier.Maps.FunctorParameter.t; types : Ident.type_ Paths.Identifier.Maps.Type.t; - path_types : Ident.path_type Paths.Identifier.Maps.Path.Type.t; - path_class_types : - Ident.path_class_type Paths.Identifier.Maps.Path.ClassType.t; - classes : Ident.class_ Paths.Identifier.Maps.Class.t; - class_types : Ident.class_type Paths.Identifier.Maps.ClassType.t; + path_types : Ident.type_ Paths.Identifier.Maps.Path.Type.t; + path_class_types : Ident.type_ Paths.Identifier.Maps.Path.ClassType.t; + classes : Ident.type_ Paths.Identifier.Maps.Class.t; + class_types : Ident.type_ Paths.Identifier.Maps.ClassType.t; } let empty () = @@ -1848,10 +1827,7 @@ module Of_Lang = struct (fun (types, path_types) i -> let id = Ident.Of_Identifier.type_ i in ( Maps.Type.add i id types, - Maps.Path.Type.add - (i :> Path.Type.t) - (id :> Ident.path_type) - path_types )) + Maps.Path.Type.add (i :> Path.Type.t) id path_types )) (map.types, map.path_types) ids.LocalIdents.types in @@ -1860,10 +1836,8 @@ module Of_Lang = struct (fun (classes, path_class_types) i -> let id = Ident.Of_Identifier.class_ i in ( Maps.Class.add i id classes, - Maps.Path.ClassType.add - (i :> Path.ClassType.t) - (id :> Ident.path_class_type) - path_class_types )) + Maps.Path.ClassType.add (i :> Path.ClassType.t) id path_class_types + )) (map.classes, map.path_class_types) ids.LocalIdents.classes in @@ -1872,14 +1846,9 @@ module Of_Lang = struct (fun (class_types, path_types, path_class_types) i -> let id = Ident.Of_Identifier.class_type i in ( Maps.ClassType.add i id class_types, - Maps.Path.Type.add - (i :> Path.Type.t) - (id :> Ident.path_type) - path_types, - Maps.Path.ClassType.add - (i :> Path.ClassType.t) - (id :> Ident.path_class_type) - path_class_types )) + Maps.Path.Type.add (i :> Path.Type.t) id path_types, + Maps.Path.ClassType.add (i :> Path.ClassType.t) id path_class_types + )) (map.class_types, path_types_new, path_class_types_new) ids.LocalIdents.class_types in @@ -1925,13 +1894,12 @@ module Of_Lang = struct let find_any_module i ident_map = match i with | { Odoc_model.Paths.Identifier.iv = `Root _ | `Module _; _ } as id -> - (Maps.Module.find id ident_map.modules :> Ident.path_module) + Maps.Module.find id ident_map.modules | { Odoc_model.Paths.Identifier.iv = #Paths.Identifier.FunctorParameter.t_pv; _; } as id -> - (Maps.FunctorParameter.find id ident_map.functor_parameters - :> Ident.path_module) + Maps.FunctorParameter.find id ident_map.functor_parameters | _ -> raise Not_found let rec resolved_module_path : diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 90596eabf3..1b53a9f5f2 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -4,16 +4,9 @@ module ModuleMap : Map.S with type key = Ident.module_ module TypeMap : Map.S with type key = Ident.type_ -module PathModuleMap : Map.S with type key = Ident.path_module -(** Useful maps *) - module ModuleTypeMap : Map.S with type key = Ident.module_type -module PathTypeMap : Map.S with type key = Ident.path_type - -module PathValueMap : Map.S with type key = Ident.path_value - -module PathClassTypeMap : Map.S with type key = Ident.path_class_type +module ValueMap : Map.S with type key = Ident.value module IdentMap : Map.S with type key = Ident.any @@ -162,7 +155,7 @@ and Exception : sig end and FunctorParameter : sig - type parameter = { id : Ident.functor_parameter; expr : ModuleType.expr } + type parameter = { id : Ident.module_; expr : ModuleType.expr } type t = Named of parameter | Unit end @@ -285,8 +278,8 @@ and Signature : sig | Exception of Ident.exception_ * Exception.t | TypExt of Extension.t | Value of Ident.value * Value.t Delayed.t - | Class of Ident.class_ * recursive * Class.t - | ClassType of Ident.class_type * recursive * ClassType.t + | Class of Ident.type_ * recursive * Class.t + | ClassType of Ident.type_ * recursive * ClassType.t | Include of Include.t | Open of Open.t | Comment of CComment.docs_or_stop @@ -407,28 +400,27 @@ and Substitution : sig type subst_module = [ `Prefixed of Cpath.module_ * Cpath.Resolved.module_ | `Substituted - | `Renamed of Ident.path_module ] + | `Renamed of Ident.module_ ] type subst_module_type = [ `Prefixed of Cpath.module_type * Cpath.Resolved.module_type | `Renamed of Ident.module_type ] type subst_type = - [ `Prefixed of Cpath.type_ * Cpath.Resolved.type_ - | `Renamed of Ident.path_type ] + [ `Prefixed of Cpath.type_ * Cpath.Resolved.type_ | `Renamed of Ident.type_ ] type subst_class_type = [ `Prefixed of Cpath.class_type * Cpath.Resolved.class_type - | `Renamed of Ident.path_class_type ] + | `Renamed of Ident.type_ ] type t = { - module_ : subst_module PathModuleMap.t; + module_ : subst_module ModuleMap.t; module_type : subst_module_type ModuleTypeMap.t; - type_ : subst_type PathTypeMap.t; - class_type : subst_class_type PathClassTypeMap.t; - type_replacement : (TypeExpr.t * TypeDecl.Equation.t) PathTypeMap.t; + type_ : subst_type TypeMap.t; + class_type : subst_class_type TypeMap.t; + type_replacement : (TypeExpr.t * TypeDecl.Equation.t) TypeMap.t; module_type_replacement : ModuleType.expr ModuleTypeMap.t; - path_invalidating_modules : Ident.path_module list; + path_invalidating_modules : Ident.module_ list; unresolve_opaque_paths : bool; } end @@ -773,7 +765,7 @@ module Of_Lang : sig val functor_parameter : map -> - Ident.functor_parameter -> + Ident.module_ -> Odoc_model.Lang.FunctorParameter.parameter -> FunctorParameter.parameter diff --git a/src/xref2/cpath.ml b/src/xref2/cpath.ml index 114a626ebc..7e34e056a8 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -6,7 +6,7 @@ module rec Resolved : sig [ `Module of module_ | `ModuleType of module_type | `FragmentRoot ] and module_ = - [ `Local of Ident.path_module + [ `Local of Ident.module_ | `Gpath of Path.Resolved.Module.t | `Substituted of module_ | `Subst of module_type * module_ @@ -28,7 +28,7 @@ module rec Resolved : sig | `OpaqueModuleType of module_type ] and type_ = - [ `Local of Ident.path_type + [ `Local of Ident.type_ | `Gpath of Path.Resolved.Type.t | `Substituted of type_ | `CanonicalType of type_ * Path.Type.t @@ -40,7 +40,7 @@ module rec Resolved : sig [ `Value of parent * ValueName.t | `Gpath of Path.Resolved.Value.t ] and class_type = - [ `Local of Ident.path_class_type + [ `Local of Ident.type_ | `Substituted of class_type | `Gpath of Path.Resolved.ClassType.t | `Class of parent * TypeName.t @@ -52,7 +52,7 @@ and Cpath : sig type module_ = [ `Resolved of Resolved.module_ | `Substituted of module_ - | `Local of Ident.path_module * bool + | `Local of Ident.module_ * bool | `Identifier of Identifier.Path.Module.t * bool | `Root of ModuleName.t | `Forward of string @@ -71,7 +71,7 @@ and Cpath : sig and type_ = [ `Resolved of Resolved.type_ | `Substituted of type_ - | `Local of Ident.path_type * bool + | `Local of Ident.type_ * bool | `Identifier of Odoc_model.Paths.Identifier.Path.Type.t * bool | `DotT of module_ * TypeName.t | `Type of Resolved.parent * TypeName.t @@ -87,7 +87,7 @@ and Cpath : sig and class_type = [ `Resolved of Resolved.class_type | `Substituted of class_type - | `Local of Ident.path_class_type * bool + | `Local of Ident.type_ * bool | `Identifier of Odoc_model.Paths.Identifier.Path.ClassType.t * bool | `DotT of module_ * TypeName.t | `Class of Resolved.parent * TypeName.t diff --git a/src/xref2/env.ml b/src/xref2/env.ml index e832753049..87ae379795 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -667,9 +667,7 @@ let add_functor_args' : | ModuleType.Functor (Named arg, res) -> ( arg.Component.FunctorParameter.id, Paths.Identifier.Mk.parameter - ( parent, - Ident.Name.typed_functor_parameter - arg.Component.FunctorParameter.id ), + (parent, Ident.Name.typed_module arg.Component.FunctorParameter.id), mk_functor_parameter arg.expr ) :: find_args (Paths.Identifier.Mk.result parent) res | ModuleType.Functor (Unit, res) -> @@ -682,7 +680,7 @@ let add_functor_args' : themselves *) let fold_fn (env, subst) (ident, identifier, m) = let ident, identifier = - ((ident, identifier) :> Ident.path_module * Identifier.Path.Module.t) + ((ident, identifier) :> Ident.module_ * Identifier.Path.Module.t) in let doc = m.Component.Module.doc in let m = Component.Delayed.put_val (Subst.module_ subst m) in diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 857a282a4c..007ba83e94 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -37,7 +37,7 @@ module Tools_error = struct and simple_module_lookup_error = [ `Local of - Env.t * Ident.path_module + Env.t * Ident.module_ (* Internal error: Found local path during lookup *) | `Find_failure | (* Internal error: the module was not found in the parent signature *) @@ -71,7 +71,7 @@ module Tools_error = struct and simple_type_lookup_error = [ `LocalType of - Env.t * Ident.path_type + Env.t * Ident.type_ (* Internal error: Found local path during lookup *) | `Class_replaced (* Class was replaced with a destructive substitution and we're not sure @@ -86,7 +86,7 @@ module Tools_error = struct and simple_value_lookup_error = [ `LocalValue of - Env.t * Ident.path_value + Env.t * Ident.value (* Internal error: Found local path during lookup *) | `Find_failure (* Internal error: the type was not found in the parent signature *) diff --git a/src/xref2/expand_tools.ml b/src/xref2/expand_tools.ml index e78e89102e..c452ff64ab 100644 --- a/src/xref2/expand_tools.ml +++ b/src/xref2/expand_tools.ml @@ -11,9 +11,7 @@ let handle_expansion env id expansion = | Named arg -> let identifier = Paths.Identifier.Mk.parameter - ( parent, - Ident.Name.typed_functor_parameter - arg.Component.FunctorParameter.id ) + (parent, Ident.Name.typed_module arg.Component.FunctorParameter.id) in let m = Component.module_of_functor_argument arg in let env' = @@ -22,7 +20,7 @@ let handle_expansion env id expansion = let rp = `Gpath (`Identifier identifier) in let p = `Resolved rp in let subst = - Subst.add_module (arg.id :> Ident.path_module) p rp Subst.identity + Subst.add_module (arg.id :> Ident.module_) p rp Subst.identity in (env', Subst.module_type_expr subst expr) in diff --git a/src/xref2/find.ml b/src/xref2/find.ml index 77dc564bca..fad642d0a1 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -112,11 +112,11 @@ let type_in_sig sg name = when TypeName.equal_modulo_shadowing (N.typed_type id) name -> Some (`FType (N.typed_type id, Delayed.get m)) | Class (id, _, c) - when TypeName.equal_modulo_shadowing (N.typed_class id) name -> - Some (`FClass (N.class' id, c)) + when TypeName.equal_modulo_shadowing (N.typed_type id) name -> + Some (`FClass (N.typed_type id, c)) | ClassType (id, _, c) - when TypeName.equal_modulo_shadowing (N.typed_class_type id) name -> - Some (`FClassType (N.class_type' id, c)) + when TypeName.equal_modulo_shadowing (N.typed_type id) name -> + Some (`FClassType (N.typed_type id, c)) | _ -> None) type removed_type = @@ -170,17 +170,17 @@ let datatype_in_sig sg name = find_in_sig sg (function | Signature.Type (id, _, t) when TypeName.equal_modulo_shadowing (N.typed_type id) name -> - Some (`FType (N.type' id, Component.Delayed.get t)) + Some (`FType (N.typed_type id, Component.Delayed.get t)) | _ -> None) let class_in_sig sg name = filter_in_sig sg (function | Signature.Class (id, _, c) - when TypeName.equal_modulo_shadowing (N.typed_class id) name -> - Some (`FClass (N.class' id, c)) + when TypeName.equal_modulo_shadowing (N.typed_type id) name -> + Some (`FClass (N.typed_type id, c)) | Signature.ClassType (id, _, c) - when TypeName.equal_modulo_shadowing (N.typed_class_type id) name -> - Some (`FClassType (N.class_type' id, c)) + when TypeName.equal_modulo_shadowing (N.typed_type id) name -> + Some (`FClassType (N.typed_type id, c)) | _ -> None) let class_in_sig_unambiguous sg name = disambiguate (class_in_sig sg name) @@ -253,20 +253,20 @@ let any_in_sig sg name = | ModuleType (id, mt) when N.module_type id = name -> Some (`FModuleType (N.typed_module_type id, Delayed.get mt)) | Type (id, _, t) when N.type_ id = name -> - Some (`FType (N.type' id, Delayed.get t)) + Some (`FType (N.typed_type id, Delayed.get t)) | TypeSubstitution (id, ts) when N.type_ id = name -> Some (`FType_subst ts) | Exception (id, exc) when N.exception_ id = name -> Some (`FExn (N.typed_exception id, exc)) | Value (id, v) when N.value id = name -> Some (`FValue (N.typed_value id, Delayed.get v)) - | Class (id, _, c) when N.class_ id = name -> - Some (`FClass (N.class' id, c)) - | ClassType (id, _, ct) when N.class_type id = name -> - Some (`FClassType (N.class_type' id, ct)) + | Class (id, _, c) when N.type_ id = name -> + Some (`FClass (N.typed_type id, c)) + | ClassType (id, _, ct) when N.type_ id = name -> + Some (`FClassType (N.typed_type id, ct)) | Type (id, _, t) -> ( let typ = Delayed.get t in match any_in_type typ name with - | Some r -> Some (`In_type (N.type' id, typ, r)) + | Some r -> Some (`In_type (N.typed_type id, typ, r)) | None -> None) | TypExt typext -> any_in_typext typext name | Comment (`Docs d) -> any_in_comment d (LabelName.make_std name) @@ -329,11 +329,11 @@ let label_parent_in_sig sg name = | ModuleType (id, mt) when N.module_type id = name -> Some (`FModuleType (N.typed_module_type id, Component.Delayed.get mt)) | Type (id, _, t) when N.type_ id = name -> - Some (`FType (N.type' id, Component.Delayed.get t)) - | Class (id, _, c) when N.class_ id = name -> - Some (`FClass (N.class' id, c)) - | ClassType (id, _, c) when N.class_type id = name -> - Some (`FClassType (N.class_type' id, c)) + Some (`FType (N.typed_type id, Component.Delayed.get t)) + | Class (id, _, c) when N.type_ id = name -> + Some (`FClass (N.typed_type id, c)) + | ClassType (id, _, c) when N.type_ id = name -> + Some (`FClassType (N.typed_type id, c)) | _ -> None) let any_in_type_in_sig sg name = @@ -341,7 +341,7 @@ let any_in_type_in_sig sg name = | Signature.Type (id, _, t) -> ( let t = Delayed.get t in match any_in_type t name with - | Some x -> Some (`In_type (N.type' id, t, x)) + | Some x -> Some (`In_type (N.typed_type id, t, x)) | None -> None) | _ -> None) diff --git a/src/xref2/ident.ml b/src/xref2/ident.ml index c975fd4e99..ced7940cb2 100644 --- a/src/xref2/ident.ml +++ b/src/xref2/ident.ml @@ -4,38 +4,11 @@ open Odoc_model.Paths (* For simplicity keep a global counter *) let counter = ref 0 -type signature = - [ `LRoot of ModuleName.t * int - | `LModule of ModuleName.t * int - | `LResult of signature * int - | `LParameter of ModuleName.t * int - | `LModuleType of ModuleTypeName.t * int ] - -type class_signature = - [ `LClass of TypeName.t * int | `LClassType of TypeName.t * int ] - -type datatype = [ `LType of TypeName.t * int ] - -type parent = [ signature | datatype ] - -type label_parent = - [ parent - | `LPage of PageName.t * int - | `LLeafPage of PageName.t * int - | class_signature ] - -type module_ = - [ `LRoot of ModuleName.t * int - | `LModule of ModuleName.t * int - | `LParameter of ModuleName.t * int ] - -type functor_parameter = [ `LParameter of ModuleName.t * int ] - -type path_module = [ module_ | `LResult of signature * int | functor_parameter ] +type module_ = [ `LModule of ModuleName.t * int ] type module_type = [ `LModuleType of ModuleTypeName.t * int ] -type type_ = datatype +type type_ = [ `LType of TypeName.t * int ] type constructor = [ `LConstructor of ConstructorName.t * int ] @@ -47,31 +20,16 @@ type exception_ = [ `LException of ExceptionName.t * int ] type value = [ `LValue of ValueName.t * int ] -type class_ = [ `LClass of TypeName.t * int ] - -type class_type = [ `LClassType of TypeName.t * int ] - -type path_type = [ type_ | class_ | class_type ] - -type path_value = value - -type path_class_type = [ class_ | class_type ] - type method_ = [ `LMethod of MethodName.t * int ] type instance_variable = [ `LInstanceVariable of InstanceVariableName.t * int ] type label = [ `LLabel of LabelName.t * int ] -type page = [ `LPage of PageName.t * int | `LLeafPage of PageName.t * int ] +type page = [ `LPage of PageName.t * int ] type any = - [ signature - | class_signature - | datatype - | parent - | label_parent - | path_module + [ module_ | module_type | type_ | constructor @@ -79,8 +37,6 @@ type any = | extension | exception_ | value - | class_ - | class_type | method_ | instance_variable | label @@ -92,55 +48,46 @@ let fresh_int () = n let int_of_any : any -> int = function - | `LRoot (_, i) | `LModule (_, i) | `LException (_, i) | `LConstructor (_, i) - | `LClassType (_, i) | `LMethod (_, i) - | `LClass (_, i) | `LType (_, i) | `LValue (_, i) | `LInstanceVariable (_, i) - | `LParameter (_, i) | `LField (_, i) - | `LResult (_, i) | `LLabel (_, i) | `LModuleType (_, i) | `LPage (_, i) - | `LLeafPage (_, i) | `LExtension (_, i) -> i module Of_Identifier = struct open Identifier - let datatype : DataType.t -> datatype = + let type_ : Type.t -> type_ = fun t -> let i = fresh_int () in match t.iv with | `Type (_, n) -> `LType (n, i) | `CoreType _n -> failwith "Bad" - let module_ : Odoc_model.Paths.Identifier.Module.t -> module_ = function + let module_ : Module.t -> module_ = function | { iv = `Module (_, n) | `Root (_, n); _ } -> let i = fresh_int () in `LModule (n, i) | { iv = `Parameter (_, n); _ } -> let i = fresh_int () in - `LParameter (n, i) + `LModule (n, i) - let functor_parameter : - Odoc_model.Paths.Identifier.FunctorParameter.t -> functor_parameter = - fun { iv = `Parameter (_, n); _ } -> `LParameter (n, fresh_int ()) + let functor_parameter : FunctorParameter.t -> module_ = + fun { iv = `Parameter (_, n); _ } -> `LModule (n, fresh_int ()) let module_type : ModuleType.t -> module_type = fun m -> let i = fresh_int () in match m.iv with `ModuleType (_, n) -> `LModuleType (n, i) - let type_ : Type.t -> type_ = datatype - let extension : Extension.t -> extension = fun e -> match e.iv with `Extension (_, n) -> `LExtension (n, fresh_int ()) @@ -153,11 +100,11 @@ module Of_Identifier = struct let value : Value.t -> value = fun v -> match v.iv with `Value (_, n) -> `LValue (n, fresh_int ()) - let class_ : Class.t -> class_ = - fun c -> match c.iv with `Class (_, n) -> `LClass (n, fresh_int ()) + let class_ : Class.t -> type_ = + fun c -> match c.iv with `Class (_, n) -> `LType (n, fresh_int ()) - let class_type : ClassType.t -> class_type = - fun c -> match c.iv with `ClassType (_, n) -> `LClassType (n, fresh_int ()) + let class_type : ClassType.t -> type_ = + fun c -> match c.iv with `ClassType (_, n) -> `LType (n, fresh_int ()) let method_ : Method.t -> method_ = fun c -> match c.iv with `Method (_, n) -> `LMethod (n, fresh_int ()) @@ -172,57 +119,17 @@ module Of_Identifier = struct end module Name = struct - let rec signature : signature -> string = function - | `LRoot (n, _) -> ModuleName.to_string n - | `LModule (n, _) -> ModuleName.to_string n - | `LResult (x, _) -> signature x - | `LParameter (n, _) -> ModuleName.to_string n - | `LModuleType (n, _) -> ModuleTypeName.to_string n - - let typed_module : module_ -> ModuleName.t = function - | `LRoot (n, _) | `LModule (n, _) | `LParameter (n, _) -> n - - let module' : module_ -> ModuleName.t = function - | `LRoot (n, _) | `LModule (n, _) | `LParameter (n, _) -> n - - let module_ m = ModuleName.to_string (module' m) - - let unsafe_module m = ModuleName.to_string_unsafe (module' m) + let typed_module : module_ -> ModuleName.t = function `LModule (n, _) -> n + let module_ m = ModuleName.to_string (typed_module m) - let path_module : path_module -> string = function - | `LRoot (n, _) -> ModuleName.to_string n - | `LModule (n, _) -> ModuleName.to_string n - | `LResult (x, _) -> signature x - | `LParameter (n, _) -> ModuleName.to_string n + let unsafe_module m = ModuleName.to_string_unsafe (typed_module m) - let typed_functor_parameter : functor_parameter -> ModuleName.t = - fun (`LParameter (n, _)) -> n - - let functor_parameter : functor_parameter -> string = - fun (`LParameter (n, _)) -> ModuleName.to_string n - - let type' : type_ -> TypeName.t = function `LType (n, _) -> n - - let type_ t = TypeName.to_string (type' t) + let typed_type : type_ -> TypeName.t = function `LType (n, _) -> n + let type_ t = TypeName.to_string (typed_type t) let unsafe_type : type_ -> string = function | `LType (n, _) -> TypeName.to_string_unsafe n - let typed_type : type_ -> TypeName.t = function `LType (n, _) -> n - - let path_type : path_type -> string = function - | `LClassType (n, _) -> TypeName.to_string n - | `LClass (n, _) -> TypeName.to_string n - | `LType (n, _) -> TypeName.to_string n - - let class' : class_ -> TypeName.t = function `LClass (n, _) -> n - - let class_ c = TypeName.to_string (class' c) - - let unsafe_class c = TypeName.to_string_unsafe (class' c) - - let typed_class : class_ -> TypeName.t = function `LClass (n, _) -> n - let module_type : module_type -> string = function | `LModuleType (n, _) -> ModuleTypeName.to_string n @@ -232,20 +139,6 @@ module Name = struct let typed_module_type : module_type -> ModuleTypeName.t = function | `LModuleType (n, _) -> n - let path_class_type : path_class_type -> string = function - | `LClass (n, _) -> TypeName.to_string n - | `LClassType (n, _) -> TypeName.to_string n - - let class_type' : class_type -> TypeName.t = function - | `LClassType (n, _) -> n - - let class_type c = TypeName.to_string (class_type' c) - - let unsafe_class_type c = TypeName.to_string_unsafe (class_type' c) - - let typed_class_type : class_type -> TypeName.t = function - | `LClassType (n, _) -> n - let exception_ : exception_ -> string = function | `LException (n, _) -> ExceptionName.to_string n @@ -276,23 +169,8 @@ module Name = struct end module Rename = struct - let rec signature : signature -> signature = function - | `LRoot (n, _) -> `LRoot (n, fresh_int ()) - | `LModule (n, _) -> `LModule (n, fresh_int ()) - | `LResult (x, _) -> `LResult (signature x, fresh_int ()) - | `LParameter (n, _) -> `LParameter (n, fresh_int ()) - | `LModuleType (n, _) -> `LModuleType (n, fresh_int ()) - let module_ : module_ -> module_ = function - | `LRoot (n, _) -> `LRoot (n, fresh_int ()) - | `LModule (n, _) -> `LModule (n, fresh_int ()) - | `LParameter (n, _) -> `LParameter (n, fresh_int ()) - - let path_module : path_module -> path_module = function - | `LRoot (n, _) -> `LRoot (n, fresh_int ()) | `LModule (n, _) -> `LModule (n, fresh_int ()) - | `LResult (x, _) -> `LResult (signature x, fresh_int ()) - | `LParameter (n, _) -> `LParameter (n, fresh_int ()) let module_type : module_type -> module_type = function | `LModuleType (n, _) -> `LModuleType (n, fresh_int ()) @@ -305,46 +183,17 @@ module Rename = struct let value : value -> value = function | `LValue (n, _) -> `LValue (n, fresh_int ()) - - let class_ : class_ -> class_ = function - | `LClass (n, _) -> `LClass (n, fresh_int ()) - - let class_type : class_type -> class_type = function - | `LClassType (n, _) -> `LClassType (n, fresh_int ()) end let hash : any -> int = Hashtbl.hash let compare : any -> any -> int = fun a b -> int_of_any a - int_of_any b -module Maps = struct - module Module = Map.Make (struct - type t = module_ - - let compare x y = compare (x : t :> any) (y : t :> any) - end) - - module ModuleType = Map.Make (struct - type t = module_type - - let compare x y = compare (x : t :> any) (y : t :> any) - end) - - module Type = Map.Make (struct - type t = type_ - - let compare x y = compare (x : t :> any) (y : t :> any) - end) -end - let reset () = counter := 0 -let rec fmt_aux (id : any) : string * int = +let fmt_aux (id : any) : string * int = match id with - | `LRoot (n, i) -> (ModuleName.to_string n, i) | `LModule (n, i) -> (ModuleName.to_string n, i) - | `LParameter (n, i) -> (ModuleName.to_string n, i) - | `LResult (x, _) -> fmt_aux (x :> any) | `LModuleType (n, i) -> (ModuleTypeName.to_string n, i) | `LType (n, i) -> (TypeName.to_string n, i) | `LConstructor (n, i) -> (ConstructorName.to_string n, i) @@ -352,13 +201,10 @@ let rec fmt_aux (id : any) : string * int = | `LExtension (n, i) -> (ExtensionName.to_string n, i) | `LException (n, i) -> (ExceptionName.to_string n, i) | `LValue (n, i) -> (ValueName.to_string n, i) - | `LClass (n, i) -> (TypeName.to_string n, i) - | `LClassType (n, i) -> (TypeName.to_string n, i) | `LMethod (n, i) -> (MethodName.to_string n, i) | `LInstanceVariable (n, i) -> (InstanceVariableName.to_string n, i) | `LLabel (n, i) -> (LabelName.to_string n, i) | `LPage (n, i) -> (PageName.to_string n, i) - | `LLeafPage (n, i) -> (PageName.to_string n, i) let fmt : Format.formatter -> [< any ] -> unit = fun ppf id -> diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 774b66d563..26fb483bad 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -5,13 +5,12 @@ open Names type maps = { module_ : Identifier.Module.t Component.ModuleMap.t; module_type : Identifier.ModuleType.t Component.ModuleTypeMap.t; - functor_parameter : - (Ident.functor_parameter * Identifier.FunctorParameter.t) list; + functor_parameter : (Ident.module_ * Identifier.FunctorParameter.t) list; type_ : Identifier.Type.t Component.TypeMap.t; - path_type : Identifier.Path.Type.t Component.PathTypeMap.t; - class_ : (Ident.class_ * Identifier.Class.t) list; - class_type : (Ident.class_type * Identifier.ClassType.t) list; - path_class_type : Identifier.Path.ClassType.t Component.PathClassTypeMap.t; + path_type : Identifier.Path.Type.t Component.TypeMap.t; + class_ : (Ident.type_ * Identifier.Class.t) list; + class_type : (Ident.type_ * Identifier.ClassType.t) list; + path_class_type : Identifier.Path.ClassType.t Component.TypeMap.t; fragment_root : Cfrag.root option; (* Shadowed items *) shadowed : Lang.Include.shadowed; @@ -34,10 +33,10 @@ let empty () = module_type = Component.ModuleTypeMap.empty; functor_parameter = []; type_ = Component.TypeMap.empty; - path_type = Component.PathTypeMap.empty; + path_type = Component.TypeMap.empty; class_ = []; class_type = []; - path_class_type = Component.PathClassTypeMap.empty; + path_class_type = Component.TypeMap.empty; fragment_root = None; shadowed = empty_shadow; } @@ -47,12 +46,9 @@ let with_fragment_root r = { (empty ()) with fragment_root = Some r } let with_shadowed shadowed = { (empty ()) with shadowed } (** Raises [Not_found] *) -let lookup_module map : Ident.path_module -> _ = function - | (`LRoot _ | `LModule _) as id -> +let lookup_module map : Ident.module_ -> _ = function + | `LModule _ as id -> (Component.ModuleMap.find id map.module_ :> Identifier.Path.Module.t) - | #Ident.functor_parameter as id -> - (List.assoc id map.functor_parameter :> Identifier.Path.Module.t) - | _ -> raise Not_found module Opt = Component.Opt @@ -107,8 +103,7 @@ module Path = struct | `Identifier (({ iv = #Odoc_model.Paths.Identifier.Path.Type.t_pv; _ } as y), b) -> `Identifier (y, b) - | `Local (id, b) -> - `Identifier (Component.PathTypeMap.find id map.path_type, b) + | `Local (id, b) -> `Identifier (Component.TypeMap.find id map.path_type, b) | `Resolved x -> `Resolved (resolved_type map x) | `DotT (p, n) -> `DotT (module_ map p, n) | `Type (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n) @@ -125,7 +120,7 @@ module Path = struct -> `Identifier (y, b) | `Local (id, b) -> - `Identifier (Component.PathClassTypeMap.find id map.path_class_type, b) + `Identifier (Component.TypeMap.find id map.path_class_type, b) | `Resolved x -> `Resolved (resolved_class_type map x) | `DotT (p, n) -> `DotT (module_ map p, n) | `Class (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n) @@ -184,7 +179,7 @@ module Path = struct Odoc_model.Paths.Path.Resolved.Type.t = match p with | `Gpath y -> y - | `Local id -> `Identifier (Component.PathTypeMap.find id map.path_type) + | `Local id -> `Identifier (Component.TypeMap.find id map.path_type) | `CanonicalType (t1, t2) -> `CanonicalType (resolved_type map t1, t2) | `Type (p, name) -> `Type (resolved_parent map p, name) | `Class (p, name) -> `Class (resolved_parent map p, name) @@ -201,8 +196,7 @@ module Path = struct Odoc_model.Paths.Path.Resolved.ClassType.t = match p with | `Gpath y -> y - | `Local id -> - `Identifier (Component.PathClassTypeMap.find id map.path_class_type) + | `Local id -> `Identifier (Component.TypeMap.find id map.path_class_type) | `Class (p, name) -> `Class (resolved_parent map p, name) | `ClassType (p, name) -> `ClassType (resolved_parent map p, name) | `Substituted s -> `SubstitutedCT (resolved_class_type map s) @@ -292,8 +286,8 @@ module ExtractIDs = struct map with type_ = Component.TypeMap.add id identifier map.type_; path_type = - Component.PathTypeMap.add - (id :> Ident.path_type) + Component.TypeMap.add + (id :> Ident.type_) (identifier :> Identifier.Path.Type.t) map.path_type; } @@ -322,47 +316,47 @@ module ExtractIDs = struct } and class_ parent map id = - let name = Ident.Name.class_ id in + let name = Ident.Name.type_ id in let typed_name = if List.mem_assoc name map.shadowed.s_classes then List.assoc name map.shadowed.s_classes - else Ident.Name.typed_class id + else Ident.Name.typed_type id in let identifier = Identifier.Mk.class_ (parent, typed_name) in { map with class_ = (id, identifier) :: map.class_; path_class_type = - Component.PathClassTypeMap.add - (id :> Ident.path_class_type) + Component.TypeMap.add + (id :> Ident.type_) (identifier :> Identifier.Path.ClassType.t) map.path_class_type; path_type = - Component.PathTypeMap.add - (id :> Ident.path_type) + Component.TypeMap.add + (id :> Ident.type_) (identifier :> Identifier.Path.Type.t) map.path_type; } - and class_type parent map (id : Ident.class_type) = - let name = Ident.Name.class_type id in + and class_type parent map (id : Ident.type_) = + let name = Ident.Name.type_ id in let typed_name = if List.mem_assoc name map.shadowed.s_class_types then List.assoc name map.shadowed.s_class_types - else Ident.Name.typed_class_type id + else Ident.Name.typed_type id in let identifier = Identifier.Mk.class_type (parent, typed_name) in { map with - class_type = ((id :> Ident.class_type), identifier) :: map.class_type; + class_type = ((id :> Ident.type_), identifier) :: map.class_type; path_class_type = - Component.PathClassTypeMap.add - (id :> Ident.path_class_type) + Component.TypeMap.add + (id :> Ident.type_) (identifier :> Identifier.Path.ClassType.t) map.path_class_type; path_type = - Component.PathTypeMap.add - (id :> Ident.path_type) + Component.TypeMap.add + (id :> Ident.type_) (identifier :> Identifier.Path.Type.t) map.path_type; } @@ -610,7 +604,7 @@ and simple_expansion : | Signature sg -> Signature (signature id map sg) | Functor (Named arg, sg) -> let identifier = Identifier.Mk.result id in - let name = Ident.Name.typed_functor_parameter arg.id in + let name = Ident.Name.typed_module arg.id in let param_identifier = Identifier.Mk.parameter (id, name) in let map = { @@ -825,7 +819,7 @@ and module_type_expr map identifier = function w_expr = u_module_type_expr map identifier w_expr; } | Functor (Named arg, expr) -> - let name = Ident.Name.typed_functor_parameter arg.id in + let name = Ident.Name.typed_module arg.id in let identifier' = Identifier.Mk.parameter (identifier, name) in let map = { diff --git a/src/xref2/lang_of.mli b/src/xref2/lang_of.mli index f0952626d0..835c739210 100644 --- a/src/xref2/lang_of.mli +++ b/src/xref2/lang_of.mli @@ -68,7 +68,7 @@ val signature : val class_ : maps -> Identifier.Signature.t -> - Ident.class_ -> + Ident.type_ -> Component.Class.t -> Odoc_model.Lang.Class.t @@ -87,7 +87,7 @@ val class_type_expr : val class_type : maps -> Identifier.Signature.t -> - Ident.class_type -> + Ident.type_ -> Component.ClassType.t -> Odoc_model.Lang.ClassType.t diff --git a/src/xref2/strengthen.ml b/src/xref2/strengthen.ml index 96a3ba3118..a1c4125960 100644 --- a/src/xref2/strengthen.ml +++ b/src/xref2/strengthen.ml @@ -25,7 +25,7 @@ let rec signature : let sg', strengthened_modules = sig_items prefix ?canonical sg in let substs = List.fold_left - (fun s mid -> Subst.path_invalidate_module (mid :> Ident.path_module) s) + (fun s mid -> Subst.path_invalidate_module (mid :> Ident.module_) s) Subst.identity strengthened_modules in Subst.signature substs sg' diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 14fdf93916..1fb51573b8 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -19,12 +19,12 @@ type nonrec t = t let identity = { - module_ = PathModuleMap.empty; + module_ = ModuleMap.empty; module_type = ModuleTypeMap.empty; module_type_replacement = ModuleTypeMap.empty; - type_ = PathTypeMap.empty; - class_type = PathClassTypeMap.empty; - type_replacement = PathTypeMap.empty; + type_ = TypeMap.empty; + class_type = TypeMap.empty; + type_replacement = TypeMap.empty; path_invalidating_modules = []; unresolve_opaque_paths = false; } @@ -35,7 +35,7 @@ let path_invalidate_module id t = { t with path_invalidating_modules = id :: t.path_invalidating_modules } let add_module id p rp t = - { t with module_ = PathModuleMap.add id (`Prefixed (p, rp)) t.module_ } + { t with module_ = ModuleMap.add id (`Prefixed (p, rp)) t.module_ } let add_module_type id p rp t = { @@ -45,50 +45,40 @@ let add_module_type id p rp t = let add_type : Ident.type_ -> Cpath.type_ -> Cpath.Resolved.type_ -> t -> t = fun id p rp t -> - { - t with - type_ = PathTypeMap.add (id :> Ident.path_type) (`Prefixed (p, rp)) t.type_; - } + { t with type_ = TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.type_ } let add_class : - Ident.class_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t = + Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t = fun id p rp t -> { t with type_ = - PathTypeMap.add - (id :> Ident.path_type) + TypeMap.add + (id :> Ident.type_) (`Prefixed ((p :> Cpath.type_), (rp :> Cpath.Resolved.type_))) t.type_; class_type = - PathClassTypeMap.add - (id :> Ident.path_class_type) - (`Prefixed (p, rp)) - t.class_type; + TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.class_type; } let add_class_type : - Ident.class_type -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t - = + Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t = fun id p rp t -> { t with type_ = - PathTypeMap.add - (id :> Ident.path_type) + TypeMap.add + (id :> Ident.type_) (`Prefixed ((p :> Cpath.type_), (rp :> Cpath.Resolved.type_))) t.type_; class_type = - PathClassTypeMap.add - (id :> Ident.path_class_type) - (`Prefixed (p, rp)) - t.class_type; + TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.class_type; } let add_type_replacement id texp equation t = { t with - type_replacement = PathTypeMap.add id (texp, equation) t.type_replacement; + type_replacement = TypeMap.add id (texp, equation) t.type_replacement; } let add_module_type_replacement path mty t = @@ -98,36 +88,31 @@ let add_module_type_replacement path mty t = ModuleTypeMap.add path mty t.module_type_replacement; } -let add_module_substitution : Ident.path_module -> t -> t = +let add_module_substitution : Ident.module_ -> t -> t = fun id t -> { t with path_invalidating_modules = id :: t.path_invalidating_modules; - module_ = PathModuleMap.add id `Substituted t.module_; + module_ = ModuleMap.add id `Substituted t.module_; } -let rename_module : Ident.path_module -> Ident.path_module -> t -> t = - fun id id' t -> - { t with module_ = PathModuleMap.add id (`Renamed id') t.module_ } +let rename_module : Ident.module_ -> Ident.module_ -> t -> t = + fun id id' t -> { t with module_ = ModuleMap.add id (`Renamed id') t.module_ } let rename_module_type : Ident.module_type -> Ident.module_type -> t -> t = fun id id' t -> { t with module_type = ModuleTypeMap.add id (`Renamed id') t.module_type } -let rename_type : Ident.path_type -> Ident.path_type -> t -> t = - fun id id' t -> { t with type_ = PathTypeMap.add id (`Renamed id') t.type_ } +let rename_type : Ident.type_ -> Ident.type_ -> t -> t = + fun id id' t -> { t with type_ = TypeMap.add id (`Renamed id') t.type_ } -let rename_class_type : Ident.path_class_type -> Ident.path_class_type -> t -> t - = +let rename_class_type : Ident.type_ -> Ident.type_ -> t -> t = fun id id' t -> { t with - class_type = PathClassTypeMap.add id (`Renamed id') t.class_type; + class_type = TypeMap.add id (`Renamed id') t.class_type; type_ = - PathTypeMap.add - (id :> Ident.path_type) - (`Renamed (id' :> Ident.path_type)) - t.type_; + TypeMap.add (id :> Ident.type_) (`Renamed (id' :> Ident.type_)) t.type_; } let rec substitute_vars vars t = @@ -179,7 +164,7 @@ let rec resolved_module_path : | `Local id -> ( if List.mem id s.path_invalidating_modules then raise Invalidated; match - try Some (PathModuleMap.find (id :> Ident.path_module) s.module_) + try Some (ModuleMap.find (id :> Ident.module_) s.module_) with _ -> None with | Some (`Renamed x) -> `Local x @@ -240,7 +225,7 @@ and module_path : t -> Cpath.module_ -> Cpath.module_ = | `Apply (p1, p2) -> `Apply (module_path s p1, module_path s p2) | `Local (id, b) -> ( match - try Some (PathModuleMap.find (id :> Ident.path_module) s.module_) + try Some (ModuleMap.find (id :> Ident.module_) s.module_) with _ -> None with | Some (`Prefixed (p, _rp)) -> p @@ -330,12 +315,10 @@ and resolved_type_path : fun s p -> match p with | `Local id -> ( - if PathTypeMap.mem id s.type_replacement then - Replaced (PathTypeMap.find id s.type_replacement) + if TypeMap.mem id s.type_replacement then + Replaced (TypeMap.find id s.type_replacement) else - match - try Some (PathTypeMap.find id s.type_) with Not_found -> None - with + match try Some (TypeMap.find id s.type_) with Not_found -> None with | Some (`Prefixed (_p, rp)) -> Not_replaced rp | Some (`Renamed x) -> Not_replaced (`Local x) | None -> Not_replaced (`Local id)) @@ -360,12 +343,10 @@ and type_path : t -> Cpath.type_ -> Cpath.type_ type_or_replaced = type_path s path') | `Substituted p -> type_path s p |> map_replaced (fun r -> `Substituted r) | `Local (id, b) -> ( - if PathTypeMap.mem id s.type_replacement then - Replaced (PathTypeMap.find id s.type_replacement) + if TypeMap.mem id s.type_replacement then + Replaced (TypeMap.find id s.type_replacement) else - match - try Some (PathTypeMap.find id s.type_) with Not_found -> None - with + match try Some (TypeMap.find id s.type_) with Not_found -> None with | Some (`Prefixed (p, _rp)) -> Not_replaced p | Some (`Renamed x) -> Not_replaced (`Local (x, b)) | None -> Not_replaced (`Local (id, b))) @@ -380,9 +361,7 @@ and resolved_class_type_path : fun s p -> match p with | `Local id -> ( - match - try Some (PathClassTypeMap.find id s.class_type) with _ -> None - with + match try Some (TypeMap.find id s.class_type) with _ -> None with | Some (`Prefixed (_p, rp)) -> rp | Some (`Renamed x) -> `Local x | None -> `Local id) @@ -400,9 +379,7 @@ and class_type_path : t -> Cpath.class_type -> Cpath.class_type = let path' = Cpath.unresolve_resolved_class_type_path r in class_type_path s path') | `Local (id, b) -> ( - match - try Some (PathClassTypeMap.find id s.class_type) with _ -> None - with + match try Some (TypeMap.find id s.class_type) with _ -> None with | Some (`Prefixed (p, _rp)) -> p | Some (`Renamed x) -> `Local (x, b) | None -> `Local (id, b)) @@ -821,7 +798,7 @@ and rename_bound_idents s sg = let open Component.Signature in let new_module_id id = try - match PathModuleMap.find (id :> Ident.path_module) s.module_ with + match ModuleMap.find (id :> Ident.module_) s.module_ with | `Renamed (`LModule _ as x) -> x | `Prefixed (_, _) -> (* This is unusual but can happen when we have TypeOf expressions. It means @@ -840,44 +817,37 @@ and rename_bound_idents s sg = in let new_type_id id = try - match PathTypeMap.find (id :> Ident.path_type) s.type_ with + match TypeMap.find (id :> Ident.type_) s.type_ with | `Renamed (`LType _ as x) -> x | `Prefixed (_, _) -> Ident.Rename.type_ id - | _ -> failwith "Error" with Not_found -> Ident.Rename.type_ id in let new_class_id id = try - match - PathClassTypeMap.find (id :> Ident.path_class_type) s.class_type - with - | `Renamed (`LClass _ as x) -> x - | `Prefixed (_, _) -> Ident.Rename.class_ id - | _ -> failwith "Error" - with Not_found -> Ident.Rename.class_ id + match TypeMap.find (id :> Ident.type_) s.class_type with + | `Renamed (`LType _ as x) -> x + | `Prefixed (_, _) -> Ident.Rename.type_ id + with Not_found -> Ident.Rename.type_ id in let new_class_type_id id = try - match - PathClassTypeMap.find (id :> Ident.path_class_type) s.class_type - with - | `Renamed (`LClassType _ as x) -> x - | `Prefixed (_, _) -> Ident.Rename.class_type id - | _ -> failwith "Error!" - with Not_found -> Ident.Rename.class_type id + match TypeMap.find (id :> Ident.type_) s.class_type with + | `Renamed (`LType _ as x) -> x + | `Prefixed (_, _) -> Ident.Rename.type_ id + with Not_found -> Ident.Rename.type_ id in function | [] -> (s, List.rev sg) | Module (id, r, m) :: rest -> let id' = new_module_id id in rename_bound_idents - (rename_module (id :> Ident.path_module) (id' :> Ident.path_module) s) + (rename_module (id :> Ident.module_) (id' :> Ident.module_) s) (Module (id', r, m) :: sg) rest | ModuleSubstitution (id, m) :: rest -> let id' = new_module_id id in rename_bound_idents - (rename_module (id :> Ident.path_module) (id' :> Ident.path_module) s) + (rename_module (id :> Ident.module_) (id' :> Ident.module_) s) (ModuleSubstitution (id', m) :: sg) rest | ModuleType (id, mt) :: rest -> @@ -895,13 +865,13 @@ and rename_bound_idents s sg = | Type (id, r, t) :: rest -> let id' = new_type_id id in rename_bound_idents - (rename_type (id :> Ident.path_type) (id' :> Ident.path_type) s) + (rename_type (id :> Ident.type_) (id' :> Ident.type_) s) (Type (id', r, t) :: sg) rest | TypeSubstitution (id, t) :: rest -> let id' = new_type_id id in rename_bound_idents - (rename_type (id :> Ident.path_type) (id' :> Ident.path_type) s) + (rename_type (id :> Ident.type_) (id' :> Ident.type_) s) (TypeSubstitution (id', t) :: sg) rest | Exception (id, e) :: rest -> @@ -914,19 +884,13 @@ and rename_bound_idents s sg = | Class (id, r, c) :: rest -> let id' = new_class_id id in rename_bound_idents - (rename_class_type - (id :> Ident.path_class_type) - (id' :> Ident.path_class_type) - s) + (rename_class_type (id :> Ident.type_) (id' :> Ident.type_) s) (Class (id', r, c) :: sg) rest | ClassType (id, r, c) :: rest -> let id' = new_class_type_id id in rename_bound_idents - (rename_class_type - (id :> Ident.path_class_type) - (id' :> Ident.path_class_type) - s) + (rename_class_type (id :> Ident.type_) (id' :> Ident.type_) s) (ClassType (id', r, c) :: sg) rest | Include ({ expansion_; _ } as i) :: rest -> diff --git a/src/xref2/subst.mli b/src/xref2/subst.mli index dfbef23537..6ca8300f7b 100644 --- a/src/xref2/subst.mli +++ b/src/xref2/subst.mli @@ -7,10 +7,10 @@ val identity : t val unresolve_opaque_paths : t -> t -val path_invalidate_module : Ident.path_module -> t -> t +val path_invalidate_module : Ident.module_ -> t -> t val add_module : - Ident.path_module -> Cpath.module_ -> Cpath.Resolved.module_ -> t -> t + Ident.module_ -> Cpath.module_ -> Cpath.Resolved.module_ -> t -> t val add_module_type : Ident.module_type -> Cpath.module_type -> Cpath.Resolved.module_type -> t -> t @@ -18,17 +18,17 @@ val add_module_type : val add_type : Ident.type_ -> Cpath.type_ -> Cpath.Resolved.type_ -> t -> t val add_class : - Ident.class_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t + Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t val add_class_type : - Ident.class_type -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t + Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t val add_type_replacement : - Ident.path_type -> TypeExpr.t -> TypeDecl.Equation.t -> t -> t + Ident.type_ -> TypeExpr.t -> TypeDecl.Equation.t -> t -> t val add_module_type_replacement : Ident.module_type -> ModuleType.expr -> t -> t -val add_module_substitution : Ident.path_module -> t -> t +val add_module_substitution : Ident.module_ -> t -> t val type_ : t -> Component.TypeDecl.t -> Component.TypeDecl.t diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 4f06bd97d9..9fa365a8fa 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -102,7 +102,7 @@ let prefix_substitution path sg = let name = Ident.Name.typed_module id in get_sub (Subst.add_module - (id :> Ident.path_module) + (id :> Ident.module_) (`Module (path, name)) (`Module (path, name)) sub') @@ -127,7 +127,7 @@ let prefix_substitution path sg = let name = Ident.Name.typed_module id in get_sub (Subst.add_module - (id :> Ident.path_module) + (id :> Ident.module_) (`Module (path, name)) (`Module (path, name)) sub') @@ -143,12 +143,12 @@ let prefix_substitution path sg = | Comment _ :: rest -> get_sub sub' rest | Class (id, _, _) :: rest -> - let name = Ident.Name.typed_class id in + let name = Ident.Name.typed_type id in get_sub (Subst.add_class id (`Class (path, name)) (`Class (path, name)) sub') rest | ClassType (id, _, _) :: rest -> - let name = Ident.Name.typed_class_type id in + let name = Ident.Name.typed_type id in get_sub (Subst.add_class_type id (`ClassType (path, name)) @@ -199,9 +199,9 @@ let prefix_signature (path, sg) = Component.Delayed.put (fun () -> Subst.value sub (Component.Delayed.get v)) ) | Class (id, r, c) -> - Class (Ident.Rename.class_ id, r, Subst.class_ sub c) + Class (Ident.Rename.type_ id, r, Subst.class_ sub c) | ClassType (id, r, c) -> - ClassType (Ident.Rename.class_type id, r, Subst.class_type sub c) + ClassType (Ident.Rename.type_ id, r, Subst.class_type sub c) | Include i -> Include (Subst.include_ sub i) | Open o -> Open (Subst.open_ sub o) | Comment c -> Comment c) @@ -404,7 +404,7 @@ let rec handle_apply env func_path arg_path m = let path = `Apply (func_path, arg_path) in let subst = Subst.add_module - (arg_id :> Ident.path_module) + (arg_id :> Ident.module_) (`Resolved substitution) substitution Subst.identity in let subst = Subst.unresolve_opaque_paths subst in @@ -900,7 +900,7 @@ and lookup_class_type : in let res = match p with - | `Local id -> Error (`LocalType (env, (id :> Ident.path_type))) + | `Local id -> Error (`LocalType (env, (id :> Ident.type_))) | `Gpath p -> lookup_class_type_gpath env p | `Substituted s -> lookup_class_type env s | `Class (p, id) -> do_type p id @@ -1133,7 +1133,7 @@ and resolve_class_type : Env.t -> Cpath.class_type -> resolve_class_type_result let id = `Gpath i' in lookup_class_type env id >>= fun t -> Ok (id, t) | `Resolved r -> lookup_class_type env r >>= fun t -> Ok (r, t) - | `Local (l, _) -> Error (`LocalType (env, (l :> Ident.path_type))) + | `Local (l, _) -> Error (`LocalType (env, (l :> Ident.type_))) | `Substituted s -> resolve_class_type env s >>= fun (p, m) -> Ok (`Substituted p, m) | `Class (parent, id) -> @@ -1988,9 +1988,9 @@ and fragmap : let sub_of_removed removed sub = match removed with | `RModule (id, p) -> - Subst.add_module (id :> Ident.path_module) (`Resolved p) p sub + Subst.add_module (id :> Ident.module_) (`Resolved p) p sub | `RType (id, r_texpr, r_eq) -> - Subst.add_type_replacement (id :> Ident.path_type) r_texpr r_eq sub + Subst.add_type_replacement (id :> Ident.type_) r_texpr r_eq sub | `RModuleType (id, e) -> Subst.add_module_type_replacement (id :> Ident.module_type) e sub in @@ -2000,7 +2000,7 @@ and fragmap : (* Invalidate resolved paths containing substituted idents - See the `With11` test for an example of why this is necessary *) let sub_of_substituted x sub = - let x = (x :> Ident.path_module) in + let x = (x :> Ident.module_) in Subst.add_module_substitution x sub |> Subst.path_invalidate_module x in From a1e91cec1d603cf2da28a7c0e310214754bcc6fa Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 27 Aug 2024 15:27:57 +0100 Subject: [PATCH 2/3] Fix missing entries in module map in Lang_of --- src/xref2/lang_of.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 26fb483bad..4260ef893c 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -611,6 +611,7 @@ and simple_expansion : map with functor_parameter = (arg.id, param_identifier) :: map.functor_parameter; + module_ = Component.ModuleMap.add arg.id param_identifier map.module_; } in let arg = functor_parameter map arg in @@ -825,6 +826,7 @@ and module_type_expr map identifier = function { map with functor_parameter = (arg.id, identifier') :: map.functor_parameter; + module_ = Component.ModuleMap.add arg.id identifier' map.module_; } in Functor From 8555bf185eeecee85996d0af613352d277ec74ea Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Tue, 27 Aug 2024 16:19:32 +0100 Subject: [PATCH 3/3] Update tests --- test/xref2/subst/test.md | 107 +++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 61 deletions(-) diff --git a/test/xref2/subst/test.md b/test/xref2/subst/test.md index c0f5c99590..005d06f4af 100644 --- a/test/xref2/subst/test.md +++ b/test/xref2/subst/test.md @@ -42,6 +42,10 @@ let module_substitution ~idents ~targets m test_data = fprintf std_formatter "AFTER \n======\n%!"; fprintf std_formatter "S%a\n\n%!" (Component.Fmt.module_ cfg) m' ``` +```mdx-error +Line 22, characters 49-66: +Error: Unbound type constructor Ident.path_module +``` Module substitution test @@ -69,27 +73,8 @@ the equations for t, u and v point to SubTargets rather than SubstituteMe type vv = SubstituteMe.v end |} ;; -BEFORE -====== -S: -sig - type tt/5 = local(SubstituteMe/2,false).t - type uu/4 = local(SubstituteMe/2,false).u - type vv/3 = local(SubstituteMe/2,false).v -end -(canonical=None) - -AFTER -====== -S: -sig - type tt/6 = resolved(SubTargets/1).t - type uu/7 = resolved(SubTargets/1).u - type vv/8 = resolved(SubTargets/1).v -end -(canonical=None) - -- : unit = () +Line 1, characters 1-20: +Error: Unbound value module_substitution ``` Now test by compiling signatures and printing the result: @@ -137,38 +122,38 @@ let compile mli = end |} ;; - : Component.Signature.t = -module type Monad/30 = +module type Monad/21 = sig - type t/31 - val map/32 : ([a] resolved(t/31)) -> ((a) -> b) -> [b] resolved(t/31) - val join/33 : ([[a] resolved(t/31)] resolved(t/31)) -> [a] resolved(t/31) + type t/22 + val map/23 : ([a] resolved(t/22)) -> ((a) -> b) -> [b] resolved(t/22) + val join/24 : ([[a] resolved(t/22)] resolved(t/22)) -> [a] resolved(t/22) end -module SomeMonad/29 : +module SomeMonad/20 : sig - type t/34 - include r(Monad/30) with [resolved(root(Monad/30).t) = [a] resolved(t/34)] + type t/25 + include r(Monad/21) with [resolved(root(Monad/21).t) = [a] resolved(t/25)] (sig : - val map/35 : ([a] resolved(t/34)) -> ((a) -> b) -> [b] resolved(t/34) - val join/36 : ([[a] resolved(t/34)] resolved(t/34)) -> [a] resolved(t/34) - (removed=type (a) t = ([a] local(t/34,false))) + val map/26 : ([a] resolved(t/25)) -> ((a) -> b) -> [b] resolved(t/25) + val join/27 : ([[a] resolved(t/25)] resolved(t/25)) -> [a] resolved(t/25) + (removed=type (a) t = ([a] local(t/25,false))) end) end (canonical=None) -module ComplexTypeExpr/28 : +module ComplexTypeExpr/19 : sig - type t/37 - include r(Monad/30) with [resolved(root(Monad/30).t) = ([resolved(int) * a] resolved(t/37) * [a * resolved(int)] resolved(t/37))] + type t/28 + include r(Monad/21) with [resolved(root(Monad/21).t) = ([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28))] (sig : - val map/38 : (([resolved(int) * a] resolved(t/37) * [a * resolved(int)] resolved(t/37))) -> ((a) -> b) -> ([resolved(int) * b] resolved(t/37) * [b * resolved(int)] resolved(t/37)) - val join/39 : (([resolved(int) * ([resolved(int) * a] resolved(t/37) * [a * resolved(int)] resolved(t/37))] resolved(t/37) * [([resolved(int) * a] resolved(t/37) * [a * resolved(int)] resolved(t/37)) * resolved(int)] resolved(t/37))) -> ([resolved(int) * a] resolved(t/37) * [a * resolved(int)] resolved(t/37)) - (removed=type (a) t = (([identifier(int,false) * a] local(t/37,false) * [a * identifier(int,false)] local(t/37,false)))) + val map/29 : (([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28))) -> ((a) -> b) -> ([resolved(int) * b] resolved(t/28) * [b * resolved(int)] resolved(t/28)) + val join/30 : (([resolved(int) * ([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28))] resolved(t/28) * [([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28)) * resolved(int)] resolved(t/28))) -> ([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28)) + (removed=type (a) t = (([identifier(int,false) * a] local(t/28,false) * [a * identifier(int,false)] local(t/28,false)))) end) end (canonical=None) -module Erase/27 : +module Erase/18 : sig - include r(Monad/30) with [resolved(root(Monad/30).t) = a] + include r(Monad/21) with [resolved(root(Monad/21).t) = a] (sig : - val map/40 : (a) -> ((a) -> b) -> b - val join/41 : (a) -> a + val map/31 : (a) -> ((a) -> b) -> b + val join/32 : (a) -> a (removed=type (a) t = (a)) end) end (canonical=None) @@ -191,22 +176,22 @@ More tests with two type variables: end |} ;; - : Component.Signature.t = -module type Monad_2/54 = +module type Monad_2/45 = sig - type t/55 - val map/56 : ([a * err] resolved(t/55)) -> f:((a) -> b) -> [b * err] resolved(t/55) - val join/57 : ([[a * e] resolved(t/55) * e] resolved(t/55)) -> [a * e] resolved(t/55) - val both/58 : ([a * e] resolved(t/55)) -> ([b * e] resolved(t/55)) -> [(a * b) * e] resolved(t/55) + type t/46 + val map/47 : ([a * err] resolved(t/46)) -> f:((a) -> b) -> [b * err] resolved(t/46) + val join/48 : ([[a * e] resolved(t/46) * e] resolved(t/46)) -> [a * e] resolved(t/46) + val both/49 : ([a * e] resolved(t/46)) -> ([b * e] resolved(t/46)) -> [(a * b) * e] resolved(t/46) end -module SwappedVars/53 : +module SwappedVars/44 : sig - type t/59 - include r(Monad_2/54) with [resolved(root(Monad_2/54).t) = [b * a] resolved(t/59)] + type t/50 + include r(Monad_2/45) with [resolved(root(Monad_2/45).t) = [b * a] resolved(t/50)] (sig : - val map/60 : ([err * a] resolved(t/59)) -> f:((a) -> b) -> [err * b] resolved(t/59) - val join/61 : ([e * [e * a] resolved(t/59)] resolved(t/59)) -> [e * a] resolved(t/59) - val both/62 : ([e * a] resolved(t/59)) -> ([e * b] resolved(t/59)) -> [e * (a * b)] resolved(t/59) - (removed=type (a, b) t = ([b * a] local(t/59,false))) + val map/51 : ([err * a] resolved(t/50)) -> f:((a) -> b) -> [err * b] resolved(t/50) + val join/52 : ([e * [e * a] resolved(t/50)] resolved(t/50)) -> [e * a] resolved(t/50) + val both/53 : ([e * a] resolved(t/50)) -> ([e * b] resolved(t/50)) -> [e * (a * b)] resolved(t/50) + (removed=type (a, b) t = ([b * a] local(t/50,false))) end) end (canonical=None) ``` @@ -226,18 +211,18 @@ Edge cases: end |} ;; - : Component.Signature.t = -module type S/69 = +module type S/60 = sig - type t/70 - val map/71 : ([a] resolved(t/70)) -> ((a) -> b) -> [b] resolved(t/70) + type t/61 + val map/62 : ([a] resolved(t/61)) -> ((a) -> b) -> [b] resolved(t/61) end -module M/68 : +module M/59 : sig - type t/72 - include r(S/69) with [resolved(root(S/69).t) = [(alias (poly_var [ `A of (a * b) ]) b)] resolved(t/72)] + type t/63 + include r(S/60) with [resolved(root(S/60).t) = [(alias (poly_var [ `A of (a * b) ]) b)] resolved(t/63)] (sig : - val map/73 : ([(alias (poly_var [ `A of (a * b) ]) b)] resolved(t/72)) -> ((a) -> b) -> [(alias (poly_var [ `A of (b * b) ]) b)] resolved(t/72) - (removed=type (a) t = ([(alias (poly_var [ `A of (a * b) ]) b)] local(t/72,false))) + val map/64 : ([(alias (poly_var [ `A of (a * b) ]) b)] resolved(t/63)) -> ((a) -> b) -> [(alias (poly_var [ `A of (b * b) ]) b)] resolved(t/63) + (removed=type (a) t = ([(alias (poly_var [ `A of (a * b) ]) b)] local(t/63,false))) end) end (canonical=None) ```