package merlin-lib
Merlin's libraries
Install
Dune Dependency
Authors
Maintainers
Sources
merlin-5.5-503.tbz
sha256=67da3b34f2fea07678267309f61da4a2c6f08298de0dc59655b8d30fd8269af1
sha512=1fb3b5180d36aa82b82a319e15b743b802b6888f0dc67645baafdb4e18dfc23a7b90064ec9bc42f7424061cf8cde7f8839178d8a8537bf4596759f3ff4891873
doc/src/merlin-lib.ocaml_typing/cmt_format.ml.html
Source file cmt_format.ml
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504
(**************************************************************************) (* *) (* OCaml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 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. *) (* *) (**************************************************************************) (** cmt and cmti files format. *) open Std open Cmi_format (* Note that in Typerex, there is an awful hack to save a cmt file together with the interface file that was generated by ocaml (this is because the installed version of ocaml might differ from the one integrated in Typerex). *) (** The layout of a cmt file is as follows: <cmt> := \{<cmi>\} <cmt magic> \{cmt infos\} \{<source info>\} where <cmi> is the cmi file format: <cmi> := <cmi magic> <cmi info>. More precisely, the optional <cmi> part must be present if and only if the file is: - a cmti, or - a cmt, for a ml file which has no corresponding mli (hence no corresponding cmti). Thus, we provide a common reading function for cmi and cmt(i) files which returns an option for each of the three parts: cmi info, cmt info, source info. *) open Typedtree let read_magic_number ic = let len_magic_number = String.length Config.cmt_magic_number in really_input_string ic len_magic_number type binary_annots = | Packed of Types.signature * string list | Implementation of structure | Interface of signature | Partial_implementation of binary_part array | 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 type dependency_kind = Definition_to_declaration | Declaration_to_declaration type cmt_infos = { cmt_modname : string; cmt_annots : binary_annots; cmt_declaration_dependencies : (dependency_kind * Uid.t * Uid.t) list; cmt_comments : (string * Location.t) list; cmt_args : string array; cmt_sourcefile : string option; cmt_builddir : string; cmt_loadpath : Load_path.paths; cmt_source_digest : Digest.t option; cmt_initial_env : Env.t; cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; 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 let cenv = {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} let clear_part = function | Partial_structure s -> Partial_structure (cenv.structure cenv s) | Partial_structure_item s -> Partial_structure_item (cenv.structure_item cenv s) | Partial_expression e -> Partial_expression (cenv.expr cenv e) | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p) | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) | Partial_signature s -> Partial_signature (cenv.signature cenv s) | Partial_signature_item s -> Partial_signature_item (cenv.signature_item cenv s) | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) let clear_env binary_annots = if need_to_clear_env then match binary_annots with | Implementation s -> Implementation (cenv.structure cenv s) | Interface s -> Interface (cenv.signature cenv s) | Packed _ -> binary_annots | Partial_implementation array -> Partial_implementation (Array.map clear_part array) | Partial_interface array -> Partial_interface (Array.map clear_part array) 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 ~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 | Texp_override (_self_path, modifs) -> List.iter ~f:(fun (id, (name : string Location.loc), _exp) -> let lid = { name with txt = Longident.Lident name.txt } in f ~namespace:Value exp_env (Path.Pident id) lid) modifs | Texp_extension_constructor (lid, path) -> f ~namespace:Extension_constructor exp_env path lid | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ | Texp_send _ | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable | Texp_open _ | Texp_typed_hole -> ()); default_iterator.expr sub e); (* Remark: some types get iterated over twice due to how constraints are encoded in the typedtree. For example, in [let x : t = 42], [t] is present in both a [Tpat_constraint] and a [Texp_constraint] node) *) 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 | Ttyp_open (path, lid, _ct) -> f ~namespace:Module ctyp_env path lid | Ttyp_any | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ -> ()); 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 | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ | Tpat_exception _ | Tpat_or _ -> ()); 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 | Tmod_structure _ | Tmod_functor _ | Tmod_apply _ | Tmod_apply_unit _ | Tmod_constraint _ | Tmod_unpack _ | Tmod_typed_hole -> ()); 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 | Tmty_signature _ | Tmty_functor _ | Tmty_typeof _ -> ()); 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 | Tcl_structure _ | Tcl_fun _ | Tcl_apply _ | Tcl_let _ | Tcl_constraint _ | Tcl_open _ -> ()); 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 | Tcty_signature _ | Tcty_arrow _ | Tcty_open _ -> ()); 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 | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_exception _ | Tsig_module _ | Tsig_recmodule _ | Tsig_modtype _ | Tsig_modtypesubst _ | Tsig_open _ | Tsig_include _ | Tsig_class _ | Tsig_class_type _ | Tsig_attribute _ -> ()); 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 | Tstr_eval _ | Tstr_value _ | Tstr_primitive _ | Tstr_type _ | Tstr_exception _ | Tstr_module _ | Tstr_recmodule _ | Tstr_modtype _ | Tstr_open _ | Tstr_class _ | Tstr_class_type _ | Tstr_include _ | Tstr_attribute _ -> ()); 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) let output_cmt oc cmt = ignore (oc, cmt) (* output_string oc Config.cmt_magic_number; Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) *) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) let ic = open_in_bin filename in Misc.try_finally ~always:(fun () -> close_in ic) (fun () -> let magic_number = read_magic_number ic in let cmi, cmt = if magic_number = Config.cmt_magic_number then None, Some (input_cmt ic) else if magic_number = Config.cmi_magic_number then let cmi = Cmi_format.input_cmi ic in let cmt = try let magic_number = read_magic_number ic in if magic_number = Config.cmt_magic_number then let cmt = input_cmt ic in Some cmt else None with _ -> None in Some cmi, cmt else raise Magic_numbers.Cmi.(Error(Not_an_interface filename)) in cmi, cmt ) let read_cmt filename = match read filename with _, None -> raise (Error (Not_a_typedtree filename)) | _, Some cmt -> cmt let read_cmi filename = match read filename with None, _ -> raise Magic_numbers.Cmi.(Error (Not_an_interface filename)) | Some cmi, _ -> cmi let saved_types = ref [] let uids_deps : (dependency_kind * Uid.t * Uid.t) list ref = ref [] let clear () = saved_types := []; uids_deps := [] let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l let get_declaration_dependencies () = !uids_deps let record_declaration_dependency (rk, uid1, uid2) = if not (Uid.equal uid1 uid2) then uids_deps := (rk, uid1, uid2) :: !uids_deps let save_cmt target binary_annots initial_env cmi shape = if !Clflags.binary_annotations && not !Clflags.print_types then begin Misc.output_to_file_via_temporary ~mode:[Open_binary] (Unit_info.Artifact.filename target) (fun temp_file_name oc -> let this_crc = match cmi with | None -> None | Some cmi -> Some (output_cmi temp_file_name oc cmi) in let sourcefile = Unit_info.Artifact.source_file target 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 = Unit_info.Artifact.modname target; cmt_annots; cmt_declaration_dependencies = !uids_deps; cmt_comments = []; cmt_args = Sys.argv; cmt_sourcefile = sourcefile; cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); cmt_loadpath = Load_path.get_paths (); cmt_source_digest = source_digest; cmt_initial_env = if need_to_clear_env then keep_only_summary initial_env else initial_env; cmt_imports = List.sort ~cmp:compare (Env.imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; cmt_uid_to_decl; cmt_impl_shape = shape; cmt_ident_occurrences; } in output_cmt oc cmt) end; clear ()
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>