diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml new file mode 100644 index 0000000000..a0cb5ce0e0 --- /dev/null +++ b/src/analysis/ast_iterators.ml @@ -0,0 +1,53 @@ +open Std +open Typedtree + +let {Logger. log} = Logger.for_section "iterators" + +(* The compiler contains an iterator that aims to gather definitions but +ignores local values like let-in expressions and local type definition. To +provide occurrences in the active buffer we extend the compiler's iterator with +these cases. *) +let iter_on_defs ~uid_to_locs_tbl = + let log = log ~title:"iter_on_defs" in + let register_uid uid fragment = + let loc = Misc_utils.loc_of_decl ~uid fragment in + Option.iter loc ~f:(fun loc -> + Types.Uid.Tbl.add uid_to_locs_tbl uid loc) + in + let iter_decl = Cmt_format.iter_on_declarations ~f:register_uid in + let register_uid uid loc = + Types.Uid.Tbl.add uid_to_locs_tbl uid loc + in + { iter_decl with + expr = (fun sub ({ exp_extra; exp_env; _ } as expr) -> + List.iter exp_extra ~f:(fun (exp_extra, _loc, _attr) -> + match exp_extra with + | Texp_newtype' (typ_id, typ_name) -> + log "Found definition %s (%a)\n%!" typ_name.txt + Logger.fmt (fun fmt -> Location.print_loc fmt typ_name.loc); + let decl = Env.find_type (Path.Pident typ_id) exp_env in + register_uid decl.type_uid typ_name; + () + | _ -> ()); + iter_decl.expr sub expr); + } + +let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () = + let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t = + Types.Uid.Tbl.create 64 + in + let iter = iter_on_defs ~uid_to_locs_tbl in + begin match local_defs with + | `Interface sign -> + iter.signature iter sign + | `Implementation str -> + iter.structure iter str end; + uid_to_locs_tbl + +let iter_on_usages ~f (local_defs : Mtyper.typedtree) = + let iter = Cmt_format.iter_on_occurrences ~f in + begin match local_defs with + | `Interface signature -> iter.signature iter signature + | `Implementation structure -> iter.structure iter structure end + + diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml index f8d713250b..76c42049c1 100644 --- a/src/analysis/completion.ml +++ b/src/analysis/completion.ml @@ -219,8 +219,8 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = | Some p, Some loc -> let namespace = (* FIXME: that's just terrible *) match kind with - | `Value -> `Vals - | `Type -> `Type + | `Value -> Shape.Sig_component_kind.Value + | `Type -> Type | _ -> assert false in begin match get_doc (`Completion_entry (namespace, p, loc)) with diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli index 8cc348526d..e5098a68a1 100644 --- a/src/analysis/completion.mli +++ b/src/analysis/completion.mli @@ -52,7 +52,7 @@ val map_entry : ('a -> 'b) -> val branch_complete : Mconfig.t - -> ?get_doc:([> `Completion_entry of Namespaced_path.Namespace.t + -> ?get_doc:([> `Completion_entry of Shape.Sig_component_kind.t * Path.t * Location.t ] -> [> `Found of string ]) -> ?target_type:Types.type_expr -> ?kinds:Compl.kind list diff --git a/src/analysis/context.ml b/src/analysis/context.ml index 30806301c0..66e51c87ef 100644 --- a/src/analysis/context.ml +++ b/src/analysis/context.ml @@ -78,9 +78,9 @@ let inspect_pattern (type a) ~cursor ~lid (p : a Typedtree.general_pattern) = (Printtyped.pattern 0) p); match p.pat_desc with | Tpat_any when Longident.last lid = "_" -> None - | Tpat_var (_, str_loc) when (Longident.last lid) = str_loc.txt -> + | Tpat_var (_, str_loc, _) when (Longident.last lid) = str_loc.txt -> None - | Tpat_alias (_, _, str_loc) + | Tpat_alias (_, _, str_loc, _) when (Longident.last lid) = str_loc.txt -> (* Assumption: if [Browse.enclosing] stopped on this node and not on the subpattern, then it must mean that the cursor is on the alias. *) @@ -141,6 +141,8 @@ let inspect_browse_tree ~cursor lid browse : t option = | Pattern p -> inspect_pattern ~cursor ~lid p | Value_description _ | Type_declaration _ + | Constructor_declaration _ + | Label_declaration _ | Extension_constructor _ | Module_binding_name _ | Module_declaration_name _ -> diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index e30f456384..568296743f 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -301,7 +301,7 @@ let rec destructible patt = let open Typedtree in match patt.pat_desc with | Tpat_any | Tpat_var _ -> true - | Tpat_alias (p, _, _) -> destructible p + | Tpat_alias (p, _, _, _) -> destructible p | _ -> false @@ -335,8 +335,8 @@ let rec subst_patt initial ~by patt = | Tpat_any | Tpat_var _ | Tpat_constant _ -> patt - | Tpat_alias (p,x,y) -> - { patt with pat_desc = Tpat_alias (f p, x, y) } + | Tpat_alias (p,x,y, uid) -> + { patt with pat_desc = Tpat_alias (f p, x, y, uid) } | Tpat_tuple lst -> { patt with pat_desc = Tpat_tuple (List.map lst ~f) } | Tpat_construct (lid, cd, lst, lco) -> @@ -362,8 +362,8 @@ let rec rm_sub patt sub = | Tpat_any | Tpat_var _ | Tpat_constant _ -> patt - | Tpat_alias (p,x,y) -> - { patt with pat_desc = Tpat_alias (f p, x, y) } + | Tpat_alias (p,x,y,uid) -> + { patt with pat_desc = Tpat_alias (f p, x, y, uid) } | Tpat_tuple lst -> { patt with pat_desc = Tpat_tuple (List.map lst ~f) } | Tpat_construct (lid, cd, lst, lco) -> @@ -388,7 +388,8 @@ let rec qualify_constructors ~unmangling_tables f pat = let qualify_constructors = qualify_constructors ~unmangling_tables in let pat_desc = match pat.pat_desc with - | Tpat_alias (p, id, loc) -> Tpat_alias (qualify_constructors f p, id, loc) + | Tpat_alias (p, id, loc, uid) -> + Tpat_alias (qualify_constructors f p, id, loc, uid) | Tpat_tuple ps -> Tpat_tuple (List.map ps ~f:(qualify_constructors f)) | Tpat_record (labels, closed) -> let labels = @@ -461,7 +462,7 @@ let find_branch patterns sub = | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> false - | Tpat_alias (p,_,_) + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) | Tpat_lazy p -> is_sub_patt p ~sub diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml new file mode 100644 index 0000000000..fa64a807fc --- /dev/null +++ b/src/analysis/env_lookup.ml @@ -0,0 +1,158 @@ +open! Std +let {Logger. log} = Logger.for_section "env-lookup" + +module Namespace = struct + type t = Shape.Sig_component_kind.t + + let to_string = Shape.Sig_component_kind.to_string + + type under_type = [ `Constr | `Labels ] + + type inferred_basic = (* TODO: share with [Namespace.t] *) + [ `Type | `Mod | `Modtype | `Vals | under_type ] + + type inferred = + [ inferred_basic + | `This_label of Types.label_description + | `This_cstr of Types.constructor_description ] + + let from_context : Context.t -> inferred list = function + | Type -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ] + | Module_type -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ] + | Expr | Constant -> + [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ] + | Patt -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ] + | Unknown -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ] + | Label lbl -> [ `This_label lbl ] + | Module_path -> [ `Mod ] + | Constructor (c, _) -> [ `This_cstr c ] +end + +type item = { + uid: Shape.Uid.t; + loc: Location.t; + namespace: Shape.Sig_component_kind.t +} + +let loc path (namespace : Namespace.t) env = + try + let loc, uid, (namespace : Namespace.t) = + match namespace with + | Value -> + let vd = Env.find_value path env in + vd.val_loc, vd.val_uid, Value + | (Type | Extension_constructor | Constructor | Label) -> + let td = Env.find_type path env in + td.type_loc, td.type_uid, Type + | Module -> + let md = Env.find_module path env in + md.md_loc, md.md_uid, Module + | Module_type -> + let mtd = Env.find_modtype path env in + mtd.mtd_loc, mtd.mtd_uid, Module_type + | Class -> + let cty = Env.find_class path env in + cty.cty_loc, cty.cty_uid, Class + | Class_type -> + let clty = Env.find_cltype path env in + clty.clty_loc, clty.clty_uid, Class + + in + Some { uid; loc; namespace } + with + Not_found -> None + +exception Found of + (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) + +let path_and_loc_of_cstr desc _ = + let open Types in + match desc.cstr_tag with + | Cstr_extension (path, _) -> path, desc.cstr_loc + | _ -> + match get_desc desc.cstr_res with + | Tconstr (path, _, _) -> path, desc.cstr_loc + | _ -> assert false + +let path_and_loc_from_label desc env = + let open Types in + match get_desc desc.lbl_res with + | Tconstr (path, _, _) -> + let typ_decl = Env.find_type path env in + path, typ_decl.Types.type_loc + | _ -> assert false + +let in_namespaces (nss : Namespace.inferred list) ident env = + let open Shape.Sig_component_kind in + try + List.iter nss ~f:(fun namespace -> + try + match namespace with + | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) -> + log ~title:"lookup" + "got extension constructor"; + let path, loc = path_and_loc_of_cstr cd env in + (* TODO: Use [`Constr] here instead of [`Type] *) + raise (Found (path, Extension_constructor, cd.cstr_uid, loc)) + | `This_cstr cd -> + log ~title:"lookup" + "got constructor, fetching path and loc in type namespace"; + let path, loc = path_and_loc_of_cstr cd env in + log ~title:"lookup" "found path: %a" + Logger.fmt (fun fmt -> Path.print fmt path); + let path = Path.Pdot (path, cd.cstr_name) + in + raise (Found (path, Constructor, cd.cstr_uid, loc)) + | `Constr -> + log ~title:"lookup" "lookup in constructor namespace" ; + let cd = Env.find_constructor_by_name ident env in + let path, loc = path_and_loc_of_cstr cd env in + let path = Path.Pdot (path, cd.cstr_name) in + (* TODO: Use [`Constr] here instead of [`Type] *) + raise (Found (path, Constructor,cd.cstr_uid, loc)) + | `Mod -> + log ~title:"lookup" "lookup in module namespace" ; + let path, md = Env.find_module_by_name ident env in + raise (Found (path, Module, md.md_uid, md.Types.md_loc)) + | `Modtype -> + let path, mtd = Env.find_modtype_by_name ident env in + raise + (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc)) + | `Type -> + log ~title:"lookup" "lookup in type namespace" ; + let path, typ_decl = Env.find_type_by_name ident env in + raise ( + Found + (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc) + ) + | `Vals -> + log ~title:"lookup" "lookup in value namespace" ; + let path, val_desc = Env.find_value_by_name ident env in + raise ( + Found + (path, Value, val_desc.val_uid, val_desc.Types.val_loc) + ) + | `This_label lbl -> + log ~title:"lookup" + "got label, fetching path and loc in type namespace"; + let path, loc = path_and_loc_from_label lbl env in + let path = Path.Pdot (path, lbl.lbl_name) + in + raise (Found (path, Label, lbl.lbl_uid, loc)) + | `Labels -> + log ~title:"lookup" "lookup in label namespace" ; + let lbl = Env.find_label_by_name ident env in + let path, loc = path_and_loc_from_label lbl env in + (* TODO: Use [`Labels] here instead of [`Type] *) + raise (Found (path, Type, lbl.lbl_uid, loc)) + with Not_found -> () + ) ; + log ~title:"lookup" " ... not in the environment" ; + None + with Found (path, namespace, decl_uid, loc) -> + log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a" + Logger.fmt (fun fmt -> Path.print fmt path) + (Shape.Sig_component_kind.to_string namespace) + Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid) + Logger.fmt (fun fmt -> Location.print_loc fmt loc); + Some (path, { uid = decl_uid; loc; namespace }) diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli new file mode 100644 index 0000000000..e09a5907a2 --- /dev/null +++ b/src/analysis/env_lookup.mli @@ -0,0 +1,38 @@ +module Namespace : sig + type t = Shape.Sig_component_kind.t + + val to_string : t -> string + + type under_type = [ `Constr | `Labels ] + type inferred_basic = + [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ] + type inferred = + [ `Constr + | `Labels + | `Mod + | `Modtype + | `This_cstr of Types.constructor_description + | `This_label of Types.label_description + | `Type + | `Vals ] + + val from_context : Context.t -> inferred list +end + +type item = { + uid: Shape.Uid.t; + loc: Location.t; + namespace: Namespace.t +} + +val loc + : Path.t + -> Namespace.t + -> Env.t + -> item option + +val in_namespaces + : Namespace.inferred list + -> Longident.t + -> Env.t + -> (Path.t * item) option diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml new file mode 100644 index 0000000000..c4a19e8148 --- /dev/null +++ b/src/analysis/index_format.ml @@ -0,0 +1,109 @@ + +exception Not_an_index of string + +module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct + type t = Longident.t Location.loc + + let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = + let p1f, p2f = Filename.(basename p1.pos_fname, basename p2.pos_fname) in + match String.compare p1f p2f with + | 0 -> Int.compare p1.pos_cnum p2.pos_cnum + | n -> n + + let compare (t1 : t) (t2 : t) = + match compare_pos t1.loc.loc_start t2.loc.loc_start with + | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end + | n -> n +end + +module LidSet = Set.Make (Lid) + +module Stats = Map.Make (String) + +(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is + already present the locations are merged. *) +let add tbl uid locs = + try + let locations = Hashtbl.find tbl uid in + Hashtbl.replace tbl uid (LidSet.union locs locations) + with Not_found -> Hashtbl.add tbl uid locs + +type stat = { mtime : float; size : int; source_digest: string option } +type index = { + defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; + approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t; + load_path : string list; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; +} + +let pp_partials (fmt : Format.formatter) + (partials : (Shape.Uid.t, LidSet.t) Hashtbl.t) = + Format.fprintf fmt "{@["; + Hashtbl.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (LidSet.elements locs)) + partials; + Format.fprintf fmt "@]}" + +let pp (fmt : Format.formatter) pl = + Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs); + Hashtbl.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (LidSet.elements locs)) + pl.defs; + Format.fprintf fmt "@]},@ "; + Format.fprintf fmt "%i approx shapes:@ @[%a@],@ " + (Hashtbl.length pl.approximated) + pp_partials pl.approximated; + Format.fprintf fmt "and shapes for CUS %s.@ " + (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) + +let ext = "ocaml-index" + +(* [magic_number] Must be the same lenght as cmt's magic numbers *) +let magic_number = "Merl2023I001" + +let write ~file index = + Merlin_utils.Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file + (fun _temp_file_name oc -> + output_string oc magic_number; + output_value oc (index : index)) + +type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown + +let read ~file = + let ic = open_in_bin file in + Merlin_utils.Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let file_magic_number = ref (Cmt_format.read_magic_number ic) in + let cmi_magic_number = Ocaml_utils.Config.cmi_magic_number in + let cmt_magic_number = Ocaml_utils.Config.cmt_magic_number in + (if String.equal !file_magic_number cmi_magic_number then + let _ = Cmi_format.input_cmi ic in + file_magic_number := Cmt_format.read_magic_number ic); + if String.equal !file_magic_number cmt_magic_number then + Cmt (input_value ic : Cmt_format.cmt_infos) + else if String.equal !file_magic_number magic_number then + Index (input_value ic : index) + else Unknown) + +let read_exn ~file = + match read ~file with Index index -> index | _ -> raise (Not_an_index file) diff --git a/src/analysis/index_format.mli b/src/analysis/index_format.mli new file mode 100644 index 0000000000..4d68269c75 --- /dev/null +++ b/src/analysis/index_format.mli @@ -0,0 +1,31 @@ +exception Not_an_index of string + +module Lid : Set.OrderedType with type t = Longident.t Location.loc +module LidSet : Set.S with type elt = Longident.t Location.loc + +val add : ('a, LidSet.t) Hashtbl.t -> 'a -> LidSet.t -> unit + +module Stats : Map.S with type key = String.t + +type stat = { mtime : float; size : int; source_digest: string option } +type index = { + defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; + approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t; + load_path : string list; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; +} + +type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown + +val pp : Format.formatter -> index -> unit + +val ext : string +val magic_number : string + +val write : file:string -> index -> unit +val read : file:string -> file_content + +(** [read_exn] raises [Not_an_index] if the file does not have the correct magic + nulmber. *) +val read_exn : file:string -> index diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 44236c0df5..be9b542d35 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -31,6 +31,21 @@ open Std let last_location = ref Location.none let {Logger. log} = Logger.for_section "locate" + +type config = { + mconfig: Mconfig.t; + ml_or_mli: [ `ML | `MLI ]; + traverse_aliases: bool; +} + +type result = { + uid: Shape.Uid.t; + decl_uid: Shape.Uid.t; + file: string; + location: Location.t; + approximated: bool; +} + module File : sig type t = private | ML of string @@ -194,10 +209,6 @@ end module Utils = struct - let is_builtin_path = function - | Path.Pident id -> Ident.is_predef id - | _ -> false - (* Reuse the code of [Misc.find_in_path_uncap] but returns all the files matching, instead of the first one. This is only used when looking for ml files, not cmts. Indeed for cmts we know that the load path will only ever @@ -297,13 +308,12 @@ let move_to filename cmt_infos = in File_switching.move_to ~digest filename - -let load_cmt ~config comp_unit ml_or_mli = - Preferences.set ml_or_mli; +let load_cmt ~config ?(with_fallback = true) comp_unit = + Preferences.set config.ml_or_mli; let file = Preferences.build comp_unit in - match Utils.find_file ~config ~with_fallback:true file with + match Utils.find_file ~config:config.mconfig ~with_fallback file with | Some path -> let cmt_infos = (Cmt_cache.read path).cmt_infos in let source_file = cmt_infos.cmt_sourcefile in @@ -339,125 +349,6 @@ let scrape_alias ~env ~fallback_uid ~namespace path = in non_alias_declaration_uid ~fallback_uid path -let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace = - let module Shape_reduce = - Shape.Make_reduce (struct - type env = Env.t - - let fuel = 10 - - let read_unit_shape ~unit_name = - log ~title:"read_unit_shape" "inspecting %s" unit_name; - match load_cmt ~config unit_name `ML with - | Ok (filename, cmt_infos) -> - move_to filename cmt_infos; - log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; - cmt_infos.cmt_impl_shape - | Error () -> - log ~title:"read_unit_shape" "failed to find %s" unit_name; - None - - let find_shape env id = Env.shape_of_path - ~namespace:Shape.Sig_component_kind.Module env (Pident id) - end) - in - let unalias fallback_uid = - let uid = scrape_alias ~fallback_uid ~env ~namespace path in - log ~title:"uid_of_path" "Unaliasing uid: %a -> %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid) - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - uid - in - match ml_or_mli with - | `MLI -> unalias decl_uid - | `ML -> - let shape = Env.shape_of_path ~namespace env path in - log ~title:"shape_of_path" "initial: %a" - Logger.fmt (fun fmt -> Shape.print fmt shape); - let r = Shape_reduce.weak_reduce env shape in - log ~title:"shape_of_path" "reduced: %a" - Logger.fmt (fun fmt -> Shape.print fmt r); - match r.uid with - | Some uid -> uid - | None -> - log ~title:"shape_of_path" "No uid found; fallbacking to declaration uid"; - unalias decl_uid - -let from_uid ~config ~ml_or_mli uid loc path = - let loc_of_comp_unit comp_unit = - match load_cmt ~config comp_unit ml_or_mli with - | Ok (pos_fname, _cmt) -> - let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in - let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in - Some loc - | _ -> None - in - let title = "from_uid" in - match uid with - | Shape.Uid.Item { comp_unit; _ } -> - let locopt = - let log_and_return msg = log ~title msg; None in - let uid_to_loc_tbl = - if Env.get_unit_name () = comp_unit then begin - log ~title "We look for %a in the current compilation unit." - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - Some (Env.get_uid_to_loc_tbl ()) - end else begin - log ~title "Loading the cmt for unit %S" comp_unit; - match load_cmt ~config comp_unit ml_or_mli with - | Ok (_pos_fname, cmt) -> Some cmt.cmt_uid_to_loc - | Error () -> log_and_return "Failed to load the cmt file." - end - in - Option.bind uid_to_loc_tbl ~f:(fun tbl -> - log ~title "Looking for %a in the uid_to_loc table" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - match Shape.Uid.Tbl.find_opt tbl uid with - | Some loc -> - log ~title "Found location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - Some (uid, loc) - | None -> log_and_return "Uid not found in the table.") - in - begin match locopt with - | Some (uid, loc) -> `Found (Some uid, loc) - | None -> - log ~title "Fallbacking to lookup location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - `Found (Some uid, loc) - end - | Compilation_unit comp_unit -> - begin - log ~title "Got the uid of a compilation unit: %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - match loc_of_comp_unit comp_unit with - | Some loc -> `Found (Some uid, loc) - | _ -> log ~title "Failed to load the CU's cmt"; - `Not_found (Path.name path, None) - end - | Predef _ | Internal -> assert false - -let locate ~config ~env ~ml_or_mli decl_uid loc path ns = - let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns in - from_uid ~config ~ml_or_mli uid loc path - -let path_and_loc_of_cstr desc _ = - let open Types in - match desc.cstr_tag with - | Cstr_extension (path, _) -> path, desc.cstr_loc - | _ -> - match get_desc desc.cstr_res with - | Tconstr (path, _, _) -> path, desc.cstr_loc - | _ -> assert false - -let path_and_loc_from_label desc env = - let open Types in - match get_desc desc.lbl_res with - | Tconstr (path, _, _) -> - let typ_decl = Env.find_type path env in - path, typ_decl.Types.type_loc - | _ -> assert false - type find_source_result = | Found of string | Not_found of File.t @@ -483,7 +374,7 @@ let find_source ~config loc = in let dir = Filename.dirname initial_path in let dir = - match Mconfig.(config.query.directory) with + match config.Mconfig.query.directory with | "" -> dir | cwd -> Misc.canonicalize_filename ~cwd dir in @@ -492,7 +383,9 @@ let find_source ~config loc = log ~title:"find_source" "failed to find %S in source path (fallback = %b)" filename with_fallback ; log ~title:"find_source" "looking for %S in %S" (File.name file) dir ; - begin match Utils.find_file_with_path ~config ~with_fallback file [dir] with + begin match + Utils.find_file_with_path ~config ~with_fallback file [dir] + with | Some source -> Found source | None -> log ~title:"find_source" "Trying to find %S in %S directly" fname dir; @@ -585,8 +478,8 @@ let find_source ~config loc path = | _ -> failure | exception _ -> failure in - match result with - | Found src -> `Found (Some src, loc.Location.loc_start) + match (result : find_source_result) with + | Found src -> `Found (src, loc) | Not_found f -> File.explain_not_found path f | Multiple_matches lst -> let matches = String.concat lst ~sep:", " in @@ -595,181 +488,182 @@ let find_source ~config loc path = merlin doesn't know which is the right one: %s" matches) -module Namespace = struct - type under_type = [ `Constr | `Labels ] - - type t = (* TODO: share with [Namespaced_path.Namespace.t] *) - [ `Type | `Mod | `Modtype | `Vals | under_type ] - - type inferred = - [ t - | `This_label of Types.label_description - | `This_cstr of Types.constructor_description ] - - let from_context : Context.t -> inferred list = function - | Type -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ] - | Module_type -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ] - | Expr | Constant -> - [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ] - | Patt -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ] - | Unknown -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ] - | Label lbl -> [ `This_label lbl ] - | Module_path -> [ `Mod ] - | Constructor (c, _) -> [ `This_cstr c ] -end - -module Env_lookup : sig - - val loc - : Path.t - -> Namespaced_path.Namespace.t - -> Env.t - -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option - - val in_namespaces - : Namespace.inferred list - -> Longident.t - -> Env.t - -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) option - -end = struct - - let loc path (namespace : Namespaced_path.Namespace.t) env = - try - Some ( - match namespace with - | `Unknown - | `Apply - | `Vals -> - let vd = Env.find_value path env in - vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value - | `Constr - | `Labels - | `Type -> - let td = Env.find_type path env in - td.type_loc, td.type_uid, Shape.Sig_component_kind.Type - | `Functor - | `Mod -> - let md = Env.find_module path env in - md.md_loc, md.md_uid, Shape.Sig_component_kind.Module - | `Modtype -> - let mtd = Env.find_modtype path env in - mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type - ) - with - Not_found -> None - - exception Found of - (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) +(** [find_loc_of_uid] uid's location are given by tables stored int he cmt files + for external compilation units or computed by Merlin for the current buffer. + This function lookups a uid's location in the appropriate table. *) +let find_loc_of_uid ~config ~local_defs uid comp_unit = + let title = "find_loc_of_uid" in + let loc_of_decl ~uid def = + match Misc_utils.loc_of_decl ~uid def with + | Some loc -> + log ~title "Found location: %a" + Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc); + `Some (uid, loc.loc) + | None -> log ~title "The declaration has no location."; `None + in + if Env.get_unit_name () = comp_unit then begin + log ~title "We look for %a in the current compilation unit." + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + log ~title "Looking for %a in the uid_to_loc table" + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in + match Shape.Uid.Tbl.find_opt tbl uid with + | Some { Location.loc; _ } -> `Some (uid, loc) + | None -> log ~title "Uid not found in the local table."; `None + end else begin + log ~title "Loading the cmt file for unit %S" comp_unit; + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Shapes successfully loaded, looking for %a" + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with + | Some decl -> loc_of_decl ~uid decl + | None -> log ~title "Uid not found in the cmt's table."; `None + end + | _ -> log ~title "Failed to load the cmt file"; `None + end - let in_namespaces (nss : Namespace.inferred list) ident env = - let open Shape.Sig_component_kind in - try - List.iter nss ~f:(fun namespace -> - try - match namespace with - | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) -> - log ~title:"lookup" - "got extension constructor"; - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Extension_constructor, cd.cstr_uid, loc)) - | `This_cstr cd -> - log ~title:"lookup" - "got constructor, fetching path and loc in type namespace"; - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Type, cd.cstr_uid,loc)) - | `Constr -> - log ~title:"lookup" "lookup in constructor namespace" ; - let cd = Env.find_constructor_by_name ident env in - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Type,cd.cstr_uid, loc)) - | `Mod -> - log ~title:"lookup" "lookup in module namespace" ; - let path, md = Env.find_module_by_name ident env in - raise (Found (path, Module, md.md_uid, md.Types.md_loc)) - | `Modtype -> - log ~title:"lookup" "lookup in module type namespace" ; - let path, mtd = Env.find_modtype_by_name ident env in - raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc)) - | `Type -> - log ~title:"lookup" "lookup in type namespace" ; - let path, typ_decl = Env.find_type_by_name ident env in - raise ( - Found (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc) - ) - | `Vals -> - log ~title:"lookup" "lookup in value namespace" ; - let path, val_desc = Env.find_value_by_name ident env in - raise ( - Found (path, Value, val_desc.val_uid, val_desc.Types.val_loc) - ) - | `This_label lbl -> - log ~title:"lookup" - "got label, fetching path and loc in type namespace"; - let path, loc = path_and_loc_from_label lbl env in - (* TODO: Use [`Labels] here instead of [`Type] *) - raise (Found (path, Type, lbl.lbl_uid, loc)) - | `Labels -> - log ~title:"lookup" "lookup in label namespace" ; - let lbl = Env.find_label_by_name ident env in - let path, loc = path_and_loc_from_label lbl env in - (* TODO: Use [`Labels] here instead of [`Type] *) - raise (Found (path, Type, lbl.lbl_uid, loc)) - with Not_found -> () - ) ; - log ~title:"lookup" " ... not in the environment" ; - None - with Found ((path, namespace, decl_uid, _loc) as x) -> - log ~title:"env_lookup" "found: '%a' in namespace %s with uid %a" - Logger.fmt (fun fmt -> Path.print fmt path) - (Shape.Sig_component_kind.to_string namespace) - Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - Some x -end +let find_loc_of_comp_unit ~config uid comp_unit = + let title = "find_loc_of_comp_unit" in + log ~title "Got the uid of a compilation unit: %s" comp_unit; + match load_cmt ~config comp_unit with + | Ok (pos_fname, _cmt) -> + let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in + let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in + `Some (uid, loc) + | _ -> log ~title "Failed to load the CU's cmt"; `None + +let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = + let namespace = decl.namespace in + let module Reduce = Shape_reduce.Make (struct + let fuel = 10 -let uid_from_longident ~config ~env nss ml_or_mli ident = + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + match + load_cmt ~config:({config with ml_or_mli = `ML}) + ~with_fallback:false unit_name + with + | Ok (filename, cmt_infos) -> + move_to filename cmt_infos; + log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; + cmt_infos.cmt_impl_shape + | Error () -> + log ~title:"read_unit_shape" "failed to find %s" unit_name; + None + end) + in + let shape = Env.shape_of_path ~namespace env path in + log ~title:"shape_of_path" "initial: %a" + Logger.fmt (Fun.flip Shape.print shape); + let _keep_aliases = + if config.traverse_aliases + then (fun _ -> false) + else (function + | Shape. { uid = Some (Item { comp_unit; _ }); + desc = Alias { desc = Comp_unit alias_cu; _ }; + _ } + when let by = comp_unit ^ "__" in + Merlin_utils.Std.String.is_prefixed ~by alias_cu -> + false + | _ -> true) + in + let reduced = Reduce.reduce_for_uid env shape + in + log ~title:"shape_of_path" "reduced: %a" + Logger.fmt (fun fmt -> Shape_reduce.print_result fmt reduced); + reduced + +let rec uid_of_aliases ~traverse_aliases = function + | [] -> assert false + | [ def ] -> def + | (Shape.Uid.Item { comp_unit; _ }) + :: (((Compilation_unit comp_unit') :: _) as tl) + when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' -> + (* Always traverse dune-wrapper aliases *) + uid_of_aliases ~traverse_aliases tl + | [ alias; def ] -> if traverse_aliases then def else alias + | _alias :: tl when traverse_aliases -> uid_of_aliases ~traverse_aliases tl + | alias :: _tl -> alias + +(** This is the main function here *) +let from_path ~config ~env ~local_defs ~decl path = + let title = "from_path" in + let unalias (decl : Env_lookup.item) = + if not config.traverse_aliases then decl.uid else + let namespace = decl.namespace in + let uid = scrape_alias ~fallback_uid:decl.uid ~env ~namespace path in + if uid <> decl.uid then + log ~title:"uid_of_path" "Unaliased declaration uid: %a -> %a" + Logger.fmt (Fun.flip Shape.Uid.print decl.uid) + Logger.fmt (Fun.flip Shape.Uid.print uid); + uid + in + (* Step 1: Path => Uid *) + let decl : Env_lookup.item = { decl with uid = (unalias decl) } in + let uid, approximated = match config.ml_or_mli with + | `MLI -> decl.uid, false + | `ML -> + let traverse_aliases = config.traverse_aliases in + match find_definition_uid ~config ~env ~decl path with + | Resolved uid -> uid, false + | Resolved_alias aliases -> uid_of_aliases ~traverse_aliases aliases, false + | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } -> + uid, approximated + | Approximated _ | Unresolved _ | Internal_error_missing_uid -> + log ~title "No definition uid, falling back to the declaration uid: %a" + Logger.fmt (Fun.flip Shape.Uid.print decl.uid); + decl.uid, true + in + (* Step 2: Uid => Location *) + let loc = match uid with + | Predef s -> `Builtin (uid, s) + | Internal -> `Builtin (uid, "") + | Item {comp_unit; _} -> find_loc_of_uid ~config ~local_defs uid comp_unit + | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit + in + let loc = match loc with + | `None -> + log ~title "Falling back to the declaration's location: %a" + Logger.fmt (Fun.flip Location.print_loc decl.loc); + `Some (decl.uid, decl.loc) + | other -> other + in + (* Step 3: Location => Source *) + match loc with + | `None -> assert false + | `Builtin _ as err -> err + | `Some (uid, loc) -> + match find_source ~config:config.mconfig loc (Path.name path) with + | `Found (file, location) -> + log ~title:"find_source" "Found file: %s (%a)" file + Logger.fmt (Fun.flip Location.print_loc location); + `Found { + uid; + decl_uid = decl.uid; + file; location; approximated } + | `File_not_found _ as otherwise -> otherwise + +let from_longident ~config ~env ~local_defs nss ident = let str_ident = try String.concat ~sep:"." (Longident.flatten ident) with _-> "Not a flat longident" in match Env_lookup.in_namespaces nss ident env with | None -> `Not_in_env str_ident - | Some (path, namespace, decl_uid, loc) -> - if Utils.is_builtin_path path then - `Builtin - else - let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace in - `Uid (uid, loc, path) + | Some (path, decl) -> from_path ~config ~env ~local_defs ~decl path -let from_longident ~config ~env nss ml_or_mli ident = - match uid_from_longident ~config ~env nss ml_or_mli ident with - | `Uid (uid, loc, path) -> from_uid ~config ~ml_or_mli uid loc path - | (`Builtin | `Not_in_env _) as v -> v - -let from_path ~config ~env ~namespace ml_or_mli path = +let from_path ~config ~env ~local_defs ~namespace path = File_switching.reset (); - if Utils.is_builtin_path path then - `Builtin - else - match Env_lookup.loc path namespace env with - | None -> `Not_in_env (Path.name path) - | Some (loc, uid, namespace) -> - match locate ~config ~env ~ml_or_mli uid loc path namespace with - | `Not_found _ - | `File_not_found _ as err -> err - | `Found (uid, loc) -> - match find_source ~config loc (Path.name path) with - | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise + match Env_lookup.loc path namespace env with + | None -> `Not_in_env (Path.name path) + | Some decl -> from_path ~config ~env ~local_defs ~decl path let infer_namespace ?namespaces ~pos lid browse is_label = match namespaces with | Some nss -> if not is_label - then `Ok (nss :> Namespace.inferred list) + then `Ok (nss :> Env_lookup.Namespace.inferred list) else if List.mem `Labels ~set:nss then ( log ~title:"from_string" "restricting namespaces to labels"; `Ok [ `Labels ] @@ -787,13 +681,13 @@ let infer_namespace ?namespaces ~pos lid browse is_label = | Some ctxt, false -> log ~title:"from_string" "inferred context: %s" (Context.to_string ctxt); - `Ok (Namespace.from_context ctxt) + `Ok (Env_lookup.Namespace.from_context ctxt) | _, true -> log ~title:"from_string" "dropping inferred context, it is not precise enough"; `Ok [ `Labels ] -let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = +let from_string ~config ~env ~local_defs ~pos ?namespaces path = File_switching.reset (); let browse = Mbrowse.of_typedtree local_defs in let lid = Type_utils.parse_longident path in @@ -804,14 +698,8 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = | `Ok nss -> log ~title:"from_string" "looking for the source of '%s' (prioritizing %s files)" - path (match switch with `ML -> ".ml" | `MLI -> ".mli"); - match from_longident ~config ~env nss switch ident with - | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err - | `Builtin -> `Builtin path - | `Found (uid, loc) -> - match find_source ~config loc path with - | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise + path (match config.ml_or_mli with `ML -> ".ml" | `MLI -> ".mli"); + from_longident ~config ~env ~local_defs nss ident in Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid @@ -864,8 +752,8 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = let rec aux pat = let open Typedtree in match pat.pat_desc with - | Tpat_var (id, _) -> f id - | Tpat_alias (pat, _, _) + | Tpat_var (id, _, _) -> f id + | Tpat_alias (pat, _, _, _) | Tpat_variant (_, Some pat, _) | Tpat_lazy pat | Tpat_or (pat, _, _) -> @@ -890,7 +778,7 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = in let typedtree = log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; - match load_cmt ~config comp_unit `MLI with + match load_cmt ~config:({config with ml_or_mli = `MLI}) comp_unit with | Ok (_, cmt_infos) -> log ~title:"doc_from_uid" "Cmt loaded, itering on the typedtree"; begin match cmt_infos.cmt_annots with @@ -932,8 +820,8 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = let doc_from_uid ~config ~loc uid = begin match uid with - | Some (Shape.Uid.Item { comp_unit; _ } as uid) - | Some (Shape.Uid.Compilation_unit comp_unit as uid) + | Shape.Uid.Item { comp_unit; _ } + | Shape.Uid.Compilation_unit comp_unit when Env.get_unit_name () <> comp_unit -> log ~title:"get_doc" "the doc (%a) you're looking for is in another compilation unit (%s)" @@ -989,38 +877,35 @@ let doc_from_comment_list ~local_defs ~buffer_comments loc = | None, _ -> `No_documentation | Some doc, _ -> `Found doc -let get_doc ~config ~env ~local_defs ~comments ~pos = +let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos = File_switching.reset (); fun path -> let_ref last_location Location.none @@ fun () -> + let config = { mconfig; ml_or_mli = `MLI; traverse_aliases = true; } in let doc_from_uid_result = match path with | `Completion_entry (namespace, path, _loc) -> log ~title:"get_doc" "completion: looking for the doc of '%a'" Logger.fmt (fun fmt -> Path.print fmt path) ; - let from_path = from_path ~config ~env ~namespace `MLI path in + + let from_path = + from_path ~config ~env ~local_defs ~namespace path + in begin match from_path with - | `Found (uid, _, pos) -> - let loc : Location.t = - { loc_start = pos; loc_end = pos; loc_ghost = true } - in + | `Found { uid; location = loc; _ } -> doc_from_uid ~config ~loc uid - | (`Builtin |`Not_in_env _|`File_not_found _|`Not_found _) + | (`Builtin _ |`Not_in_env _|`File_not_found _|`Not_found _) as otherwise -> otherwise end | `User_input path -> log ~title:"get_doc" "looking for the doc of '%s'" path; - begin match from_string ~config ~env ~local_defs ~pos `MLI path with - | `Found (uid, _, pos) -> - let loc : Location.t = - { loc_start = pos; loc_end = pos; loc_ghost = true } - in + begin match from_string ~config ~env ~local_defs ~pos path with + | `Found { uid; location = loc; _ } -> doc_from_uid ~config ~loc uid | `At_origin -> `Found_loc { Location.loc_start = pos; loc_end = pos; loc_ghost = true } | `Missing_labels_namespace -> `No_documentation - | `Builtin _ -> `Builtin - | (`Not_in_env _ | `Not_found _ |`File_not_found _ ) + | (`Builtin _ | `Not_in_env _ | `Not_found _ |`File_not_found _ ) as otherwise -> otherwise end in @@ -1028,7 +913,7 @@ let get_doc ~config ~env ~local_defs ~comments ~pos = | `Found_doc doc -> `Found doc | `Found_loc loc -> doc_from_comment_list ~local_defs ~buffer_comments:comments loc - | `Builtin -> + | `Builtin _ -> begin match path with | `User_input path -> `Builtin path | `Completion_entry (_, path, _) -> `Builtin (Path.name path) diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index 581d75c294..2fb5b8f3ec 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -28,33 +28,51 @@ val log : 'a Logger.printf -module Namespace : sig - type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ] -end +type config = { + mconfig: Mconfig.t; + ml_or_mli: [ `ML | `MLI ]; + traverse_aliases: bool; +} + +type result = { + uid: Shape.Uid.t; + decl_uid: Shape.Uid.t; + file: string; + location: Location.t; + approximated: bool; +} + +val uid_of_aliases : traverse_aliases:bool -> Shape.Uid.t list -> Shape.Uid.t + +val find_source + : config: Mconfig.t + -> Warnings.loc + -> string + -> [> `File_not_found of string + | `Found of string * Location.t ] val from_path - : config:Mconfig.t + : config:config -> env:Env.t - -> namespace:Namespaced_path.Namespace.t - -> [ `ML | `MLI ] + -> local_defs:Mtyper.typedtree + -> namespace:Env_lookup.Namespace.t -> Path.t -> [> `File_not_found of string - | `Found of Shape.Uid.t option * string option * Lexing.position - | `Builtin + | `Found of result + | `Builtin of Shape.Uid.t * string | `Not_in_env of string | `Not_found of string * string option ] val from_string - : config:Mconfig.t + : config:config -> env:Env.t -> local_defs:Mtyper.typedtree -> pos:Lexing.position - -> ?namespaces:Namespace.t list - -> [ `ML | `MLI ] + -> ?namespaces:Env_lookup.Namespace.inferred_basic list -> string -> [> `File_not_found of string - | `Found of Shape.Uid.t option * string option * Lexing.position - | `Builtin of string + | `Found of result + | `Builtin of Shape.Uid.t * string | `Missing_labels_namespace | `Not_found of string * string option | `Not_in_env of string @@ -67,8 +85,7 @@ val get_doc -> comments:(string * Location.t) list -> pos:Lexing.position -> [ `User_input of string - | `Completion_entry of - Namespaced_path.Namespace.t * Path.t * Location.t ] + | `Completion_entry of Env_lookup.Namespace.t * Path.t * Location.t ] -> [> `File_not_found of string | `Found of string | `Builtin of string diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index b5ac18dedd..78e23d77b1 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -57,3 +57,27 @@ let parenthesize_name name = else "(" ^ name ^ ")" ) + +let loc_of_decl ~uid = + let of_option name = + match name.Location.txt with + | Some txt -> Some { name with txt } + | None -> None + in + let of_value_binding vb = + let bound_idents = Typedtree.let_bound_idents_full [vb] in + ListLabels.find_map ~f:(fun (_, loc, _, uid') -> if uid = uid' then Some loc else None) bound_idents + in + function + | Typedtree.Value vd -> Some vd.val_name + | Value_binding vb -> of_value_binding vb + | Type td -> Some td.typ_name + | Constructor cd -> Some cd.cd_name + | Label ld -> Some ld.ld_name + | Module md -> of_option md.md_name + | Module_type mtd -> Some mtd.mtd_name + | Module_substitution msd -> Some msd.ms_name; + | Module_binding mb -> of_option mb.mb_name + | Class cd -> Some cd.ci_id_name + | Class_type ctd -> Some ctd.ci_id_name + | Extension_constructor ec -> Some ec.ext_name diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 06a02a5db1..1df3e86826 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -22,3 +22,7 @@ end (* Add parenthesis to qualified operators *) val parenthesize_name : string -> string + +(** Extracts the loc from cmt's cmt_uid_to_decl tables *) +val loc_of_decl : + uid:Shape.Uid.t -> Typedtree.item_declaration -> string Location.loc option diff --git a/src/analysis/namespaced_path.ml b/src/analysis/namespaced_path.ml deleted file mode 100644 index 2ade36f4c7..0000000000 --- a/src/analysis/namespaced_path.ml +++ /dev/null @@ -1,133 +0,0 @@ -open Std - -module Namespace = struct - type t = [ - | `Vals - | `Type - | `Constr - | `Mod - | `Modtype - | `Functor - | `Labels - | `Unknown - | `Apply - ] - - let to_tag_string = function - | `Mod -> "" - | `Functor -> "[functor]" - | `Labels -> "[label]" - | `Constr -> "[cstr]" - | `Type -> "[type]" - | `Vals -> "[val]" - | `Modtype -> "[Mty]" - | `Unknown -> "[?]" - | `Apply -> "[functor application]" - - let to_string = function - | `Mod -> "(module) " - | `Functor -> "(functor)" - | `Labels -> "(label) " - | `Constr -> "(constructor) " - | `Type -> "(type) " - | `Vals -> "(value) " - | `Modtype -> "(module type) " - | `Unknown -> "(unknown)" - | `Apply -> "(functor application)" -end - -module Id = struct - type t = - | Id of Ident.t - | String of string - - let name = function - | Id id -> Ident.name id - | String s -> s - - let unique_name = function - | Id id -> Ident.unique_toplevel_name id - | String s -> s - - let equal mi1 mi2 = - match mi1, mi2 with - | Id i1, Id i2 -> Ident.equal i1 i2 - | Id i, String s - | String s, Id i -> (Ident.name i) = s - | String s1, String s2 -> s1 = s2 -end - -type t = elt list -and elt = - | Ident of Id.t * Namespace.t - | Applied_to of t - -let rec to_string ~name = function - | [] - | Applied_to _ :: _ -> invalid_arg "Namespaced_path.to_string" - | Ident (id, ns) :: rest -> - List.fold_left rest ~init:(name id ^ Namespace.to_tag_string ns) ~f:( - fun acc elt -> - match elt with - | Ident (id, ns) -> - Printf.sprintf "%s.%s%s" acc (name id) (Namespace.to_tag_string ns) - | Applied_to arg -> - Printf.sprintf "%s(%s)" acc (to_string ~name arg) - ) - -let to_unique_string l = to_string ~name:Id.unique_name l -let to_string l = to_string ~name:Id.name l - -let of_path ~namespace p = - let rec aux namespace acc p = - let open Path in - match p with - | Pident id -> Ident (Id.Id id, namespace) :: acc - | Pdot (p, s) -> aux `Mod (Ident (Id.String s, namespace) :: acc) p - | Papply (p1, p2) -> - let acc = - Applied_to (aux `Mod [] p2) :: acc - in - aux `Mod acc p1 - in - aux namespace [] p - -let head_exn = function - | [] -> invalid_arg "head" - | x :: _ -> x - -let head x = - try Some (head_exn x) - with Invalid_argument _ -> None - -let peal_head_exn = function - | [] -> invalid_arg "peal_head_exn" - | _head :: rest -> rest - -let peal_head p = - try Some (peal_head_exn p) - with Invalid_argument _ -> None - -let rec equal p1 p2 = List.equal ~eq:equal_elt p1 p2 -and equal_elt elt1 elt2 = - match elt1, elt2 with - | Ident (i1, ns1), Ident (i2, ns2) -> Id.equal i1 i2 && ns1 = ns2 - | Applied_to p1, Applied_to p2 -> equal p1 p2 - | _, _ -> false - -let rewrite_head ~new_prefix p = new_prefix @ p - -let strip_stamps = - List.map ~f:(function - | Ident (Id i, ns) -> Ident (String (Ident.name i), ns) - | elt -> elt - ) - -let empty = [] - -let rec subst_prefix ~old_prefix ~new_prefix p = - match old_prefix, p with - | [], _ -> Some (new_prefix @ p) - | op1 :: ops, elt1 :: p when equal_elt op1 elt1 -> - subst_prefix ~old_prefix:ops ~new_prefix p - | _ -> None diff --git a/src/analysis/namespaced_path.mli b/src/analysis/namespaced_path.mli deleted file mode 100644 index 4e4a75cec2..0000000000 --- a/src/analysis/namespaced_path.mli +++ /dev/null @@ -1,49 +0,0 @@ -module Namespace : sig - type t = [ - | `Vals - | `Type - | `Constr - | `Mod - | `Modtype - | `Functor - | `Labels - | `Unknown - | `Apply - ] - - val to_string : t -> string -end - -module Id : sig - type t = private - | Id of Ident.t - | String of string - - val name : t -> string -end - -type t (* = private elt list *) -and elt = private - | Ident of Id.t * Namespace.t - | Applied_to of t - -val to_string : t -> string -val to_unique_string : t -> string - -val head : t -> elt option -val head_exn : t -> elt - -val peal_head : t -> t option -val peal_head_exn : t -> t - -val equal : t -> t -> bool - -val rewrite_head : new_prefix:t -> t -> t - -val strip_stamps : t -> t - -val of_path : namespace:Namespace.t -> Path.t -> t - -val empty : t - -val subst_prefix : old_prefix:t -> new_prefix:t -> t -> t option diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml new file mode 100644 index 0000000000..ad73e6077b --- /dev/null +++ b/src/analysis/occurrences.ml @@ -0,0 +1,289 @@ +open Std +module LidSet = Index_format.LidSet + +let {Logger. log} = Logger.for_section "occurrences" + +let set_fname ~file (loc : Location.t) = + let pos_fname = file in + { loc with + loc_start = { loc.loc_start with pos_fname }; + loc_end = { loc.loc_end with pos_fname }} + +let decl_of_path_or_lid env namespace path lid = + match (namespace : Shape.Sig_component_kind.t) with + | Constructor -> + begin match Env.find_constructor_by_name lid env with + | exception Not_found -> None + | {cstr_uid; cstr_loc; _ } -> + Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace } + end + | Label -> + begin match Env.find_label_by_name lid env with + | exception Not_found -> None + | {lbl_uid; lbl_loc; _ } -> + Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace } + end + | _ -> Env_lookup.loc path namespace env + +let index_buffer ~scope ~current_buffer_path ~local_defs () = + let {Logger. log} = Logger.for_section "index" in + let defs = Hashtbl.create 64 in + let module Shape_reduce = + Shape_reduce.Make (struct + let fuel = 10 + + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + let cmt = Format.sprintf "%s.cmt" unit_name in + match Cmt_format.read (Load_path.find_uncap cmt) with + | _, Some cmt_infos -> + log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; + cmt_infos.cmt_impl_shape + | exception _ | _ -> + log ~title:"read_unit_shape" "failed to find %s" unit_name; + None + end) + in + let f ~namespace env path (lid : Longident.t Location.loc) = + log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path); + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in + let index_decl () = + begin match decl_of_path_or_lid env namespace path lid.txt with + | exception _ | None -> log ~title:"index_buffer" "Declaration not found" + | Some decl -> + log ~title:"index_buffer" "Found declaration: %a" + Logger.fmt (Fun.flip Location.print_loc decl.loc); + Index_format.(add defs decl.uid (LidSet.singleton lid)) + end + in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | path_shape -> + log ~title:"index_buffer" "Shape of path: %a" + Logger.fmt (Fun.flip Shape.print path_shape); + begin match Shape_reduce.reduce_for_uid env path_shape with + | Internal_error_missing_uid -> + log ~title:"index_buffer" "Reduction failed: missing uid"; + index_decl () + | Resolved_alias l -> + let uid = Locate.uid_of_aliases ~traverse_aliases:false l in + Index_format.(add defs uid (LidSet.singleton lid)) + | Resolved uid -> + log ~title:"index_buffer" "Found %s (%a) wiht uid %a" + (Longident.head lid.txt) + Logger.fmt (Fun.flip Location.print_loc lid.loc) + Logger.fmt (Fun.flip Shape.Uid.print uid); + Index_format.(add defs uid (LidSet.singleton lid)) + | Approximated s -> + log ~title:"index_buffer" "Shape is approximative, found uid: %a" + Logger.fmt (Fun.flip (Format.pp_print_option Shape.Uid.print) s); + index_decl () + | Unresolved s -> + log ~title:"index_buffer" "Shape unresolved, stuck on: %a" + Logger.fmt (Fun.flip Shape.print s); + index_decl () + end + in + let f ~namespace env path (lid : Longident.t Location.loc) = + (* The compiler lacks sufficient location information to precisely hihglight + modules in paths. This function hacks around that issue when looking for + occurrences in the current buffer only. *) + let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) = + let () = f ~namespace env path lid in + if scope = `Buffer then + match path, txt with + | Pdot (path, _), Ldot (lid, s) -> + let length_with_dot = String.length s + 1 in + let lid = + { Location.txt = lid; loc = { loc with loc_end = {loc.loc_end with + pos_cnum = loc.loc_end.pos_cnum - length_with_dot}} } + in + iter_on_path ~namespace:Module path lid + | Papply _, _ -> () + | _, _ -> () + in + iter_on_path ~namespace path lid + in + Ast_iterators.iter_on_usages ~f local_defs; + defs + +let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl + +(* A longident can have the form: A.B.x Right now we are only interested in + values, but we will eventually want to index all occurrences of modules in + such longidents. However there is an issue with that: we only have the + location of the complete longident which might span multiple lines. This is + enough to get the last component since it will always be on the last line, + but will prevent us to find the location of previous components. *) +let last_loc (loc : Location.t) lid = + if lid = Longident.Lident "*unknown*" then loc + else + let last_size = Longident.last lid |> String.length in + { loc with + loc_start = { loc.loc_end with + pos_cnum = loc.loc_end.pos_cnum - last_size; + } + } + +let uid_and_loc_of_node env node = + let open Browse_raw in + log ~title:"occurrences" "Looking for uid of node %s" + @@ string_of_node node; + match node with + | Module_binding_name { mb_id = Some ident; mb_name; _ } -> + let md = Env.find_module (Pident ident) env in + Some (md.md_uid, mb_name.loc) + | Pattern { pat_desc = + Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid); _ } -> + Some (uid, name.loc) + | Type_declaration { typ_type; typ_name; _ } -> + Some (typ_type.type_uid, typ_name.loc) + | Label_declaration { ld_uid; ld_loc ; _ } -> + Some (ld_uid, ld_loc) + | Constructor_declaration { cd_uid; cd_loc ; _ } -> + Some (cd_uid, cd_loc) + | Value_description { val_val; val_name; _ } -> + Some (val_val.val_uid, val_name.loc) + | _ -> None + +let loc_of_local_def ~local_defs uid = + (* WIP *) + (* todo: cache or specialize ? *) + let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t = + Types.Uid.Tbl.create 64 + in + match local_defs with + | `Interface _ -> failwith "not implemented" + | `Implementation str -> + let iter = Ast_iterators.iter_on_defs ~uid_to_locs_tbl in + iter.structure iter str; + (* todo: optimize, the iterator could be more flexible *) + (* we could check equality and raise with the result as soon that it arrive *) + Shape.Uid.Tbl.find uid_to_locs_tbl uid + +let comp_unit_of_uid = function + | Shape.Uid.Compilation_unit comp_unit + | Item { comp_unit; _ } -> Some comp_unit + | Internal | Predef _ -> None + +let check Index_format.{ stats; _ } file = + let open Index_format in + match Stats.find_opt file stats with + | None -> log ~title:"stat_check" "No mtime found for file %S." file; true + | Some { size; _ } -> + try + let stats = Unix.stat file in + let equal = + (* This is fast but approximative. A better option would be to check + [mtime] and then [source_digest] if the times differ. *) + Int.equal stats.st_size size + in + log ~title:"stat_check" + "File %s has been modified since the index was built." file; + equal + with Unix.Unix_error _ -> false + +let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path = + log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" + path + (Lexing.print_position () pos); + let locate_result = + Locate.from_string + ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} + ~env ~local_defs ~pos path + in + (* When we fail to find an exact definition we restrict the scope to the local + buffer *) + let def, scope = + match locate_result with + | `At_origin -> + log ~title:"locs_of" "Cursor is on definition / declaration"; + (* We are on a definition / declaration so we look for the node's uid *) + (* todo: refactor *) + let browse = Mbrowse.of_typedtree local_defs in + let node = Mbrowse.enclosing pos [browse] in + let env, node = Mbrowse.leaf_node node in + uid_and_loc_of_node env node, scope + | `Found { uid; location; approximated = false; _ } -> + log ~title:"locs_of" "Found definition uid using locate: %a " + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + Some (uid, location), scope + | `Found { decl_uid; location; approximated = true; _ } -> + log ~title:"locs_of" "Approx: %a " + Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); + Some (decl_uid, location), `Buffer + | `Builtin (uid, s) -> + log ~title:"locs_of" "Locate found a builtin: %s" s; + Some (uid, Location.none), scope + | _ -> + log ~title:"locs_of" "Locate failed to find a definition."; + None, `Buffer + in + let current_buffer_path = + Filename.concat config.query.directory config.query.filename + in + match def with + | Some (def_uid, def_loc) -> + log ~title:"locs_of" "Definition has uid %a (%a)" + Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid) + Logger.fmt (fun fmt -> Location.print_loc fmt def_loc); + log ~title:"locs_of" "Indexing current buffer"; + let buffer_index = + index_buffer ~scope ~current_buffer_path ~local_defs () + in + let buffer_locs = Hashtbl.find_opt buffer_index def_uid in + let external_locs, desync = + if scope = `Buffer then None, false else begin + let exception File_changed in + let open Option.Infix in + try + let locs = config.merlin.index_file >>= fun file -> + let external_index = Index_format.read_exn ~file in + Hashtbl.find_opt external_index.defs def_uid + >>| fun locs -> LidSet.filter (fun {loc; _} -> + (* We ignore external results that concern the current buffer *) + let fname = loc.Location.loc_start.Lexing.pos_fname in + (* We ignore external results if the index is not up-to-date *) + (* We could return partial results from up-to-date file *) + if String.equal fname current_buffer_path then false + else begin + if not (check external_index fname) then raise File_changed; + true + end) locs + in + locs, false + with File_changed -> None, true + end + in + if desync then log ~title:"locs_of" "External index might be out-of-sync."; + let locs = match buffer_locs, external_locs with + | None, None -> LidSet.empty + | Some locs, None | None, Some locs -> locs + | Some b_locs, Some e_locs -> LidSet.union b_locs e_locs + in + let locs = + log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); + LidSet.elements locs + |> List.filter_map ~f:(fun {Location.txt; loc} -> + log ~title:"occurrences" "Found occ: %s %a" + (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); + let loc = last_loc loc txt in + let fname = loc.Location.loc_start.Lexing.pos_fname in + if Filename.is_relative fname then begin + match Locate.find_source ~config loc fname with + | `Found (file, _) -> Some (set_fname ~file loc) + | `File_not_found msg -> + log ~title:"occurrences" "%s" msg; + None + end else Some loc) + in + let def_uid_is_in_current_unit = + let uid_comp_unit = comp_unit_of_uid def_uid in + Option.value_map ~default:false uid_comp_unit + ~f:(String.equal @@ Env.get_unit_name ()) + in + if not def_uid_is_in_current_unit then Ok (locs, desync) + else Ok (set_fname ~file:current_buffer_path def_loc :: locs, desync) + | None -> Error "nouid" diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml index ed179236ca..54a64a0e71 100644 --- a/src/analysis/outline.ml +++ b/src/analysis/outline.ml @@ -36,7 +36,7 @@ open Browse_raw open Browse_tree let id_of_patt = function - | { pat_desc = Tpat_var (id, _) ; _ } -> Some id + | { pat_desc = Tpat_var (id, _, _) ; _ } -> Some id | _ -> None let mk ?(children=[]) ~location ~deprecated outline_kind outline_type id = diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e3a1aaba00..3ac4df2077 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -90,6 +90,10 @@ module Cache = File_cache.Make (struct recurse := true else if String.is_prefixed ~by:". " line then includes := String.trim (String.drop 2 line) :: !includes + else if String.is_prefixed ~by:"INDEX_FILE " line then + tell (`INDEX_FILE (String.drop 11 line)) + else if String.is_prefixed ~by:"UNIT_NAME " line then + tell (`UNIT_NAME (String.drop 10 line)) else if String.is_prefixed ~by:"STDLIB " line then tell (`STDLIB (String.drop 7 line)) else if String.is_prefixed ~by:"FINDLIB " line then @@ -305,6 +309,8 @@ type config = { pass_forward : Merlin_dot_protocol.Directive.no_processing_required list; to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list; stdlib : string option; + index_file : string option; + unit_name : string option; packages_to_load : string list; findlib : string option; findlib_path : string list; @@ -315,6 +321,8 @@ let empty_config = { pass_forward = []; to_canonicalize = []; stdlib = None; + index_file = None; + unit_name = None; packages_to_load = []; findlib = None; findlib_path = []; @@ -326,7 +334,7 @@ let prepend_config ~cwd ~cfg = match d with | `B _ | `S _ | `CMI _ | `CMT _ as directive -> { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } - | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ + | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ | `UNIT_NAME _ | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive -> { cfg with pass_forward = directive :: cfg.pass_forward } | `PKG ps -> @@ -339,6 +347,9 @@ let prepend_config ~cwd ~cfg = log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path end; { cfg with stdlib = Some canon_path } + | `INDEX_FILE path -> + let canon_path = canonicalize_filename ~cwd path in + { cfg with pass_forward = `INDEX_FILE canon_path :: cfg.pass_forward } | `FINDLIB path -> let canon_path = canonicalize_filename ~cwd path in begin match cfg.stdlib with diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 97648d9317..ed6466a40c 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -37,6 +37,8 @@ module Directive = struct [ `EXT of string list | `FLG of string list | `STDLIB of string + | `INDEX_FILE of string + | `UNIT_NAME of string | `SUFFIX of string | `READER of string list | `EXCLUDE_QUERY_DIR @@ -85,6 +87,8 @@ module Sexp = struct | "CMI" -> `CMI value | "CMT" -> `CMT value | "STDLIB" -> `STDLIB value + | "INDEX_FILE" -> `INDEX_FILE value + | "UNIT_NAME" -> `UNIT_NAME value | "SUFFIX" -> `SUFFIX value | "ERROR" -> `ERROR_MSG value | "FLG" -> @@ -117,6 +121,8 @@ module Sexp = struct | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ]) | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ]) | `STDLIB s -> ("STDLIB", single s) + | `INDEX_FILE s -> ("INDEX_FILE", single s) + | `UNIT_NAME s -> ("UNIT_NAME", single s) | `SUFFIX s -> ("SUFFIX", single s) | `READER ss -> ("READER", [ List (atoms_of_strings ss) ]) | `EXCLUDE_QUERY_DIR -> ("EXCLUDE_QUERY_DIR", []) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index c238b813ae..ffb744380b 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -49,6 +49,8 @@ module Directive : sig [ `EXT of string list | `FLG of string list | `STDLIB of string + | `INDEX_FILE of string + | `UNIT_NAME of string | `SUFFIX of string | `READER of string list | `EXCLUDE_QUERY_DIR diff --git a/src/frontend/ocamlmerlin/query_json.ml b/src/frontend/ocamlmerlin/query_json.ml index 3332370642..3b97d1f6df 100644 --- a/src/frontend/ocamlmerlin/query_json.ml +++ b/src/frontend/ocamlmerlin/query_json.ml @@ -422,7 +422,7 @@ let json_of_response (type a) (query : a t) (response : a) : json = | Findlib_list, strs -> `List (List.map ~f:Json.string strs) | Extension_list _, strs -> `List (List.map ~f:Json.string strs) | Path_list _, strs -> `List (List.map ~f:Json.string strs) - | Occurrences (_, scope), locations -> + | Occurrences (_, scope), (locations, _desync) -> let with_file = scope = `Project in `List (List.map locations ~f:(fun loc -> with_location ~with_file loc [])) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 7894247861..91d0dae284 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -362,7 +362,8 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Locate_type pos -> let typer = Mpipeline.typer_result pipeline in - let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in + let local_defs = Mtyper.get_typedtree typer in + let structures = Mbrowse.of_typedtree local_defs in let pos = Mpipeline.get_lexing_pos pipeline pos in let node = match Mbrowse.enclosing pos [structures] with @@ -388,15 +389,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | None -> `Invalid_context | Some (env, path) -> Locate.log ~title:"debug" "found type: %s" (Path.name path); + let config = Locate.{ + mconfig = Mpipeline.final_config pipeline; + ml_or_mli = `MLI; + traverse_aliases = true + } + in match Locate.from_path + ~config ~env - ~config:(Mpipeline.final_config pipeline) - ~namespace:`Type `MLI + ~local_defs + ~namespace:Type path with - | `Builtin -> `Builtin (Path.name path) + | `Builtin (_, s) -> `Builtin s | `Not_in_env _ as s -> s | `Not_found _ as s -> s - | `Found (_uid, file, pos) -> `Found (file, pos) + | `Found { file; location; _ } -> `Found (Some file, location.loc_start) | `File_not_found _ as s -> s end @@ -520,19 +528,24 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in if path = "" then `Invalid_context else - begin match - Locate.from_string - ~config:(Mpipeline.final_config pipeline) - ~env ~local_defs ~pos ml_or_mli path - with - | `Found (_, file, pos) -> + let config = Locate.{ + mconfig = Mpipeline.final_config pipeline; + ml_or_mli; + traverse_aliases = true + } + in + begin match Locate.from_string ~config ~env ~local_defs ~pos path with + | `Found { file; location; _ } -> Locate.log ~title:"result" - "found: %s" (Option.value ~default:"" file); - `Found (file, pos) + "found: %s" file; + `Found (Some file, location.loc_start) | `Missing_labels_namespace -> (* Can't happen because we haven't passed a namespace as input. *) assert false - | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _|`Builtin _) as + | `Builtin (_, s) -> + Locate.log ~title:"result" "found builtin %s" s; + `Builtin s + | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _) as otherwise -> Locate.log ~title:"result" "not found"; otherwise @@ -782,62 +795,27 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let config = Mpipeline.final_config pipeline in Mconfig.(config.merlin.source_path) - | Occurrences (`Ident_at pos, _scope) -> + | Occurrences (`Ident_at pos, scope) -> + let config = Mpipeline.final_config pipeline in let typer = Mpipeline.typer_result pipeline in - let str = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in + let local_defs = Mtyper.get_typedtree typer in let pos = Mpipeline.get_lexing_pos pipeline pos in - let enclosing = Mbrowse.enclosing pos [str] in - let curr_node = - let is_wildcard_pat = function - | Browse_raw.Pattern {pat_desc = Typedtree.Tpat_any; _} -> true - | _ -> false - in - List.find_some enclosing ~f:(fun (_, node) -> - (* it doesn't make sense to find occurrences of a wildcard pattern *) - not (is_wildcard_pat node)) - |> Option.map ~f:(fun (env, node) -> Browse_tree.of_node ~env node) - |> Option.value ~default:Browse_tree.dummy - in - let str = Browse_tree.of_browse str in - let get_loc {Location.txt = _; loc} = loc in - let ident_occurrence () = - let paths = Browse_raw.node_paths curr_node.Browse_tree.t_node in - let under_cursor p = Location_aux.compare_pos pos (get_loc p) = 0 in - Logger.log ~section:"occurrences" ~title:"Occurrences paths" "%a" - Logger.json (fun () -> - let dump_path ({Location.txt; loc} as p) = - let ppf, to_string = Format.to_string () in - Printtyp.path ppf txt; - `Assoc [ - "start", Lexing.json_of_position loc.Location.loc_start; - "end", Lexing.json_of_position loc.Location.loc_end; - "under_cursor", `Bool (under_cursor p); - "path", `String (to_string ()) - ] - in - `List (List.map ~f:dump_path paths)); - match List.filter paths ~f:under_cursor with - | [] -> [] - | (path :: _) -> - let path = path.Location.txt in - let ts = Browse_tree.all_occurrences path str in - let loc (_t,paths) = List.map ~f:get_loc paths in - List.concat_map ~f:loc ts - - in - let constructor_occurrence d = - let ts = Browse_tree.all_constructor_occurrences (curr_node,d) str in - List.map ~f:get_loc ts - + let env, node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in + let path = + let path = reconstruct_identifier pipeline pos None in + let path = Mreader_lexer.identifier_suffix path in + let path = List.map ~f:(fun {Location. txt; _} -> txt) path in + let path = String.concat ~sep:"." path in + Locate.log ~title:"reconstructed identifier" "%s" path; + path in - let locs = - match Browse_raw.node_is_constructor curr_node.Browse_tree.t_node with - | Some d -> constructor_occurrence d.Location.txt - | None -> ident_occurrence () + let locs, desync = + Occurrences.locs_of ~config ~scope ~env ~local_defs ~node ~pos path + |> Result.value ~default:([], false) in let loc_start l = l.Location.loc_start in let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in - List.sort ~cmp locs + (List.sort ~cmp locs), desync | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 38552f486f..ad2296f840 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -195,6 +195,6 @@ type _ t = -> string list t | Occurrences(* *) : [`Ident_at of Msource.position] * [`Project | `Buffer] - -> Location.t list t + -> (Location.t list * bool) t | Version : string t diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 93ef775227..996e383227 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -77,6 +77,8 @@ type merlin = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + index_file : string option; + unit_name : string option; reader : string list; protocol : [`Json | `Sexp]; log_file : string option; @@ -115,6 +117,8 @@ let dump_merlin x = ]) x.suffixes ); "stdlib" , Json.option Json.string x.stdlib; + "index_file" , Json.option Json.string x.index_file; + "unit_name" , Json.option Json.string x.unit_name; "reader" , `List (List.map ~f:Json.string x.reader); "protocol" , (match x.protocol with | `Json -> `String "json" @@ -251,6 +255,8 @@ let get_external_config path t = extensions = dot.extensions @ merlin.extensions; suffixes = dot.suffixes @ merlin.suffixes; stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib); + index_file = dot.index_file; + unit_name = dot.unit_name; reader = if dot.reader = [] then merlin.reader @@ -623,6 +629,8 @@ let initial = { extensions = []; suffixes = [(".ml", ".mli"); (".re", ".rei")]; stdlib = None; + index_file = None; + unit_name = None; reader = []; protocol = `Json; log_file = None; @@ -795,4 +803,7 @@ let global_modules ?(include_current=false) config = ( let filename t = t.query.filename -let unitname t = Misc.unitname t.query.filename +let unitname t = + match t.merlin.unit_name with + | None -> Misc.unitname t.query.filename + | Some unit_name -> String.capitalize_ascii unit_name diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index e219f4b4fe..22f65d6479 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -35,6 +35,8 @@ type merlin = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + index_file : string option; + unit_name : string option; reader : string list; protocol : [`Json | `Sexp]; log_file : string option; @@ -57,7 +59,7 @@ val dump_merlin : merlin -> json (** {1 Some flags affecting queries} *) -module Verbosity : sig +module Verbosity : sig type t = Smart | Lvl of int (** the default value for verbosity, i.e., [Lvl 0] *) diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index 13ad8eba99..6e3df99352 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -41,6 +41,8 @@ type config = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + index_file : string option; + unit_name : string option; reader : string list; exclude_query_dir : bool; use_ppx_cache : bool; @@ -55,6 +57,8 @@ let empty_config = { suffixes = []; flags = []; stdlib = None; + index_file = None; + unit_name = None; reader = []; exclude_query_dir = false; use_ppx_cache = false; @@ -246,6 +250,10 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config = {config with flags = flags :: config.flags}, errors | `STDLIB path -> {config with stdlib = Some path}, errors + | `INDEX_FILE path -> + {config with index_file = Some path}, errors + | `UNIT_NAME unit_name -> + {config with unit_name = Some unit_name}, errors | `READER reader -> {config with reader}, errors | `EXCLUDE_QUERY_DIR -> @@ -273,8 +281,10 @@ let postprocess_config config = extensions = clean config.extensions; suffixes = clean config.suffixes; flags = clean config.flags; - stdlib = config.stdlib; - reader = config.reader; + stdlib = config.stdlib; + index_file = config.index_file; + unit_name = config.unit_name; + reader = config.reader; exclude_query_dir = config.exclude_query_dir; use_ppx_cache = config.use_ppx_cache; } diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 7e1ad9a1e3..aa9fc4c7d9 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -37,6 +37,8 @@ type config = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + index_file : string option; + unit_name : string option; reader : string list; exclude_query_dir : bool; use_ppx_cache : bool; diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 034cb10c7d..593fa7335b 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -8,6 +8,7 @@ type ('p,'t) item = { typedtree_items: 't list * Types.signature_item list; part_snapshot : Types.snapshot; part_stamp : int; + part_uid : int; part_env : Env.t; part_errors : exn list; part_checks : Typecore.delayed_check list; @@ -28,15 +29,16 @@ let fresh_env config = let env0 = Extension.register Mconfig.(config.merlin.extensions) env0 in let snap0 = Btype.snapshot () in let stamp0 = Ident.get_currentstamp () in - (env0, snap0, stamp0) + let uid0 = Shape.Uid.get_current_stamp () in + (env0, snap0, stamp0, uid0) let get_cache config = match !cache with - | Some (env0, snap0, stamp0, items, _) when Types.is_valid snap0 -> - env0, snap0, stamp0, Some items + | Some (env0, snap0, stamp0, uid0, items, _) when Types.is_valid snap0 -> + env0, snap0, stamp0, uid0, Some items | Some _ | None -> - let env0, snap0, stamp0 = fresh_env config in - env0, snap0, stamp0, None + let env0, snap0, stamp0, uid0 = fresh_env config in + env0, snap0, stamp0, uid0, None let return_and_cache status = cache := Some status; @@ -47,6 +49,7 @@ type result = { initial_env : Env.t; initial_snapshot : Types.snapshot; initial_stamp : int; + initial_uid : int; typedtree : [ | `Interface of (Parsetree.signature_item, Typedtree.signature_item) item list @@ -87,6 +90,7 @@ let rec type_structure caught env = function parsetree_item; typedtree_items; part_env; part_snapshot = Btype.snapshot (); part_stamp = Ident.get_currentstamp (); + part_uid = Shape.Uid.get_current_stamp (); part_errors = !caught; part_checks = !Typecore.delayed_checks; part_warnings = Warnings.backup (); @@ -102,6 +106,7 @@ let rec type_signature caught env = function parsetree_item; typedtree_items = (sig_items, sig_type); part_env; part_snapshot = Btype.snapshot (); part_stamp = Ident.get_currentstamp (); + part_uid = Shape.Uid.get_current_stamp (); part_errors = !caught; part_checks = !Typecore.delayed_checks; part_warnings = Warnings.backup (); @@ -110,46 +115,52 @@ let rec type_signature caught env = function | [] -> [] let type_implementation config caught parsetree = - let env0, snap0, stamp0, prefix = get_cache config in + let env0, snap0, stamp0, uid0, prefix = get_cache config in let prefix, parsetree, cache_stat = match prefix with | Some (`Implementation items) -> compatible_prefix items parsetree | Some (`Interface _) | None -> ([], parsetree, Miss) in - let env', snap', stamp', warn' = match prefix with - | [] -> (env0, snap0, stamp0, Warnings.backup ()) + let env', snap', stamp', uid', warn' = match prefix with + | [] -> (env0, snap0, stamp0, uid0, Warnings.backup ()) | x :: _ -> caught := x.part_errors; Typecore.delayed_checks := x.part_checks; - (x.part_env, x.part_snapshot, x.part_stamp, x.part_warnings) + (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings) in Btype.backtrack snap'; Warnings.restore warn'; Env.cleanup_functor_caches ~stamp:stamp'; + Env.cleanup_usage_tables ~stamp:uid'; + Shape.Uid.restore_stamp uid'; let suffix = type_structure caught env' parsetree in return_and_cache - (env0, snap0, stamp0, `Implementation (List.rev_append prefix suffix), cache_stat) + (env0, snap0, stamp0, uid0, `Implementation (List.rev_append prefix suffix), + cache_stat) let type_interface config caught parsetree = - let env0, snap0, stamp0, prefix = get_cache config in + let env0, snap0, stamp0, uid0, prefix = get_cache config in let prefix, parsetree, cache_stat = match prefix with | Some (`Interface items) -> compatible_prefix items parsetree | Some (`Implementation _) | None -> ([], parsetree, Miss) in - let env', snap', stamp', warn' = match prefix with - | [] -> (env0, snap0, stamp0, Warnings.backup ()) + let env', snap', stamp', uid', warn' = match prefix with + | [] -> (env0, snap0, stamp0, uid0, Warnings.backup ()) | x :: _ -> caught := x.part_errors; Typecore.delayed_checks := x.part_checks; - (x.part_env, x.part_snapshot, x.part_stamp, x.part_warnings) + (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings) in Btype.backtrack snap'; Warnings.restore warn'; Env.cleanup_functor_caches ~stamp:stamp'; + Env.cleanup_usage_tables ~stamp:uid'; + Shape.Uid.restore_stamp uid'; let suffix = type_signature caught env' parsetree in return_and_cache - (env0, snap0, stamp0, `Interface (List.rev_append prefix suffix), cache_stat) + (env0, snap0, stamp0, uid0, `Interface (List.rev_append prefix suffix), + cache_stat) let run config parsetree = if not (Env.check_state_consistency ()) then ( @@ -164,12 +175,23 @@ let run config parsetree = let caught = ref [] in Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> Typecore.reset_delayed_checks (); - let initial_env, initial_snapshot, initial_stamp, typedtree, cache_stat = match parsetree with + let + initial_env, initial_snapshot, initial_stamp, initial_uid, typedtree, cache_stat + = + match parsetree with | `Implementation parsetree -> type_implementation config caught parsetree | `Interface parsetree -> type_interface config caught parsetree in Typecore.reset_delayed_checks (); - { config; initial_env; initial_snapshot; initial_stamp; typedtree; cache_stat } + { + config; + initial_env; + initial_snapshot; + initial_uid; + initial_stamp; + typedtree; + cache_stat; + } let get_env ?pos:_ t = Option.value ~default:t.initial_env ( diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 88caa4bed6..49ea56c4ec 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -299,7 +299,7 @@ let of_pat_record_field obj loc lbl = let of_pattern_desc (type k) (desc : k pattern_desc) = match desc with | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> id_fold - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p + | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p | Tpat_exception p -> of_pattern p | Tpat_value p -> of_pattern (p :> value general_pattern) | Tpat_tuple ps | Tpat_construct (_,_,ps,None) | Tpat_array ps -> @@ -368,7 +368,7 @@ let of_expression_desc loc = function | Texp_letmodule (mb_id, mb_name, mb_presence, mb_expr, e) -> let mb = {mb_id;mb_name;mb_expr;mb_loc=Location.none;mb_attributes=[] - ; mb_presence } + ; mb_presence; mb_uid=Shape.Uid.internal_not_actually_unique } in app (Module_binding mb) ** of_expression e | Texp_letexception (ec,e) -> @@ -778,9 +778,9 @@ let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } = match (pat_desc : k pattern_desc) with | Tpat_construct (lid_loc,{Types. cstr_name; cstr_res; _},_,_) -> fake_path lid_loc cstr_res cstr_name - | Tpat_var (id, {Location. loc; txt}) -> + | Tpat_var (id, {Location. loc; txt}, _) -> [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)] - | Tpat_alias (_,id,loc) -> + | Tpat_alias (_,id,loc, _) -> [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] | _ -> [] in diff --git a/src/ocaml/merlin_specific/tast_helper.ml b/src/ocaml/merlin_specific/tast_helper.ml index 1664fa1586..2ae85d8e58 100644 --- a/src/ocaml/merlin_specific/tast_helper.ml +++ b/src/ocaml/merlin_specific/tast_helper.ml @@ -14,7 +14,7 @@ module Pat = struct | None -> str.Asttypes.loc | Some loc -> loc in - let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str) in + let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str, Uid.internal_not_actually_unique) in { pat_desc; pat_loc; pat_extra; pat_attributes; pat_type; pat_env } let record ?(loc=Location.none) pat_env pat_type lst closed_flag = @@ -25,7 +25,7 @@ module Pat = struct let pat_desc = Tpat_tuple lst in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - let construct ?(loc=Location.none) + let construct ?(loc=Location.none) pat_env pat_type lid cstr_desc args locs_coretype = let pat_desc = Tpat_construct (lid, cstr_desc, args, locs_coretype) in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } diff --git a/src/ocaml/preprocess/lexer_ident.mll b/src/ocaml/preprocess/lexer_ident.mll index e9690dbd27..fd448d141c 100644 --- a/src/ocaml/preprocess/lexer_ident.mll +++ b/src/ocaml/preprocess/lexer_ident.mll @@ -91,6 +91,7 @@ rule token = parse { UIDENT ident } | "`" { BACKQUOTE } | "'" { QUOTE } + | "()" { LIDENT "()"} | "(" { LPAREN } | ")" { RPAREN } | "." { DOT } diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml index 49a629879f..5dacc789fc 100644 --- a/src/ocaml/typing/cmt_format.ml +++ b/src/ocaml/typing/cmt_format.ml @@ -76,21 +76,62 @@ type cmt_infos = { cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) -} + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list + } type error = Not_a_typedtree of string +let iter_on_parts (it : Tast_iterator.iterator) = function + | Partial_structure s -> it.structure it s + | Partial_structure_item s -> it.structure_item it s + | Partial_expression e -> it.expr it e + | Partial_pattern (_category, p) -> it.pat it p + | Partial_class_expr ce -> it.class_expr it ce + | Partial_signature s -> it.signature it s + | Partial_signature_item s -> it.signature_item it s + | Partial_module_type s -> it.module_type it s + +let iter_on_annots (it : Tast_iterator.iterator) = function + | Implementation s -> it.structure it s + | Interface s -> it.signature it s + | Packed _ -> () + | Partial_implementation array -> Array.iter (iter_on_parts it) array + | Partial_interface array -> Array.iter (iter_on_parts it) array + +let iter_on_declaration f decl = + match decl with + | Value vd -> f vd.val_val.val_uid decl; + | Value_binding vb -> + let bound_idents = let_bound_idents_full [vb] in + List.iter ~f:(fun (_, _, _, uid) -> f uid decl) bound_idents + | Type td -> + if not (Btype.is_row_name (Ident.name td.typ_id)) then + f td.typ_type.type_uid (Type td) + | Constructor cd -> f cd.cd_uid decl + | Extension_constructor ec -> f ec.ext_type.ext_uid decl; + | Label ld -> f ld.ld_uid decl + | Module md -> f md.md_uid decl + | Module_type mtd -> f mtd.mtd_uid decl + | Module_substitution ms -> f ms.ms_uid decl + | Module_binding mb -> f mb.mb_uid decl + | Class cd -> f cd.ci_decl.cty_uid decl + | Class_type ct -> f ct.ci_decl.cty_uid decl + +let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = { + Tast_iterator.default_iterator with + item_declaration = (fun _sub decl -> iter_on_declaration f decl); +} + let need_to_clear_env = try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false with Not_found -> true let keep_only_summary = Env.keep_only_summary -open Tast_mapper - let cenv = {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} @@ -119,6 +160,212 @@ let clear_env binary_annots = else binary_annots +(* Every typedtree node with a located longident corresponding to user-facing + syntax should be indexed. *) +let iter_on_occurrences + ~(f : namespace:Shape.Sig_component_kind.t -> + Env.t -> Path.t -> Longident.t Location.loc -> + unit) = + let path_in_type typ name = + match Types.get_desc typ with + | Tconstr (type_path, _, _) -> + Some (Path.Pdot (type_path, name)) + | _ -> None + in + let add_constructor_description env lid = + function + | { Types.cstr_tag = Cstr_extension (path, _); _ } -> + let namespace : Shape.Sig_component_kind.t = Extension_constructor in + f ~namespace env path lid + | { Types.cstr_uid = Predef name; _} -> + let id = List.assoc name Predef.builtin_idents in + f ~namespace:Constructor env (Pident id) lid + | { Types.cstr_res; cstr_name; _ } -> + let path = path_in_type cstr_res cstr_name in + Option.iter ~f:(fun path -> f ~namespace:Constructor env path lid) path + in + let add_label env lid { Types.lbl_name; lbl_res; _ } = + let path = path_in_type lbl_res lbl_name in + Option.iter ~f:(fun path -> f ~namespace:Label env path lid) path + in + let with_constraint ~env (_path, _lid, with_constraint) = + match with_constraint with + | Twith_module (path', lid') | Twith_modsubst (path', lid') -> + f ~namespace:Module env path' lid' + | _ -> () + in + Tast_iterator.{ default_iterator with + + expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> + (match exp_desc with + | Texp_ident (path, lid, _) -> + f ~namespace:Value exp_env path lid + | Texp_construct (lid, constr_desc, _) -> + add_constructor_description exp_env lid constr_desc + | Texp_field (_, lid, label_desc) + | Texp_setfield (_, lid, label_desc, _) -> + add_label exp_env lid label_desc + | Texp_new (path, lid, _) -> + f ~namespace:Class exp_env path lid + | Texp_record { fields; _ } -> + Array.iter (fun (label_descr, record_label_definition) -> + match record_label_definition with + | Overridden ( + { Location.txt; loc}, + {exp_loc; _}) + when not exp_loc.loc_ghost + && loc.loc_start = exp_loc.loc_start + && loc.loc_end = exp_loc.loc_end -> + (* In the presence of punning we want to index the label + even if it is ghosted *) + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in + add_label exp_env lid label_descr + | Overridden (lid, _) -> add_label exp_env lid label_descr + | Kept _ -> ()) fields + | Texp_instvar (_self_path, path, name) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_setinstvar (_self_path, path, name, _) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | _ -> ()); + default_iterator.expr sub e); + + typ = + (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> + (match ctyp_desc with + | Ttyp_constr (path, lid, _ctyps) -> + f ~namespace:Type ctyp_env path lid + | Ttyp_package {pack_path; pack_txt} -> + f ~namespace:Module_type ctyp_env pack_path pack_txt + | Ttyp_class (path, lid, _typs) -> + (* Deprecated syntax to extend a polymorphic variant *) + f ~namespace:Type ctyp_env path lid + | _ -> ()); + default_iterator.typ sub ct); + + pat = + (fun (type a) sub + ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> + (match pat_desc with + | Tpat_construct (lid, constr_desc, _, _) -> + add_constructor_description pat_env lid constr_desc + | Tpat_record (fields, _) -> + List.iter ~f:(fun (lid, label_descr, pat) -> + let lid = + let open Location in + (* In the presence of punning we want to index the label + even if it is ghosted *) + if (not pat.pat_loc.loc_ghost + && lid.loc.loc_start = pat.pat_loc.loc_start + && lid.loc.loc_end = pat.pat_loc.loc_end) + then {lid with loc = {lid.loc with loc_ghost = false}} + else lid + in + add_label pat_env lid label_descr) + fields + | _ -> ()); + List.iter ~f:(fun (pat_extra, _, _) -> + match pat_extra with + | Tpat_open (path, lid, _) -> + f ~namespace:Module pat_env path lid + | Tpat_type (path, lid) -> + f ~namespace:Type pat_env path lid + | Tpat_constraint _ | Tpat_unpack -> ()) + pat_extra; + default_iterator.pat sub pat); + + binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> + let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in + f ~namespace:Value bop_exp.exp_env bop_op_path lid; + default_iterator.binding_op sub bop); + + module_expr = + (fun sub ({ mod_desc; mod_env; _ } as me) -> + (match mod_desc with + | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid + | _ -> ()); + default_iterator.module_expr sub me); + + open_description = + (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> + f ~namespace:Module open_env path lid; + default_iterator.open_description sub od); + + module_type = + (fun sub ({ mty_desc; mty_env; _ } as mty) -> + (match mty_desc with + | Tmty_ident (path, lid) -> + f ~namespace:Module_type mty_env path lid + | Tmty_with (_mty, l) -> + List.iter ~f:(with_constraint ~env:mty_env) l + | Tmty_alias (path, lid) -> + f ~namespace:Module mty_env path lid + | _ -> ()); + default_iterator.module_type sub mty); + + class_expr = + (fun sub ({ cl_desc; cl_env; _} as ce) -> + (match cl_desc with + | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid + | _ -> ()); + default_iterator.class_expr sub ce); + + class_type = + (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> + (match cltyp_desc with + | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid + | _ -> ()); + default_iterator.class_type sub ct); + + signature_item = + (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> + (match sig_desc with + | Tsig_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor sig_env path lid + | Tsig_modsubst { ms_manifest; ms_txt } -> + f ~namespace:Module sig_env ms_manifest ms_txt + | Tsig_typext { tyext_path; tyext_txt } -> + f ~namespace:Type sig_env tyext_path tyext_txt + | _ -> ()); + default_iterator.signature_item sub sig_item); + + structure_item = + (fun sub ({ str_desc; str_env; _ } as str_item) -> + (match str_desc with + | Tstr_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor str_env path lid + | Tstr_typext { tyext_path; tyext_txt } -> + f ~namespace:Type str_env tyext_path tyext_txt + | _ -> ()); + default_iterator.structure_item sub str_item) +} + +let index_declarations binary_annots = + let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in + let f uid fragment = Types.Uid.Tbl.add index uid fragment in + iter_on_annots (iter_on_declarations ~f) binary_annots; + index + +let index_occurrences binary_annots = + let index : (Longident.t Location.loc * Shape_reduce.result) list ref = + ref [] + in + let f ~namespace env path lid = + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | path_shape -> + let result = Shape_reduce.local_reduce_for_uid env path_shape in + index := (lid, result) :: !index + in + iter_on_annots (iter_on_occurrences ~f) binary_annots; + !index + + exception Error of error let input_cmt ic = (input_value ic : cmt_infos) @@ -192,10 +439,18 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = | None -> None | Some cmi -> Some (output_cmi temp_file_name oc cmi) in + let cmt_ident_occurrences = + if !Clflags.store_occurrences then + index_occurrences binary_annots + else + [] + in + let cmt_annots = clear_env binary_annots in + let cmt_uid_to_decl = index_declarations cmt_annots in let source_digest = Option.map ~f:Digest.file sourcefile in let cmt = { cmt_modname = modname; - cmt_annots = clear_env binary_annots; + cmt_annots; cmt_value_dependencies = !value_deps; cmt_comments = []; cmt_args = Sys.argv; @@ -208,8 +463,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = cmt_imports = List.sort ~cmp:compare (Env.imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; - cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); + cmt_uid_to_decl; cmt_impl_shape = shape; + cmt_ident_occurrences; } in output_cmt oc cmt) end; diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli index 43e09f1236..7764b0d469 100644 --- a/src/ocaml/typing/cmt_format.mli +++ b/src/ocaml/typing/cmt_format.mli @@ -65,8 +65,10 @@ type cmt_infos = { cmt_imports : crcs; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list } type error = @@ -112,7 +114,6 @@ val set_saved_types : binary_part list -> unit val record_value_dependency: Types.value_description -> Types.value_description -> unit - (* val is_magic_number : string -> bool @@ -124,3 +125,15 @@ val record_value_dependency: val read_signature : 'a -> string -> Types.signature * 'b list * 'c list *) + +val iter_on_declarations : + f:(Types.Uid.t -> item_declaration -> unit) + -> Tast_iterator.iterator + +val iter_on_occurrences : + f:(namespace:Shape.Sig_component_kind.t -> + Env.t -> + Path.t -> + Longident.t Location.loc -> + unit) + -> Tast_iterator.iterator diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index 823da2ad43..997213e2f8 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -28,7 +28,7 @@ module String = Misc.String let add_delayed_check_forward = ref (fun _ -> assert false) -type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t +type 'a usage_tbl = (Uid.t, ('a -> unit)) Stamped_hashtable.t (** This table is used to track usage of value declarations. A declaration is identified by its uid. The callback attached to a declaration is called whenever the value (or @@ -36,16 +36,30 @@ type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t (inclusion test between signatures, cf Includemod.value_descriptions, ...). *) -let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 -let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 -let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let local_stamped n : Stamped_hashtable.changelog * ('a usage_tbl) = + let changelog = Stamped_hashtable.create_changelog () in + changelog, Stamped_hashtable.create changelog n -let uid_to_loc : Location.t Types.Uid.Tbl.t ref = - s_table Types.Uid.Tbl.create 16 +let stamped_value_declarations = s_table local_stamped 32 +let value_declarations_changelog, value_declarations = !stamped_value_declarations -let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc +let stamped_type_declarations = s_table local_stamped 32 +let type_declarations_changelog, type_declarations = !stamped_type_declarations -let get_uid_to_loc_tbl () = !uid_to_loc +let stamped_module_declarations = s_table local_stamped 32 +let module_declarations_changelog, module_declarations = !stamped_module_declarations + +(* let prune_usage_tables ~stamp = + (* We remove *) + let prune tbl = + Types.Uid.Tbl.filter_map_inplace + (fun uid value -> + if Shape.Uid.is_more_recent ~stamp uid then None else Some value) + tbl + in + prune !value_declarations; + prune !type_declarations; + prune !module_declarations *) type constructor_usage = Positive | Pattern | Exported_private | Exported type constructor_usages = @@ -81,8 +95,8 @@ let constructor_usage_complaint ~rebind priv cu | false, false, true -> Some Only_exported_private end -let used_constructors : constructor_usage usage_tbl ref = - s_table Types.Uid.Tbl.create 16 +let stamped_used_constructors = s_table local_stamped 32 +let used_constructors_changelog, used_constructors = !stamped_used_constructors type label_usage = Projection | Mutation | Construct | Exported_private | Exported @@ -131,8 +145,8 @@ let label_usage_complaint priv mut lu | true, false, _ -> Some Not_mutated end -let used_labels : label_usage usage_tbl ref = - s_table Types.Uid.Tbl.create 16 +let stamped_used_labels = s_table local_stamped 32 +let used_labels_changelog, used_labels = !stamped_used_labels (** Map indexed by the name of module components. *) module NameMap = String.Map @@ -499,7 +513,7 @@ let in_signature_flag = 0x01 let stamped_changelog = s_table Stamped_hashtable.create_changelog () -let stamped_add table path value = +let stamped_path_add table path value = let rec path_stamp = function | Pident id -> Ident.stamp id | Pdot (t, _) -> path_stamp t @@ -509,11 +523,15 @@ let stamped_add table path value = let stamp = if stamp = 0 then None else Some stamp in Stamped_hashtable.add table ?stamp path value -let stamped_mem table path = - Stamped_hashtable.mem table path +let stamped_uid_add table uid value = + let stamp = Types.Uid.stamp_of_uid uid in + Stamped_hashtable.add table ?stamp uid value -let stamped_find table path = - Stamped_hashtable.find table path +let stamped_mem table value = + Stamped_hashtable.mem table value + +let stamped_find table value = + Stamped_hashtable.find table value let stamped_create n = Stamped_hashtable.create !stamped_changelog n @@ -990,12 +1008,11 @@ let register_import_as_opaque modname = Persistent_env.register_import_as_opaque !persistent_env modname let reset_declaration_caches () = - Types.Uid.Tbl.clear !value_declarations; - Types.Uid.Tbl.clear !type_declarations; - Types.Uid.Tbl.clear !module_declarations; - Types.Uid.Tbl.clear !used_constructors; - Types.Uid.Tbl.clear !used_labels; - Types.Uid.Tbl.clear !uid_to_loc; + Stamped_hashtable.clear value_declarations; + Stamped_hashtable.clear type_declarations; + Stamped_hashtable.clear module_declarations; + Stamped_hashtable.clear used_constructors; + Stamped_hashtable.clear used_labels; () let reset_cache () = @@ -1042,7 +1059,7 @@ let modtype_of_functor_appl fcomp p1 p2 = in Subst.modtype (Rescope scope) subst mty in - stamped_add fcomp.fcomp_subst_cache p2 mty; + stamped_path_add fcomp.fcomp_subst_cache p2 mty; mty let check_functor_appl @@ -1312,6 +1329,10 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = match ns with | Type -> (IdTbl.find_same id env.types).tda_shape + | Constructor -> + Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) + | Label -> + Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) | Extension_constructor -> (TycompTbl.find_same id env.constrs).cda_shape | Value -> @@ -1987,9 +2008,9 @@ and check_usage loc id uid warn tbl = Warnings.is_active (warn "") then begin let name = Ident.name id in - if Types.Uid.Tbl.mem tbl uid then () + if stamped_mem tbl uid then () else let used = ref false in - Types.Uid.Tbl.add tbl uid (fun () -> used := true); + stamped_uid_add tbl uid (fun () -> used := true); if not (name = "" || name.[0] = '_' || name.[0] = '#') then !add_delayed_check_forward @@ -2009,7 +2030,7 @@ and check_value_name name loc = and store_value ?check id addr decl shape env = check_value_name (Ident.name id) decl.val_loc; Option.iter - (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) + (fun f -> check_usage decl.val_loc id decl.val_uid f value_declarations) check; let vda = { vda_description = decl; @@ -2029,9 +2050,9 @@ and store_constructor ~check type_decl type_id cstr_id cstr env = let loc = cstr.cstr_loc in let k = cstr.cstr_uid in let priv = type_decl.type_private in - if not (Types.Uid.Tbl.mem !used_constructors k) then begin + if not (stamped_mem used_constructors k) then begin let used = constructor_usages () in - Types.Uid.Tbl.add !used_constructors k + stamped_uid_add used_constructors k (add_constructor_usage used); if not (ty_name = "" || ty_name.[0] = '_') then @@ -2062,9 +2083,9 @@ and store_label ~check type_decl type_id lbl_id lbl env = let loc = lbl.lbl_loc in let mut = lbl.lbl_mut in let k = lbl.lbl_uid in - if not (Types.Uid.Tbl.mem !used_labels k) then + if not (stamped_mem used_labels k) then let used = label_usages () in - Types.Uid.Tbl.add !used_labels k + stamped_uid_add used_labels k (add_label_usage used); if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_') then !add_delayed_check_forward @@ -2085,7 +2106,7 @@ and store_type ~check ~long_path ~predef id info shape env = if check then check_usage loc id info.type_uid (fun s -> Warnings.Unused_type_declaration s) - !type_declarations; + type_declarations; let descrs, env = let path = Pident id in match info.type_kind with @@ -2155,9 +2176,9 @@ and store_extension ~check ~rebind id addr ext shape env = let is_exception = Path.same ext.ext_type_path Predef.path_exn in let name = cstr.cstr_name in let k = cstr.cstr_uid in - if not (Types.Uid.Tbl.mem !used_constructors k) then begin + if not (stamped_mem used_constructors k) then begin let used = constructor_usages () in - Types.Uid.Tbl.add !used_constructors k + stamped_uid_add used_constructors k (add_constructor_usage used); !add_delayed_check_forward (fun () -> @@ -2179,7 +2200,7 @@ and store_module ?(update_summary=true) ~check let open Subst.Lazy in let loc = md.mdl_loc in Option.iter - (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + (fun f -> check_usage loc id md.mdl_uid f module_declarations) check; let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in let comps = components_of_module ~alerts ~uid:md.mdl_uid @@ -2261,7 +2282,7 @@ let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env = (*???*) env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape in - stamped_add f_comp.fcomp_cache arg comps; + stamped_path_add f_comp.fcomp_cache arg comps; comps (* Define forward functions *) @@ -2453,8 +2474,6 @@ let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env let add_value = add_value ?shape:None -let add_type = add_type ?shape:None -let add_extension = add_extension ?shape:None let add_class = add_class ?shape:None let add_cltype = add_cltype ?shape:None let add_modtype = add_modtype ?shape:None @@ -2709,28 +2728,28 @@ let (initial_safe_string, initial_unsafe_string) = (add_extension ~check:false ~rebind:false) empty -let add_type_long_path ~check id info env = - add_type ~check ~predef:false ~long_path:true id info env +let add_type_long_path ~check ?shape id info env = + add_type ~check ?shape ~predef:false ~long_path:true id info env -let add_type ~check id info env = - add_type ~check ~predef:false ~long_path:false id info env +let add_type ~check ?shape id info env = + add_type ~check ?shape ~predef:false ~long_path:false id info env (* Tracking usage *) let mark_module_used uid = - match Types.Uid.Tbl.find !module_declarations uid with + match Stamped_hashtable.find module_declarations uid with | mark -> mark () | exception Not_found -> () let mark_modtype_used _uid = () let mark_value_used uid = - match Types.Uid.Tbl.find !value_declarations uid with + match Stamped_hashtable.find value_declarations uid with | mark -> mark () | exception Not_found -> () let mark_type_used uid = - match Types.Uid.Tbl.find !type_declarations uid with + match Stamped_hashtable.find type_declarations uid with | mark -> mark () | exception Not_found -> () @@ -2740,24 +2759,24 @@ let mark_type_path_used env path = | exception Not_found -> () let mark_constructor_used usage cd = - match Types.Uid.Tbl.find !used_constructors cd.cd_uid with + match stamped_find used_constructors cd.cd_uid with | mark -> mark usage | exception Not_found -> () let mark_extension_used usage ext = - match Types.Uid.Tbl.find !used_constructors ext.ext_uid with + match stamped_find used_constructors ext.ext_uid with | mark -> mark usage | exception Not_found -> () let mark_label_used usage ld = - match Types.Uid.Tbl.find !used_labels ld.ld_uid with + match stamped_find used_labels ld.ld_uid with | mark -> mark usage | exception Not_found -> () let mark_constructor_description_used usage env cstr = let ty_path = Btype.cstr_type_path cstr in mark_type_path_used env ty_path; - match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with + match stamped_find used_constructors cstr.cstr_uid with | mark -> mark usage | exception Not_found -> () @@ -2768,30 +2787,30 @@ let mark_label_description_used usage env lbl = | _ -> assert false in mark_type_path_used env ty_path; - match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with + match stamped_find used_labels lbl.lbl_uid with | mark -> mark usage | exception Not_found -> () let mark_class_used uid = - match Types.Uid.Tbl.find !type_declarations uid with + match stamped_find type_declarations uid with | mark -> mark () | exception Not_found -> () let mark_cltype_used uid = - match Types.Uid.Tbl.find !type_declarations uid with + match stamped_find type_declarations uid with | mark -> mark () | exception Not_found -> () let set_value_used_callback vd callback = - Types.Uid.Tbl.add !value_declarations vd.val_uid callback + stamped_uid_add value_declarations vd.val_uid callback let set_type_used_callback td callback = if Uid.for_actual_declaration td.type_uid then let old = - try Types.Uid.Tbl.find !type_declarations td.type_uid + try stamped_find type_declarations td.type_uid with Not_found -> ignore in - Types.Uid.Tbl.replace !type_declarations td.type_uid + Stamped_hashtable.replace type_declarations td.type_uid (fun () -> callback old) (* Lookup by name *) @@ -4014,7 +4033,7 @@ and short_paths_functor_components_desc env mpath comp path = Subst.modtype (Rescope (Path.scope (Papply (mpath, path)))) subst f.fcomp_res in - stamped_add f.fcomp_subst_cache path mty; + stamped_path_add f.fcomp_subst_cache path mty; mty in let loc = Location.(in_file !input_name) in @@ -4124,3 +4143,10 @@ let short_paths env = let cleanup_functor_caches ~stamp = Stamped_hashtable.backtrack !stamped_changelog ~stamp + +let cleanup_usage_tables ~stamp = + Stamped_hashtable.backtrack value_declarations_changelog ~stamp; + Stamped_hashtable.backtrack type_declarations_changelog ~stamp; + Stamped_hashtable.backtrack module_declarations_changelog ~stamp; + Stamped_hashtable.backtrack used_constructors_changelog ~stamp; + Stamped_hashtable.backtrack used_labels_changelog ~stamp diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli index 03ae201cd7..1b9191f468 100644 --- a/src/ocaml/typing/env.mli +++ b/src/ocaml/typing/env.mli @@ -18,10 +18,6 @@ open Types open Misc -val register_uid : Uid.t -> Location.t -> unit - -val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t - type value_unbound_reason = | Val_unbound_instance_variable | Val_unbound_self @@ -284,10 +280,13 @@ val make_copy_of_types: t -> (t -> t) val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t -val add_type: check:bool -> Ident.t -> type_declaration -> t -> t -val add_type_long_path: check:bool -> Ident.t -> type_declaration -> t -> t +val add_type: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +val add_type_long_path: check:bool -> ?shape:Shape.t -> Ident.t -> + type_declaration -> t -> t val add_extension: - check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t + check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> + extension_constructor -> t -> t val add_module: ?arg:bool -> ?shape:Shape.t -> Ident.t -> module_presence -> module_type -> t -> t val add_module_lazy: update_summary:bool -> @@ -534,3 +533,4 @@ val with_cmis : (unit -> 'a) -> 'a val add_merlin_extension_module: Ident.t -> module_type -> t -> t val cleanup_functor_caches : stamp:int -> unit +val cleanup_usage_tables : stamp:int -> unit diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml index 27491f609f..0a52dfc7e5 100644 --- a/src/ocaml/typing/includemod.ml +++ b/src/ocaml/typing/includemod.ml @@ -741,7 +741,21 @@ and signature_components ~in_eq ~loc old_env ~mark env subst type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 in let item = mark_error_as_unrecoverable item in + (* Right now we don't filter hidden constructors / labels from the + shape. *) let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + let shape_map = + match tydec1.type_kind with + | Type_variant (cstrs, _) -> + List.fold_left (fun shape_map { cd_id; _ } -> + Shape.Map.add_type_proj shape_map cd_id orig_shape) + shape_map cstrs + | Type_record (labels, _) -> + List.fold_left (fun shape_map { ld_id; _ } -> + Shape.Map.add_label_proj shape_map ld_id orig_shape) + shape_map labels + | _ -> shape_map + in id1, item, shape_map, false | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> let item = diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml index e8ca641410..67ba445454 100644 --- a/src/ocaml/typing/parmatch.ml +++ b/src/ocaml/typing/parmatch.ml @@ -37,7 +37,8 @@ let omega_list = Patterns.omega_list let extra_pat = make_pat - (Tpat_var (Ident.create_local "+", mknoloc "+")) + (Tpat_var (Ident.create_local "+", mknoloc "+", + Uid.internal_not_actually_unique)) Ctype.none Env.empty @@ -283,8 +284,8 @@ module Compat | ((Tpat_any|Tpat_var _),_) | (_,(Tpat_any|Tpat_var _)) -> true (* Structural induction *) - | Tpat_alias (p,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_) -> compat p q + | Tpat_alias (p,_,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_,_) -> compat p q | Tpat_or (p1,p2,_),_ -> (compat p1 q || compat p2 q) | _,Tpat_or (q1,q2,_) -> @@ -921,7 +922,8 @@ let build_other ext env = (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create_local "*extension*", - {txt="*extension*"; loc = d.pat_loc})) + {txt="*extension*"; loc = d.pat_loc}, + Uid.internal_not_actually_unique)) Ctype.none Env.empty | Construct _ -> begin match ext with @@ -1051,7 +1053,7 @@ let build_other ext env = let rec has_instance p = match p.pat_desc with | Tpat_variant (l,_,r) when is_absent l r -> false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> has_instances ps @@ -1505,7 +1507,7 @@ let is_var_column rs = (* Standard or-args for left-to-right matching *) let rec or_args p = match p.pat_desc with | Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_,_) -> or_args p +| Tpat_alias (p,_,_,_) -> or_args p | _ -> assert false (* Just remove current column *) @@ -1685,8 +1687,8 @@ and every_both pss qs q1 q2 = let rec le_pat p q = match (p.pat_desc, q.pat_desc) with | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_,_), _ -> le_pat p q - | _, Tpat_alias(q,_,_) -> le_pat p q + | Tpat_alias(p,_,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_,_) -> le_pat p q | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs @@ -1725,8 +1727,8 @@ let get_mins le ps = *) let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_,_),_ -> lub p q -| _,Tpat_alias (q,_,_) -> lub p q +| Tpat_alias (p,_,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_,_) -> lub p q | (Tpat_any|Tpat_var _),_ -> q | _,(Tpat_any|Tpat_var _) -> p | Tpat_or (p1,p2,_),_ -> orlub p1 p2 q @@ -1861,14 +1863,14 @@ module Conv = struct match pat.pat_desc with Tpat_or (pa,pb,_) -> mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *) + | Tpat_var (_, ({txt="*extension*"} as nm), _) -> (* PR#7330 *) mkpat (Ppat_var nm) | Tpat_any | Tpat_var _ -> mkpat Ppat_any | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p,_,_) -> loop p + | Tpat_alias (p,_,_,_) -> loop p | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) | Tpat_construct (cstr_lid, cstr, lst, _) -> @@ -1909,7 +1911,7 @@ end let contains_extension pat = exists_pattern (function - | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true | _ -> false) pat @@ -2021,7 +2023,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with List.fold_left (fun r (_, _, p) -> collect_paths_from_pat r p) r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) -> + collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 | Tpat_lazy p @@ -2155,7 +2158,7 @@ let inactive ~partial pat = end | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> List.for_all (fun p -> loop p) ps - | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) -> loop p | Tpat_record (ldps,_) -> List.for_all @@ -2274,9 +2277,9 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; } let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k = let rec simpl head_bound_variables varsets p ps k = match (Patterns.General.view p).pat_desc with - | `Alias (p,x,_) -> + | `Alias (p,x,_,_) -> simpl (Ident.Set.add x head_bound_variables) varsets p ps k - | `Var (x, _) -> + | `Var (x,_,_) -> simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k | `Or (p1,p2,_) -> simpl head_bound_variables varsets p1 ps diff --git a/src/ocaml/typing/patterns.ml b/src/ocaml/typing/patterns.ml index 55f9d4ff43..456f8dff33 100644 --- a/src/ocaml/typing/patterns.ml +++ b/src/ocaml/typing/patterns.ml @@ -79,18 +79,18 @@ end module General = struct type view = [ | Half_simple.view - | `Var of Ident.t * string loc - | `Alias of pattern * Ident.t * string loc + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t ] type pattern = view pattern_data let view_desc = function | Tpat_any -> `Any - | Tpat_var (id, str) -> - `Var (id, str) - | Tpat_alias (p, id, str) -> - `Alias (p, id, str) + | Tpat_var (id, str, uid) -> + `Var (id, str, uid) + | Tpat_alias (p, id, str, uid) -> + `Alias (p, id, str, uid) | Tpat_constant cst -> `Constant cst | Tpat_tuple ps -> @@ -110,8 +110,8 @@ module General = struct let erase_desc = function | `Any -> Tpat_any - | `Var (id, str) -> Tpat_var (id, str) - | `Alias (p, id, str) -> Tpat_alias (p, id, str) + | `Var (id, str, uid) -> Tpat_var (id, str, uid) + | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid) | `Constant cst -> Tpat_constant cst | `Tuple ps -> Tpat_tuple ps | `Construct (cstr, cst_descr, args) -> @@ -129,7 +129,7 @@ module General = struct let rec strip_vars (p : pattern) : Half_simple.pattern = match p.pat_desc with - | `Alias (p, _, _) -> strip_vars (view p) + | `Alias (p, _, _, _) -> strip_vars (view p) | `Var _ -> { p with pat_desc = `Any } | #Half_simple.view as view -> { p with pat_desc = view } end diff --git a/src/ocaml/typing/patterns.mli b/src/ocaml/typing/patterns.mli index 66dd2d05a4..2ad645b0d0 100644 --- a/src/ocaml/typing/patterns.mli +++ b/src/ocaml/typing/patterns.mli @@ -65,8 +65,8 @@ end module General : sig type view = [ | Half_simple.view - | `Var of Ident.t * string loc - | `Alias of pattern * Ident.t * string loc + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t ] type pattern = view pattern_data diff --git a/src/ocaml/typing/printpat.ml b/src/ocaml/typing/printpat.ml index 64094b63ec..e90fd8eeb1 100644 --- a/src/ocaml/typing/printpat.ml +++ b/src/ocaml/typing/printpat.ml @@ -52,7 +52,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | [] -> match v.pat_desc with | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) + | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x) | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs @@ -98,7 +98,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x,_) -> + | Tpat_alias (v, x,_,_) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_value v -> fprintf ppf "%a" pretty_val (v :> pattern) diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index c3480379d2..2430b903db 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -242,8 +242,8 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> end; match x.pat_desc with | Tpat_any -> line i ppf "Tpat_any\n"; - | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; - | Tpat_alias (p, s,_) -> + | Tpat_var (s,_,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; + | Tpat_alias (p, s,_,_) -> line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; pattern i ppf p; | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; diff --git a/src/ocaml/typing/rec_check.ml b/src/ocaml/typing/rec_check.ml index 99802cbf51..4210771820 100644 --- a/src/ocaml/typing/rec_check.ml +++ b/src/ocaml/typing/rec_check.ml @@ -221,7 +221,7 @@ let classify_expression : Typedtree.expression -> sd = let old_env = env in let add_value_binding env vb = match vb.vb_pat.pat_desc with - | Tpat_var (id, _loc) -> + | Tpat_var (id, _loc, _uid) -> let size = classify_expression old_env vb.vb_expr in Ident.add id size env | _ -> @@ -1197,8 +1197,8 @@ and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env -> and is_destructuring_pattern : type k . k general_pattern -> bool = fun pat -> match pat.pat_desc with | Tpat_any -> false - | Tpat_var (_, _) -> false - | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat + | Tpat_var (_, _, _) -> false + | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat | Tpat_constant _ -> true | Tpat_tuple _ -> true | Tpat_construct _ -> true diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml index 8bd04f4dd5..c22b9a356f 100644 --- a/src/ocaml/typing/shape.ml +++ b/src/ocaml/typing/shape.ml @@ -38,10 +38,17 @@ module Uid = struct print fmt t end) - let id = ref (-1) + let id = Local_store.s_ref (-1) let reinit () = id := (-1) + let get_current_stamp () = !id + let restore_stamp i = id := i + + let stamp_of_uid = function + | Item { id; _ } -> Some id + | _ -> None + let mk ~current_unit = incr id; Item { comp_unit = current_unit; id = !id } @@ -67,6 +74,8 @@ module Sig_component_kind = struct type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -76,6 +85,8 @@ module Sig_component_kind = struct let to_string = function | Value -> "value" | Type -> "type" + | Constructor -> "constructor" + | Label -> "label" | Module -> "module" | Module_type -> "module type" | Extension_constructor -> "extension constructor" @@ -87,6 +98,8 @@ module Sig_component_kind = struct | Extension_constructor -> false | Type + | Constructor + | Label | Module | Module_type | Class @@ -99,10 +112,15 @@ module Item = struct type t = string * Sig_component_kind.t let compare = compare + let name (name, _) = name + let kind (_, kind) = kind + let make str ns = str, ns let value id = Ident.name id, Sig_component_kind.Value let type_ id = Ident.name id, Sig_component_kind.Type + let constr id = Ident.name id, Sig_component_kind.Constructor + let label id = Ident.name id, Sig_component_kind.Label let module_ id = Ident.name id, Sig_component_kind.Module let module_type id = Ident.name id, Sig_component_kind.Module_type let extension_constructor id = @@ -124,17 +142,19 @@ module Item = struct end type var = Ident.t -type t = { uid: Uid.t option; desc: desc } +type t = { uid: Uid.t option; desc: desc; approximated: bool } and desc = | Var of var | Abs of var * t | App of t * t | Struct of t Item.Map.t + | Alias of t | Leaf | Proj of t * Item.t | Comp_unit of string + | Error of string -let print fmt = +let print fmt t = let print_uid_opt = Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) in @@ -171,345 +191,104 @@ let print fmt = aux t ) in - Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + if Item.Map.is_empty map then + Format.fprintf fmt "@[{%a}@]" print_uid_opt uid + else + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + | Alias t -> + Format.fprintf fmt "Alias@[(@[%a@,%a@])@]" print_uid_opt uid aux t + | Error s -> + Format.fprintf fmt "Error %s" s in - Format.fprintf fmt"@[%a@]@;" aux + if t.approximated then + Format.fprintf fmt "@[(approx)@ %a@]@;" aux t + else + Format.fprintf fmt "@[%a@]@;" aux t + +let rec strip_head_aliases = function + | { desc = Alias t; _ } -> strip_head_aliases t + | t -> t let fresh_var ?(name="shape-var") uid = let var = Ident.create_local name in - var, { uid = Some uid; desc = Var var } + var, { uid = Some uid; desc = Var var; approximated = false } let for_unnamed_functor_param = Ident.create_local "()" let var uid id = - { uid = Some uid; desc = Var id } + { uid = Some uid; desc = Var id; approximated = false } let abs ?uid var body = - { uid; desc = Abs (var, body) } + { uid; desc = Abs (var, body); approximated = false } let str ?uid map = - { uid; desc = Struct map } + { uid; desc = Struct map; approximated = false } + +let alias ?uid t = + { uid; desc = Alias t; approximated = false} let leaf uid = - { uid = Some uid; desc = Leaf } + { uid = Some uid; desc = Leaf; approximated = false } + +let approx t = { t with approximated = true} let proj ?uid t item = match t.desc with | Leaf -> (* When stuck projecting in a leaf we propagate the leaf as a best effort *) - t + approx t | Struct map -> begin try Item.Map.find item map - with Not_found -> t (* ill-typed program *) + with Not_found -> approx t (* ill-typed program *) end | _ -> - { uid; desc = Proj (t, item) } + { uid; desc = Proj (t, item); approximated = false } let app ?uid f ~arg = - { uid; desc = App (f, arg) } + { uid; desc = App (f, arg); approximated = false } let decompose_abs t = match t.desc with | Abs (x, t) -> Some (x, t) | _ -> None -module Make_reduce(Params : sig - type env - val fuel : int - val read_unit_shape : unit_name:string -> t option - val find_shape : env -> Ident.t -> t -end) = struct - (* We implement a strong call-by-need reduction, following an - evaluator from Nathanaelle Courant. *) - - type nf = { uid: Uid.t option; desc: nf_desc } - and nf_desc = - | NVar of var - | NApp of nf * nf - | NAbs of local_env * var * t * delayed_nf - | NStruct of delayed_nf Item.Map.t - | NProj of nf * Item.t - | NLeaf - | NComp_unit of string - | NoFuelLeft of desc - (* A type of normal forms for strong call-by-need evaluation. - The normal form of an abstraction - Abs(x, t) - is a closure - NAbs(env, x, t, dnf) - when [env] is the local environment, and [dnf] is a delayed - normal form of [t]. - - A "delayed normal form" is morally equivalent to (nf Lazy.t), but - we use a different representation that is compatible with - memoization (lazy values are not hashable/comparable by default - comparison functions): we represent a delayed normal form as - just a not-yet-computed pair [local_env * t] of a term in a - local environment -- we could also see this as a term under - an explicit substitution. This delayed thunked is "forced" - by calling the normalization function as usual, but duplicate - computations are precisely avoided by memoization. - *) - and delayed_nf = Thunk of local_env * t - - and local_env = delayed_nf option Ident.Map.t - (* When reducing in the body of an abstraction [Abs(x, body)], we - bind [x] to [None] in the environment. [Some v] is used for - actual substitutions, for example in [App(Abs(x, body), t)], when - [v] is a thunk that will evaluate to the normal form of [t]. *) - - let improve_uid uid (nf : nf) = - match nf.uid with - | Some _ -> nf - | None -> { nf with uid } - - let in_memo_table memo_table memo_key f arg = - match Hashtbl.find memo_table memo_key with - | res -> res - | exception Not_found -> - let res = f arg in - Hashtbl.replace memo_table memo_key res; - res - - type env = { - fuel: int ref; - global_env: Params.env; - local_env: local_env; - reduce_memo_table: (local_env * t, nf) Hashtbl.t; - read_back_memo_table: (nf, t) Hashtbl.t; - } - - let bind env var shape = - { env with local_env = Ident.Map.add var shape env.local_env } - - let rec reduce_ env t = - let memo_key = (env.local_env, t) in - in_memo_table env.reduce_memo_table memo_key (reduce__ env) t - (* Memoization is absolutely essential for performance on this - problem, because the normal forms we build can in some real-world - cases contain an exponential amount of redundancy. Memoization - can avoid the repeated evaluation of identical subterms, - providing a large speedup, but even more importantly it - implicitly shares the memory of the repeated results, providing - much smaller normal forms (that blow up again if printed back - as trees). A functor-heavy file from Irmin has its shape normal - form decrease from 100Mio to 2.5Mio when memoization is enabled. - - Note: the local environment is part of the memoization key, while - it is defined using a type Ident.Map.t of non-canonical balanced - trees: two maps could have exactly the same items, but be - balanced differently and therefore hash differently, reducing - the effectivenss of memoization. - This could in theory happen, say, with the two programs - (fun x -> fun y -> ...) - and - (fun y -> fun x -> ...) - having "the same" local environments, with additions done in - a different order, giving non-structurally-equal trees. Should we - define our own hash functions to provide robust hashing on - environments? - - We believe that the answer is "no": this problem does not occur - in practice. We can assume that identifiers are unique on valid - typedtree fragments (identifier "stamps" distinguish - binding positions); in particular the two program fragments above - in fact bind *distinct* identifiers x (with different stamps) and - different identifiers y, so the environments are distinct. If two - environments are structurally the same, they must correspond to - the evaluation evnrionments of two sub-terms that are under - exactly the same scope of binders. So the two environments were - obtained by the same term traversal, adding binders in the same - order, giving the same balanced trees: the environments have the - same hash. -*) - - and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = - let reduce env t = reduce_ env t in - let delay_reduce env t = Thunk (env.local_env, t) in - let force (Thunk (local_env, t)) = - reduce { env with local_env } t in - let return desc : nf = { uid = t.uid; desc } in - if !fuel < 0 then return (NoFuelLeft t.desc) - else - match t.desc with - | Comp_unit unit_name -> - begin match Params.read_unit_shape ~unit_name with - | Some t -> reduce env t - | None -> return (NComp_unit unit_name) - end - | App(f, arg) -> - let f = reduce env f in - begin match f.desc with - | NAbs(clos_env, var, body, _body_nf) -> - let arg = delay_reduce env arg in - let env = bind { env with local_env = clos_env } var (Some arg) in - reduce env body - |> improve_uid t.uid - | _ -> - let arg = reduce env arg in - return (NApp(f, arg)) - end - | Proj(str, item) -> - let str = reduce env str in - let nored () = return (NProj(str, item)) in - begin match str.desc with - | NStruct (items) -> - begin match Item.Map.find item items with - | exception Not_found -> nored () - | nf -> - force nf - |> improve_uid t.uid - end - | _ -> - nored () - end - | Abs(var, body) -> - let body_nf = delay_reduce (bind env var None) body in - return (NAbs(local_env, var, body, body_nf)) - | Var id -> - begin match Ident.Map.find id local_env with - (* Note: instead of binding abstraction-bound variables to - [None], we could unify it with the [Some v] case by - binding the bound variable [x] to [NVar x]. - - One reason to distinguish the situations is that we can - provide a different [Uid.t] location; for bound - variables, we use the [Uid.t] of the bound occurrence - (not the binding site), whereas for bound values we use - their binding-time [Uid.t]. *) - | None -> return (NVar id) - | Some def -> force def - | exception Not_found -> - match Params.find_shape global_env id with - | exception Not_found -> return (NVar id) - | res when res = t -> return (NVar id) - | res -> - decr fuel; - reduce env res - end - | Leaf -> return NLeaf - | Struct m -> - let mnf = Item.Map.map (delay_reduce env) m in - return (NStruct mnf) - - let rec read_back env (nf : nf) : t = - in_memo_table env.read_back_memo_table nf (read_back_ env) nf - (* The [nf] normal form we receive may contain a lot of internal - sharing due to the use of memoization in the evaluator. We have - to memoize here again, otherwise the sharing is lost by mapping - over the term as a tree. *) - - and read_back_ env (nf : nf) : t = - { uid = nf.uid; desc = read_back_desc env nf.desc } - - and read_back_desc env desc = - let read_back nf = read_back env nf in - let read_back_force (Thunk (local_env, t)) = - read_back (reduce_ { env with local_env } t) in - match desc with - | NVar v -> - Var v - | NApp (nft, nfu) -> - App(read_back nft, read_back nfu) - | NAbs (_env, x, _t, nf) -> - Abs(x, read_back_force nf) - | NStruct nstr -> - Struct (Item.Map.map read_back_force nstr) - | NProj (nf, item) -> - Proj (read_back nf, item) - | NLeaf -> Leaf - | NComp_unit s -> Comp_unit s - | NoFuelLeft t -> t - - (* When in Merlin we don't need to perform full shape reduction since we are - only interested by uid's stored at the "top-level" of the shape once the - projections have been done. *) - let weak_read_back env (nf : nf) : t = - let cache = Hashtbl.create 42 in - let rec weak_read_back env nf = - let memo_key = (env.local_env, nf) in - in_memo_table cache memo_key (weak_read_back_ env) nf - and weak_read_back_ env nf : t = - { uid = nf.uid; desc = weak_read_back_desc env nf.desc } - and weak_read_back_desc env desc : desc = - let weak_read_back_no_force (Thunk (_local_env, t)) = t in - match desc with - | NVar v -> - Var v - | NApp (nft, nfu) -> - App(weak_read_back env nft, weak_read_back env nfu) - | NAbs (_env, x, _t, nf) -> - Abs(x, weak_read_back_no_force nf) - | NStruct nstr -> - Struct (Item.Map.map weak_read_back_no_force nstr) - | NProj (nf, item) -> - Proj (read_back env nf, item) - | NLeaf -> Leaf - | NComp_unit s -> Comp_unit s - | NoFuelLeft t -> t - in weak_read_back env nf - - let reduce global_env t = - let fuel = ref Params.fuel in - let reduce_memo_table = Hashtbl.create 42 in - let read_back_memo_table = Hashtbl.create 42 in - let local_env = Ident.Map.empty in - let env = { - fuel; - global_env; - reduce_memo_table; - read_back_memo_table; - local_env; - } in - reduce_ env t |> read_back env - - let weak_reduce global_env t = - let fuel = ref Params.fuel in - let reduce_memo_table = Hashtbl.create 42 in - let read_back_memo_table = Hashtbl.create 42 in - let local_env = Ident.Map.empty in - let env = { - fuel; - global_env; - reduce_memo_table; - read_back_memo_table; - local_env; - } in - reduce_ env t |> weak_read_back env -end - -module Local_reduce = - (* Note: this definition with [type env = unit] is only suitable for - reduction of toplevel shapes -- shapes of compilation units, - where free variables are only Comp_unit names. If we wanted to - reduce shapes inside module signatures, we would need to take - a typing environment as parameter. *) - Make_reduce(struct - type env = unit - let fuel = 10 - let read_unit_shape ~unit_name:_ = None - let find_shape _env _id = raise Not_found - end) - -let local_reduce shape = - Local_reduce.reduce () shape - -let dummy_mod = { uid = None; desc = Struct Item.Map.empty } +let dummy_mod = + { uid = None; desc = Struct Item.Map.empty; approximated = false } -let of_path ~find_shape ~namespace = +let of_path ~find_shape ~namespace path = let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function | Pident id -> find_shape ns id - | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Pdot (path, name) -> + (* We need to handle the following cases: + Path of constructor: + M.t.C + Path of label: + M.t.lbl + Path on label of inline record: + M.t.C.lbl *) + let is_capitalized name = String.capitalize_ascii name = name in + let is_label namespace = namespace = Sig_component_kind.Label in + let namespace : Sig_component_kind.t = + match path with + | Pident id when is_capitalized (Ident.name id) -> + if is_label ns then Constructor else Module + | Pident _ -> Type + | Pdot (_, name) when is_capitalized name -> + if is_label ns then Constructor else Module + | Pdot _ -> Type + | Papply _ -> Module + in + proj (aux namespace path) (name, ns) | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) in - aux namespace + aux namespace path let for_persistent_unit s = { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); - desc = Comp_unit s } + desc = Comp_unit s; approximated = false } -let leaf_for_unpack = { uid = None; desc = Leaf } +let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false } let set_uid_if_none t uid = match t.uid with @@ -529,11 +308,21 @@ module Map = struct let item = Item.value id in Item.Map.add item (proj shape item) t - let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type t id shape = Item.Map.add (Item.type_ id) shape t let add_type_proj t id shape = let item = Item.type_ id in Item.Map.add item (proj shape item) t + let add_constr t id shape = Item.Map.add (Item.constr id) shape t + let add_constr_proj t id shape = + let item = Item.constr id in + Item.Map.add item (proj shape item) t + + let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t + let add_label_proj t id shape = + let item = Item.label id in + Item.Map.add item (proj shape item) t + let add_module t id shape = Item.Map.add (Item.module_ id) shape t let add_module_proj t id shape = let item = Item.module_ id in @@ -545,8 +334,8 @@ module Map = struct let item = Item.module_type id in Item.Map.add item (proj shape item) t - let add_extcons t id uid = - Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons t id shape = + Item.Map.add (Item.extension_constructor id) shape t let add_extcons_proj t id shape = let item = Item.extension_constructor id in Item.Map.add item (proj shape item) t diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli index 9740a3ad2d..ed6c84692a 100644 --- a/src/ocaml/typing/shape.mli +++ b/src/ocaml/typing/shape.mli @@ -13,6 +13,48 @@ (* *) (**************************************************************************) +(** Shapes are an abstract representation of modules' implementations which + allow the tracking of definitions through functor applications and other + module-level operations. + + The Shape of a compilation unit is elaborated during typing, partially + reduced (without loading external shapes) and written to the [cmt] file. + + External tools can retrieve the definition of any value (or type, or module, + etc) by following this procedure: + + - Build the Shape corresponding to the value's path: + [let shape = Env.shape_of_path ~namespace env path] + + - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from + external units and to looks for shapes in the environment (usually using + [Env.shape_of_path]). + + - Completely reduce the shape: + [let shape = My_reduce.(weak_)reduce env shape] + + - The [Uid.t] stored in the reduced shape should be the one of the + definition. However, if the [approximate] field of the reduced shape is + [true] then the [Uid.t] will not correspond to the definition, but to the + closest parent module's uid. This happens when Shape reduction gets stuck, + for example when hitting first-class modules. + + - The location of the definition can be easily found with the + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. + + See: + - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } + the design document} + - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } + a talk about the reduction strategy +*) + +(** A [Uid.t] is associated with every declaration in signatures and + implementations, they uniquely identify bindings in the program. + When associated with these bindings' locations they are useful to + external tools when trying to jump to the declaration of + definitions of identifiers. They are stored to that effect in the + [uid_to_decl] table of cmt files. *) module Uid : sig type t = private | Compilation_unit of string @@ -21,6 +63,9 @@ module Uid : sig | Predef of string val reinit : unit -> unit + val get_current_stamp : unit -> int + val restore_stamp : int -> unit + val stamp_of_uid : t -> int option val mk : current_unit:string -> t val of_compilation_unit_id : Ident.t -> t @@ -36,6 +81,8 @@ module Sig_component_kind : sig type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -48,35 +95,47 @@ module Sig_component_kind : sig val can_appear_in_types : t -> bool end +(** Shape's items are elements of a structure. These structures models module + components and nested types' constructors and labels *) module Item : sig - type t + type t = string * Sig_component_kind.t + val name : t -> string + val kind : t -> Sig_component_kind.t val make : string -> Sig_component_kind.t -> t val value : Ident.t -> t val type_ : Ident.t -> t + val constr : Ident.t -> t + val label : Ident.t -> t val module_ : Ident.t -> t val module_type : Ident.t -> t val extension_constructor : Ident.t -> t val class_ : Ident.t -> t val class_type : Ident.t -> t + val print : Format.formatter -> t -> unit + module Map : Map.S with type key = t end type var = Ident.t -type t = { uid: Uid.t option; desc: desc } +type t = { uid: Uid.t option; desc: desc; approximated: bool } and desc = | Var of var | Abs of var * t | App of t * t | Struct of t Item.Map.t + | Alias of t | Leaf | Proj of t * Item.t | Comp_unit of string + | Error of string val print : Format.formatter -> t -> unit +val strip_head_aliases : t -> t + (* Smart constructors *) val for_unnamed_functor_param : var @@ -86,6 +145,7 @@ val var : Uid.t -> Ident.t -> t val abs : ?uid:Uid.t -> var -> t -> t val app : ?uid:Uid.t -> t -> arg:t -> t val str : ?uid:Uid.t -> t Item.Map.t -> t +val alias : ?uid:Uid.t -> t -> t val proj : ?uid:Uid.t -> t -> Item.t -> t val leaf : Uid.t -> t @@ -105,16 +165,22 @@ module Map : sig val add_value : t -> Ident.t -> Uid.t -> t val add_value_proj : t -> Ident.t -> shape -> t - val add_type : t -> Ident.t -> Uid.t -> t + val add_type : t -> Ident.t -> shape -> t val add_type_proj : t -> Ident.t -> shape -> t + val add_constr : t -> Ident.t -> shape -> t + val add_constr_proj : t -> Ident.t -> shape -> t + + val add_label : t -> Ident.t -> Uid.t -> t + val add_label_proj : t -> Ident.t -> shape -> t + val add_module : t -> Ident.t -> shape -> t val add_module_proj : t -> Ident.t -> shape -> t val add_module_type : t -> Ident.t -> Uid.t -> t val add_module_type_proj : t -> Ident.t -> shape -> t - val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons : t -> Ident.t -> shape -> t val add_extcons_proj : t -> Ident.t -> shape -> t val add_class : t -> Ident.t -> Uid.t -> t @@ -126,33 +192,12 @@ end val dummy_mod : t +(** This function returns the shape corresponding to a given path. It requires a + callback to find shapes in the environment. It is generally more useful to + rely directly on the [Env.shape_of_path] function to get the shape + associated with a given path. *) val of_path : find_shape:(Sig_component_kind.t -> Ident.t -> t) -> namespace:Sig_component_kind.t -> Path.t -> t val set_uid_if_none : t -> Uid.t -> t - -(** The [Make_reduce] functor is used to generate a reduction function for - shapes. - - It is parametrized by: - - an environment and a function to find shapes by path in that environment - - a function to load the shape of an external compilation unit - - some fuel, which is used to bound recursion when dealing with recursive - shapes introduced by recursive modules. (FTR: merlin currently uses a - fuel of 10, which seems to be enough for most practical examples) -*) -module Make_reduce(Context : sig - type env - - val fuel : int - - val read_unit_shape : unit_name:string -> t option - - val find_shape : env -> Ident.t -> t - end) : sig - val reduce : Context.env -> t -> t - val weak_reduce : Context.env -> t -> t -end - -val local_reduce : t -> t diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml new file mode 100644 index 0000000000..fd18b81f27 --- /dev/null +++ b/src/ocaml/typing/shape_reduce.ml @@ -0,0 +1,350 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Shape + +type result = + | Resolved of Uid.t + | Resolved_alias of Uid.t list + | Unresolved of t + | Approximated of Uid.t option + | Internal_error_missing_uid + +let print_result fmt result = + match result with + | Resolved uid -> + Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + | Resolved_alias uids -> + Format.fprintf fmt "@[Resolved_alias: %a@]@;" + Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") + Uid.print) uids + | Unresolved shape -> + Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + | Approximated (Some uid) -> + Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + | Approximated None -> + Format.fprintf fmt "@[Approximated: No uid@]@;" + | Internal_error_missing_uid -> + Format.fprintf fmt "@[Missing uid@]@;" + + +let find_shape env id = + let namespace = Shape.Sig_component_kind.Module in + Env.shape_of_path ~namespace env (Pident id) + +module Make(Params : sig + val fuel : int + val read_unit_shape : unit_name:string -> t option +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NAlias of delayed_nf + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NError of string + + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let approx_nf nf = { nf with approximated = true } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Env.t; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let local_env = env.local_env in + let memo_key = (local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ + ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = reduce { env with local_env } t in + let return desc = { uid = t.uid; desc; approximated = t.approximated } in + let rec force_aliases nf = match nf.desc with + | NAlias delayed_nf -> + let nf = force delayed_nf in + force_aliases nf + | _ -> nf + in + let reset_uid_if_new_binding t' = + match t.uid with + | None -> t' + | Some _ as uid -> { t' with uid } + in + if !fuel < 0 then approx_nf (return (NError "NoFuelLeft")) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f |> force_aliases in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body |> reset_uid_if_new_binding + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str |> force_aliases in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> force nf |> reset_uid_if_new_binding + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> + begin match force def with + | { uid = Some _; _ } as nf -> nf + (* This var already has a binding uid *) + | { uid = None; _ } as nf -> { nf with uid = t.uid } + (* Set the var's binding uid *) + end + | exception Not_found -> + match find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + | Alias t -> return (NAlias (delay_reduce env t)) + | Error s -> approx_nf (return (NError s)) + + and read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid ; + desc = read_back_desc env nf.desc; + approximated = nf.approximated } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NAlias nf -> Alias (read_back_force nf) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NError s -> Error s + + (* Sharing the memo tables is safe at the level of a compilation unit since + idents should be unique *) + let reduce_memo_table = Hashtbl.create 42 + let read_back_memo_table = Hashtbl.create 42 + + let reduce global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env + + let rec is_stuck_on_comp_unit (nf : nf) = + match nf.desc with + | NVar _ -> + (* This should not happen if we only reduce closed terms *) + false + | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf + | NStruct _ | NAbs _ -> false + | NAlias _ -> false + | NComp_unit _ -> true + | NError _ -> false + | NLeaf -> false + + let get_aliases_uids (t : t) = + let rec aux acc (t : t) = match t with + | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t + | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) + | _ -> Internal_error_missing_uid + in + aux [] t + + let reduce_for_uid global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + let nf = reduce_ env t in + if is_stuck_on_comp_unit nf then + Unresolved (read_back env nf) + else match nf with + | { desc = NAlias _; approximated = false; _ } -> + get_aliases_uids (read_back env nf) + | { uid = Some uid; approximated = false; _ } -> + Resolved uid + | { uid; approximated = true; _ } -> + Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid +end + +module Local_reduce = + (* Note: this definition with [type env = unit] is only suitable for + reduction of toplevel shapes -- shapes of compilation units, + where free variables are only Comp_unit names. If we wanted to + reduce shapes inside module signatures, we would need to take + a typing environment as parameter. *) + Make(struct + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + end) + +let local_reduce = Local_reduce.reduce +let local_reduce_for_uid = Local_reduce.reduce_for_uid diff --git a/src/ocaml/typing/shape_reduce.mli b/src/ocaml/typing/shape_reduce.mli new file mode 100644 index 0000000000..6156207ad6 --- /dev/null +++ b/src/ocaml/typing/shape_reduce.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Shape + +(** The result of reducing a shape and looking for its uid *) +type result = + | Resolved of Uid.t (** Shape reduction succeeded and a uid was found *) + | Resolved_alias of Uid.t list (** Reduction led to an alias chain *) + | Unresolved of t (** Result still contains [Comp_unit] terms *) + | Approximated of Uid.t option + (** Reduction failed: it can arrive with first-clsss modules for example *) + | Internal_error_missing_uid + (** Reduction succeeded but no uid was found, this should never happen *) + +val print_result : Format.formatter -> result -> unit + +(** The [Make] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) +*) +module Make(_ : sig + val fuel : int + + val read_unit_shape : unit_name:string -> t option + end) : sig + val reduce : Env.t -> t -> t + + (** Perform weak reduction and return the head's uid if any. If reduction was + incomplete the partially reduced shape is returned. *) + val reduce_for_uid : Env.t -> t -> result +end + +(** [local_reduce] will not reduce shapes that require loading external + compilation units. *) +val local_reduce : Env.t -> t -> t + +(** [local_reduce_for_uid] will not reduce shapes that require loading external + compilation units. *) +val local_reduce_for_uid : Env.t -> t -> result diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml index 98bc77dfb5..3ac8513008 100644 --- a/src/ocaml/typing/tast_iterator.ml +++ b/src/ocaml/typing/tast_iterator.ml @@ -59,6 +59,7 @@ type iterator = value_bindings: iterator -> (rec_flag * value_binding list) -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; } let structure sub {str_items; str_final_env; _} = @@ -69,19 +70,25 @@ let class_infos sub f x = List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; f x.ci_expr -let module_type_declaration sub {mtd_type; _} = +let module_type_declaration sub ({mtd_type; _} as x) = + sub.item_declaration sub (Module_type x); Option.iter (sub.module_type sub) mtd_type -let module_declaration sub {md_type; _} = +let module_declaration sub ({md_type; _} as md) = + sub.item_declaration sub (Module md); sub.module_type sub md_type -let module_substitution _ _ = () + +let module_substitution sub ms = + sub.item_declaration sub (Module_substitution ms) let include_infos f {incl_mod; _} = f incl_mod let class_type_declaration sub x = + sub.item_declaration sub (Class_type x); class_infos sub (sub.class_type sub) x let class_declaration sub x = + sub.item_declaration sub (Class x); class_infos sub (sub.class_expr sub) x let structure_item sub {str_desc; str_env; _} = @@ -104,15 +111,20 @@ let structure_item sub {str_desc; str_env; _} = | Tstr_open od -> sub.open_declaration sub od | Tstr_attribute _ -> () -let value_description sub x = sub.typ sub x.val_desc +let value_description sub x = + sub.item_declaration sub (Value x); + sub.typ sub x.val_desc -let label_decl sub {ld_type; _} = sub.typ sub ld_type +let label_decl sub ({ld_type; _} as ld) = + sub.item_declaration sub (Label ld); + sub.typ sub ld_type let constructor_args sub = function | Cstr_tuple l -> List.iter (sub.typ sub) l | Cstr_record l -> List.iter (label_decl sub) l -let constructor_decl sub {cd_args; cd_res; _} = +let constructor_decl sub ({cd_args; cd_res; _} as x) = + sub.item_declaration sub (Constructor x); constructor_args sub cd_args; Option.iter (sub.typ sub) cd_res @@ -122,7 +134,9 @@ let type_kind sub = function | Ttype_record list -> List.iter (label_decl sub) list | Ttype_open -> () -let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} = +let type_declaration + sub ({typ_cstrs; typ_kind; typ_manifest; typ_params; _} as x) = + sub.item_declaration sub (Type x); List.iter (fun (c1, c2, _) -> sub.typ sub c1; @@ -141,7 +155,8 @@ let type_extension sub {tyext_constructors; tyext_params; _} = let type_exception sub {tyexn_constructor; _} = sub.extension_constructor sub tyexn_constructor -let extension_constructor sub {ext_kind; _} = +let extension_constructor sub ({ext_kind; _} as ec) = + sub.item_declaration sub (Extension_constructor ec); match ext_kind with | Text_decl (_, ctl, cto) -> constructor_args sub ctl; @@ -170,7 +185,7 @@ let pat | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l - | Tpat_alias (p, _, _) -> sub.pat sub p + | Tpat_alias (p, _, _, _) -> sub.pat sub p | Tpat_lazy p -> sub.pat sub p | Tpat_value p -> sub.pat sub (p :> pattern) | Tpat_exception p -> sub.pat sub p @@ -293,6 +308,7 @@ let signature_item sub {sig_desc; sig_env; _} = | Tsig_attribute _ -> () let class_description sub x = + sub.item_declaration sub (Class_type x); class_infos sub (sub.class_type sub) x let functor_parameter sub = function @@ -318,8 +334,8 @@ let with_constraint sub = function | Twith_typesubst decl -> sub.type_declaration sub decl | Twith_module _ -> () | Twith_modsubst _ -> () - | Twith_modtype _ -> () - | Twith_modtypesubst _ -> () + | Twith_modtype decl -> sub.module_type sub decl + | Twith_modtypesubst decl -> sub.module_type sub decl let open_description sub {open_env; _} = sub.env sub open_env @@ -362,7 +378,9 @@ let module_expr sub {mod_desc; mod_env; _} = sub.module_coercion sub c | Tmod_unpack (exp, _) -> sub.expr sub exp -let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr +let module_binding sub ({mb_expr; _} as mb) = + sub.item_declaration sub (Module_binding mb); + sub.module_expr sub mb_expr let class_expr sub {cl_desc; cl_env; _} = sub.env sub cl_env; @@ -465,12 +483,15 @@ let case sub {c_lhs; c_guard; c_rhs} = Option.iter (sub.expr sub) c_guard; sub.expr sub c_rhs -let value_binding sub {vb_pat; vb_expr; _} = +let value_binding sub ({vb_pat; vb_expr; _} as vb) = + sub.item_declaration sub (Value_binding vb); sub.pat sub vb_pat; sub.expr sub vb_expr let env _sub _ = () +let item_declaration _sub _ = () + let default_iterator = { binding_op; @@ -514,4 +535,5 @@ let default_iterator = value_bindings; value_description; with_constraint; + item_declaration; } diff --git a/src/ocaml/typing/tast_iterator.mli b/src/ocaml/typing/tast_iterator.mli index e126128edf..5e6d3b6c72 100644 --- a/src/ocaml/typing/tast_iterator.mli +++ b/src/ocaml/typing/tast_iterator.mli @@ -63,6 +63,7 @@ type iterator = value_bindings: iterator -> (rec_flag * value_binding list) -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; } val default_iterator: iterator diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml index fe7268676e..a2700b7cba 100644 --- a/src/ocaml/typing/tast_mapper.ml +++ b/src/ocaml/typing/tast_mapper.ml @@ -219,7 +219,7 @@ let pat | Tpat_record (l, closed) -> Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) - | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) + | Tpat_alias (p, id, s, uid) -> Tpat_alias (sub.pat sub p, id, s, uid) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) | Tpat_value p -> (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index 28f0645780..787f82c2dd 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -1305,7 +1305,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = Typecore.type_let In_class_def val_env rec_flag sdefs in let (vals, met_env) = List.fold_right - (fun (id, _id_loc, _typ) (vals, met_env) -> + (fun (id, _id_loc, _typ, _uid) (vals, met_env) -> let path = Pident id in (* do not mark the value as used *) let vd = Env.find_value path val_env in @@ -1952,7 +1952,7 @@ let approx_class_declarations env sdecls = open Format -let non_virtual_string_of_kind = function +let non_virtual_string_of_kind : kind -> string = function | Object -> "object" | Class -> "non-virtual class" | Class_type -> "non-virtual class type" diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index f83421683b..2bedac3cf9 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -537,6 +537,7 @@ type pattern_variable = pv_loc: Location.t; pv_as_var: bool; pv_attributes: attributes; + pv_uid : Uid.t; } type module_variable = @@ -570,19 +571,21 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty !pattern_variables then raise(error(loc, Env.empty, Multiply_bound_variable name.txt)); let id = Ident.create_local name.txt in + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in pattern_variables := {pv_id = id; pv_type = ty; pv_loc = loc; pv_as_var = is_as_variable; - pv_attributes = attrs} :: !pattern_variables; + pv_attributes = attrs; + pv_uid} :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (error (loc, Env.empty, Modules_not_allowed)); module_variables := (name, loc) :: !module_variables end; - id + id, pv_uid let sort_pattern_variables vs = List.sort @@ -648,7 +651,7 @@ let rec build_as_type ~refine (env : Env.t ref) p = and build_as_type_aux ~refine (env : Env.t ref) p = let build_as_type = build_as_type ~refine in match p.pat_desc with - Tpat_alias(p1,_, _) -> build_as_type env p1 + Tpat_alias(p1,_, _, _) -> build_as_type env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl) @@ -1783,14 +1786,14 @@ and type_pat_aux end | Ppat_var name -> let ty = instance expected_ty in - let id = (* PR#7330 *) + let id, uid = (* PR#7330 *) if name.txt = "*extension*" then - Ident.create_local name.txt + Ident.create_local name.txt, Uid.internal_not_actually_unique else enter_variable loc name ty sp.ppat_attributes in rvp k { - pat_desc = Tpat_var (id, name); + pat_desc = Tpat_var (id, name, uid); pat_loc = loc; pat_extra=[]; pat_type = ty; pat_attributes = sp.ppat_attributes; @@ -1809,9 +1812,9 @@ and type_pat_aux pat_env = !env } | Some s -> let v = { name with txt = s } in - let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in + let id, uid = enter_variable loc v t ~is_module:true sp.ppat_attributes in rvp k { - pat_desc = Tpat_var (id, v); + pat_desc = Tpat_var (id, v, uid); pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; pat_type = t; @@ -1825,8 +1828,8 @@ and type_pat_aux assert construction_not_used_in_counterexamples; let cty, ty, ty' = solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in - let id = enter_variable lloc name ty' attrs in - rvp k { pat_desc = Tpat_var (id, name); + let id, uid = enter_variable lloc name ty' attrs in + rvp k { pat_desc = Tpat_var (id, name, uid); pat_loc = lloc; pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; pat_type = ty; @@ -1836,11 +1839,11 @@ and type_pat_aux assert construction_not_used_in_counterexamples; type_pat Value sq expected_ty (fun q -> let ty_var = solve_Ppat_alias ~refine env q in - let id = + let id, uid = enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes in rvp k { - pat_desc = Tpat_alias(q, id, name); + pat_desc = Tpat_alias(q, id, name, uid); pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; pat_attributes = sp.ppat_attributes; @@ -2159,12 +2162,16 @@ and type_pat_aux let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in let p : k general_pattern = match category, (p : k general_pattern) with - | Value, {pat_desc = Tpat_var (id,s); _} -> + | Value, {pat_desc = Tpat_var (id,s,uid); _} -> {p with pat_type = ty; pat_desc = Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); + ({p with + pat_desc = Tpat_any; + pat_attributes = (* Merlin should ignore these nodes *) + [Ast_helper.Attr.mk (mknoloc "merlin.hide") (PStr [])]; + pat_loc = { p.pat_loc with loc_ghost = true }}, id,s,uid); pat_extra = [extra]; } | _, p -> @@ -2256,12 +2263,12 @@ let iter_pattern_variables_type f : pattern_variable list -> unit = let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env -> + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env -> let check = if pv_as_var then check_as else check in Env.add_value ?check pv_id {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; val_attributes = pv_attributes; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = pv_uid; } env ) pv env @@ -2885,8 +2892,8 @@ let rec name_pattern default = function [] -> Ident.create_local default | p :: rem -> match p.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id + Tpat_var (id, _, _) -> id + | Tpat_alias(_, id, _, _) -> id | _ -> name_pattern default rem let name_cases default lst = @@ -3873,10 +3880,12 @@ and type_expect_ | _ -> Mp_present in let scope = create_scope () in + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let md = { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } + md_uid; } in + let md_shape = Shape.set_uid_if_none md_shape md_uid in let (id, new_env) = match name.txt with | None -> None, env @@ -3902,7 +3911,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_letexception(cd, sbody) -> - let (cd, newenv) = Typedecl.transl_exception env cd in + let (cd, newenv, _shape) = Typedecl.transl_exception env cd in let body = type_expect newenv sbody ty_expected_explained in re { exp_desc = Texp_letexception(cd, body); @@ -4701,7 +4710,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = } in let exp_env = Env.add_value id desc env in - {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; + {pat_desc = + Tpat_var (id, mknoloc name, desc.val_uid); + pat_type = ty; + pat_extra=[]; pat_attributes = []; pat_loc = Location.none; pat_env = env}, {exp_type = ty; exp_loc = Location.none; exp_env = exp_env; @@ -5574,7 +5586,7 @@ and type_let List.iter (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var _ -> () - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () + | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> () | _ -> raise(error(pat.pat_loc, env, Illegal_letrec_pat))) l; List.iter (function diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli index 73772b47ac..2c162e714b 100644 --- a/src/ocaml/typing/typecore.mli +++ b/src/ocaml/typing/typecore.mli @@ -56,6 +56,7 @@ type pattern_variable = pv_loc: Location.t; pv_as_var: bool; pv_attributes: Typedtree.attributes; + pv_uid : Uid.t; } val mk_expected: diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 502418335f..504637a427 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -82,12 +82,12 @@ let get_unboxed_from_attributes sdecl = (* Enter all declared types in the environment as abstract types *) -let add_type ~long_path ~check id decl env = +let add_type ~long_path ~check ?shape id decl env = Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes (fun () -> match long_path with - | true -> Env.add_type_long_path ~check id decl env - | false -> Env.add_type ~check id decl env) + | true -> Env.add_type_long_path ~check ?shape id decl env + | false -> Env.add_type ~check ?shape id decl env) let enter_type rec_flag env sdecl (id, uid) = let needed = @@ -225,7 +225,9 @@ let transl_labels env univars closed lbls = let arg = Ast_helper.Typ.force_poly arg in let cty = transl_simple_type env ?univars closed arg in {ld_id = Ident.create_local name.txt; - ld_name = name; ld_mutable = mut; + ld_name = name; + ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + ld_mutable = mut; ld_type = cty; ld_loc = loc; ld_attributes = attrs} ) in @@ -235,14 +237,12 @@ let transl_labels env univars closed lbls = (fun ld -> let ty = ld.ld_type.ctyp_type in let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in - let ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in - Env.register_uid ld_uid ld.ld_loc; {Types.ld_id = ld.ld_id; ld_mutable = ld.ld_mutable; ld_type = ty; ld_loc = ld.ld_loc; ld_attributes = ld.ld_attributes; - ld_uid; + ld_uid = ld.ld_uid; } ) lbls in @@ -312,6 +312,25 @@ let make_constructor env loc type_path type_params svars sargs sret_type = widen z; targs, Some tret_type, args, Some ret_type +let shape_map_labels = + List.fold_left (fun map { ld_id; ld_uid; _} -> + Shape.Map.add_label map ld_id ld_uid) + Shape.Map.empty + +let shape_map_cstrs = + List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } -> + let cstr_shape_map = + let label_decls = + match cd_args with + | Cstr_tuple _ -> [] + | Cstr_record ldecls -> ldecls + in + shape_map_labels label_decls + in + Shape.Map.add_constr map cd_id + @@ Shape.str ~uid:cd_uid cstr_shape_map) + (Shape.Map.empty) + let transl_declaration env sdecl (id, uid) = (* Bind type parameters *) reset_type_variables(); @@ -398,6 +417,7 @@ let transl_declaration env sdecl (id, uid) = let tcstr = { cd_id = name; cd_name = scstr.pcd_name; + cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); cd_vars = scstr.pcd_vars; cd_args = targs; cd_res = tret_type; @@ -405,14 +425,12 @@ let transl_declaration env sdecl (id, uid) = cd_attributes = scstr.pcd_attributes } in let cstr = - let cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in - Env.register_uid cd_uid scstr.pcd_loc; { Types.cd_id = name; cd_args = args; cd_res = ret_type; cd_loc = scstr.pcd_loc; cd_attributes = scstr.pcd_attributes; - cd_uid; } + cd_uid = tcstr.cd_uid; } in tcstr, cstr in @@ -477,18 +495,32 @@ let transl_declaration env sdecl (id, uid) = in set_private_row env sdecl.ptype_loc p decl end; - { - typ_id = id; - typ_name = sdecl.ptype_name; - typ_params = tparams; - typ_type = decl; - typ_cstrs = cstrs; - typ_loc = sdecl.ptype_loc; - typ_manifest = tman; - typ_kind = tkind; - typ_private = sdecl.ptype_private; - typ_attributes = sdecl.ptype_attributes; - } + let decl = + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + in + let typ_shape = + let uid = decl.typ_type.type_uid in + let map = match decl.typ_kind with + | Ttype_variant cstrs -> Some (shape_map_cstrs cstrs) + | Ttype_record labels -> Some (shape_map_labels labels) + | Ttype_abstract | Ttype_open -> None + in + Option.map (Shape.str ~uid) map + (* Abstract types are just leafs *) + |> Option.value ~default:(Shape.leaf uid) + in + decl, typ_shape (* Generalize a type declaration *) @@ -848,10 +880,11 @@ let check_redefined_unit (td: Parsetree.type_declaration) = | _ -> () -let add_types_to_env decls env = - List.fold_right - (fun (id, decl) env -> add_type ~long_path:false ~check:true id decl env) - decls env +let add_types_to_env decls shapes env = + List.fold_right2 + (fun (id, decl) shape env -> + add_type ~long_path:false ~check:true ~shape id decl env) + decls shapes env (* Translate a set of type declarations, mutually recursive or not *) let transl_type_decl env rec_flag sdecl_list = @@ -917,13 +950,16 @@ let transl_type_decl env rec_flag sdecl_list = in let tdecls = List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in - let decls = - List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in + let decls, shapes = + List.map (fun (tdecl, tshape) -> (tdecl.typ_id, tdecl.typ_type), tshape) + tdecls + |> List.split + in current_slot := None; (* Check for duplicates *) check_duplicates sdecl_list; (* Build the final env. *) - let new_env = add_types_to_env decls env in + let new_env = add_types_to_env decls shapes env in (* Update stubs *) begin match rec_flag with | Asttypes.Nonrecursive -> () @@ -950,11 +986,12 @@ let transl_type_decl env rec_flag sdecl_list = check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id) decl to_check) decls; - List.iter - (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls; + List.iter (fun (decl, _shape) -> + check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check decl) + tdecls; (* Check that all type variables are closed *) List.iter2 - (fun sdecl tdecl -> + (fun sdecl (tdecl, _shape) -> let decl = tdecl.typ_type in match Ctype.closed_type_decl decl with Some ty -> @@ -981,18 +1018,18 @@ let transl_type_decl env rec_flag sdecl_list = raise (Error (loc, Separability err)) in (* Compute the final environment with variance and immediacy *) - let final_env = add_types_to_env decls env in + let final_env = add_types_to_env decls shapes env in (* Check re-exportation *) List.iter2 (check_abbrev final_env) sdecl_list decls; (* Keep original declaration *) let final_decls = List.map2 - (fun tdecl (_id2, decl) -> + (fun (tdecl, _shape) (_id2, decl) -> { tdecl with typ_type = decl } ) tdecls decls in (* Done *) - (final_decls, final_env) + (final_decls, final_env, shapes) (* Translating type extensions *) @@ -1101,12 +1138,22 @@ let transl_extension_constructor ~scope env type_path type_params ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } in + let ext_cstrs = { ext_id = id; ext_name = sext.pext_name; ext_type = ext; ext_kind = kind; Typedtree.ext_loc = sext.pext_loc; Typedtree.ext_attributes = sext.pext_attributes; } + in + let shape = + let map = match ext_cstrs.ext_kind with + | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls + | _ -> Shape.Map.empty + in + Shape.str ~uid:ext_cstrs.ext_type.ext_uid map + in + ext_cstrs, shape let transl_extension_constructor ~scope env type_path type_params typext_params priv sext = @@ -1183,13 +1230,13 @@ let transl_type_extension extend env loc styext = (* Generalize types *) List.iter Ctype.generalize type_params; List.iter - (fun ext -> + (fun (ext, _shape) -> Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; Option.iter Ctype.generalize ext.ext_type.ext_ret_type) constructors; (* Check that all type variables are closed *) List.iter - (fun ext -> + (fun (ext, _shape) -> match Ctype.closed_extension_constructor ext.ext_type with Some ty -> raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) @@ -1197,7 +1244,7 @@ let transl_type_extension extend env loc styext = constructors; (* Check variances are correct *) List.iter - (fun ext-> + (fun (ext, _shape) -> (* Note that [loc] here is distinct from [type_decl.type_loc], which makes the [loc] parameter to this function useful. [loc] is the location of the extension, while [type_decl] points to the original @@ -1210,11 +1257,13 @@ let transl_type_extension extend env loc styext = (* Add extension constructors to the environment *) let newenv = List.fold_left - (fun env ext -> + (fun env (ext, shape) -> let rebind = is_rebind ext in - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env) + Env.add_extension ~check:true ~shape ~rebind + ext.ext_id ext.ext_type env) env constructors in + let constructors, shapes = List.split constructors in let tyext = { tyext_path = type_path; tyext_txt = styext.ptyext_path; @@ -1224,7 +1273,7 @@ let transl_type_extension extend env loc styext = tyext_loc = styext.ptyext_loc; tyext_attributes = styext.ptyext_attributes; } in - (tyext, newenv) + (tyext, newenv, shapes) let transl_type_extension extend env loc styext = Builtin_attributes.warning_scope styext.ptyext_attributes @@ -1234,7 +1283,7 @@ let transl_exception env sext = let scope = Ctype.create_scope () in reset_type_variables(); Ctype.begin_def(); - let ext = + let ext, shape = transl_extension_constructor ~scope env Predef.path_exn [] [] Asttypes.Public sext in @@ -1250,13 +1299,13 @@ let transl_exception env sext = end; let rebind = is_rebind ext in let newenv = - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env + Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env in - ext, newenv + ext, newenv, shape let transl_type_exception env t = Builtin_attributes.check_no_alert t.ptyexn_attributes; - let contructor, newenv = + let contructor, newenv, shape = Builtin_attributes.warning_scope t.ptyexn_attributes (fun () -> transl_exception env t.ptyexn_constructor @@ -1264,7 +1313,7 @@ let transl_type_exception env t = in {tyexn_constructor = contructor; tyexn_loc = t.ptyexn_loc; - tyexn_attributes = t.ptyexn_attributes}, newenv + tyexn_attributes = t.ptyexn_attributes}, newenv, shape type native_repr_attribute = diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli index 0fb68edf42..cc4cf3fc80 100644 --- a/src/ocaml/typing/typedecl.mli +++ b/src/ocaml/typing/typedecl.mli @@ -20,19 +20,19 @@ open Format val transl_type_decl: Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> - Typedtree.type_declaration list * Env.t + Typedtree.type_declaration list * Env.t * Shape.t list val transl_exception: Env.t -> Parsetree.extension_constructor -> - Typedtree.extension_constructor * Env.t + Typedtree.extension_constructor * Env.t * Shape.t val transl_type_exception: Env.t -> - Parsetree.type_exception -> Typedtree.type_exception * Env.t + Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t val transl_type_extension: bool -> Env.t -> Location.t -> Parsetree.type_extension -> - Typedtree.type_extension * Env.t + Typedtree.type_extension * Env.t * Shape.t list val transl_value_decl: Env.t -> Location.t -> diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml index 19c3e15e83..2c270b0f61 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -18,6 +18,8 @@ open Asttypes open Types +module Uid = Shape.Uid + (* Value expressions for the core language *) type partial = Partial | Total @@ -53,9 +55,9 @@ and pat_extra = and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc - | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc | Tpat_alias : - value general_pattern * Ident.t * string loc -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc | Tpat_constant : constant -> value pattern_desc | Tpat_tuple : value general_pattern list -> value pattern_desc | Tpat_construct : @@ -291,6 +293,7 @@ and module_binding = { mb_id: Ident.t option; mb_name: string option loc; + mb_uid: Uid.t; mb_presence: module_presence; mb_expr: module_expr; mb_attributes: attribute list; @@ -370,6 +373,7 @@ and module_declaration = { md_id: Ident.t option; md_name: string option loc; + md_uid: Uid.t; md_presence: module_presence; md_type: module_type; md_attributes: attribute list; @@ -380,6 +384,7 @@ and module_substitution = { ms_id: Ident.t; ms_name: string loc; + ms_uid: Uid.t; ms_manifest: Path.t; ms_txt: Longident.t loc; ms_attributes: attributes; @@ -390,6 +395,7 @@ and module_type_declaration = { mtd_id: Ident.t; mtd_name: string loc; + mtd_uid: Uid.t; mtd_type: module_type option; mtd_attributes: attribute list; mtd_loc: Location.t; @@ -512,6 +518,7 @@ and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_uid: Uid.t; ld_mutable: mutable_flag; ld_type: core_type; ld_loc: Location.t; @@ -522,6 +529,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_uid: Uid.t; cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; @@ -630,6 +638,19 @@ type implementation = { shape: Shape.t; } +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration (* Auxiliary functions over the a.s.t. *) @@ -675,7 +696,7 @@ type pattern_action = let shallow_iter_pattern_desc : type k . pattern_action -> k pattern_desc -> unit = fun f -> function - | Tpat_alias(p, _, _) -> f.f p + | Tpat_alias(p, _, _, _) -> f.f p | Tpat_tuple patl -> List.iter f.f patl | Tpat_construct(_, _, patl, _) -> List.iter f.f patl | Tpat_variant(_, pat, _) -> Option.iter f.f pat @@ -695,8 +716,8 @@ type pattern_transformation = let shallow_map_pattern_desc : type k . pattern_transformation -> k pattern_desc -> k pattern_desc = fun f d -> match d with - | Tpat_alias (p1, id, s) -> - Tpat_alias (f.f p1, id, s) + | Tpat_alias (p1, id, s, uid) -> + Tpat_alias (f.f p1, id, s, uid) | Tpat_tuple pats -> Tpat_tuple (List.map f.f pats) | Tpat_record (lpats, closed) -> @@ -757,11 +778,11 @@ let rec iter_bound_idents : type k . _ -> k general_pattern -> _ = fun f pat -> match pat.pat_desc with - | Tpat_var (id,s) -> - f (id,s,pat.pat_type) - | Tpat_alias(p, id, s) -> + | Tpat_var (id, s, uid) -> + f (id,s,pat.pat_type, uid) + | Tpat_alias(p, id, s, uid) -> iter_bound_idents f p; - f (id,s,pat.pat_type) + f (id,s,pat.pat_type, uid) | Tpat_or(p1, _, _) -> (* Invariant : both arguments bind the same variables *) iter_bound_idents f p1 @@ -777,7 +798,7 @@ let rev_pat_bound_idents_full pat = !idents_full let rev_only_idents idents_full = - List.rev_map (fun (id,_,_) -> id) idents_full + List.rev_map (fun (id,_,_,_) -> id) idents_full let pat_bound_idents_full pat = List.rev (rev_pat_bound_idents_full pat) @@ -801,14 +822,14 @@ let alpha_var env id = List.assoc id env let rec alpha_pat : type k . _ -> k general_pattern -> k general_pattern = fun env p -> match p.pat_desc with - | Tpat_var (id, s) -> (* note the ``Not_found'' case *) + | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *) {p with pat_desc = - try Tpat_var (alpha_var env id, s) with + try Tpat_var (alpha_var env id, s, uid) with | Not_found -> Tpat_any} - | Tpat_alias (p1, id, s) -> + | Tpat_alias (p1, id, s, uid) -> let new_p : k general_pattern = alpha_pat env p1 in begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)} with | Not_found -> new_p end diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index fffc5186e4..e6e1324fd8 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -22,6 +22,7 @@ *) open Asttypes +module Uid = Shape.Uid (* Value expressions for the core language *) @@ -75,10 +76,10 @@ and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc (** _ *) - | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc (** x *) | Tpat_alias : - value general_pattern * Ident.t * string loc -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc (** P as a *) | Tpat_constant : constant -> value pattern_desc (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) @@ -437,6 +438,7 @@ and module_binding = { mb_id: Ident.t option; mb_name: string option loc; + mb_uid: Uid.t; mb_presence: Types.module_presence; mb_expr: module_expr; mb_attributes: attributes; @@ -515,6 +517,7 @@ and module_declaration = { md_id: Ident.t option; md_name: string option loc; + md_uid: Uid.t; md_presence: Types.module_presence; md_type: module_type; md_attributes: attributes; @@ -525,6 +528,7 @@ and module_substitution = { ms_id: Ident.t; ms_name: string loc; + ms_uid: Uid.t; ms_manifest: Path.t; ms_txt: Longident.t loc; ms_attributes: attributes; @@ -535,6 +539,7 @@ and module_type_declaration = { mtd_id: Ident.t; mtd_name: string loc; + mtd_uid: Uid.t; mtd_type: module_type option; mtd_attributes: attributes; mtd_loc: Location.t; @@ -659,6 +664,7 @@ and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_uid: Uid.t; ld_mutable: mutable_flag; ld_type: core_type; ld_loc: Location.t; @@ -669,6 +675,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_uid: Uid.t; cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; @@ -786,6 +793,23 @@ type implementation = { structure. *) +type item_declaration = +| Value of value_description +| Value_binding of value_binding +| Type of type_declaration +| Constructor of constructor_declaration +| Extension_constructor of extension_constructor +| Label of label_declaration +| Module of module_declaration +| Module_substitution of module_substitution +| Module_binding of module_binding +| Module_type of module_type_declaration +| Class of class_declaration +| Class_type of class_type_declaration +(** [item_declaration] groups together items that correspond to the syntactic + category of "declarations" which include types, values, modules, etc. + declarations in signatures and their definitions in implementations. *) + (* Auxiliary functions over the a.s.t. *) (** [as_computation_pattern p] is a computation pattern with description @@ -816,7 +840,9 @@ val exists_pattern: (pattern -> bool) -> pattern -> bool val let_bound_idents: value_binding list -> Ident.t list val let_bound_idents_full: - value_binding list -> (Ident.t * string loc * Types.type_expr) list + value_binding list -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list + (** Alpha conversion of patterns *) val alpha_pat: @@ -827,7 +853,8 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc val pat_bound_idents: 'k general_pattern -> Ident.t list val pat_bound_idents_full: - 'k general_pattern -> (Ident.t * string loc * Types.type_expr) list + 'k general_pattern -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 7020d7d3c1..612edf380e 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -1051,7 +1051,7 @@ end = struct let open Sig_component_kind in match component with | Value -> names.values - | Type -> names.types + | Type | Label | Constructor -> names.types | Module -> names.modules | Module_type -> names.modtypes | Extension_constructor -> names.typexts @@ -1388,7 +1388,6 @@ and transl_signature ?(keep_warnings = false) env sg = Typedecl.transl_value_decl env item.psig_loc sdesc in Signature_names.check_value names tdesc.val_loc tdesc.val_id; - Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; res with | (tdesc, newenv) -> @@ -1402,17 +1401,15 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_type (rec_flag, sdecls) -> begin match - let (decls, _) as res = + let (decls, _, _) as res = Typedecl.transl_type_decl env rec_flag sdecls in List.iter (fun td -> Signature_names.check_type names td.typ_loc td.typ_id; - if not (Btype.is_row_name (Ident.name td.typ_id)) then - Env.register_uid td.typ_type.type_uid td.typ_loc ) decls; res with - | (decls, newenv) -> + | (decls, newenv, _) -> let newenv = Env.update_short_paths newenv in let (trem, rem, final_env) = transl_sig newenv srem in let sg = @@ -1437,7 +1434,7 @@ and transl_signature ?(keep_warnings = false) env sg = once we have nice error messages there. *) raise (Error (td.ptype_loc, env, Invalid_type_subst_rhs)) ) sdecls; - let (decls, _) as res = + let (decls, _, _) as res = Typedecl.transl_type_decl env Nonrecursive sdecls in List.iter (fun td -> @@ -1453,12 +1450,11 @@ and transl_signature ?(keep_warnings = false) env sg = in Some (`Substituted_away subst) in - Signature_names.check_type ?info names td.typ_loc td.typ_id; - Env.register_uid td.typ_type.type_uid td.typ_loc + Signature_names.check_type ?info names td.typ_loc td.typ_id ) decls; res with - | (decls, newenv) -> + | (decls, newenv, _) -> let (trem, rem, final_env) = transl_sig newenv srem in let sg = rem in @@ -1471,17 +1467,16 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_typext styext -> begin match - let (tyext, _) as res = + let (tyext, _, _) as res = Typedecl.transl_type_extension false env item.psig_loc styext in let constructors = tyext.tyext_constructors in List.iter (fun ext -> - Signature_names.check_typext names ext.ext_loc ext.ext_id; - Env.register_uid ext.ext_type.ext_uid ext.ext_loc + Signature_names.check_typext names ext.ext_loc ext.ext_id ) constructors; res, constructors with - | (tyext, newenv), constructors -> + | (tyext, newenv, _), constructors -> let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_typext tyext) env loc :: trem, map_ext (fun es ext -> @@ -1494,16 +1489,13 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_exception sext -> begin match - let (ext, _) as res = Typedecl.transl_type_exception env sext in + let (ext, _, _) as res = Typedecl.transl_type_exception env sext in let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; - Env.register_uid - constructor.ext_type.ext_uid - constructor.ext_loc; res, constructor with - | (ext, newenv), constructor -> + | (ext, newenv, _), constructor -> let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception ext) env loc :: trem, Sig_typext(constructor.ext_id, @@ -1517,6 +1509,7 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_module pmd -> let scope = Ctype.create_scope () in + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in begin match let tmty = Builtin_attributes.warning_scope pmd.pmd_attributes @@ -1534,7 +1527,7 @@ and transl_signature ?(keep_warnings = false) env sg = md_type=tmty.mty_type; md_attributes=pmd.pmd_attributes; md_loc=pmd.pmd_loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + md_uid; } in let id, newenv = @@ -1542,15 +1535,14 @@ and transl_signature ?(keep_warnings = false) env sg = in let newenv = Env.update_short_paths newenv in Signature_names.check_module names pmd.pmd_name.loc id; - Env.register_uid md.md_uid md.md_loc; let sig_item = Sig_module(id, pres, md, Trec_not, Exported) in Some id, pres, newenv, Some sig_item, tmty with | (id, pres, newenv, sig_item, tmty) -> let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; - md_presence=pres; md_type=tmty; - md_loc=pmd.pmd_loc; + md_uid; md_presence=pres; + md_type=tmty; md_loc=pmd.pmd_loc; md_attributes=pmd.pmd_attributes}) env loc :: trem, (match sig_item with None -> rem | Some i -> i :: rem), @@ -1589,8 +1581,7 @@ and transl_signature ?(keep_warnings = false) env sg = `Substituted_away (Subst.add_module id path Subst.identity) in Signature_names.check_module ~info names pms.pms_name.loc id; - Env.register_uid md.md_uid md.md_loc; - (newenv, Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; + (newenv, Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; ms_uid=md.md_uid; ms_manifest=path; ms_txt=pms.pms_manifest; ms_loc=pms.pms_loc; ms_attributes=pms.pms_attributes}) @@ -1613,9 +1604,8 @@ and transl_signature ?(keep_warnings = false) env sg = | Some id -> Some (id, md, uid) ) tdecls in - List.iter (fun (id, md, uid) -> + List.iter (fun (id, md, _uid) -> Signature_names.check_module names md.md_loc id; - Env.register_uid uid md.md_loc ) decls; (tdecls, decls, newenv) with @@ -1640,7 +1630,6 @@ and transl_signature ?(keep_warnings = false) env sg = begin match transl_modtype_decl env pmtd with | newenv, mtd, decl -> Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid mtd.mtd_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype mtd) env loc :: trem, Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, @@ -1651,7 +1640,7 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_modtypesubst pmtd -> begin match transl_modtype_decl env pmtd with - | newenv, mtd, decl -> + | newenv, mtd, _decl -> let info = let mty = match mtd.mtd_type with | Some tmty -> tmty.mty_type @@ -1665,7 +1654,6 @@ and transl_signature ?(keep_warnings = false) env sg = | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) in Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid mtd.mtd_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtypesubst mtd) env loc :: trem, rem, @@ -1726,7 +1714,6 @@ and transl_signature ?(keep_warnings = false) env sg = Signature_names.check_class names loc cls.cls_id; Signature_names.check_class_type names loc cls.cls_ty_id; Signature_names.check_type names loc cls.cls_typesharp_id; - Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; ) classes; res with @@ -1762,9 +1749,6 @@ and transl_signature ?(keep_warnings = false) env sg = Signature_names.check_class_type names loc decl.clsty_ty_id; Signature_names.check_type names loc decl.clsty_obj_id; Signature_names.check_type names loc decl.clsty_typesharp_id; - Env.register_uid - decl.clsty_ty_decl.clty_uid - decl.clsty_ty_decl.clty_loc; ) classes; res with @@ -1834,6 +1818,7 @@ and transl_modtype_decl_aux env { mtd_id=id; mtd_name=pmtd_name; + mtd_uid=decl.mtd_uid; mtd_type=tmty; mtd_attributes=pmtd_attributes; mtd_loc=pmtd_loc; @@ -1916,11 +1901,11 @@ and transl_recmodule_modtypes env sdecls = List.map2 (fun pmd (id_shape, id_loc, md, mty) -> let tmd = {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; - md_presence=Mp_present; + md_uid=md.Types.md_uid; md_presence=Mp_present; md_loc=pmd.pmd_loc; md_attributes=pmd.pmd_attributes} in - tmd, md.md_uid, Option.map snd id_shape + tmd, md.Types.md_uid, Option.map snd id_shape ) sdecls dcl2 in (dcl2, env2) @@ -2110,6 +2095,7 @@ let check_recmodule_inclusion env bindings = { mb_id = id; mb_name = name; + mb_uid = uid; mb_presence = Mp_present; mb_expr = modl'; mb_attributes = attrs; @@ -2273,6 +2259,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = let shape = Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path in + let shape = if alias && aliasable then Shape.alias shape else shape in let md = if alias && aliasable then (Env.add_required_global (Path.head path); md) @@ -2626,10 +2613,9 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho will be marked as being used during the signature inclusion test. *) let items, shape_map = List.fold_left - (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)-> Signature_names.check_value names loc id; let vd = Env.find_value (Pident id) newenv in - Env.register_uid vd.val_uid vd.val_loc; Sig_value(id, vd, Exported) :: acc, Shape.Map.add_value shape_map id vd.val_uid ) @@ -2643,13 +2629,14 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho | Pstr_primitive sdesc -> let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in Signature_names.check_value names desc.val_loc desc.val_id; - Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val, Exported)], Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, newenv | Pstr_type (rec_flag, sdecls) -> - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + let (decls, newenv, shapes) = + Typedecl.transl_type_decl env rec_flag sdecls + in let newenv = Env.update_short_paths newenv in List.iter Signature_names.(fun td -> check_type names td.typ_loc td.typ_id) @@ -2658,32 +2645,26 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) decls [] in - let shape_map = List.fold_left - (fun shape_map -> function - | Sig_type (id, vd, _, _) -> - if not (Btype.is_row_name (Ident.name id)) then begin - Env.register_uid vd.type_uid vd.type_loc; - Shape.Map.add_type shape_map id vd.type_uid - end else shape_map - | _ -> assert false - ) + let shape_map = List.fold_left2 + (fun map { typ_id; _} shape -> + Shape.Map.add_type map typ_id shape) shape_map - items + decls + shapes in Tstr_type (rec_flag, decls), items, shape_map, enrich_type_decls anchor decls env newenv | Pstr_typext styext -> - let (tyext, newenv) = + let (tyext, newenv, shapes) = Typedecl.transl_type_extension true env loc styext in let constructors = tyext.tyext_constructors in - let shape_map = List.fold_left (fun shape_map ext -> + let shape_map = List.fold_left2 (fun shape_map ext shape -> Signature_names.check_typext names ext.ext_loc ext.ext_id; - Env.register_uid ext.ext_type.ext_uid ext.ext_loc; - Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid - ) shape_map constructors + Shape.Map.add_extcons shape_map ext.ext_id shape + ) shape_map constructors shapes in (Tstr_typext tyext, map_ext @@ -2692,13 +2673,10 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho shape_map, newenv) | Pstr_exception sext -> - let (ext, newenv) = Typedecl.transl_type_exception env sext in + let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; - Env.register_uid - constructor.ext_type.ext_uid - constructor.ext_loc; Tstr_exception ext, [Sig_typext(constructor.ext_id, constructor.ext_type, @@ -2706,7 +2684,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho Exported)], Shape.Map.add_extcons shape_map constructor.ext_id - constructor.ext_type.ext_uid, + shape, newenv | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; @@ -2734,7 +2712,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho } in let md_shape = Shape.set_uid_if_none md_shape md_uid in - Env.register_uid md_uid pmb_loc; (*prerr_endline (Ident.unique_toplevel_name id);*) Mtype.lower_nongen outer_scope md.md_type; let id, newenv, sg = @@ -2758,8 +2735,9 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho | Some id -> Shape.Map.add_module shape_map id md_shape | None -> shape_map in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, + Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid; + mb_expr=modl; mb_presence=pres; mb_attributes=attrs; + mb_loc=pmb_loc; }, sg, shape_map, newenv @@ -2834,8 +2812,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho ) bindings2 in let shape_map = - List.fold_left (fun map (id, mb, uid, shape) -> - Env.register_uid uid mb.mb_loc; + List.fold_left (fun map (id, _mb, _uid, shape) -> Shape.Map.add_module map id shape ) shape_map mbs in @@ -2855,7 +2832,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho let newenv, mtd, decl = transl_modtype_decl env pmtd in let newenv = Env.update_short_paths newenv in Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid decl.mtd_loc; let id = mtd.mtd_id in let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv @@ -2875,12 +2851,12 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho Signature_names.check_class_type names loc cls.cls_ty_id; Signature_names.check_type names loc cls.cls_obj_id; Signature_names.check_type names loc cls.cls_typesharp_id; - Env.register_uid cls.cls_decl.cty_uid loc; - let map f id acc = f acc id cls.cls_decl.cty_uid in - map Shape.Map.add_class cls.cls_id acc - |> map Shape.Map.add_class_type cls.cls_ty_id - |> map Shape.Map.add_type cls.cls_obj_id - |> map Shape.Map.add_type cls.cls_typesharp_id + let uid = cls.cls_decl.cty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class cls.cls_id uid acc + |> map Shape.Map.add_class_type cls.cls_ty_id uid + |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid) + |> map Shape.Map.add_type cls.cls_typesharp_id (Shape.leaf uid) ) shape_map classes in Tstr_class @@ -2907,11 +2883,11 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho Signature_names.check_class_type names loc decl.clsty_ty_id; Signature_names.check_type names loc decl.clsty_obj_id; Signature_names.check_type names loc decl.clsty_typesharp_id; - Env.register_uid decl.clsty_ty_decl.clty_uid loc; - let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in - map Shape.Map.add_class_type decl.clsty_ty_id acc - |> map Shape.Map.add_type decl.clsty_obj_id - |> map Shape.Map.add_type decl.clsty_typesharp_id + let uid = decl.clsty_ty_decl.clty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class_type decl.clsty_ty_id uid acc + |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid) + |> map Shape.Map.add_type decl.clsty_typesharp_id (Shape.leaf uid) ) shape_map classes in Tstr_class_type @@ -3185,7 +3161,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = let simple_sg = Signature_names.simplify finalenv names sg in if !Clflags.print_types then begin Typecore.force_delayed_checks (); - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in Printtyp.wrap_printing_env ~error:false initial_env (fun () -> fprintf std_formatter "%a@." (Printtyp.printed_signature sourcefile) simple_sg @@ -3214,7 +3190,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported are not reported as being unused. *) - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in let annots = Cmt_format.Implementation str in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename annots (Some sourcefile) initial_env None (Some shape); @@ -3237,7 +3213,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in if not !Clflags.dont_write_files then begin let alerts = Builtin_attributes.alerts_of_str ast in let cmi = diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index 6f4075882b..46705e7609 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -76,6 +76,8 @@ module Sig_component_kind : sig type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml index a3fbeaf9d1..642758d10d 100644 --- a/src/ocaml/typing/untypeast.ml +++ b/src/ocaml/typing/untypeast.ml @@ -298,7 +298,8 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> match pat with { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } -> Ppat_unpack { txt = None; loc } - | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> + | { pat_extra=[Tpat_unpack, _, _attrs]; + pat_desc = Tpat_var (_,name, _); _ } -> Ppat_unpack { name with txt = Some name.txt } | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type (map_loc sub lid) @@ -308,7 +309,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | _ -> match pat.pat_desc with Tpat_any -> Ppat_any - | Tpat_var (id, name) -> + | Tpat_var (id, name, _) -> begin match (Ident.name id).[0] with 'A'..'Z' -> @@ -321,11 +322,11 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> The compiler transforms (x:t) into (_ as x : t). This avoids transforming a warning 27 into a 26. *) - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _) when pat_loc = pat.pat_loc -> Ppat_var name - | Tpat_alias (pat, _id, name) -> + | Tpat_alias (pat, _id, name, _) -> Ppat_alias (sub.pat sub pat, name) | Tpat_constant cst -> Ppat_constant (constant cst) | Tpat_tuple list -> @@ -789,7 +790,7 @@ let core_type sub ct = let class_structure sub cs = let rec remove_self = function - | { pat_desc = Tpat_alias (p, id, _s) } + | { pat_desc = Tpat_alias (p, id, _s, _) } when string_is_prefix "selfpat-" (Ident.name id) -> remove_self p | p -> p @@ -819,7 +820,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} = Of.mk ~loc ~attrs desc and is_self_pat = function - | { pat_desc = Tpat_alias(_pat, id, _) } -> + | { pat_desc = Tpat_alias(_pat, id, _, _) } -> string_is_prefix "self-" (Ident.name id) | _ -> false diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml index 2c4bd6631e..ed727351d0 100644 --- a/src/ocaml/utils/clflags.ml +++ b/src/ocaml/utils/clflags.ml @@ -25,6 +25,7 @@ let open_modules = ref [] let annotations = ref false let binary_annotations = ref true +let store_occurrences = ref true let print_types = ref false let native_code = ref false let error_size = ref 500 diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli index e06b7a4c6b..de4666e087 100644 --- a/src/ocaml/utils/clflags.mli +++ b/src/ocaml/utils/clflags.mli @@ -23,6 +23,7 @@ val open_modules : string list ref Ignored by merlin but kept for compatibility with upstream code. *) val annotations : bool ref val binary_annotations : bool ref +val store_occurrences : bool ref val print_types : bool ref val native_code : bool ref val dont_write_files : bool ref diff --git a/src/utils/misc.ml b/src/utils/misc.ml index 1c1c2f4093..3b5de7927e 100644 --- a/src/utils/misc.ml +++ b/src/utils/misc.ml @@ -271,9 +271,9 @@ let find_in_path_uncap ?(fallback="") path name = then Some (Filename.concat dirname uname) else if exact_file_exists ~dirname ~basename:name then Some (Filename.concat dirname name) - else - let () = Logger.log - ~section:"locate" + else + let () = Logger.log + ~section:"find-file" ~title:"find_in_path_uncap" "Failed to load %s/%s" dirname name in diff --git a/src/utils/stamped_hashtable.ml b/src/utils/stamped_hashtable.ml index d5dd9aad03..d741531fcd 100644 --- a/src/utils/stamped_hashtable.ml +++ b/src/utils/stamped_hashtable.ml @@ -42,12 +42,20 @@ let add {table; changelog} ?stamp key value = | Some stamp -> changelog.recent <- Cell {stamp; key; table} :: changelog.recent +let replace t k v = + Hashtbl.replace t.table k v + let mem t a = Hashtbl.mem t.table a let find t a = Hashtbl.find t.table a +let clear t = + Hashtbl.clear t.table; + t.changelog.recent <- []; + t.changelog.sorted <- [] + (* Implementation of backtracking *) (* Helper to sort by decreasing stamps *) diff --git a/src/utils/stamped_hashtable.mli b/src/utils/stamped_hashtable.mli index 40c3386333..78fcd8b3e8 100644 --- a/src/utils/stamped_hashtable.mli +++ b/src/utils/stamped_hashtable.mli @@ -34,9 +34,16 @@ val mem : ('a, 'b) t -> 'a -> bool val find : ('a, 'b) t -> 'a -> 'b (** See [Hashtbl.find]. *) +val clear : ('a, 'b) t -> unit +(** Clear the table and empty the changelog. See [Hashtbl.clear]. *) + val create_changelog : unit -> changelog (** Create a new change log. *) (* [backtrack changelog ~stamp] remove all items added to tables logging to [changelog] with a stamp strictly greater than [stamp] *) val backtrack : changelog -> stamp:int -> unit + +val replace : ('a, 'b) t -> 'a -> 'b -> unit +(** This operation is unsafe in general. Only replacements that does not imply + re-stamping are safe. *) diff --git a/src/utils/std.ml b/src/utils/std.ml index 0031c04b04..cfcdcc509a 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -343,9 +343,7 @@ module Option = struct end module Result = struct - type ('a, 'e) t = ('a, 'e) result = - | Ok of 'a - | Error of 'e + include Result let map ~f r = Result.map f r let bind ~f r = Result.bind r f diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index b9ae8c7eee..f1c485a8d9 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -51,6 +51,8 @@ } ], "stdlib": null, + "index_file": null, + "unit_name": null, "reader": [], "protocol": "json", "log_file": null, diff --git a/tests/test-dirs/document/issue1513.t b/tests/test-dirs/document/issue1513.t index 245bfed984..50fdeca695 100644 --- a/tests/test-dirs/document/issue1513.t +++ b/tests/test-dirs/document/issue1513.t @@ -16,12 +16,10 @@ Merlin should show comments for a type's constructor from another module: $ $OCAMLC -c -bin-annot naux.ml -FIXME: We should not rely on "fallbacking". This requires a compiler change. +We should not rely on "fallbacking". This requires a compiler change. $ $MERLIN single document -position 1:13 \ - > -log-file - -log-section locate \ - > -filename main.ml &1 | - > grep "Uid not found in the table." - Uid not found in the table. + > -filename main.ml -filename ./other_module.ml < ./other_module.ml | jq '.value' { "file": "$TESTCASE_ROOT/record.ml", "pos": { "line": 1, - "col": 0 + "col": 11 } } diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t index 34e4cce900..3e01314838 100644 --- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t +++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t @@ -7,7 +7,7 @@ Trying them all: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } }, "notifications": [] @@ -20,7 +20,7 @@ Trying them all: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 3, - "col": 0 + "col": 12 } }, "notifications": [] @@ -33,24 +33,18 @@ Trying them all: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 7, - "col": 0 + "col": 12 } }, "notifications": [] } -FIXME this should say "Already at definition point" (we're defining the label): +This should say "Already at definition point" (we're defining the label): $ $MERLIN single locate -look-for ml -position 13:12 -filename ./test.ml < ./test.ml { "class": "return", - "value": { - "file": "$TESTCASE_ROOT/test.ml", - "pos": { - "line": 5, - "col": 4 - } - }, + "value": "Already at definition point", "notifications": [] } @@ -61,7 +55,7 @@ FIXME this should say "Already at definition point" (we're defining the label): "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 5 } }, "notifications": [] @@ -96,7 +90,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 5 } }, "notifications": [] @@ -109,7 +103,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } }, "notifications": [] @@ -122,7 +116,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 11, - "col": 0 + "col": 10 } }, "notifications": [] @@ -151,7 +145,7 @@ FIXME this should jump to line 11: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 13, - "col": 0 + "col": 11 } }, "notifications": [] @@ -177,7 +171,7 @@ FIXME this should jump to line 11: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 13, - "col": 0 + "col": 11 } }, "notifications": [] diff --git a/tests/test-dirs/locate/f-alias.t b/tests/test-dirs/locate/f-alias.t new file mode 100644 index 0000000000..8cc301cd0d --- /dev/null +++ b/tests/test-dirs/locate/f-alias.t @@ -0,0 +1,44 @@ + $ cat >main.ml <<'EOF' + > module Id(X : sig end) = X + > module F (X :sig end ) : + > sig module M : sig end end = + > struct module M = X end + > module N = struct end + > module Z = F(Id(N)) + > + > include Z.M + > EOF + + $ $MERLIN single locate -look-for ml -position 8:11 \ + > -filename main.ml main.ml <<'EOF' + > module M = struct end + > module N = M + > module O = N + > EOF + + $ $MERLIN single locate -look-for ml -position 3:11 \ + > -filename main.ml main.ml <<'EOF' + > module M : sig + > module F (X : sig end) : sig end + > end = struct + > module F (X : sig end) = X + > end + > module X = struct end + > module N = M.F (X) + > + > include N + > EOF + + $ $MERLIN single locate -look-for ml -position 9:8 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/main.ml", + "pos": { + "line": 7, + "col": 7 + } + } + + $ $MERLIN single occurrences -identifier-at 9:8 \ + > -filename ./main.ml < ./main.ml | jq '.value' | grep line | uniq + "line": 7, + "line": 9, diff --git a/tests/test-dirs/locate/functors/f-all_local.t/run.t b/tests/test-dirs/locate/functors/f-all_local.t/run.t index 1cb47dc635..835e9981c5 100644 --- a/tests/test-dirs/locate/functors/f-all_local.t/run.t +++ b/tests/test-dirs/locate/functors/f-all_local.t/run.t @@ -7,7 +7,7 @@ Check that we can jump locally inside the functor: "file": "$TESTCASE_ROOT/all_local.ml", "pos": { "line": 12, - "col": 2 + "col": 7 } }, "notifications": [] @@ -38,7 +38,7 @@ Check that we can jump from inside the functor to the (sig of the) parameter: "file": "$TESTCASE_ROOT/all_local.ml", "pos": { "line": 2, - "col": 2 + "col": 7 } }, "notifications": [] @@ -53,7 +53,7 @@ Check the argument is substituted for the parameter "file": "$TESTCASE_ROOT/all_local.ml", "pos": { "line": 6, - "col": 2 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-from_application.t/run.t b/tests/test-dirs/locate/functors/f-from_application.t/run.t index 37624dbcb5..c28cb0493e 100644 --- a/tests/test-dirs/locate/functors/f-from_application.t/run.t +++ b/tests/test-dirs/locate/functors/f-from_application.t/run.t @@ -8,7 +8,7 @@ FIXME: we confuse the module for the constructor and jump to the wrong place "file": "$TESTCASE_ROOT/from_application.ml", "pos": { "line": 5, - "col": 0 + "col": 7 } }, "notifications": [] @@ -23,7 +23,7 @@ Jump from inside the functor application to inside the functor application: "file": "$TESTCASE_ROOT/from_application.ml", "pos": { "line": 14, - "col": 4 + "col": 9 } }, "notifications": [] @@ -38,7 +38,7 @@ Jump from inside the functor application to the outer scope: "file": "$TESTCASE_ROOT/from_application.ml", "pos": { "line": 9, - "col": 0 + "col": 5 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-generative.t/run.t b/tests/test-dirs/locate/functors/f-generative.t/run.t index 28de85ca5d..e8d473b0a4 100644 --- a/tests/test-dirs/locate/functors/f-generative.t/run.t +++ b/tests/test-dirs/locate/functors/f-generative.t/run.t @@ -7,7 +7,7 @@ Check that we handle generative functors properly: "file": "$TESTCASE_ROOT/generative.ml", "pos": { "line": 3, - "col": 2 + "col": 6 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t index 99b22601c9..40f8de69df 100644 --- a/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t +++ b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t @@ -22,7 +22,7 @@ Reproduce bug described (and fixed) in commit e558d203334fd06f7653a6388b46dba895 "file": "$TESTCASE_ROOT/missed_shadowing.ml", "pos": { "line": 7, - "col": 0 + "col": 12 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-nested_applications.t/run.t b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t index 0d933368c3..3977c4d0ca 100644 --- a/tests/test-dirs/locate/functors/f-nested_applications.t/run.t +++ b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t @@ -7,7 +7,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -21,7 +21,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -35,7 +35,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -49,7 +49,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -63,7 +63,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-test-ml-mli.t b/tests/test-dirs/locate/functors/f-test-ml-mli.t index 35d27170b3..bffd012ce7 100644 --- a/tests/test-dirs/locate/functors/f-test-ml-mli.t +++ b/tests/test-dirs/locate/functors/f-test-ml-mli.t @@ -34,7 +34,7 @@ Should jump to mySet.ml: "file": "$TESTCASE_ROOT/mySet.ml", "pos": { "line": 2, - "col": 2 + "col": 7 } } @@ -45,6 +45,6 @@ Should jump to mySet.mli: "file": "$TESTCASE_ROOT/mySet.mli", "pos": { "line": 2, - "col": 2 + "col": 7 } } diff --git a/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t b/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t index d844c52eb1..7427839f88 100644 --- a/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t +++ b/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t @@ -1,12 +1,18 @@ $ dune build @check -FIXME: When the deifinition is in one of the implicit transitive dependencies -Merlin does not found the file in the source path provided by Dune. One possible -fix would be for Dune to provide additional source path for "externatl" deps. +When the definition is in one of the implicit transitive dependencies +Merlin does not find the file in the source path provided by Dune. One possible +fix would be for Dune to provide additional source path for "external" deps. $ $MERLIN single locate -look-for ml -position 1:15 \ > -filename bin/main.ml val foo : int > EOF - $ dune build + $ dune build @check Jump to interface: $ $MERLIN single locate -look-for mli -position 1:16 \ @@ -27,18 +27,17 @@ Jump to interface: "file": "$TESTCASE_ROOT/test2.mli", "pos": { "line": 1, - "col": 0 + "col": 4 } } Jump to definition: -FIXME: it should jump to the ml file $ $MERLIN single locate -look-for ml -position 1:16 \ > -filename test.ml -filename ./main.ml < ./main.ml | jq '.value.pos' { "line": 2, - "col": 2 + "col": 14 } $ $MERLIN single locate -look-for ml -position 7:13 \ > -filename ./main.ml < ./main.ml | jq '.value.pos' { "line": 2, - "col": 2 + "col": 14 } @@ -29,5 +29,5 @@ > -filename ./main.ml < ./main.ml | jq '.value.pos' { "line": 2, - "col": 2 + "col": 14 } diff --git a/tests/test-dirs/locate/issue802.t/run.t b/tests/test-dirs/locate/issue802.t/run.t index 73505e98d8..9f32717e42 100644 --- a/tests/test-dirs/locate/issue802.t/run.t +++ b/tests/test-dirs/locate/issue802.t/run.t @@ -15,7 +15,7 @@ Test jumping from a normal constructor: "file": "$TESTCASE_ROOT/error.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } }, "notifications": [] @@ -30,7 +30,7 @@ From an exception: "file": "$TESTCASE_ROOT/error.ml", "pos": { "line": 3, - "col": 0 + "col": 10 } }, "notifications": [] @@ -60,7 +60,7 @@ And from the extensible type name itself: "file": "$TESTCASE_ROOT/error.ml", "pos": { "line": 5, - "col": 0 + "col": 5 } }, "notifications": [] diff --git a/tests/test-dirs/locate/issue845.t/run.t b/tests/test-dirs/locate/issue845.t/run.t index 3dafe6f83b..5dcc18ec66 100644 --- a/tests/test-dirs/locate/issue845.t/run.t +++ b/tests/test-dirs/locate/issue845.t/run.t @@ -22,7 +22,7 @@ FIXME: this jumps to the .mli... "file": "$TESTCASE_ROOT/local_map.ml", "pos": { "line": 1, - "col": 0 + "col": 7 } }, "notifications": [] @@ -39,7 +39,7 @@ Test jumping to intf: "file": "$TESTCASE_ROOT/local_map.mli", "pos": { "line": 1, - "col": 0 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/l-413-features.t b/tests/test-dirs/locate/l-413-features.t index 95682571fc..7de71cff21 100644 --- a/tests/test-dirs/locate/l-413-features.t +++ b/tests/test-dirs/locate/l-413-features.t @@ -58,7 +58,7 @@ Module types substitutions "file": "$TESTCASE_ROOT/mtsubst.ml", "pos": { "line": 5, - "col": 19 + "col": 31 } }, "notifications": [] @@ -86,7 +86,7 @@ Module types substitutions "file": "$TESTCASE_ROOT/mtsubst.ml", "pos": { "line": 5, - "col": 19 + "col": 31 } }, "notifications": [] diff --git a/tests/test-dirs/locate/local-build-scheme.t b/tests/test-dirs/locate/local-build-scheme.t index eae49fc8fe..a444f64b4c 100644 --- a/tests/test-dirs/locate/local-build-scheme.t +++ b/tests/test-dirs/locate/local-build-scheme.t @@ -42,7 +42,7 @@ "file": "experimental", "pos": { "line": 1, - "col": 20 + "col": 24 } } diff --git a/tests/test-dirs/locate/local-locate.t b/tests/test-dirs/locate/local-locate.t new file mode 100644 index 0000000000..eeb3ae8033 --- /dev/null +++ b/tests/test-dirs/locate/local-locate.t @@ -0,0 +1,17 @@ + $ cat >main.ml < let _ = let x = 42 in x + > EOF + + $ $MERLIN single locate -look-for ml -position 1:22 \ + > -filename main.ml -filename main.ml constr.mli < type t = A of int | B + > type u = { label_a : int } + > EOF + + $ cat >constr.ml < type u = { label_a : int } + > type t = A of int | B + > let foo : t = A 42 + > EOF + + $ cat >main.ml < let foo : Constr.t = Constr.A 42 + > let bar : Constr.u = { Constr.label_a = 42 } + > EOF + + $ $OCAMLC -c -bin-annot -bin-annot-occurrences constr.mli constr.ml + + $ $MERLIN single locate -look-for mli -position 1:28 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/constr.mli", + "pos": { + "line": 1, + "col": 9 + } + } + + $ $MERLIN single locate -look-for ml -position 1:28 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/constr.ml", + "pos": { + "line": 2, + "col": 9 + } + } + + $ $MERLIN single locate -look-for mli -position 2:30 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/constr.mli", + "pos": { + "line": 2, + "col": 11 + } + } + + $ $MERLIN single locate -look-for ml -position 2:30 \ + > -filename ./main.ml < ./main.ml | jq '.value' + { + "file": "$TESTCASE_ROOT/constr.ml", + "pos": { + "line": 1, + "col": 11 + } + } + + $ cat >main.ml < module Constr : sig + > type t = A of int | B + > type u = { label_a : int } + > end = struct + > type u = { label_a : int } + > type t = A of int | B + > end + > let foo : Constr.t = Constr.A 42 + > let bar : Constr.u = { Constr.label_a = 42 } + > EOF + + $ $MERLIN single locate -look-for mli -position 8:28 \ + > -filename ./main.ml < ./main.ml | jq '.value.pos' + { + "line": 2, + "col": 11 + } + + $ $MERLIN single locate -look-for ml -position 8:28 \ + > -filename ./main.ml < ./main.ml | jq '.value.pos' + { + "line": 6, + "col": 11 + } + + + $ $MERLIN single locate -look-for mli -position 9:30 \ + > -filename ./main.ml < ./main.ml | jq '.value.pos' + { + "line": 3, + "col": 13 + } + + $ $MERLIN single locate -look-for ml -position 9:30 \ + > -filename ./main.ml < ./main.ml | jq '.value.pos' + { + "line": 5, + "col": 13 + } diff --git a/tests/test-dirs/locate/locate-constrs.t b/tests/test-dirs/locate/locate-constrs.t index 6df036bc09..06024a93b6 100644 --- a/tests/test-dirs/locate/locate-constrs.t +++ b/tests/test-dirs/locate/locate-constrs.t @@ -17,7 +17,6 @@ } } -FIXME: this is not a very satisfying answer. We could expect 1:9 $ $MERLIN single locate -look-for ml -position 2:14 \ > -filename ./constr.ml < ./constr.ml | jq '.value' @@ -25,7 +24,7 @@ We could expect 1:9 "file": "$TESTCASE_ROOT/constr.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } } @@ -42,7 +41,7 @@ With the declaration in another compilation unit: "file": "$TESTCASE_ROOT/constr.ml", "pos": { "line": 1, - "col": 18 + "col": 21 } } diff --git a/tests/test-dirs/locate/module-aliases.t/run.t b/tests/test-dirs/locate/module-aliases.t/run.t index 5eac85a908..8b1d56a598 100644 --- a/tests/test-dirs/locate/module-aliases.t/run.t +++ b/tests/test-dirs/locate/module-aliases.t/run.t @@ -49,7 +49,7 @@ Jump to the declaration of an element of an alisaed module `A.|f`: "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } } @@ -128,7 +128,7 @@ Jump from to another module value decl `Anothermod.|a`: "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 2, - "col": 0 + "col": 5 } } @@ -139,7 +139,7 @@ Jump from to another module value def `Anothermod.|a`: "file": "$TESTCASE_ROOT/anothermod.ml", "pos": { "line": 2, - "col": 0 + "col": 5 } } @@ -151,7 +151,7 @@ Jump to the declaration of an element of an alisaed module `A.|f`: "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } } diff --git a/tests/test-dirs/locate/module-decl-aliases.t b/tests/test-dirs/locate/module-decl-aliases.t index 0d297716e1..c1b66ff728 100644 --- a/tests/test-dirs/locate/module-decl-aliases.t +++ b/tests/test-dirs/locate/module-decl-aliases.t @@ -25,7 +25,7 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 6, - "col": 2 + "col": 9 } } @@ -35,7 +35,7 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 2, - "col": 2 + "col": 9 } } $ $MERLIN single locate -look-for ml -position 2:10 \ @@ -44,7 +44,7 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 6, - "col": 2 + "col": 9 } } @@ -54,6 +54,6 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 2, - "col": 2 + "col": 9 } } diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t index 3a0fc89d37..2f257adbfa 100644 --- a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t +++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t @@ -19,9 +19,10 @@ available: "notifications": [] } - $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d' - Loading the cmt for unit "A" - Looking for A.0 in the uid_to_loc table + $ grep -A1 -e from_path -e find_loc_of_uid log | + > grep -v -e from_path -e find_loc_of_uid | sed '/^--$/d' + Loading the cmt file for unit "A" + Shapes successfully loaded, looking for A.0 Found location: File "a.ml", line 1, characters 4-9 $ rm log @@ -40,9 +41,10 @@ available: "notifications": [] } - $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d' - Loading the cmt for unit "A" - Looking for A.0 in the uid_to_loc table + $ grep -A1 -e from_path -e find_loc_of_uid log | + > grep -v -e from_path -e find_loc_of_uid | sed '/^--$/d' + Loading the cmt file for unit "A" + Shapes successfully loaded, looking for A.0 Found location: File "a.ml", line 1, characters 4-9 $ rm log @@ -65,10 +67,11 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense: "notifications": [] } - $ grep -A1 from_uid log | grep -v from_uid - Loading the cmt for unit "A" - -- - Failed to load the cmt file. - Fallbacking to lookup location: File "a.ml", line 1, characters 4-9 + $ grep -A1 -e from_path -e find_loc_of_uid log | + > grep -v -e from_path -e find_loc_of_uid + No definition uid, falling back to the declaration uid: A.0 + Loading the cmt file for unit "A" + Failed to load the cmt file + Falling back to the declaration's location: File "a.ml", line 1, characters 4-9 $ rm log diff --git a/tests/test-dirs/locate/non-local/preference.t/run.t b/tests/test-dirs/locate/non-local/preference.t/run.t index 181bcda82d..404f51bf20 100644 --- a/tests/test-dirs/locate/non-local/preference.t/run.t +++ b/tests/test-dirs/locate/non-local/preference.t/run.t @@ -51,7 +51,7 @@ Test that Locate.locate and Locate.from_path do their job properly: "file": "$TESTCASE_ROOT/a.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } }, "notifications": [] @@ -64,7 +64,7 @@ Test that Locate.locate and Locate.from_path do their job properly: "file": "$TESTCASE_ROOT/a.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } }, "notifications": [] @@ -77,7 +77,7 @@ Test that Locate.locate and Locate.from_path do their job properly: "file": "$TESTCASE_ROOT/a.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } }, "notifications": [] diff --git a/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t index c73c509066..c1bc158677 100644 --- a/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t +++ b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t @@ -7,7 +7,7 @@ Regression test for #624 "file": "$TESTCASE_ROOT/off_by_one.ml", "pos": { "line": 1, - "col": 0 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/sig-substs.t/run.t b/tests/test-dirs/locate/sig-substs.t/run.t index 292826a7f4..882968144e 100644 --- a/tests/test-dirs/locate/sig-substs.t/run.t +++ b/tests/test-dirs/locate/sig-substs.t/run.t @@ -9,13 +9,12 @@ when both are present in the buffer (the struct will always be preferred). "file": "$TESTCASE_ROOT/basic.ml", "pos": { "line": 8, - "col": 2 + "col": 9 } }, "notifications": [] } -TODO SHAPES: it could be more precise by answering 8:21 $ $MERLIN single locate -look-for ml -position 10:13 -filename ./basic.ml < ./basic.ml { "class": "return", @@ -23,7 +22,7 @@ TODO SHAPES: it could be more precise by answering 8:21 "file": "$TESTCASE_ROOT/basic.ml", "pos": { "line": 8, - "col": 2 + "col": 25 } }, "notifications": [] diff --git a/tests/test-dirs/locate/without-implem.t b/tests/test-dirs/locate/without-implem.t index 7b5c06db64..3028f0f892 100644 --- a/tests/test-dirs/locate/without-implem.t +++ b/tests/test-dirs/locate/without-implem.t @@ -18,6 +18,7 @@ $ dune build ./main.exe 2> /dev/null +Definition of t $ $MERLIN single locate -look-for ml -position 1:16 \ > -filename main.ml -filename main.ml -filename main.ml -filename main.ml main.ml let f = function + > | Unix.WEXITED n -> n + > | _ -> 0 + > EOF + + $ $MERLIN single occurrences -identifier-at 2:17 -filename main.ml main.ml let f = function + > | { Unix.st_ino = n; _ } when true -> n + > | { Unix.st_ino = n; _ } -> n + > | _ -> 0 + > EOF + + $ $MERLIN single occurrences -identifier-at 2:14 -filename main.ml main.ml <<'EOF' + > module M : sig + > type t = A of { label_a : int } + > end = struct + > type t = A of { label_a : int } + > let _ = A { label_a = 1 } + > end + > + > let _ = M.A { label_a = 1 } + > + > open M + > + > let _ = A { label_a = 1 } + > EOF + +Constructor declaration: + $ $MERLIN single locate -look-for mli -position 12:8 \ + > -filename main.ml -filename main.ml -filename main.ml -filename main.ml -filename main.ml -filename main.ml main.ml <<'EOF' + > type t = { a : int; b : float } + > let _ = { a = 4; b = 2.0 } + > let a = 4 + > let r = { a; b = 2.0 } + > let _ = { r with b = 2.0 } + > let { a; b } = r + > EOF + + $ $MERLIN single occurrences -identifier-at 6:15 \ + > -filename main.ml -filename main.ml lib.ml <<'EOF' + > let something_fun () = print_string "fun";; + > let g = something_fun + > EOF + + $ cat >main.ml <<'EOF' + > let () = Lib.something_fun () + > EOF + + $ $OCAMLC -c -bin-annot -bin-annot-occurrences - lib.ml main.ml + $ ocaml-index aggregate --root ${PWD} lib.cmt main.cmt -o project.index + + $ cat >.merlin <<'EOF' + > INDEX_FILE project.index + > B . + > EOF + +FIXME: remove duplicates + $ $MERLIN single occurrences -scope project -identifier-at 1:16 \ + > -filename main.ml -filename lib.ml -filename lib.ml main.ml <<'EOF' + > let _ = Bytes.create 0 + > let _ = Bytes.create 0 + > EOF + +We shouldn't return the definition when it's not in the current workspace + $ $MERLIN single occurrences -scope project -identifier-at 2:17 \ + > -filename main.ml | _ -> 0 > EOF -FIXME: we can do better than that $ $MERLIN single occurrences -identifier-at 5:2 \ - > -log-file - -log-section occurrences \ > -filename main.ml main.ml < type t = { lbl_a : int } + > let f (x : t) = match x with + > | { lbl_a } -> ignore lbl_a + > EOF + + + $ $MERLIN single occurrences -identifier-at 3:8 -scope project \ + > -filename main.ml main.ml <<'EOF' + > module Client (P : sig + > val url : string + > end) = + > struct + > let url = P.url + > let url2 = P.url + > end + > EOF + +There are two usages of P.url + $ $MERLIN single occurrences -identifier-at 6:17 \ + > -filename main.ml jq '.value' > let x = 3 and y = 4 + 2 in @@ -40,21 +40,21 @@ FIXME occurrences identifier-at 2:1 returns the occurrences of [x] (should be [+ { "start": { "line": 1, - "col": 4 + "col": 20 }, "end": { "line": 1, - "col": 5 + "col": 21 } }, { "start": { "line": 2, - "col": 0 + "col": 1 }, "end": { "line": 2, - "col": 1 + "col": 2 } } ] @@ -84,6 +84,6 @@ locate position 2:1 returns the definition of [(+)] "file": "lib/ocaml/stdlib.mli", "pos": { "line": 347, - "col": 0 + "col": 9 } } diff --git a/tests/test-dirs/occurrences/issue1410.t b/tests/test-dirs/occurrences/issue1410.t index 27922260d4..65e4e27ad5 100644 --- a/tests/test-dirs/occurrences/issue1410.t +++ b/tests/test-dirs/occurrences/issue1410.t @@ -1,7 +1,4 @@ -FIXME - -First result is incorrect when in the body of a function with an optional argument - +No result is returned, we could expect the one occurrence of None. $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml < jq '.value' > (* test case *) @@ -9,16 +6,6 @@ First result is incorrect when in the body of a function with an optional argume > None > EOF [ - { - "start": { - "line": 0, - "col": -1 - }, - "end": { - "line": 0, - "col": -1 - } - }, { "start": { "line": 3, diff --git a/tests/test-dirs/occurrences/issue827.t/run.t b/tests/test-dirs/occurrences/issue827.t/run.t index 922bd797c8..43d1bab64f 100644 --- a/tests/test-dirs/occurrences/issue827.t/run.t +++ b/tests/test-dirs/occurrences/issue827.t/run.t @@ -17,7 +17,7 @@ Reproduction case: { "start": { "line": 4, - "col": 8 + "col": 10 }, "end": { "line": 4, @@ -35,7 +35,7 @@ Reproduction case: { "start": { "line": 2, - "col": 18 + "col": 16 }, "end": { "line": 2, @@ -76,7 +76,7 @@ work: { "start": { "line": 4, - "col": 8 + "col": 10 }, "end": { "line": 4, diff --git a/tests/test-dirs/occurrences/modules-in-path.t b/tests/test-dirs/occurrences/modules-in-path.t new file mode 100644 index 0000000000..95f9c56ee0 --- /dev/null +++ b/tests/test-dirs/occurrences/modules-in-path.t @@ -0,0 +1,103 @@ + $ cat >main.ml <<'EOF' + > module N = struct module M = struct let x = 42 end end + > let () = print_int N.M.x + > let () = print_int N.M.(*comment*)x + > EOF + +FIXME: longident with spaces will be highlighted incorrectly + + $ $MERLIN single occurrences -identifier-at 1:25 \ + > -filename main.ml -filename main.ml -log-file - -log-section locate \ + > -filename main.ml oui_ml.ml <<'EOF' + > type t = int + > EOF + + $ cat >no_ml.mli <<'EOF' + > include module type of Oui_ml + > EOF + + $ cat >main.ml <<'EOF' + > let (x : No_ml.t) = 42 + > open No_ml + > let (y : t) = 43 + > EOF + + $ $OCAMLC -bin-annot -bin-annot-occurrences -c oui_ml.ml no_ml.mli main.ml + $ ocaml-index aggregate oui_ml.cmt no_ml.cmti main.cmt -o project.index + + $ cat >.merlin <<'EOF' + > INDEX_FILE project.index + > EOF + + $ $MERLIN single occurrences -scope project -identifier-at 1:15 \ + > -filename main.ml -filename main.ml dune-workspace <<'EOF' + > (lang dune 3.11) + > (workspace_indexation enabled) + > EOF + + $ cat >dune-project <<'EOF' + > (lang dune 3.11) + > EOF + + $ mkdir lib + + $ cat >lib/wrapped_module.ml <<'EOF' + > let x = 42 + > let f () = x + > EOF + + $ cat >lib/dune <<'EOF' + > (library + > (name lib)) + > EOF + + $ cat >main.ml <<'EOF' + > open Lib + > let _y = print_int Wrapped_module.x + > EOF + + $ cat >dune <<'EOF' + > (executable + > (name main) + > (libraries lib)) + > EOF + + $ dune build @ocaml-index @all + + $ ocaml-index dump _build/default/project.ocaml-index + 7 uids: + {uid: Lib__Wrapped_module; locs: + "Lib__Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 24-43 + uid: Dune__exe__Main.0; locs: + "_y": File "$TESTCASE_ROOT/main.ml", line 2, characters 4-6 + uid: Stdlib.313; locs: + "print_int": File "$TESTCASE_ROOT/main.ml", line 2, characters 9-18 + uid: Lib.0; locs: + "Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 7-21 + uid: Lib__Wrapped_module.0; locs: + "Wrapped_module.x": File "$TESTCASE_ROOT/main.ml", line 2, characters 19-35; + "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 1, characters 4-5; + "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 11-12 + uid: Lib; locs: + "Lib": File "$TESTCASE_ROOT/main.ml", line 1, characters 5-8 + uid: Lib__Wrapped_module.1; locs: + "f": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 4-5 + }, 0 approx shapes: {}, and shapes for CUS . + + $ $MERLIN single occurrences -scope project -identifier-at 2:34 \ + > -filename main.ml -filename lib/wrapped_module.ml local.ml <<'EOF' + > type t = int + > let x : int = 42 + > EOF + +Predef: + $ $MERLIN single occurrences -identifier-at 2:9 \ + > -filename local.ml local.ml <<'EOF' + > let _ = None + > let None = None + > EOF + + $ $MERLIN single occurrences -identifier-at 1:10 \ + > -filename local.ml local.ml <<'EOF' + > let _ = true + > let _ = true + > EOF + + $ $MERLIN single occurrences -identifier-at 1:10 \ + > -filename local.ml local.ml <<'EOF' + > let _ = () + > let f () = () + > EOF + + $ $MERLIN single occurrences -identifier-at 1:9 \ + > -filename local.ml dune-workspace <<'EOF' + > (lang dune 3.11) + > (workspace_indexation enabled) + > EOF + + $ cat >dune-project <<'EOF' + > (lang dune 3.11) + > EOF + + $ mkdir lib + $ cat >lib/lib.ml <<'EOF' + > let x = 42 + > let y = x + > EOF + + $ cat >lib/dune <<'EOF' + > (library + > (name lib)) + > EOF + + $ mkdir exe + $ cat >exe/main.ml <<'EOF' + > print_int Lib.x + > EOF + + $ cat >exe/dune <<'EOF' + > (library + > (name main) + > (libraries lib)) + > EOF + + $ dune build @all + + $ ocaml-index dump _build/default/project.ocaml-index + 3 uids: + {uid: Lib.1; locs: + "y": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 4-5 + uid: Stdlib.313; locs: + "print_int": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 0-9 + uid: Lib.0; locs: + "x": File "$TESTCASE_ROOT/lib/lib.ml", line 1, characters 4-5; + "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9; + "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15 + }, 0 approx shapes: {}, and shapes for CUS . + +Occurrences of Lib.x + $ $MERLIN single occurrences -scope project -identifier-at 1:15 \ + > -filename exe/main.ml > lib/lib.ml + + $ $MERLIN single occurrences -scope project -identifier-at 1:15 \ + > -log-file log -log-section occurrences \ + > -filename exe/main.ml local.ml <<'EOF' + > let _x : bool = Filename.is_relative "/" + > let _y : bool = Filename.is_relative "/" + > let _z : string = Filename.basename "/" + > EOF + +There are two occurrences of Filename.is_relative + $ $MERLIN single occurrences -identifier-at 1:30 \ + > -filename local.ml main.ml <<'EOF' + > let x' = 1 + > let x = 41 + > let f x = x + > let y = f x + > EOF + + $ $MERLIN server occurrences -scope local -identifier-at 3:10 \ + > -log-file log_1 -log-section index \ + > -filename main.ml /dev/null + + $ cat >main.ml <<'EOF' + > let x' = 1 + > let x = 42 + > let f x = x + > let y = f x + > EOF + + $ $MERLIN server occurrences -scope local -identifier-at 3:10 \ + > -log-file log_2 -log-section index \ + > -filename main.ml /dev/null + +FIXME: The uids should be the same on both queries ! + $ cat log_1 | grep Found | cat >log_1g + $ cat log_2 | grep Found | cat >log_2g + $ diff log_1g log_2g + + $ $MERLIN server stop-server diff --git a/tests/test-dirs/server-tests/warnings/backtrack.t b/tests/test-dirs/server-tests/warnings/backtrack.t index 99d27a20fa..65003eb30f 100644 --- a/tests/test-dirs/server-tests/warnings/backtrack.t +++ b/tests/test-dirs/server-tests/warnings/backtrack.t @@ -78,4 +78,44 @@ environment in different queries, some warnings will be reported only once. "notifications": [] } + + $ $MERLIN server errors -filename backtrack.ml -w +A < let f x = () + > let g y = () + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 6 + }, + "end": { + "line": 1, + "col": 7 + }, + "type": "warning", + "sub": [], + "valid": true, + "message": "Warning 27: unused variable x." + }, + { + "start": { + "line": 2, + "col": 6 + }, + "end": { + "line": 2, + "col": 7 + }, + "type": "warning", + "sub": [], + "valid": true, + "message": "Warning 27: unused variable y." + } + ], + "notifications": [] + } + $ $MERLIN server stop-server diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t index da5ab50a03..860985c129 100644 --- a/tests/test-dirs/type-enclosing/te-413-features.t +++ b/tests/test-dirs/type-enclosing/te-413-features.t @@ -78,6 +78,7 @@ Module types substitutions > end > EOF +1. $ $MERLIN single type-enclosing -position 6:25 \ > -filename mtsubst.ml < mtsubst.ml | > tr '\n' ' ' | jq '.value[0:2]' @@ -108,48 +109,39 @@ Module types substitutions } ] - $ $MERLIN single occurrences -identifier-at 6:19 \ +2. + $ $MERLIN single occurrences -identifier-at 7:20 \ > -filename mtsubst.ml < mtsubst.ml | > tr '\n' ' ' | jq '.value' [ { "start": { - "line": 2, - "col": 14 + "line": 5, + "col": 31 }, "end": { - "line": 2, - "col": 15 + "line": 5, + "col": 32 } }, { "start": { - "line": 3, - "col": 12 - }, - "end": { - "line": 3, - "col": 13 - } - }, - { - "start": { - "line": 3, - "col": 17 + "line": 6, + "col": 25 }, "end": { - "line": 3, - "col": 18 + "line": 6, + "col": 26 } }, { "start": { - "line": 6, - "col": 19 + "line": 7, + "col": 20 }, "end": { - "line": 6, - "col": 20 + "line": 7, + "col": 21 } } ] @@ -166,6 +158,7 @@ Module types substitutions > end > EOF +3. $ $MERLIN single type-enclosing -position 6:26 \ > -filename mtsubst.ml < mtsubst.ml | > tr '\n' ' ' | jq '.value[0:2]' @@ -196,48 +189,40 @@ Module types substitutions } ] - $ $MERLIN single occurrences -identifier-at 6:19 \ +4. + $ $MERLIN single occurrences -identifier-at 7:20 \ > -filename mtsubst.ml < mtsubst.ml | > tr '\n' ' ' | jq '.value' [ { "start": { - "line": 2, - "col": 14 - }, - "end": { - "line": 2, - "col": 15 - } - }, - { - "start": { - "line": 3, - "col": 12 + "line": 5, + "col": 31 }, "end": { - "line": 3, - "col": 13 + "line": 5, + "col": 32 } }, { "start": { - "line": 3, - "col": 17 + "line": 6, + "col": 26 }, "end": { - "line": 3, - "col": 18 + "line": 6, + "col": 27 } }, { "start": { - "line": 6, - "col": 19 + "line": 7, + "col": 20 }, "end": { - "line": 6, - "col": 20 + "line": 7, + "col": 21 } } ] + diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t index 088abcc73e..eabb5adfcd 100644 --- a/tests/test-dirs/typing-recovery.t +++ b/tests/test-dirs/typing-recovery.t @@ -106,7 +106,9 @@ Ttyp_constr \"t/273\" [] Tpat_alias \"x/278\" - pattern (test.ml[2,15+7]..test.ml[2,15+8]) + pattern (test.ml[2,15+7]..test.ml[2,15+8]) ghost + attribute \"merlin.hide\" + [] Tpat_any expression (test.ml[3,31+2]..test.ml[6,69+12]) Texp_match diff --git a/upstream/ocaml_414/base-rev.txt b/upstream/ocaml_414/base-rev.txt index 32276392e2..18dfb3f240 100644 --- a/upstream/ocaml_414/base-rev.txt +++ b/upstream/ocaml_414/base-rev.txt @@ -1 +1 @@ -87efa5e6681dd0fc6547ef4669883bf15c871588 +12b1d5914b9ed5abdeb05a1a4896004ea9509208 diff --git a/upstream/ocaml_414/file_formats/cmt_format.ml b/upstream/ocaml_414/file_formats/cmt_format.ml index a493780e5a..9955577bf5 100644 --- a/upstream/ocaml_414/file_formats/cmt_format.ml +++ b/upstream/ocaml_414/file_formats/cmt_format.ml @@ -36,14 +36,14 @@ type binary_annots = | Partial_interface of binary_part array and binary_part = -| Partial_structure of structure -| Partial_structure_item of structure_item -| Partial_expression of expression -| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part -| Partial_class_expr of class_expr -| Partial_signature of signature -| Partial_signature_item of signature_item -| Partial_module_type of module_type + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type type cmt_infos = { cmt_modname : string; @@ -60,21 +60,62 @@ type cmt_infos = { cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list } type error = Not_a_typedtree of string +let iter_on_parts (it : Tast_iterator.iterator) = function + | Partial_structure s -> it.structure it s + | Partial_structure_item s -> it.structure_item it s + | Partial_expression e -> it.expr it e + | Partial_pattern (_category, p) -> it.pat it p + | Partial_class_expr ce -> it.class_expr it ce + | Partial_signature s -> it.signature it s + | Partial_signature_item s -> it.signature_item it s + | Partial_module_type s -> it.module_type it s + +let iter_on_annots (it : Tast_iterator.iterator) = function + | Implementation s -> it.structure it s + | Interface s -> it.signature it s + | Packed _ -> () + | Partial_implementation array -> Array.iter (iter_on_parts it) array + | Partial_interface array -> Array.iter (iter_on_parts it) array + +let iter_on_declaration f decl = + match decl with + | Value vd -> f vd.val_val.val_uid decl; + | Value_binding vb -> + let bound_idents = let_bound_idents_full [vb] in + List.iter (fun (_, _, _, uid) -> f uid decl) bound_idents + | Type td -> + if not (Btype.is_row_name (Ident.name td.typ_id)) then + f td.typ_type.type_uid (Type td) + | Constructor cd -> f cd.cd_uid decl + | Extension_constructor ec -> f ec.ext_type.ext_uid decl; + | Label ld -> f ld.ld_uid decl + | Module md -> f md.md_uid decl + | Module_type mtd -> f mtd.mtd_uid decl + | Module_substitution ms -> f ms.ms_uid decl + | Module_binding mb -> f mb.mb_uid decl + | Class cd -> f cd.ci_decl.cty_uid decl + | Class_type ct -> f ct.ci_decl.cty_uid decl + +let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = { + Tast_iterator.default_iterator with + item_declaration = (fun _sub decl -> iter_on_declaration f decl); +} + let need_to_clear_env = try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false with Not_found -> true let keep_only_summary = Env.keep_only_summary -open Tast_mapper - let cenv = {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} @@ -103,6 +144,211 @@ let clear_env binary_annots = else binary_annots +(* Every typedtree node with a located longident corresponding to user-facing + syntax should be indexed. *) +let iter_on_occurrences + ~(f : namespace:Shape.Sig_component_kind.t -> + Env.t -> Path.t -> Longident.t Location.loc -> + unit) = + let path_in_type typ name = + match Types.get_desc typ with + | Tconstr (type_path, _, _) -> + Some (Path.Pdot (type_path, name)) + | _ -> None + in + let add_constructor_description env lid = + function + | { Types.cstr_tag = Cstr_extension (path, _); _ } -> + f ~namespace:Extension_constructor env path lid + | { Types.cstr_uid = Predef name; _} -> + let id = List.assoc name Predef.builtin_idents in + f ~namespace:Constructor env (Pident id) lid + | { Types.cstr_res; cstr_name; _ } -> + let path = path_in_type cstr_res cstr_name in + Option.iter (fun path -> f ~namespace:Constructor env path lid) path + in + let add_label env lid { Types.lbl_name; lbl_res; _ } = + let path = path_in_type lbl_res lbl_name in + Option.iter (fun path -> f ~namespace:Label env path lid) path + in + let with_constraint ~env (_path, _lid, with_constraint) = + match with_constraint with + | Twith_module (path', lid') | Twith_modsubst (path', lid') -> + f ~namespace:Module env path' lid' + | _ -> () + in + Tast_iterator.{ default_iterator with + + expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> + (match exp_desc with + | Texp_ident (path, lid, _) -> + f ~namespace:Value exp_env path lid + | Texp_construct (lid, constr_desc, _) -> + add_constructor_description exp_env lid constr_desc + | Texp_field (_, lid, label_desc) + | Texp_setfield (_, lid, label_desc, _) -> + add_label exp_env lid label_desc + | Texp_new (path, lid, _) -> + f ~namespace:Class exp_env path lid + | Texp_record { fields; _ } -> + Array.iter (fun (label_descr, record_label_definition) -> + match record_label_definition with + | Overridden ( + { Location.txt; loc}, + {exp_loc; _}) + when not exp_loc.loc_ghost + && loc.loc_start = exp_loc.loc_start + && loc.loc_end = exp_loc.loc_end -> + (* In the presence of punning we want to index the label + even if it is ghosted *) + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in + add_label exp_env lid label_descr + | Overridden (lid, _) -> add_label exp_env lid label_descr + | Kept _ -> ()) fields + | Texp_instvar (_self_path, path, name) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_setinstvar (_self_path, path, name, _) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | _ -> ()); + default_iterator.expr sub e); + + typ = + (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> + (match ctyp_desc with + | Ttyp_constr (path, lid, _ctyps) -> + f ~namespace:Type ctyp_env path lid + | Ttyp_package {pack_path; pack_txt} -> + f ~namespace:Module_type ctyp_env pack_path pack_txt + | Ttyp_class (path, lid, _typs) -> + (* Deprecated syntax to extend a polymorphic variant *) + f ~namespace:Type ctyp_env path lid + | _ -> ()); + default_iterator.typ sub ct); + + pat = + (fun (type a) sub + ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> + (match pat_desc with + | Tpat_construct (lid, constr_desc, _, _) -> + add_constructor_description pat_env lid constr_desc + | Tpat_record (fields, _) -> + List.iter (fun (lid, label_descr, pat) -> + let lid = + let open Location in + (* In the presence of punning we want to index the label + even if it is ghosted *) + if (not pat.pat_loc.loc_ghost + && lid.loc.loc_start = pat.pat_loc.loc_start + && lid.loc.loc_end = pat.pat_loc.loc_end) + then {lid with loc = {lid.loc with loc_ghost = false}} + else lid + in + add_label pat_env lid label_descr) + fields + | _ -> ()); + List.iter (fun (pat_extra, _, _) -> + match pat_extra with + | Tpat_open (path, lid, _) -> + f ~namespace:Module pat_env path lid + | Tpat_type (path, lid) -> + f ~namespace:Type pat_env path lid + | Tpat_constraint _ | Tpat_unpack -> ()) + pat_extra; + default_iterator.pat sub pat); + + binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> + let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in + f ~namespace:Value bop_exp.exp_env bop_op_path lid; + default_iterator.binding_op sub bop); + + module_expr = + (fun sub ({ mod_desc; mod_env; _ } as me) -> + (match mod_desc with + | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid + | _ -> ()); + default_iterator.module_expr sub me); + + open_description = + (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> + f ~namespace:Module open_env path lid; + default_iterator.open_description sub od); + + module_type = + (fun sub ({ mty_desc; mty_env; _ } as mty) -> + (match mty_desc with + | Tmty_ident (path, lid) -> + f ~namespace:Module_type mty_env path lid + | Tmty_with (_mty, l) -> + List.iter (with_constraint ~env:mty_env) l + | Tmty_alias (path, lid) -> + f ~namespace:Module mty_env path lid + | _ -> ()); + default_iterator.module_type sub mty); + + class_expr = + (fun sub ({ cl_desc; cl_env; _} as ce) -> + (match cl_desc with + | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid + | _ -> ()); + default_iterator.class_expr sub ce); + + class_type = + (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> + (match cltyp_desc with + | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid + | _ -> ()); + default_iterator.class_type sub ct); + + signature_item = + (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> + (match sig_desc with + | Tsig_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor sig_env path lid + | Tsig_modsubst { ms_manifest; ms_txt } -> + f ~namespace:Module sig_env ms_manifest ms_txt + | Tsig_typext { tyext_path; tyext_txt } -> + f ~namespace:Type sig_env tyext_path tyext_txt + | _ -> ()); + default_iterator.signature_item sub sig_item); + + structure_item = + (fun sub ({ str_desc; str_env; _ } as str_item) -> + (match str_desc with + | Tstr_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor str_env path lid + | Tstr_typext { tyext_path; tyext_txt } -> + f ~namespace:Type str_env tyext_path tyext_txt + | _ -> ()); + default_iterator.structure_item sub str_item) +} + +let index_declarations binary_annots = + let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in + let f uid fragment = Types.Uid.Tbl.add index uid fragment in + iter_on_annots (iter_on_declarations ~f) binary_annots; + index + +let index_occurrences binary_annots = + let index : (Longident.t Location.loc * Shape_reduce.result) list ref = + ref [] + in + let f ~namespace env path lid = + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | { uid = Some (Predef _); _ } -> () + | path_shape -> + let result = Shape_reduce.local_reduce_for_uid env path_shape in + index := (lid, result) :: !index + in + iter_on_annots (iter_on_occurrences ~f) binary_annots; + !index + exception Error of error let input_cmt ic = (input_value ic : cmt_infos) @@ -174,10 +420,18 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = | None -> None | Some cmi -> Some (output_cmi temp_file_name oc cmi) in + let cmt_ident_occurrences = + if !Clflags.store_occurrences then + index_occurrences binary_annots + else + [] + in + let cmt_annots = clear_env binary_annots in + let cmt_uid_to_decl = index_declarations cmt_annots in let source_digest = Option.map Digest.file sourcefile in let cmt = { cmt_modname = modname; - cmt_annots = clear_env binary_annots; + cmt_annots; cmt_value_dependencies = !value_deps; cmt_comments = Lexer.comments (); cmt_args = Sys.argv; @@ -190,8 +444,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = cmt_imports = List.sort compare (Env.imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; - cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); + cmt_uid_to_decl; cmt_impl_shape = shape; + cmt_ident_occurrences; } in output_cmt oc cmt) end; diff --git a/upstream/ocaml_414/file_formats/cmt_format.mli b/upstream/ocaml_414/file_formats/cmt_format.mli index 43e09f1236..e2dd81a49d 100644 --- a/upstream/ocaml_414/file_formats/cmt_format.mli +++ b/upstream/ocaml_414/file_formats/cmt_format.mli @@ -65,8 +65,10 @@ type cmt_infos = { cmt_imports : crcs; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list } type error = @@ -112,7 +114,6 @@ val set_saved_types : binary_part list -> unit val record_value_dependency: Types.value_description -> Types.value_description -> unit - (* val is_magic_number : string -> bool diff --git a/upstream/ocaml_414/typing/cmt2annot.ml b/upstream/ocaml_414/typing/cmt2annot.ml index 40ee752e80..219c6023b2 100644 --- a/upstream/ocaml_414/typing/cmt2annot.ml +++ b/upstream/ocaml_414/typing/cmt2annot.ml @@ -23,7 +23,7 @@ let variables_iterator scope = let super = default_iterator in let pat sub (type k) (p : k general_pattern) = begin match p.pat_desc with - | Tpat_var (id, _) | Tpat_alias (_, id, _) -> + | Tpat_var (id, _, _) | Tpat_alias (_, id, _, _) -> Stypes.record (Stypes.An_ident (p.pat_loc, Ident.name id, Annot.Idef scope)) diff --git a/upstream/ocaml_414/typing/env.ml b/upstream/ocaml_414/typing/env.ml index 6e324888da..95e53ce1b8 100644 --- a/upstream/ocaml_414/typing/env.ml +++ b/upstream/ocaml_414/typing/env.ml @@ -40,13 +40,6 @@ let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 -let uid_to_loc : Location.t Types.Uid.Tbl.t ref = - s_table Types.Uid.Tbl.create 16 - -let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc - -let get_uid_to_loc_tbl () = !uid_to_loc - type constructor_usage = Positive | Pattern | Exported_private | Exported type constructor_usages = { @@ -941,7 +934,6 @@ let reset_declaration_caches () = Types.Uid.Tbl.clear !module_declarations; Types.Uid.Tbl.clear !used_constructors; Types.Uid.Tbl.clear !used_labels; - Types.Uid.Tbl.clear !uid_to_loc; () let reset_cache () = @@ -1258,6 +1250,10 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = match ns with | Type -> (IdTbl.find_same id env.types).tda_shape + | Constructor -> + Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) + | Label -> + Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) | Extension_constructor -> (TycompTbl.find_same id env.constrs).cda_shape | Value -> @@ -2339,8 +2335,6 @@ let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env let add_value = add_value ?shape:None -let add_type = add_type ?shape:None -let add_extension = add_extension ?shape:None let add_class = add_class ?shape:None let add_cltype = add_cltype ?shape:None let add_modtype = add_modtype ?shape:None diff --git a/upstream/ocaml_414/typing/env.mli b/upstream/ocaml_414/typing/env.mli index 49040b83cb..9c2bcac374 100644 --- a/upstream/ocaml_414/typing/env.mli +++ b/upstream/ocaml_414/typing/env.mli @@ -18,10 +18,6 @@ open Types open Misc -val register_uid : Uid.t -> Location.t -> unit - -val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t - type value_unbound_reason = | Val_unbound_instance_variable | Val_unbound_self @@ -284,9 +280,11 @@ val make_copy_of_types: t -> (t -> t) val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t -val add_type: check:bool -> Ident.t -> type_declaration -> t -> t +val add_type: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t val add_extension: - check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t + check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> + extension_constructor -> t -> t val add_module: ?arg:bool -> ?shape:Shape.t -> Ident.t -> module_presence -> module_type -> t -> t val add_module_lazy: update_summary:bool -> diff --git a/upstream/ocaml_414/typing/includemod.ml b/upstream/ocaml_414/typing/includemod.ml index b2bf46a367..b81c448183 100644 --- a/upstream/ocaml_414/typing/includemod.ml +++ b/upstream/ocaml_414/typing/includemod.ml @@ -738,7 +738,21 @@ and signature_components ~in_eq ~loc old_env ~mark env subst type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 in let item = mark_error_as_unrecoverable item in + (* Right now we don't filter hidden constructors / labels from the + shape. *) let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + let shape_map = + match tydec1.type_kind with + | Type_variant (cstrs, _) -> + List.fold_left (fun shape_map { cd_id; _ } -> + Shape.Map.add_type_proj shape_map cd_id orig_shape) + shape_map cstrs + | Type_record (labels, _) -> + List.fold_left (fun shape_map { ld_id; _ } -> + Shape.Map.add_label_proj shape_map ld_id orig_shape) + shape_map labels + | _ -> shape_map + in id1, item, shape_map, false | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> let item = diff --git a/upstream/ocaml_414/typing/parmatch.ml b/upstream/ocaml_414/typing/parmatch.ml index 2b48d63d54..0af42d4926 100644 --- a/upstream/ocaml_414/typing/parmatch.ml +++ b/upstream/ocaml_414/typing/parmatch.ml @@ -37,7 +37,8 @@ let omega_list = Patterns.omega_list let extra_pat = make_pat - (Tpat_var (Ident.create_local "+", mknoloc "+")) + (Tpat_var (Ident.create_local "+", mknoloc "+", + Uid.internal_not_actually_unique)) Ctype.none Env.empty @@ -283,8 +284,8 @@ module Compat | ((Tpat_any|Tpat_var _),_) | (_,(Tpat_any|Tpat_var _)) -> true (* Structural induction *) - | Tpat_alias (p,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_) -> compat p q + | Tpat_alias (p,_,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_,_) -> compat p q | Tpat_or (p1,p2,_),_ -> (compat p1 q || compat p2 q) | _,Tpat_or (q1,q2,_) -> @@ -921,7 +922,8 @@ let build_other ext env = (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create_local "*extension*", - {txt="*extension*"; loc = d.pat_loc})) + {txt="*extension*"; loc = d.pat_loc}, + Uid.internal_not_actually_unique)) Ctype.none Env.empty | Construct _ -> begin match ext with @@ -1051,7 +1053,7 @@ let build_other ext env = let rec has_instance p = match p.pat_desc with | Tpat_variant (l,_,r) when is_absent l r -> false | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> has_instances ps @@ -1505,7 +1507,7 @@ let is_var_column rs = (* Standard or-args for left-to-right matching *) let rec or_args p = match p.pat_desc with | Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_,_) -> or_args p +| Tpat_alias (p,_,_,_) -> or_args p | _ -> assert false (* Just remove current column *) @@ -1685,8 +1687,8 @@ and every_both pss qs q1 q2 = let rec le_pat p q = match (p.pat_desc, q.pat_desc) with | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_,_), _ -> le_pat p q - | _, Tpat_alias(q,_,_) -> le_pat p q + | Tpat_alias(p,_,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_,_) -> le_pat p q | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs @@ -1725,8 +1727,8 @@ let get_mins le ps = *) let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_,_),_ -> lub p q -| _,Tpat_alias (q,_,_) -> lub p q +| Tpat_alias (p,_,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_,_) -> lub p q | (Tpat_any|Tpat_var _),_ -> q | _,(Tpat_any|Tpat_var _) -> p | Tpat_or (p1,p2,_),_ -> orlub p1 p2 q @@ -1861,14 +1863,14 @@ module Conv = struct match pat.pat_desc with Tpat_or (pa,pb,_) -> mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *) + | Tpat_var (_, ({txt="*extension*"} as nm), _) -> (* PR#7330 *) mkpat (Ppat_var nm) | Tpat_any | Tpat_var _ -> mkpat Ppat_any | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p,_,_) -> loop p + | Tpat_alias (p,_,_,_) -> loop p | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) | Tpat_construct (cstr_lid, cstr, lst, _) -> @@ -1909,7 +1911,7 @@ end let contains_extension pat = exists_pattern (function - | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true | _ -> false) pat @@ -2021,7 +2023,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with List.fold_left (fun r (_, _, p) -> collect_paths_from_pat r p) r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) -> + collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 | Tpat_lazy p @@ -2155,7 +2158,7 @@ let inactive ~partial pat = end | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> List.for_all (fun p -> loop p) ps - | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) -> loop p | Tpat_record (ldps,_) -> List.for_all @@ -2274,9 +2277,9 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; } let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k = let rec simpl head_bound_variables varsets p ps k = match (Patterns.General.view p).pat_desc with - | `Alias (p,x,_) -> + | `Alias (p,x,_,_) -> simpl (Ident.Set.add x head_bound_variables) varsets p ps k - | `Var (x, _) -> + | `Var (x,_,_) -> simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k | `Or (p1,p2,_) -> simpl head_bound_variables varsets p1 ps diff --git a/upstream/ocaml_414/typing/patterns.ml b/upstream/ocaml_414/typing/patterns.ml index 55f9d4ff43..456f8dff33 100644 --- a/upstream/ocaml_414/typing/patterns.ml +++ b/upstream/ocaml_414/typing/patterns.ml @@ -79,18 +79,18 @@ end module General = struct type view = [ | Half_simple.view - | `Var of Ident.t * string loc - | `Alias of pattern * Ident.t * string loc + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t ] type pattern = view pattern_data let view_desc = function | Tpat_any -> `Any - | Tpat_var (id, str) -> - `Var (id, str) - | Tpat_alias (p, id, str) -> - `Alias (p, id, str) + | Tpat_var (id, str, uid) -> + `Var (id, str, uid) + | Tpat_alias (p, id, str, uid) -> + `Alias (p, id, str, uid) | Tpat_constant cst -> `Constant cst | Tpat_tuple ps -> @@ -110,8 +110,8 @@ module General = struct let erase_desc = function | `Any -> Tpat_any - | `Var (id, str) -> Tpat_var (id, str) - | `Alias (p, id, str) -> Tpat_alias (p, id, str) + | `Var (id, str, uid) -> Tpat_var (id, str, uid) + | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid) | `Constant cst -> Tpat_constant cst | `Tuple ps -> Tpat_tuple ps | `Construct (cstr, cst_descr, args) -> @@ -129,7 +129,7 @@ module General = struct let rec strip_vars (p : pattern) : Half_simple.pattern = match p.pat_desc with - | `Alias (p, _, _) -> strip_vars (view p) + | `Alias (p, _, _, _) -> strip_vars (view p) | `Var _ -> { p with pat_desc = `Any } | #Half_simple.view as view -> { p with pat_desc = view } end diff --git a/upstream/ocaml_414/typing/patterns.mli b/upstream/ocaml_414/typing/patterns.mli index 66dd2d05a4..2ad645b0d0 100644 --- a/upstream/ocaml_414/typing/patterns.mli +++ b/upstream/ocaml_414/typing/patterns.mli @@ -65,8 +65,8 @@ end module General : sig type view = [ | Half_simple.view - | `Var of Ident.t * string loc - | `Alias of pattern * Ident.t * string loc + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t ] type pattern = view pattern_data diff --git a/upstream/ocaml_414/typing/printpat.ml b/upstream/ocaml_414/typing/printpat.ml index 64094b63ec..e90fd8eeb1 100644 --- a/upstream/ocaml_414/typing/printpat.ml +++ b/upstream/ocaml_414/typing/printpat.ml @@ -52,7 +52,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | [] -> match v.pat_desc with | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) + | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x) | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs @@ -98,7 +98,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x,_) -> + | Tpat_alias (v, x,_,_) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_value v -> fprintf ppf "%a" pretty_val (v :> pattern) diff --git a/upstream/ocaml_414/typing/printtyped.ml b/upstream/ocaml_414/typing/printtyped.ml index b925123aa9..fea441ebd1 100644 --- a/upstream/ocaml_414/typing/printtyped.ml +++ b/upstream/ocaml_414/typing/printtyped.ml @@ -242,8 +242,8 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> end; match x.pat_desc with | Tpat_any -> line i ppf "Tpat_any\n"; - | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; - | Tpat_alias (p, s,_) -> + | Tpat_var (s,_,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; + | Tpat_alias (p, s,_,_) -> line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; pattern i ppf p; | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; diff --git a/upstream/ocaml_414/typing/rec_check.ml b/upstream/ocaml_414/typing/rec_check.ml index 1980b82d02..fda80675b5 100644 --- a/upstream/ocaml_414/typing/rec_check.ml +++ b/upstream/ocaml_414/typing/rec_check.ml @@ -220,7 +220,7 @@ let classify_expression : Typedtree.expression -> sd = let old_env = env in let add_value_binding env vb = match vb.vb_pat.pat_desc with - | Tpat_var (id, _loc) -> + | Tpat_var (id, _loc, _uid) -> let size = classify_expression old_env vb.vb_expr in Ident.add id size env | _ -> @@ -1187,8 +1187,8 @@ and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env -> and is_destructuring_pattern : type k . k general_pattern -> bool = fun pat -> match pat.pat_desc with | Tpat_any -> false - | Tpat_var (_, _) -> false - | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat + | Tpat_var (_, _, _) -> false + | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat | Tpat_constant _ -> true | Tpat_tuple _ -> true | Tpat_construct _ -> true diff --git a/upstream/ocaml_414/typing/shape.ml b/upstream/ocaml_414/typing/shape.ml index f82e5343fa..d11a835d32 100644 --- a/upstream/ocaml_414/typing/shape.ml +++ b/upstream/ocaml_414/typing/shape.ml @@ -67,6 +67,8 @@ module Sig_component_kind = struct type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -76,6 +78,8 @@ module Sig_component_kind = struct let to_string = function | Value -> "value" | Type -> "type" + | Constructor -> "constructor" + | Label -> "label" | Module -> "module" | Module_type -> "module type" | Extension_constructor -> "extension constructor" @@ -87,6 +91,8 @@ module Sig_component_kind = struct | Extension_constructor -> false | Type + | Constructor + | Label | Module | Module_type | Class @@ -99,10 +105,15 @@ module Item = struct type t = string * Sig_component_kind.t let compare = compare + let name (name, _) = name + let kind (_, kind) = kind + let make str ns = str, ns let value id = Ident.name id, Sig_component_kind.Value let type_ id = Ident.name id, Sig_component_kind.Type + let constr id = Ident.name id, Sig_component_kind.Constructor + let label id = Ident.name id, Sig_component_kind.Label let module_ id = Ident.name id, Sig_component_kind.Module let module_type id = Ident.name id, Sig_component_kind.Module_type let extension_constructor id = @@ -124,17 +135,19 @@ module Item = struct end type var = Ident.t -type t = { uid: Uid.t option; desc: desc } +type t = { uid: Uid.t option; desc: desc; approximated: bool } and desc = | Var of var | Abs of var * t | App of t * t | Struct of t Item.Map.t + | Alias of t | Leaf | Proj of t * Item.t | Comp_unit of string + | Error of string -let print fmt = +let print fmt t = let print_uid_opt = Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) in @@ -171,303 +184,104 @@ let print fmt = aux t ) in - Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + if Item.Map.is_empty map then + Format.fprintf fmt "@[{%a}@]" print_uid_opt uid + else + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + | Alias t -> + Format.fprintf fmt "Alias@[(@[%a@,%a@])@]" print_uid_opt uid aux t + | Error s -> + Format.fprintf fmt "Error %s" s in - Format.fprintf fmt"@[%a@]@;" aux + if t.approximated then + Format.fprintf fmt "@[(approx)@ %a@]@;" aux t + else + Format.fprintf fmt "@[%a@]@;" aux t + +let rec strip_head_aliases = function + | { desc = Alias t; _ } -> strip_head_aliases t + | t -> t let fresh_var ?(name="shape-var") uid = let var = Ident.create_local name in - var, { uid = Some uid; desc = Var var } + var, { uid = Some uid; desc = Var var; approximated = false } let for_unnamed_functor_param = Ident.create_local "()" let var uid id = - { uid = Some uid; desc = Var id } + { uid = Some uid; desc = Var id; approximated = false } let abs ?uid var body = - { uid; desc = Abs (var, body) } + { uid; desc = Abs (var, body); approximated = false } let str ?uid map = - { uid; desc = Struct map } + { uid; desc = Struct map; approximated = false } + +let alias ?uid t = + { uid; desc = Alias t; approximated = false} let leaf uid = - { uid = Some uid; desc = Leaf } + { uid = Some uid; desc = Leaf; approximated = false } + +let approx t = { t with approximated = true} let proj ?uid t item = match t.desc with | Leaf -> (* When stuck projecting in a leaf we propagate the leaf as a best effort *) - t + approx t | Struct map -> begin try Item.Map.find item map - with Not_found -> t (* ill-typed program *) + with Not_found -> approx t (* ill-typed program *) end | _ -> - { uid; desc = Proj (t, item) } + { uid; desc = Proj (t, item); approximated = false } let app ?uid f ~arg = - { uid; desc = App (f, arg) } + { uid; desc = App (f, arg); approximated = false } let decompose_abs t = match t.desc with | Abs (x, t) -> Some (x, t) | _ -> None -module Make_reduce(Params : sig - type env - val fuel : int - val read_unit_shape : unit_name:string -> t option - val find_shape : env -> Ident.t -> t -end) = struct - (* We implement a strong call-by-need reduction, following an - evaluator from Nathanaelle Courant. *) - - type nf = { uid: Uid.t option; desc: nf_desc } - and nf_desc = - | NVar of var - | NApp of nf * nf - | NAbs of local_env * var * t * delayed_nf - | NStruct of delayed_nf Item.Map.t - | NProj of nf * Item.t - | NLeaf - | NComp_unit of string - | NoFuelLeft of desc - (* A type of normal forms for strong call-by-need evaluation. - The normal form of an abstraction - Abs(x, t) - is a closure - NAbs(env, x, t, dnf) - when [env] is the local environment, and [dnf] is a delayed - normal form of [t]. - - A "delayed normal form" is morally equivalent to (nf Lazy.t), but - we use a different representation that is compatible with - memoization (lazy values are not hashable/comparable by default - comparison functions): we represent a delayed normal form as - just a not-yet-computed pair [local_env * t] of a term in a - local environment -- we could also see this as a term under - an explicit substitution. This delayed thunked is "forced" - by calling the normalization function as usual, but duplicate - computations are precisely avoided by memoization. - *) - and delayed_nf = Thunk of local_env * t - - and local_env = delayed_nf option Ident.Map.t - (* When reducing in the body of an abstraction [Abs(x, body)], we - bind [x] to [None] in the environment. [Some v] is used for - actual substitutions, for example in [App(Abs(x, body), t)], when - [v] is a thunk that will evaluate to the normal form of [t]. *) - - let improve_uid uid (nf : nf) = - match nf.uid with - | Some _ -> nf - | None -> { nf with uid } - - let in_memo_table memo_table memo_key f arg = - match Hashtbl.find memo_table memo_key with - | res -> res - | exception Not_found -> - let res = f arg in - Hashtbl.replace memo_table memo_key res; - res - - type env = { - fuel: int ref; - global_env: Params.env; - local_env: local_env; - reduce_memo_table: (local_env * t, nf) Hashtbl.t; - read_back_memo_table: (nf, t) Hashtbl.t; - } - - let bind env var shape = - { env with local_env = Ident.Map.add var shape env.local_env } - - let rec reduce_ env t = - let memo_key = (env.local_env, t) in - in_memo_table env.reduce_memo_table memo_key (reduce__ env) t - (* Memoization is absolutely essential for performance on this - problem, because the normal forms we build can in some real-world - cases contain an exponential amount of redundancy. Memoization - can avoid the repeated evaluation of identical subterms, - providing a large speedup, but even more importantly it - implicitly shares the memory of the repeated results, providing - much smaller normal forms (that blow up again if printed back - as trees). A functor-heavy file from Irmin has its shape normal - form decrease from 100Mio to 2.5Mio when memoization is enabled. - - Note: the local environment is part of the memoization key, while - it is defined using a type Ident.Map.t of non-canonical balanced - trees: two maps could have exactly the same items, but be - balanced differently and therefore hash differently, reducing - the effectivenss of memoization. - This could in theory happen, say, with the two programs - (fun x -> fun y -> ...) - and - (fun y -> fun x -> ...) - having "the same" local environments, with additions done in - a different order, giving non-structurally-equal trees. Should we - define our own hash functions to provide robust hashing on - environments? - - We believe that the answer is "no": this problem does not occur - in practice. We can assume that identifiers are unique on valid - typedtree fragments (identifier "stamps" distinguish - binding positions); in particular the two program fragments above - in fact bind *distinct* identifiers x (with different stamps) and - different identifiers y, so the environments are distinct. If two - environments are structurally the same, they must correspond to - the evaluation evnrionments of two sub-terms that are under - exactly the same scope of binders. So the two environments were - obtained by the same term traversal, adding binders in the same - order, giving the same balanced trees: the environments have the - same hash. -*) - - and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = - let reduce env t = reduce_ env t in - let delay_reduce env t = Thunk (env.local_env, t) in - let force (Thunk (local_env, t)) = - reduce { env with local_env } t in - let return desc : nf = { uid = t.uid; desc } in - if !fuel < 0 then return (NoFuelLeft t.desc) - else - match t.desc with - | Comp_unit unit_name -> - begin match Params.read_unit_shape ~unit_name with - | Some t -> reduce env t - | None -> return (NComp_unit unit_name) - end - | App(f, arg) -> - let f = reduce env f in - begin match f.desc with - | NAbs(clos_env, var, body, _body_nf) -> - let arg = delay_reduce env arg in - let env = bind { env with local_env = clos_env } var (Some arg) in - reduce env body - |> improve_uid t.uid - | _ -> - let arg = reduce env arg in - return (NApp(f, arg)) - end - | Proj(str, item) -> - let str = reduce env str in - let nored () = return (NProj(str, item)) in - begin match str.desc with - | NStruct (items) -> - begin match Item.Map.find item items with - | exception Not_found -> nored () - | nf -> - force nf - |> improve_uid t.uid - end - | _ -> - nored () - end - | Abs(var, body) -> - let body_nf = delay_reduce (bind env var None) body in - return (NAbs(local_env, var, body, body_nf)) - | Var id -> - begin match Ident.Map.find id local_env with - (* Note: instead of binding abstraction-bound variables to - [None], we could unify it with the [Some v] case by - binding the bound variable [x] to [NVar x]. - - One reason to distinguish the situations is that we can - provide a different [Uid.t] location; for bound - variables, we use the [Uid.t] of the bound occurrence - (not the binding site), whereas for bound values we use - their binding-time [Uid.t]. *) - | None -> return (NVar id) - | Some def -> force def - | exception Not_found -> - match Params.find_shape global_env id with - | exception Not_found -> return (NVar id) - | res when res = t -> return (NVar id) - | res -> - decr fuel; - reduce env res - end - | Leaf -> return NLeaf - | Struct m -> - let mnf = Item.Map.map (delay_reduce env) m in - return (NStruct mnf) - - let rec read_back env (nf : nf) : t = - in_memo_table env.read_back_memo_table nf (read_back_ env) nf - (* The [nf] normal form we receive may contain a lot of internal - sharing due to the use of memoization in the evaluator. We have - to memoize here again, otherwise the sharing is lost by mapping - over the term as a tree. *) - - and read_back_ env (nf : nf) : t = - { uid = nf.uid; desc = read_back_desc env nf.desc } - - and read_back_desc env desc = - let read_back nf = read_back env nf in - let read_back_force (Thunk (local_env, t)) = - read_back (reduce_ { env with local_env } t) in - match desc with - | NVar v -> - Var v - | NApp (nft, nfu) -> - App(read_back nft, read_back nfu) - | NAbs (_env, x, _t, nf) -> - Abs(x, read_back_force nf) - | NStruct nstr -> - Struct (Item.Map.map read_back_force nstr) - | NProj (nf, item) -> - Proj (read_back nf, item) - | NLeaf -> Leaf - | NComp_unit s -> Comp_unit s - | NoFuelLeft t -> t - - let reduce global_env t = - let fuel = ref Params.fuel in - let reduce_memo_table = Hashtbl.create 42 in - let read_back_memo_table = Hashtbl.create 42 in - let local_env = Ident.Map.empty in - let env = { - fuel; - global_env; - reduce_memo_table; - read_back_memo_table; - local_env; - } in - reduce_ env t |> read_back env -end - -module Local_reduce = - (* Note: this definition with [type env = unit] is only suitable for - reduction of toplevel shapes -- shapes of compilation units, - where free variables are only Comp_unit names. If we wanted to - reduce shapes inside module signatures, we would need to take - a typing environment as parameter. *) - Make_reduce(struct - type env = unit - let fuel = 10 - let read_unit_shape ~unit_name:_ = None - let find_shape _env _id = raise Not_found - end) - -let local_reduce shape = - Local_reduce.reduce () shape +let dummy_mod = + { uid = None; desc = Struct Item.Map.empty; approximated = false } -let dummy_mod = { uid = None; desc = Struct Item.Map.empty } - -let of_path ~find_shape ~namespace = +let of_path ~find_shape ~namespace path = let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function | Pident id -> find_shape ns id - | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Pdot (path, name) -> + (* We need to handle the following cases: + Path of constructor: + M.t.C + Path of label: + M.t.lbl + Path on label of inline record: + M.t.C.lbl *) + let is_capitalized name = String.capitalize_ascii name = name in + let is_label namespace = namespace = Sig_component_kind.Label in + let namespace : Sig_component_kind.t = + match path with + | Pident id when is_capitalized (Ident.name id) -> + if is_label ns then Constructor else Module + | Pident _ -> Type + | Pdot (_, name) when is_capitalized name -> + if is_label ns then Constructor else Module + | Pdot _ -> Type + | Papply _ -> Module + in + proj (aux namespace path) (name, ns) | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) in - aux namespace + aux namespace path let for_persistent_unit s = { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); - desc = Comp_unit s } + desc = Comp_unit s; approximated = false } -let leaf_for_unpack = { uid = None; desc = Leaf } +let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false } let set_uid_if_none t uid = match t.uid with @@ -487,11 +301,21 @@ module Map = struct let item = Item.value id in Item.Map.add item (proj shape item) t - let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type t id shape = Item.Map.add (Item.type_ id) shape t let add_type_proj t id shape = let item = Item.type_ id in Item.Map.add item (proj shape item) t + let add_constr t id shape = Item.Map.add (Item.constr id) shape t + let add_constr_proj t id shape = + let item = Item.constr id in + Item.Map.add item (proj shape item) t + + let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t + let add_label_proj t id shape = + let item = Item.label id in + Item.Map.add item (proj shape item) t + let add_module t id shape = Item.Map.add (Item.module_ id) shape t let add_module_proj t id shape = let item = Item.module_ id in @@ -503,8 +327,8 @@ module Map = struct let item = Item.module_type id in Item.Map.add item (proj shape item) t - let add_extcons t id uid = - Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons t id shape = + Item.Map.add (Item.extension_constructor id) shape t let add_extcons_proj t id shape = let item = Item.extension_constructor id in Item.Map.add item (proj shape item) t diff --git a/upstream/ocaml_414/typing/shape.mli b/upstream/ocaml_414/typing/shape.mli index 8a5aaca4fb..3d686ab185 100644 --- a/upstream/ocaml_414/typing/shape.mli +++ b/upstream/ocaml_414/typing/shape.mli @@ -2,7 +2,7 @@ (* *) (* OCaml *) (* *) -(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Ulysse Gérard, Thomas Refis, N G Tarides *) (* *) (* Copyright 2021 Institut National de Recherche en Informatique et *) (* en Automatique. *) @@ -13,6 +13,48 @@ (* *) (**************************************************************************) +(** Shapes are an abstract representation of modules' implementations which + allow the tracking of definitions through functor applications and other + module-level operations. + + The Shape of a compilation unit is elaborated during typing, partially + reduced (without loading external shapes) and written to the [cmt] file. + + External tools can retrieve the definition of any value (or type, or module, + etc) by following this procedure: + + - Build the Shape corresponding to the value's path: + [let shape = Env.shape_of_path ~namespace env path] + + - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from + external units and to looks for shapes in the environment (usually using + [Env.shape_of_path]). + + - Completely reduce the shape: + [let shape = My_reduce.(weak_)reduce env shape] + + - The [Uid.t] stored in the reduced shape should be the one of the + definition. However, if the [approximate] field of the reduced shape is + [true] then the [Uid.t] will not correspond to the definition, but to the + closest parent module's uid. This happens when Shape reduction gets stuck, + for example when hitting first-class modules. + + - The location of the definition can be easily found with the + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. + + See: + - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } + the design document} + - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } + a talk about the reduction strategy +*) + +(** A [Uid.t] is associated with every declaration in signatures and + implementations, they uniquely identify bindings in the program. + When associated with these bindings' locations they are useful to + external tools when trying to jump to the declaration of + definitions of identifiers. They are stored to that effect in the + [uid_to_decl] table of cmt files. *) module Uid : sig type t = private | Compilation_unit of string @@ -36,6 +78,8 @@ module Sig_component_kind : sig type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -48,35 +92,47 @@ module Sig_component_kind : sig val can_appear_in_types : t -> bool end +(** Shape's items are elements of a structure. These structures models module + components and nested types' constructors and labels *) module Item : sig - type t + type t = string * Sig_component_kind.t + val name : t -> string + val kind : t -> Sig_component_kind.t val make : string -> Sig_component_kind.t -> t val value : Ident.t -> t val type_ : Ident.t -> t + val constr : Ident.t -> t + val label : Ident.t -> t val module_ : Ident.t -> t val module_type : Ident.t -> t val extension_constructor : Ident.t -> t val class_ : Ident.t -> t val class_type : Ident.t -> t + val print : Format.formatter -> t -> unit + module Map : Map.S with type key = t end type var = Ident.t -type t = { uid: Uid.t option; desc: desc } +type t = { uid: Uid.t option; desc: desc; approximated: bool } and desc = | Var of var | Abs of var * t | App of t * t | Struct of t Item.Map.t + | Alias of t | Leaf | Proj of t * Item.t | Comp_unit of string + | Error of string val print : Format.formatter -> t -> unit +val strip_head_aliases : t -> t + (* Smart constructors *) val for_unnamed_functor_param : var @@ -86,6 +142,7 @@ val var : Uid.t -> Ident.t -> t val abs : ?uid:Uid.t -> var -> t -> t val app : ?uid:Uid.t -> t -> arg:t -> t val str : ?uid:Uid.t -> t Item.Map.t -> t +val alias : ?uid:Uid.t -> t -> t val proj : ?uid:Uid.t -> t -> Item.t -> t val leaf : Uid.t -> t @@ -105,16 +162,22 @@ module Map : sig val add_value : t -> Ident.t -> Uid.t -> t val add_value_proj : t -> Ident.t -> shape -> t - val add_type : t -> Ident.t -> Uid.t -> t + val add_type : t -> Ident.t -> shape -> t val add_type_proj : t -> Ident.t -> shape -> t + val add_constr : t -> Ident.t -> shape -> t + val add_constr_proj : t -> Ident.t -> shape -> t + + val add_label : t -> Ident.t -> Uid.t -> t + val add_label_proj : t -> Ident.t -> shape -> t + val add_module : t -> Ident.t -> shape -> t val add_module_proj : t -> Ident.t -> shape -> t val add_module_type : t -> Ident.t -> Uid.t -> t val add_module_type_proj : t -> Ident.t -> shape -> t - val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons : t -> Ident.t -> shape -> t val add_extcons_proj : t -> Ident.t -> shape -> t val add_class : t -> Ident.t -> Uid.t -> t @@ -126,32 +189,12 @@ end val dummy_mod : t +(** This function returns the shape corresponding to a given path. It requires a + callback to find shapes in the environment. It is generally more useful to + rely directly on the [Env.shape_of_path] function to get the shape + associated with a given path. *) val of_path : find_shape:(Sig_component_kind.t -> Ident.t -> t) -> namespace:Sig_component_kind.t -> Path.t -> t val set_uid_if_none : t -> Uid.t -> t - -(** The [Make_reduce] functor is used to generate a reduction function for - shapes. - - It is parametrized by: - - an environment and a function to find shapes by path in that environment - - a function to load the shape of an external compilation unit - - some fuel, which is used to bound recursion when dealing with recursive - shapes introduced by recursive modules. (FTR: merlin currently uses a - fuel of 10, which seems to be enough for most practical examples) -*) -module Make_reduce(Context : sig - type env - - val fuel : int - - val read_unit_shape : unit_name:string -> t option - - val find_shape : env -> Ident.t -> t - end) : sig - val reduce : Context.env -> t -> t -end - -val local_reduce : t -> t diff --git a/upstream/ocaml_414/typing/shape_reduce.ml b/upstream/ocaml_414/typing/shape_reduce.ml new file mode 100644 index 0000000000..0b6e7916ec --- /dev/null +++ b/upstream/ocaml_414/typing/shape_reduce.ml @@ -0,0 +1,350 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Shape + +type result = + | Resolved of Uid.t + | Resolved_alias of Uid.t list + | Unresolved of t + | Approximated of Uid.t option + | Internal_error_missing_uid + +let print_result fmt result = + match result with + | Resolved uid -> + Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + | Resolved_alias uids -> + Format.fprintf fmt "@[Resolved_alias: %a@]@;" + Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") + Uid.print) uids + | Unresolved shape -> + Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + | Approximated (Some uid) -> + Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + | Approximated None -> + Format.fprintf fmt "@[Approximated: No uid@]@;" + | Internal_error_missing_uid -> + Format.fprintf fmt "@[Missing uid@]@;" + + +let find_shape env id = + let namespace = Shape.Sig_component_kind.Module in + Env.shape_of_path ~namespace env (Pident id) + +module Make(Params : sig + val fuel : int + val read_unit_shape : unit_name:string -> t option +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NAlias of delayed_nf + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NError of string + + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let approx_nf nf = { nf with approximated = true } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Env.t; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let local_env = env.local_env in + let memo_key = (local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ + ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = reduce { env with local_env } t in + let return desc = { uid = t.uid; desc; approximated = t.approximated } in + let rec force_aliases nf = match nf.desc with + | NAlias delayed_nf -> + let nf = force delayed_nf in + force_aliases nf + | _ -> nf + in + let reset_uid_if_new_binding t' = + match t.uid with + | None -> t' + | Some _ as uid -> { t' with uid } + in + if !fuel < 0 then approx_nf (return (NError "NoFuelLeft")) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f |> force_aliases in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body |> reset_uid_if_new_binding + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str |> force_aliases in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> force nf |> reset_uid_if_new_binding + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> + begin match force def with + | { uid = Some _; _ } as nf -> nf + (* This var already has a binding uid *) + | { uid = None; _ } as nf -> { nf with uid = t.uid } + (* Set the var's binding uid *) + end + | exception Not_found -> + match find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + | Alias t -> return (NAlias (delay_reduce env t)) + | Error s -> approx_nf (return (NError s)) + + and read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid ; + desc = read_back_desc env nf.desc; + approximated = nf.approximated } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NAlias nf -> Alias (read_back_force nf) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NError s -> Error s + + (* Sharing the memo tables is safe at the level of a compilation unit since + idents should be unique *) + let reduce_memo_table = Local_store.s_table Hashtbl.create 42 + let read_back_memo_table = Local_store.s_table Hashtbl.create 42 + + let reduce global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env + + let rec is_stuck_on_comp_unit (nf : nf) = + match nf.desc with + | NVar _ -> + (* This should not happen if we only reduce closed terms *) + false + | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf + | NStruct _ | NAbs _ -> false + | NAlias _ -> false + | NComp_unit _ -> true + | NError _ -> false + | NLeaf -> false + + let get_aliases_uids (t : t) = + let rec aux acc (t : t) = match t with + | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t + | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) + | _ -> Internal_error_missing_uid + in + aux [] t + + let reduce_for_uid global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + let nf = reduce_ env t in + if is_stuck_on_comp_unit nf then + Unresolved (read_back env nf) + else match nf with + | { desc = NAlias _; approximated = false; _ } -> + get_aliases_uids (read_back env nf) + | { uid = Some uid; approximated = false; _ } -> + Resolved uid + | { uid; approximated = true; _ } -> + Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid +end + +module Local_reduce = + (* Note: this definition with [type env = unit] is only suitable for + reduction of toplevel shapes -- shapes of compilation units, + where free variables are only Comp_unit names. If we wanted to + reduce shapes inside module signatures, we would need to take + a typing environment as parameter. *) + Make(struct + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + end) + +let local_reduce = Local_reduce.reduce +let local_reduce_for_uid = Local_reduce.reduce_for_uid diff --git a/upstream/ocaml_414/typing/shape_reduce.mli b/upstream/ocaml_414/typing/shape_reduce.mli new file mode 100644 index 0000000000..6156207ad6 --- /dev/null +++ b/upstream/ocaml_414/typing/shape_reduce.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Shape + +(** The result of reducing a shape and looking for its uid *) +type result = + | Resolved of Uid.t (** Shape reduction succeeded and a uid was found *) + | Resolved_alias of Uid.t list (** Reduction led to an alias chain *) + | Unresolved of t (** Result still contains [Comp_unit] terms *) + | Approximated of Uid.t option + (** Reduction failed: it can arrive with first-clsss modules for example *) + | Internal_error_missing_uid + (** Reduction succeeded but no uid was found, this should never happen *) + +val print_result : Format.formatter -> result -> unit + +(** The [Make] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) +*) +module Make(_ : sig + val fuel : int + + val read_unit_shape : unit_name:string -> t option + end) : sig + val reduce : Env.t -> t -> t + + (** Perform weak reduction and return the head's uid if any. If reduction was + incomplete the partially reduced shape is returned. *) + val reduce_for_uid : Env.t -> t -> result +end + +(** [local_reduce] will not reduce shapes that require loading external + compilation units. *) +val local_reduce : Env.t -> t -> t + +(** [local_reduce_for_uid] will not reduce shapes that require loading external + compilation units. *) +val local_reduce_for_uid : Env.t -> t -> result diff --git a/upstream/ocaml_414/typing/tast_iterator.ml b/upstream/ocaml_414/typing/tast_iterator.ml index a700c0d91b..506036afcf 100644 --- a/upstream/ocaml_414/typing/tast_iterator.ml +++ b/upstream/ocaml_414/typing/tast_iterator.ml @@ -59,6 +59,7 @@ type iterator = value_bindings: iterator -> (rec_flag * value_binding list) -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; } let structure sub {str_items; str_final_env; _} = @@ -69,19 +70,25 @@ let class_infos sub f x = List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; f x.ci_expr -let module_type_declaration sub {mtd_type; _} = +let module_type_declaration sub ({mtd_type; _} as x) = + sub.item_declaration sub (Module_type x); Option.iter (sub.module_type sub) mtd_type -let module_declaration sub {md_type; _} = +let module_declaration sub ({md_type; _} as md) = + sub.item_declaration sub (Module md); sub.module_type sub md_type -let module_substitution _ _ = () + +let module_substitution sub ms = + sub.item_declaration sub (Module_substitution ms) let include_infos f {incl_mod; _} = f incl_mod let class_type_declaration sub x = + sub.item_declaration sub (Class_type x); class_infos sub (sub.class_type sub) x let class_declaration sub x = + sub.item_declaration sub (Class x); class_infos sub (sub.class_expr sub) x let structure_item sub {str_desc; str_env; _} = @@ -104,15 +111,20 @@ let structure_item sub {str_desc; str_env; _} = | Tstr_open od -> sub.open_declaration sub od | Tstr_attribute _ -> () -let value_description sub x = sub.typ sub x.val_desc +let value_description sub x = + sub.item_declaration sub (Value x); + sub.typ sub x.val_desc -let label_decl sub {ld_type; _} = sub.typ sub ld_type +let label_decl sub ({ld_type; _} as ld) = + sub.item_declaration sub (Label ld); + sub.typ sub ld_type let constructor_args sub = function | Cstr_tuple l -> List.iter (sub.typ sub) l | Cstr_record l -> List.iter (label_decl sub) l -let constructor_decl sub {cd_args; cd_res; _} = +let constructor_decl sub ({cd_args; cd_res; _} as x) = + sub.item_declaration sub (Constructor x); constructor_args sub cd_args; Option.iter (sub.typ sub) cd_res @@ -122,7 +134,9 @@ let type_kind sub = function | Ttype_record list -> List.iter (label_decl sub) list | Ttype_open -> () -let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} = +let type_declaration + sub ({typ_cstrs; typ_kind; typ_manifest; typ_params; _} as x) = + sub.item_declaration sub (Type x); List.iter (fun (c1, c2, _) -> sub.typ sub c1; @@ -141,7 +155,8 @@ let type_extension sub {tyext_constructors; tyext_params; _} = let type_exception sub {tyexn_constructor; _} = sub.extension_constructor sub tyexn_constructor -let extension_constructor sub {ext_kind; _} = +let extension_constructor sub ({ext_kind; _} as ec) = + sub.item_declaration sub (Extension_constructor ec); match ext_kind with | Text_decl (_, ctl, cto) -> constructor_args sub ctl; @@ -170,7 +185,7 @@ let pat | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l - | Tpat_alias (p, _, _) -> sub.pat sub p + | Tpat_alias (p, _, _, _) -> sub.pat sub p | Tpat_lazy p -> sub.pat sub p | Tpat_value p -> sub.pat sub (p :> pattern) | Tpat_exception p -> sub.pat sub p @@ -291,6 +306,7 @@ let signature_item sub {sig_desc; sig_env; _} = | Tsig_attribute _ -> () let class_description sub x = + sub.item_declaration sub (Class_type x); class_infos sub (sub.class_type sub) x let functor_parameter sub = function @@ -316,8 +332,8 @@ let with_constraint sub = function | Twith_typesubst decl -> sub.type_declaration sub decl | Twith_module _ -> () | Twith_modsubst _ -> () - | Twith_modtype _ -> () - | Twith_modtypesubst _ -> () + | Twith_modtype decl -> sub.module_type sub decl + | Twith_modtypesubst decl -> sub.module_type sub decl let open_description sub {open_env; _} = sub.env sub open_env @@ -360,7 +376,9 @@ let module_expr sub {mod_desc; mod_env; _} = sub.module_coercion sub c | Tmod_unpack (exp, _) -> sub.expr sub exp -let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr +let module_binding sub ({mb_expr; _} as mb) = + sub.item_declaration sub (Module_binding mb); + sub.module_expr sub mb_expr let class_expr sub {cl_desc; cl_env; _} = sub.env sub cl_env; @@ -463,12 +481,15 @@ let case sub {c_lhs; c_guard; c_rhs} = Option.iter (sub.expr sub) c_guard; sub.expr sub c_rhs -let value_binding sub {vb_pat; vb_expr; _} = +let value_binding sub ({vb_pat; vb_expr; _} as vb) = + sub.item_declaration sub (Value_binding vb); sub.pat sub vb_pat; sub.expr sub vb_expr let env _sub _ = () +let item_declaration _sub _ = () + let default_iterator = { binding_op; @@ -512,4 +533,5 @@ let default_iterator = value_bindings; value_description; with_constraint; + item_declaration; } diff --git a/upstream/ocaml_414/typing/tast_iterator.mli b/upstream/ocaml_414/typing/tast_iterator.mli index e126128edf..5e6d3b6c72 100644 --- a/upstream/ocaml_414/typing/tast_iterator.mli +++ b/upstream/ocaml_414/typing/tast_iterator.mli @@ -63,6 +63,7 @@ type iterator = value_bindings: iterator -> (rec_flag * value_binding list) -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; } val default_iterator: iterator diff --git a/upstream/ocaml_414/typing/tast_mapper.ml b/upstream/ocaml_414/typing/tast_mapper.ml index 9eb7f64e88..fd861f0522 100644 --- a/upstream/ocaml_414/typing/tast_mapper.ml +++ b/upstream/ocaml_414/typing/tast_mapper.ml @@ -219,7 +219,7 @@ let pat | Tpat_record (l, closed) -> Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) - | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) + | Tpat_alias (p, id, s, uid) -> Tpat_alias (sub.pat sub p, id, s, uid) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) | Tpat_value p -> (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc diff --git a/upstream/ocaml_414/typing/typeclass.ml b/upstream/ocaml_414/typing/typeclass.ml index 79d464fa7d..51a76f5eb0 100644 --- a/upstream/ocaml_414/typing/typeclass.ml +++ b/upstream/ocaml_414/typing/typeclass.ml @@ -1305,7 +1305,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = Typecore.type_let In_class_def val_env rec_flag sdefs in let (vals, met_env) = List.fold_right - (fun (id, _id_loc, _typ) (vals, met_env) -> + (fun (id, _id_loc, _typ, _uid) (vals, met_env) -> let path = Pident id in (* do not mark the value as used *) let vd = Env.find_value path val_env in @@ -1952,7 +1952,7 @@ let approx_class_declarations env sdecls = open Format -let non_virtual_string_of_kind = function +let non_virtual_string_of_kind : kind -> string = function | Object -> "object" | Class -> "non-virtual class" | Class_type -> "non-virtual class type" diff --git a/upstream/ocaml_414/typing/typecore.ml b/upstream/ocaml_414/typing/typecore.ml index e043e237c5..f9d433fa8e 100644 --- a/upstream/ocaml_414/typing/typecore.ml +++ b/upstream/ocaml_414/typing/typecore.ml @@ -438,6 +438,7 @@ type pattern_variable = pv_loc: Location.t; pv_as_var: bool; pv_attributes: attributes; + pv_uid : Uid.t; } type module_variable = @@ -471,19 +472,21 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty !pattern_variables then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); let id = Ident.create_local name.txt in + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in pattern_variables := {pv_id = id; pv_type = ty; pv_loc = loc; pv_as_var = is_as_variable; - pv_attributes = attrs} :: !pattern_variables; + pv_attributes = attrs; + pv_uid} :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (Error (loc, Env.empty, Modules_not_allowed)); module_variables := (name, loc) :: !module_variables end; - id + id, pv_uid let sort_pattern_variables vs = List.sort @@ -549,7 +552,7 @@ let rec build_as_type ~refine (env : Env.t ref) p = and build_as_type_aux ~refine (env : Env.t ref) p = let build_as_type = build_as_type ~refine in match p.pat_desc with - Tpat_alias(p1,_, _) -> build_as_type env p1 + Tpat_alias(p1,_, _, _) -> build_as_type env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl) @@ -1661,14 +1664,14 @@ and type_pat_aux end | Ppat_var name -> let ty = instance expected_ty in - let id = (* PR#7330 *) + let id, uid = (* PR#7330 *) if name.txt = "*extension*" then - Ident.create_local name.txt + Ident.create_local name.txt, Uid.internal_not_actually_unique else enter_variable loc name ty sp.ppat_attributes in rvp k { - pat_desc = Tpat_var (id, name); + pat_desc = Tpat_var (id, name, uid); pat_loc = loc; pat_extra=[]; pat_type = ty; pat_attributes = sp.ppat_attributes; @@ -1687,9 +1690,9 @@ and type_pat_aux pat_env = !env } | Some s -> let v = { name with txt = s } in - let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in + let id, uid = enter_variable loc v t ~is_module:true sp.ppat_attributes in rvp k { - pat_desc = Tpat_var (id, v); + pat_desc = Tpat_var (id, v, uid); pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; pat_type = t; @@ -1703,8 +1706,8 @@ and type_pat_aux assert construction_not_used_in_counterexamples; let cty, ty, ty' = solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in - let id = enter_variable lloc name ty' attrs in - rvp k { pat_desc = Tpat_var (id, name); + let id, uid = enter_variable lloc name ty' attrs in + rvp k { pat_desc = Tpat_var (id, name, uid); pat_loc = lloc; pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; pat_type = ty; @@ -1714,11 +1717,11 @@ and type_pat_aux assert construction_not_used_in_counterexamples; type_pat Value sq expected_ty (fun q -> let ty_var = solve_Ppat_alias ~refine env q in - let id = + let id, uid = enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes in rvp k { - pat_desc = Tpat_alias(q, id, name); + pat_desc = Tpat_alias(q, id, name, uid); pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; pat_attributes = sp.ppat_attributes; @@ -2037,12 +2040,12 @@ and type_pat_aux let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in let p : k general_pattern = match category, (p : k general_pattern) with - | Value, {pat_desc = Tpat_var (id,s); _} -> + | Value, {pat_desc = Tpat_var (id,s,uid); _} -> {p with pat_type = ty; pat_desc = Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); + ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s,uid); pat_extra = [extra]; } | _, p -> @@ -2133,12 +2136,12 @@ let iter_pattern_variables_type f : pattern_variable list -> unit = let add_pattern_variables ?check ?check_as env pv = List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env -> + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env -> let check = if pv_as_var then check_as else check in Env.add_value ?check pv_id {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; val_attributes = pv_attributes; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + val_uid = pv_uid; } env ) pv env @@ -2756,8 +2759,8 @@ let rec name_pattern default = function [] -> Ident.create_local default | p :: rem -> match p.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id + Tpat_var (id, _, _) -> id + | Tpat_alias(_, id, _, _) -> id | _ -> name_pattern default rem let name_cases default lst = @@ -3680,10 +3683,12 @@ and type_expect_ | _ -> Mp_present in let scope = create_scope () in + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let md = { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } + md_uid; } in + let md_shape = Shape.set_uid_if_none md_shape md_uid in let (id, new_env) = match name.txt with | None -> None, env @@ -3709,7 +3714,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_letexception(cd, sbody) -> - let (cd, newenv) = Typedecl.transl_exception env cd in + let (cd, newenv, _shape) = Typedecl.transl_exception env cd in let body = type_expect newenv sbody ty_expected_explained in re { exp_desc = Texp_letexception(cd, body); @@ -4470,7 +4475,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = } in let exp_env = Env.add_value id desc env in - {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; + {pat_desc = + Tpat_var (id, mknoloc name, desc.val_uid); + pat_type = ty; + pat_extra=[]; pat_attributes = []; pat_loc = Location.none; pat_env = env}, {exp_type = ty; exp_loc = Location.none; exp_env = exp_env; @@ -5330,7 +5338,7 @@ and type_let List.iter (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var _ -> () - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () + | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> () | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat))) l; List.iter (function diff --git a/upstream/ocaml_414/typing/typecore.mli b/upstream/ocaml_414/typing/typecore.mli index 2f56bb49f0..97c949d15d 100644 --- a/upstream/ocaml_414/typing/typecore.mli +++ b/upstream/ocaml_414/typing/typecore.mli @@ -56,6 +56,7 @@ type pattern_variable = pv_loc: Location.t; pv_as_var: bool; pv_attributes: Typedtree.attributes; + pv_uid : Uid.t; } val mk_expected: diff --git a/upstream/ocaml_414/typing/typedecl.ml b/upstream/ocaml_414/typing/typedecl.ml index d00c0fc450..25728a8d61 100644 --- a/upstream/ocaml_414/typing/typedecl.ml +++ b/upstream/ocaml_414/typing/typedecl.ml @@ -82,9 +82,9 @@ let get_unboxed_from_attributes sdecl = (* Enter all declared types in the environment as abstract types *) -let add_type ~check id decl env = +let add_type ~check ?shape id decl env = Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes - (fun () -> Env.add_type ~check id decl env) + (fun () -> Env.add_type ~check ?shape id decl env) let enter_type rec_flag env sdecl (id, uid) = let needed = @@ -222,7 +222,9 @@ let transl_labels env univars closed lbls = let arg = Ast_helper.Typ.force_poly arg in let cty = transl_simple_type env ?univars closed arg in {ld_id = Ident.create_local name.txt; - ld_name = name; ld_mutable = mut; + ld_name = name; + ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + ld_mutable = mut; ld_type = cty; ld_loc = loc; ld_attributes = attrs} ) in @@ -237,7 +239,7 @@ let transl_labels env univars closed lbls = ld_type = ty; ld_loc = ld.ld_loc; ld_attributes = ld.ld_attributes; - ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + ld_uid = ld.ld_uid; } ) lbls in @@ -307,6 +309,27 @@ let make_constructor env loc type_path type_params svars sargs sret_type = widen z; targs, Some tret_type, args, Some ret_type + +let shape_map_labels = + List.fold_left (fun map { ld_id; ld_uid; _} -> + Shape.Map.add_label map ld_id ld_uid) + Shape.Map.empty + +let shape_map_cstrs = + List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } -> + let cstr_shape_map = + let label_decls = + match cd_args with + | Cstr_tuple _ -> [] + | Cstr_record ldecls -> ldecls + in + shape_map_labels label_decls + in + Shape.Map.add_constr map cd_id + @@ Shape.str ~uid:cd_uid cstr_shape_map) + (Shape.Map.empty) + + let transl_declaration env sdecl (id, uid) = (* Bind type parameters *) reset_type_variables(); @@ -393,6 +416,7 @@ let transl_declaration env sdecl (id, uid) = let tcstr = { cd_id = name; cd_name = scstr.pcd_name; + cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); cd_vars = scstr.pcd_vars; cd_args = targs; cd_res = tret_type; @@ -405,7 +429,7 @@ let transl_declaration env sdecl (id, uid) = cd_res = ret_type; cd_loc = scstr.pcd_loc; cd_attributes = scstr.pcd_attributes; - cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + cd_uid = tcstr.cd_uid } in tcstr, cstr in @@ -470,18 +494,32 @@ let transl_declaration env sdecl (id, uid) = in set_private_row env sdecl.ptype_loc p decl end; - { - typ_id = id; - typ_name = sdecl.ptype_name; - typ_params = tparams; - typ_type = decl; - typ_cstrs = cstrs; - typ_loc = sdecl.ptype_loc; - typ_manifest = tman; - typ_kind = tkind; - typ_private = sdecl.ptype_private; - typ_attributes = sdecl.ptype_attributes; - } + let decl = + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + in + let typ_shape = + let uid = decl.typ_type.type_uid in + let map = match decl.typ_kind with + | Ttype_variant cstrs -> Some (shape_map_cstrs cstrs) + | Ttype_record labels -> Some (shape_map_labels labels) + | Ttype_abstract | Ttype_open -> None + in + Option.map (Shape.str ~uid) map + (* Abstract types are just leafs *) + |> Option.value ~default:(Shape.leaf uid) + in + decl, typ_shape (* Generalize a type declaration *) @@ -841,10 +879,11 @@ let check_redefined_unit (td: Parsetree.type_declaration) = | _ -> () -let add_types_to_env decls env = - List.fold_right - (fun (id, decl) env -> add_type ~check:true id decl env) - decls env +let add_types_to_env decls shapes env = + List.fold_right2 + (fun (id, decl) shape env -> + add_type ~check:true ~shape id decl env) + decls shapes env (* Translate a set of type declarations, mutually recursive or not *) let transl_type_decl env rec_flag sdecl_list = @@ -910,13 +949,16 @@ let transl_type_decl env rec_flag sdecl_list = in let tdecls = List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in - let decls = - List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in + let decls, shapes = + List.map (fun (tdecl, tshape) -> (tdecl.typ_id, tdecl.typ_type), tshape) + tdecls + |> List.split + in current_slot := None; (* Check for duplicates *) check_duplicates sdecl_list; (* Build the final env. *) - let new_env = add_types_to_env decls env in + let new_env = add_types_to_env decls shapes env in (* Update stubs *) begin match rec_flag with | Asttypes.Nonrecursive -> () @@ -943,11 +985,12 @@ let transl_type_decl env rec_flag sdecl_list = check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id) decl to_check) decls; - List.iter - (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls; + List.iter (fun (decl, _shape) -> + check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check decl) + tdecls; (* Check that all type variables are closed *) List.iter2 - (fun sdecl tdecl -> + (fun sdecl (tdecl, _shape) -> let decl = tdecl.typ_type in match Ctype.closed_type_decl decl with Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) @@ -972,18 +1015,18 @@ let transl_type_decl env rec_flag sdecl_list = raise (Error (loc, Separability err)) in (* Compute the final environment with variance and immediacy *) - let final_env = add_types_to_env decls env in + let final_env = add_types_to_env decls shapes env in (* Check re-exportation *) List.iter2 (check_abbrev final_env) sdecl_list decls; (* Keep original declaration *) let final_decls = List.map2 - (fun tdecl (_id2, decl) -> + (fun (tdecl, _shape) (_id2, decl) -> { tdecl with typ_type = decl } ) tdecls decls in (* Done *) - (final_decls, final_env) + (final_decls, final_env, shapes) (* Translating type extensions *) @@ -1092,12 +1135,22 @@ let transl_extension_constructor ~scope env type_path type_params ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } in + let ext_cstrs = { ext_id = id; ext_name = sext.pext_name; ext_type = ext; ext_kind = kind; Typedtree.ext_loc = sext.pext_loc; Typedtree.ext_attributes = sext.pext_attributes; } + in + let shape = + let map = match ext_cstrs.ext_kind with + | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls + | _ -> Shape.Map.empty + in + Shape.str ~uid:ext_cstrs.ext_type.ext_uid map + in + ext_cstrs, shape let transl_extension_constructor ~scope env type_path type_params typext_params priv sext = @@ -1174,13 +1227,13 @@ let transl_type_extension extend env loc styext = (* Generalize types *) List.iter Ctype.generalize type_params; List.iter - (fun ext -> + (fun (ext, _shape) -> Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; Option.iter Ctype.generalize ext.ext_type.ext_ret_type) constructors; (* Check that all type variables are closed *) List.iter - (fun ext -> + (fun (ext, _shape) -> match Ctype.closed_extension_constructor ext.ext_type with Some ty -> raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) @@ -1188,7 +1241,7 @@ let transl_type_extension extend env loc styext = constructors; (* Check variances are correct *) List.iter - (fun ext-> + (fun (ext, _shape) -> (* Note that [loc] here is distinct from [type_decl.type_loc], which makes the [loc] parameter to this function useful. [loc] is the location of the extension, while [type_decl] points to the original @@ -1201,11 +1254,13 @@ let transl_type_extension extend env loc styext = (* Add extension constructors to the environment *) let newenv = List.fold_left - (fun env ext -> + (fun env (ext, shape) -> let rebind = is_rebind ext in - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env) + Env.add_extension ~check:true ~shape ~rebind + ext.ext_id ext.ext_type env) env constructors in + let constructors, shapes = List.split constructors in let tyext = { tyext_path = type_path; tyext_txt = styext.ptyext_path; @@ -1215,7 +1270,7 @@ let transl_type_extension extend env loc styext = tyext_loc = styext.ptyext_loc; tyext_attributes = styext.ptyext_attributes; } in - (tyext, newenv) + (tyext, newenv, shapes) let transl_type_extension extend env loc styext = Builtin_attributes.warning_scope styext.ptyext_attributes @@ -1225,7 +1280,7 @@ let transl_exception env sext = let scope = Ctype.create_scope () in reset_type_variables(); Ctype.begin_def(); - let ext = + let ext, shape = transl_extension_constructor ~scope env Predef.path_exn [] [] Asttypes.Public sext in @@ -1241,13 +1296,13 @@ let transl_exception env sext = end; let rebind = is_rebind ext in let newenv = - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env + Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env in - ext, newenv + ext, newenv, shape let transl_type_exception env t = Builtin_attributes.check_no_alert t.ptyexn_attributes; - let contructor, newenv = + let contructor, newenv, shape = Builtin_attributes.warning_scope t.ptyexn_attributes (fun () -> transl_exception env t.ptyexn_constructor @@ -1255,7 +1310,7 @@ let transl_type_exception env t = in {tyexn_constructor = contructor; tyexn_loc = t.ptyexn_loc; - tyexn_attributes = t.ptyexn_attributes}, newenv + tyexn_attributes = t.ptyexn_attributes}, newenv, shape type native_repr_attribute = diff --git a/upstream/ocaml_414/typing/typedecl.mli b/upstream/ocaml_414/typing/typedecl.mli index 0fb68edf42..cc4cf3fc80 100644 --- a/upstream/ocaml_414/typing/typedecl.mli +++ b/upstream/ocaml_414/typing/typedecl.mli @@ -20,19 +20,19 @@ open Format val transl_type_decl: Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> - Typedtree.type_declaration list * Env.t + Typedtree.type_declaration list * Env.t * Shape.t list val transl_exception: Env.t -> Parsetree.extension_constructor -> - Typedtree.extension_constructor * Env.t + Typedtree.extension_constructor * Env.t * Shape.t val transl_type_exception: Env.t -> - Parsetree.type_exception -> Typedtree.type_exception * Env.t + Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t val transl_type_extension: bool -> Env.t -> Location.t -> Parsetree.type_extension -> - Typedtree.type_extension * Env.t + Typedtree.type_extension * Env.t * Shape.t list val transl_value_decl: Env.t -> Location.t -> diff --git a/upstream/ocaml_414/typing/typedtree.ml b/upstream/ocaml_414/typing/typedtree.ml index 9194a59c18..56b35f6e77 100644 --- a/upstream/ocaml_414/typing/typedtree.ml +++ b/upstream/ocaml_414/typing/typedtree.ml @@ -18,6 +18,8 @@ open Asttypes open Types +module Uid = Shape.Uid + (* Value expressions for the core language *) type partial = Partial | Total @@ -53,9 +55,9 @@ and pat_extra = and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc - | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc | Tpat_alias : - value general_pattern * Ident.t * string loc -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc | Tpat_constant : constant -> value pattern_desc | Tpat_tuple : value general_pattern list -> value pattern_desc | Tpat_construct : @@ -288,6 +290,7 @@ and module_binding = { mb_id: Ident.t option; mb_name: string option loc; + mb_uid: Uid.t; mb_presence: module_presence; mb_expr: module_expr; mb_attributes: attribute list; @@ -367,6 +370,7 @@ and module_declaration = { md_id: Ident.t option; md_name: string option loc; + md_uid: Uid.t; md_presence: module_presence; md_type: module_type; md_attributes: attribute list; @@ -377,6 +381,7 @@ and module_substitution = { ms_id: Ident.t; ms_name: string loc; + ms_uid: Uid.t; ms_manifest: Path.t; ms_txt: Longident.t loc; ms_attributes: attributes; @@ -387,6 +392,7 @@ and module_type_declaration = { mtd_id: Ident.t; mtd_name: string loc; + mtd_uid: Uid.t; mtd_type: module_type option; mtd_attributes: attribute list; mtd_loc: Location.t; @@ -509,6 +515,7 @@ and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_uid: Uid.t; ld_mutable: mutable_flag; ld_type: core_type; ld_loc: Location.t; @@ -519,6 +526,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_uid: Uid.t; cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; @@ -627,6 +635,19 @@ type implementation = { shape: Shape.t; } +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration (* Auxiliary functions over the a.s.t. *) @@ -672,7 +693,7 @@ type pattern_action = let shallow_iter_pattern_desc : type k . pattern_action -> k pattern_desc -> unit = fun f -> function - | Tpat_alias(p, _, _) -> f.f p + | Tpat_alias(p, _, _, _) -> f.f p | Tpat_tuple patl -> List.iter f.f patl | Tpat_construct(_, _, patl, _) -> List.iter f.f patl | Tpat_variant(_, pat, _) -> Option.iter f.f pat @@ -692,8 +713,8 @@ type pattern_transformation = let shallow_map_pattern_desc : type k . pattern_transformation -> k pattern_desc -> k pattern_desc = fun f d -> match d with - | Tpat_alias (p1, id, s) -> - Tpat_alias (f.f p1, id, s) + | Tpat_alias (p1, id, s, uid) -> + Tpat_alias (f.f p1, id, s, uid) | Tpat_tuple pats -> Tpat_tuple (List.map f.f pats) | Tpat_record (lpats, closed) -> @@ -754,11 +775,11 @@ let rec iter_bound_idents : type k . _ -> k general_pattern -> _ = fun f pat -> match pat.pat_desc with - | Tpat_var (id,s) -> - f (id,s,pat.pat_type) - | Tpat_alias(p, id, s) -> + | Tpat_var (id, s, uid) -> + f (id,s,pat.pat_type, uid) + | Tpat_alias(p, id, s, uid) -> iter_bound_idents f p; - f (id,s,pat.pat_type) + f (id,s,pat.pat_type, uid) | Tpat_or(p1, _, _) -> (* Invariant : both arguments bind the same variables *) iter_bound_idents f p1 @@ -774,7 +795,7 @@ let rev_pat_bound_idents_full pat = !idents_full let rev_only_idents idents_full = - List.rev_map (fun (id,_,_) -> id) idents_full + List.rev_map (fun (id,_,_,_) -> id) idents_full let pat_bound_idents_full pat = List.rev (rev_pat_bound_idents_full pat) @@ -797,14 +818,14 @@ let alpha_var env id = List.assoc id env let rec alpha_pat : type k . _ -> k general_pattern -> k general_pattern = fun env p -> match p.pat_desc with - | Tpat_var (id, s) -> (* note the ``Not_found'' case *) + | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *) {p with pat_desc = - try Tpat_var (alpha_var env id, s) with + try Tpat_var (alpha_var env id, s, uid) with | Not_found -> Tpat_any} - | Tpat_alias (p1, id, s) -> + | Tpat_alias (p1, id, s, uid) -> let new_p = alpha_pat env p1 in begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)} with | Not_found -> new_p end diff --git a/upstream/ocaml_414/typing/typedtree.mli b/upstream/ocaml_414/typing/typedtree.mli index f5460d1ea2..d085194d83 100644 --- a/upstream/ocaml_414/typing/typedtree.mli +++ b/upstream/ocaml_414/typing/typedtree.mli @@ -22,6 +22,7 @@ *) open Asttypes +module Uid = Shape.Uid (* Value expressions for the core language *) @@ -75,10 +76,10 @@ and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc (** _ *) - | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc (** x *) | Tpat_alias : - value general_pattern * Ident.t * string loc -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc (** P as a *) | Tpat_constant : constant -> value pattern_desc (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) @@ -429,6 +430,7 @@ and module_binding = { mb_id: Ident.t option; mb_name: string option loc; + mb_uid: Uid.t; mb_presence: Types.module_presence; mb_expr: module_expr; mb_attributes: attributes; @@ -507,6 +509,7 @@ and module_declaration = { md_id: Ident.t option; md_name: string option loc; + md_uid: Uid.t; md_presence: Types.module_presence; md_type: module_type; md_attributes: attributes; @@ -517,6 +520,7 @@ and module_substitution = { ms_id: Ident.t; ms_name: string loc; + ms_uid: Uid.t; ms_manifest: Path.t; ms_txt: Longident.t loc; ms_attributes: attributes; @@ -527,6 +531,7 @@ and module_type_declaration = { mtd_id: Ident.t; mtd_name: string loc; + mtd_uid: Uid.t; mtd_type: module_type option; mtd_attributes: attributes; mtd_loc: Location.t; @@ -651,6 +656,7 @@ and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_uid: Uid.t; ld_mutable: mutable_flag; ld_type: core_type; ld_loc: Location.t; @@ -661,6 +667,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_uid: Uid.t; cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; @@ -778,6 +785,23 @@ type implementation = { structure. *) +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration +(** [item_declaration] groups together items that correspond to the syntactic + category of "declarations" which include types, values, modules, etc. + declarations in signatures and their definitions in implementations. *) + (* Auxiliary functions over the a.s.t. *) (** [as_computation_pattern p] is a computation pattern with description @@ -808,7 +832,8 @@ val exists_pattern: (pattern -> bool) -> pattern -> bool val let_bound_idents: value_binding list -> Ident.t list val let_bound_idents_full: - value_binding list -> (Ident.t * string loc * Types.type_expr) list + value_binding list -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list (** Alpha conversion of patterns *) val alpha_pat: @@ -819,7 +844,8 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc val pat_bound_idents: 'k general_pattern -> Ident.t list val pat_bound_idents_full: - 'k general_pattern -> (Ident.t * string loc * Types.type_expr) list + 'k general_pattern -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: diff --git a/upstream/ocaml_414/typing/typemod.ml b/upstream/ocaml_414/typing/typemod.ml index b575de2909..9648d04526 100644 --- a/upstream/ocaml_414/typing/typemod.ml +++ b/upstream/ocaml_414/typing/typemod.ml @@ -1042,7 +1042,7 @@ end = struct let open Sig_component_kind in match component with | Value -> names.values - | Type -> names.types + | Type | Label | Constructor -> names.types | Module -> names.modules | Module_type -> names.modtypes | Extension_constructor -> names.typexts @@ -1378,19 +1378,16 @@ and transl_signature env sg = Typedecl.transl_value_decl env item.psig_loc sdesc in Signature_names.check_value names tdesc.val_loc tdesc.val_id; - Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; let (trem,rem, final_env) = transl_sig newenv srem in mksig (Tsig_value tdesc) env loc :: trem, Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem, final_env | Psig_type (rec_flag, sdecls) -> - let (decls, newenv) = + let (decls, newenv, _) = Typedecl.transl_type_decl env rec_flag sdecls in List.iter (fun td -> Signature_names.check_type names td.typ_loc td.typ_id; - if not (Btype.is_row_name (Ident.name td.typ_id)) then - Env.register_uid td.typ_type.type_uid td.typ_loc ) decls; let (trem, rem, final_env) = transl_sig newenv srem in let sg = @@ -1402,7 +1399,7 @@ and transl_signature env sg = sg, final_env | Psig_typesubst sdecls -> - let (decls, newenv) = + let (decls, newenv, _) = Typedecl.transl_type_decl env Nonrecursive sdecls in List.iter (fun td -> @@ -1422,8 +1419,7 @@ and transl_signature env sg = in Some (`Substituted_away subst) in - Signature_names.check_type ?info names td.typ_loc td.typ_id; - Env.register_uid td.typ_type.type_uid td.typ_loc + Signature_names.check_type ?info names td.typ_loc td.typ_id ) decls; let (trem, rem, final_env) = transl_sig newenv srem in let sg = rem @@ -1432,13 +1428,12 @@ and transl_signature env sg = sg, final_env | Psig_typext styext -> - let (tyext, newenv) = + let (tyext, newenv, _shapes) = Typedecl.transl_type_extension false env item.psig_loc styext in let constructors = tyext.tyext_constructors in List.iter (fun ext -> - Signature_names.check_typext names ext.ext_loc ext.ext_id; - Env.register_uid ext.ext_type.ext_uid ext.ext_loc + Signature_names.check_typext names ext.ext_loc ext.ext_id ) constructors; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_typext tyext) env loc :: trem, @@ -1447,13 +1442,10 @@ and transl_signature env sg = ) constructors rem, final_env | Psig_exception sext -> - let (ext, newenv) = Typedecl.transl_type_exception env sext in + let (ext, newenv, _s) = Typedecl.transl_type_exception env sext in let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; - Env.register_uid - constructor.ext_type.ext_uid - constructor.ext_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception ext) env loc :: trem, Sig_typext(constructor.ext_id, @@ -1489,11 +1481,10 @@ and transl_signature env sg = Signature_names.check_module names pmd.pmd_name.loc id; Some id, newenv in - Env.register_uid md.md_uid md.md_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; - md_presence=pres; md_type=tmty; - md_loc=pmd.pmd_loc; + md_uid=md.md_uid; md_presence=pres; + md_type=tmty; md_loc=pmd.pmd_loc; md_attributes=pmd.pmd_attributes}) env loc :: trem, (match id with @@ -1529,9 +1520,8 @@ and transl_signature env sg = `Substituted_away (Subst.add_module id path Subst.identity) in Signature_names.check_module ~info names pms.pms_name.loc id; - Env.register_uid md.md_uid md.md_loc; let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; + mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; ms_uid=md.md_uid; ms_manifest=path; ms_txt=pms.pms_manifest; ms_loc=pms.pms_loc; ms_attributes=pms.pms_attributes}) @@ -1548,9 +1538,8 @@ and transl_signature env sg = | Some id -> Some (id, md, uid) ) tdecls in - List.iter (fun (id, md, uid) -> + List.iter (fun (id, md, _uid) -> Signature_names.check_module names md.md_loc id; - Env.register_uid uid md.md_loc ) decls; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) tdecls)) @@ -1565,15 +1554,16 @@ and transl_signature env sg = decls rem, final_env | Psig_modtype pmtd -> - let newenv, mtd, decl = transl_modtype_decl env pmtd in + let newenv, mtd, (decl : modtype_declaration) = + transl_modtype_decl env pmtd + in Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid mtd.mtd_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype mtd) env loc :: trem, Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, final_env | Psig_modtypesubst pmtd -> - let newenv, mtd, decl = transl_modtype_decl env pmtd in + let newenv, mtd, _decl = transl_modtype_decl env pmtd in let info = let mty = match mtd.mtd_type with | Some tmty -> tmty.mty_type @@ -1587,7 +1577,6 @@ and transl_signature env sg = | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) in Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid mtd.mtd_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtypesubst mtd) env loc :: trem, rem, @@ -1630,7 +1619,6 @@ and transl_signature env sg = Signature_names.check_class names loc cls.cls_id; Signature_names.check_class_type names loc cls.cls_ty_id; Signature_names.check_type names loc cls.cls_typesharp_id; - Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; ) classes; let (trem, rem, final_env) = transl_sig newenv srem in let sg = @@ -1658,9 +1646,6 @@ and transl_signature env sg = Signature_names.check_class_type names loc decl.clsty_ty_id; Signature_names.check_type names loc decl.clsty_obj_id; Signature_names.check_type names loc decl.clsty_typesharp_id; - Env.register_uid - decl.clsty_ty_decl.clty_uid - decl.clsty_ty_decl.clty_loc; ) classes; let (trem,rem, final_env) = transl_sig newenv srem in let sg = @@ -1726,6 +1711,7 @@ and transl_modtype_decl_aux env { mtd_id=id; mtd_name=pmtd_name; + mtd_uid=decl.mtd_uid; mtd_type=tmty; mtd_attributes=pmtd_attributes; mtd_loc=pmtd_loc; @@ -1808,11 +1794,11 @@ and transl_recmodule_modtypes env sdecls = List.map2 (fun pmd (id_shape, id_loc, md, mty) -> let tmd = {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; - md_presence=Mp_present; + md_uid=md.Types.md_uid; md_presence=Mp_present; md_loc=pmd.pmd_loc; md_attributes=pmd.pmd_attributes} in - tmd, md.md_uid, Option.map snd id_shape + tmd, md.Types.md_uid, Option.map snd id_shape ) sdecls dcl2 in (dcl2, env2) @@ -1999,6 +1985,7 @@ let check_recmodule_inclusion env bindings = { mb_id = id; mb_name = name; + mb_uid = uid; mb_presence = Mp_present; mb_expr = modl'; mb_attributes = attrs; @@ -2142,6 +2129,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = let shape = Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path in + let shape = if alias && aliasable then Shape.alias shape else shape in let md = if alias && aliasable then (Env.add_required_global (Path.head path); md) @@ -2464,10 +2452,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = will be marked as being used during the signature inclusion test. *) let items, shape_map = List.fold_left - (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)-> Signature_names.check_value names loc id; let vd = Env.find_value (Pident id) newenv in - Env.register_uid vd.val_uid vd.val_loc; Sig_value(id, vd, Exported) :: acc, Shape.Map.add_value shape_map id vd.val_uid ) @@ -2481,13 +2468,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = | Pstr_primitive sdesc -> let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in Signature_names.check_value names desc.val_loc desc.val_id; - Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val, Exported)], Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, newenv | Pstr_type (rec_flag, sdecls) -> - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + let (decls, newenv, shapes) = + Typedecl.transl_type_decl env rec_flag sdecls + in List.iter Signature_names.(fun td -> check_type names td.typ_loc td.typ_id) decls; @@ -2495,32 +2483,26 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) decls [] in - let shape_map = List.fold_left - (fun shape_map -> function - | Sig_type (id, vd, _, _) -> - if not (Btype.is_row_name (Ident.name id)) then begin - Env.register_uid vd.type_uid vd.type_loc; - Shape.Map.add_type shape_map id vd.type_uid - end else shape_map - | _ -> assert false - ) + let shape_map = List.fold_left2 + (fun map { typ_id; _} shape -> + Shape.Map.add_type map typ_id shape) shape_map - items + decls + shapes in Tstr_type (rec_flag, decls), items, shape_map, enrich_type_decls anchor decls env newenv | Pstr_typext styext -> - let (tyext, newenv) = + let (tyext, newenv, shapes) = Typedecl.transl_type_extension true env loc styext in let constructors = tyext.tyext_constructors in - let shape_map = List.fold_left (fun shape_map ext -> + let shape_map = List.fold_left2 (fun shape_map ext shape -> Signature_names.check_typext names ext.ext_loc ext.ext_id; - Env.register_uid ext.ext_type.ext_uid ext.ext_loc; - Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid - ) shape_map constructors + Shape.Map.add_extcons shape_map ext.ext_id shape + ) shape_map constructors shapes in (Tstr_typext tyext, map_ext @@ -2529,13 +2511,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = shape_map, newenv) | Pstr_exception sext -> - let (ext, newenv) = Typedecl.transl_type_exception env sext in + let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; - Env.register_uid - constructor.ext_type.ext_uid - constructor.ext_loc; Tstr_exception ext, [Sig_typext(constructor.ext_id, constructor.ext_type, @@ -2543,7 +2522,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = Exported)], Shape.Map.add_extcons shape_map constructor.ext_id - constructor.ext_type.ext_uid, + shape, newenv | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; @@ -2571,7 +2550,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = } in let md_shape = Shape.set_uid_if_none md_shape md_uid in - Env.register_uid md_uid pmb_loc; (*prerr_endline (Ident.unique_toplevel_name id);*) Mtype.lower_nongen outer_scope md.md_type; let id, newenv, sg = @@ -2594,8 +2572,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = | Some id -> Shape.Map.add_module shape_map id md_shape | None -> shape_map in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, + Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid; + mb_expr=modl; mb_presence=pres; mb_attributes=attrs; + mb_loc=pmb_loc; }, sg, shape_map, newenv @@ -2668,8 +2647,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = ) bindings2 in let shape_map = - List.fold_left (fun map (id, mb, uid, shape) -> - Env.register_uid uid mb.mb_loc; + List.fold_left (fun map (id, _mb, _uid, shape) -> Shape.Map.add_module map id shape ) shape_map mbs in @@ -2688,7 +2666,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = (* check that it is non-abstract *) let newenv, mtd, decl = transl_modtype_decl env pmtd in Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid decl.mtd_loc; let id = mtd.mtd_id in let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv @@ -2706,12 +2683,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = Signature_names.check_class_type names loc cls.cls_ty_id; Signature_names.check_type names loc cls.cls_obj_id; Signature_names.check_type names loc cls.cls_typesharp_id; - Env.register_uid cls.cls_decl.cty_uid loc; - let map f id acc = f acc id cls.cls_decl.cty_uid in - map Shape.Map.add_class cls.cls_id acc - |> map Shape.Map.add_class_type cls.cls_ty_id - |> map Shape.Map.add_type cls.cls_obj_id - |> map Shape.Map.add_type cls.cls_typesharp_id + let uid = cls.cls_decl.cty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class cls.cls_id uid acc + |> map Shape.Map.add_class_type cls.cls_ty_id uid + |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid) + |> map Shape.Map.add_type cls.cls_typesharp_id (Shape.leaf uid) ) shape_map classes in Tstr_class @@ -2737,11 +2714,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr = Signature_names.check_class_type names loc decl.clsty_ty_id; Signature_names.check_type names loc decl.clsty_obj_id; Signature_names.check_type names loc decl.clsty_typesharp_id; - Env.register_uid decl.clsty_ty_decl.clty_uid loc; - let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in - map Shape.Map.add_class_type decl.clsty_ty_id acc - |> map Shape.Map.add_type decl.clsty_obj_id - |> map Shape.Map.add_type decl.clsty_typesharp_id + let uid = decl.clsty_ty_decl.clty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class_type decl.clsty_ty_id uid acc + |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid) + |> map Shape.Map.add_type decl.clsty_typesharp_id (Shape.leaf uid) ) shape_map classes in Tstr_class_type @@ -3005,7 +2982,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = let simple_sg = Signature_names.simplify finalenv names sg in if !Clflags.print_types then begin Typecore.force_delayed_checks (); - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in Printtyp.wrap_printing_env ~error:false initial_env (fun () -> fprintf std_formatter "%a@." (Printtyp.printed_signature sourcefile) simple_sg @@ -3035,7 +3012,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported are not reported as being unused. *) - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in let annots = Cmt_format.Implementation str in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename annots (Some sourcefile) initial_env None (Some shape); @@ -3059,7 +3036,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in if not !Clflags.dont_write_files then begin let alerts = Builtin_attributes.alerts_of_str ast in let cmi = diff --git a/upstream/ocaml_414/typing/typemod.mli b/upstream/ocaml_414/typing/typemod.mli index 30ed1c7174..473e9b853f 100644 --- a/upstream/ocaml_414/typing/typemod.mli +++ b/upstream/ocaml_414/typing/typemod.mli @@ -76,6 +76,8 @@ module Sig_component_kind : sig type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor diff --git a/upstream/ocaml_414/typing/untypeast.ml b/upstream/ocaml_414/typing/untypeast.ml index 84af674ad2..5145f79c8a 100644 --- a/upstream/ocaml_414/typing/untypeast.ml +++ b/upstream/ocaml_414/typing/untypeast.ml @@ -298,7 +298,8 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> match pat with { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } -> Ppat_unpack { txt = None; loc } - | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> + | { pat_extra=[Tpat_unpack, _, _attrs]; + pat_desc = Tpat_var (_,name, _); _ } -> Ppat_unpack { name with txt = Some name.txt } | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type (map_loc sub lid) @@ -308,7 +309,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | _ -> match pat.pat_desc with Tpat_any -> Ppat_any - | Tpat_var (id, name) -> + | Tpat_var (id, name, _) -> begin match (Ident.name id).[0] with 'A'..'Z' -> @@ -321,11 +322,11 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> The compiler transforms (x:t) into (_ as x : t). This avoids transforming a warning 27 into a 26. *) - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _) when pat_loc = pat.pat_loc -> Ppat_var name - | Tpat_alias (pat, _id, name) -> + | Tpat_alias (pat, _id, name, _) -> Ppat_alias (sub.pat sub pat, name) | Tpat_constant cst -> Ppat_constant (constant cst) | Tpat_tuple list -> @@ -782,7 +783,7 @@ let core_type sub ct = let class_structure sub cs = let rec remove_self = function - | { pat_desc = Tpat_alias (p, id, _s) } + | { pat_desc = Tpat_alias (p, id, _s, _) } when string_is_prefix "selfpat-" (Ident.name id) -> remove_self p | p -> p @@ -812,7 +813,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} = Of.mk ~loc ~attrs desc and is_self_pat = function - | { pat_desc = Tpat_alias(_pat, id, _) } -> + | { pat_desc = Tpat_alias(_pat, id, _, _) } -> string_is_prefix "self-" (Ident.name id) | _ -> false diff --git a/upstream/ocaml_414/utils/clflags.ml b/upstream/ocaml_414/utils/clflags.ml index 83bd357f15..9e4511aa0c 100644 --- a/upstream/ocaml_414/utils/clflags.ml +++ b/upstream/ocaml_414/utils/clflags.ml @@ -68,6 +68,7 @@ and all_ppx = ref ([] : string list) (* -ppx *) let absname = ref false (* -absname *) let annotations = ref false (* -annot *) let binary_annotations = ref false (* -bin-annot *) +let store_occurrences = ref false (* -bin-annot-occurrences *) and use_threads = ref false (* -thread *) and noassert = ref false (* -noassert *) and verbose = ref false (* -verbose *) diff --git a/upstream/ocaml_414/utils/clflags.mli b/upstream/ocaml_414/utils/clflags.mli index 8cab8f15ac..822d00c65a 100644 --- a/upstream/ocaml_414/utils/clflags.mli +++ b/upstream/ocaml_414/utils/clflags.mli @@ -98,6 +98,7 @@ val all_ppx : string list ref val absname : bool ref val annotations : bool ref val binary_annotations : bool ref +val store_occurrences : bool ref val use_threads : bool ref val noassert : bool ref val verbose : bool ref