1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1996 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* *) 10(* All rights reserved. This file is distributed under the terms of *) 11(* the GNU Lesser General Public License version 2.1, with the *) 12(* special exception on linking described in the file LICENSE. *) 13(* *) 14(**************************************************************************) 15 16(* Substitutions *) 17 18open Misc 19open Path 20open Types 21open Btype 22 23type t = 24 { types: (Ident.t, Path.t) Tbl.t; 25 modules: (Ident.t, Path.t) Tbl.t; 26 modtypes: (Ident.t, module_type) Tbl.t; 27 for_saving: bool } 28 29let identity = 30 { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty; 31 for_saving = false } 32 33let add_type id p s = { s with types = Tbl.add id p s.types } 34 35let add_module id p s = { s with modules = Tbl.add id p s.modules } 36 37let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes } 38 39let for_saving s = { s with for_saving = true } 40 41let loc s x = 42 if s.for_saving && not !Clflags.keep_locs then Location.none else x 43 44let remove_loc = 45 let open Ast_mapper in 46 {default_mapper with location = (fun _this _loc -> Location.none)} 47 48let is_not_doc = function 49 | ({Location.txt = "ocaml.doc"}, _) -> false 50 | ({Location.txt = "ocaml.text"}, _) -> false 51 | ({Location.txt = "doc"}, _) -> false 52 | ({Location.txt = "text"}, _) -> false 53 | _ -> true 54 55let attrs s x = 56 let x = 57 if s.for_saving && not !Clflags.keep_docs then 58 List.filter is_not_doc x 59 else x 60 in 61 if s.for_saving && not !Clflags.keep_locs 62 then remove_loc.Ast_mapper.attributes remove_loc x 63 else x 64 65let rec module_path s = function 66 Pident id as p -> 67 begin try Tbl.find id s.modules with Not_found -> p end 68 | Pdot(p, n, pos) -> 69 Pdot(module_path s p, n, pos) 70 | Papply(p1, p2) -> 71 Papply(module_path s p1, module_path s p2) 72 73let modtype_path s = function 74 Pident id as p -> 75 begin try 76 match Tbl.find id s.modtypes with 77 | Mty_ident p -> p 78 | _ -> fatal_error "Subst.modtype_path" 79 with Not_found -> p end 80 | Pdot(p, n, pos) -> 81 Pdot(module_path s p, n, pos) 82 | Papply _ -> 83 fatal_error "Subst.modtype_path" 84 85let type_path s = function 86 Pident id as p -> 87 begin try Tbl.find id s.types with Not_found -> p end 88 | Pdot(p, n, pos) -> 89 Pdot(module_path s p, n, pos) 90 | Papply _ -> 91 fatal_error "Subst.type_path" 92 93let type_path s p = 94 match Path.constructor_typath p with 95 | Regular p -> type_path s p 96 | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos) 97 | LocalExt _ -> type_path s p 98 | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos) 99 100(* Special type ids for saved signatures *) 101 102let new_id = ref (-1) 103let reset_for_saving () = new_id := -1 104 105let newpersty desc = 106 decr new_id; 107 { desc = desc; level = generic_level; id = !new_id } 108 109(* ensure that all occurrences of 'Tvar None' are physically shared *) 110let tvar_none = Tvar None 111let tunivar_none = Tunivar None 112let norm = function 113 | Tvar None -> tvar_none 114 | Tunivar None -> tunivar_none 115 | d -> d 116 117(* Similar to [Ctype.nondep_type_rec]. *) 118let rec typexp s ty = 119 let ty = repr ty in 120 match ty.desc with 121 Tvar _ | Tunivar _ as desc -> 122 if s.for_saving || ty.id < 0 then 123 let ty' = 124 if s.for_saving then newpersty (norm desc) 125 else newty2 ty.level desc 126 in 127 save_desc ty desc; ty.desc <- Tsubst ty'; ty' 128 else ty 129 | Tsubst ty -> 130 ty 131 | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method 132 && field_kind_repr k <> Fabsent && (repr ty).level < generic_level -> 133 (* do not copy the type of self when it is not generalized *) 134 ty 135(* cannot do it, since it would omit subsitution 136 | Tvariant row when not (static_row row) -> 137 ty 138*) 139 | _ -> 140 let desc = ty.desc in 141 save_desc ty desc; 142 let tm = row_of_type ty in 143 let has_fixed_row = 144 not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in 145 (* Make a stub *) 146 let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in 147 ty.desc <- Tsubst ty'; 148 ty'.desc <- 149 begin if has_fixed_row then 150 match tm.desc with (* PR#7348 *) 151 Tconstr (Pdot(m,i,pos), tl, _abbrev) -> 152 let i' = String.sub i 0 (String.length i - 4) in 153 Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil) 154 | _ -> assert false 155 else match desc with 156 | Tconstr(p, tl, _abbrev) -> 157 Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil) 158 | Tpackage(p, n, tl) -> 159 Tpackage(modtype_path s p, n, List.map (typexp s) tl) 160 | Tobject (t1, name) -> 161 Tobject (typexp s t1, 162 ref (match !name with 163 None -> None 164 | Some (p, tl) -> 165 Some (type_path s p, List.map (typexp s) tl))) 166 | Tvariant row -> 167 let row = row_repr row in 168 let more = repr row.row_more in 169 (* We must substitute in a subtle way *) 170 (* Tsubst takes a tuple containing the row var and the variant *) 171 begin match more.desc with 172 Tsubst {desc = Ttuple [_;ty2]} -> 173 (* This variant type has been already copied *) 174 ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) 175 Tlink ty2 176 | _ -> 177 let dup = 178 s.for_saving || more.level = generic_level || static_row row || 179 match more.desc with Tconstr _ -> true | _ -> false in 180 (* Various cases for the row variable *) 181 let more' = 182 match more.desc with 183 Tsubst ty -> ty 184 | Tconstr _ | Tnil -> typexp s more 185 | Tunivar _ | Tvar _ -> 186 save_desc more more.desc; 187 if s.for_saving then newpersty (norm more.desc) else 188 if dup && is_Tvar more then newgenty more.desc else more 189 | _ -> assert false 190 in 191 (* Register new type first for recursion *) 192 more.desc <- Tsubst(newgenty(Ttuple[more';ty'])); 193 (* Return a new copy *) 194 let row = 195 copy_row (typexp s) true row (not dup) more' in 196 match row.row_name with 197 Some (p, tl) -> 198 Tvariant {row with row_name = Some (type_path s p, tl)} 199 | None -> 200 Tvariant row 201 end 202 | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> 203 Tlink (typexp s t2) 204 | _ -> copy_type_desc (typexp s) desc 205 end; 206 ty' 207 208(* 209 Always make a copy of the type. If this is not done, type levels 210 might not be correct. 211*) 212let type_expr s ty = 213 let ty' = typexp s ty in 214 cleanup_types (); 215 ty' 216 217let label_declaration s l = 218 { 219 ld_id = l.ld_id; 220 ld_mutable = l.ld_mutable; 221 ld_type = typexp s l.ld_type; 222 ld_loc = loc s l.ld_loc; 223 ld_attributes = attrs s l.ld_attributes; 224 } 225 226let constructor_arguments s = function 227 | Cstr_tuple l -> 228 Cstr_tuple (List.map (typexp s) l) 229 | Cstr_record l -> 230 Cstr_record (List.map (label_declaration s) l) 231 232let constructor_declaration s c = 233 { 234 cd_id = c.cd_id; 235 cd_args = constructor_arguments s c.cd_args; 236 cd_res = may_map (typexp s) c.cd_res; 237 cd_loc = loc s c.cd_loc; 238 cd_attributes = attrs s c.cd_attributes; 239 } 240 241let type_declaration s decl = 242 let decl = 243 { type_params = List.map (typexp s) decl.type_params; 244 type_arity = decl.type_arity; 245 type_kind = 246 begin match decl.type_kind with 247 Type_abstract -> Type_abstract 248 | Type_variant cstrs -> 249 Type_variant (List.map (constructor_declaration s) cstrs) 250 | Type_record(lbls, rep) -> 251 Type_record (List.map (label_declaration s) lbls, rep) 252 | Type_open -> Type_open 253 end; 254 type_manifest = 255 begin 256 match decl.type_manifest with 257 None -> None 258 | Some ty -> Some(typexp s ty) 259 end; 260 type_private = decl.type_private; 261 type_variance = decl.type_variance; 262 type_newtype_level = None; 263 type_loc = loc s decl.type_loc; 264 type_attributes = attrs s decl.type_attributes; 265 type_immediate = decl.type_immediate; 266 type_unboxed = decl.type_unboxed; 267 } 268 in 269 cleanup_types (); 270 decl 271 272let class_signature s sign = 273 { csig_self = typexp s sign.csig_self; 274 csig_vars = 275 Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.csig_vars; 276 csig_concr = sign.csig_concr; 277 csig_inher = 278 List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) 279 sign.csig_inher; 280 } 281 282let rec class_type s = 283 function 284 Cty_constr (p, tyl, cty) -> 285 Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) 286 | Cty_signature sign -> 287 Cty_signature (class_signature s sign) 288 | Cty_arrow (l, ty, cty) -> 289 Cty_arrow (l, typexp s ty, class_type s cty) 290 291let class_declaration s decl = 292 let decl = 293 { cty_params = List.map (typexp s) decl.cty_params; 294 cty_variance = decl.cty_variance; 295 cty_type = class_type s decl.cty_type; 296 cty_path = type_path s decl.cty_path; 297 cty_new = 298 begin match decl.cty_new with 299 None -> None 300 | Some ty -> Some (typexp s ty) 301 end; 302 cty_loc = loc s decl.cty_loc; 303 cty_attributes = attrs s decl.cty_attributes; 304 } 305 in 306 (* Do not clean up if saving: next is cltype_declaration *) 307 if not s.for_saving then cleanup_types (); 308 decl 309 310let cltype_declaration s decl = 311 let decl = 312 { clty_params = List.map (typexp s) decl.clty_params; 313 clty_variance = decl.clty_variance; 314 clty_type = class_type s decl.clty_type; 315 clty_path = type_path s decl.clty_path; 316 clty_loc = loc s decl.clty_loc; 317 clty_attributes = attrs s decl.clty_attributes; 318 } 319 in 320 (* Do clean up even if saving: type_declaration may be recursive *) 321 cleanup_types (); 322 decl 323 324let class_type s cty = 325 let cty = class_type s cty in 326 cleanup_types (); 327 cty 328 329let value_description s descr = 330 { val_type = type_expr s descr.val_type; 331 val_kind = descr.val_kind; 332 val_loc = loc s descr.val_loc; 333 val_attributes = attrs s descr.val_attributes; 334 } 335 336let extension_constructor s ext = 337 let ext = 338 { ext_type_path = type_path s ext.ext_type_path; 339 ext_type_params = List.map (typexp s) ext.ext_type_params; 340 ext_args = constructor_arguments s ext.ext_args; 341 ext_ret_type = may_map (typexp s) ext.ext_ret_type; 342 ext_private = ext.ext_private; 343 ext_attributes = attrs s ext.ext_attributes; 344 ext_loc = if s.for_saving then Location.none else ext.ext_loc; } 345 in 346 cleanup_types (); 347 ext 348 349let rec rename_bound_idents s idents = function 350 [] -> (List.rev idents, s) 351 | Sig_type(id, _, _) :: sg -> 352 let id' = Ident.rename id in 353 rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg 354 | Sig_module(id, _, _) :: sg -> 355 let id' = Ident.rename id in 356 rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg 357 | Sig_modtype(id, _) :: sg -> 358 let id' = Ident.rename id in 359 rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) 360 (id' :: idents) sg 361 | (Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> 362 (* cheat and pretend they are types cf. PR#6650 *) 363 let id' = Ident.rename id in 364 rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg 365 | (Sig_value(id, _) | Sig_typext(id, _, _)) :: sg -> 366 let id' = Ident.rename id in 367 rename_bound_idents s (id' :: idents) sg 368 369let rec modtype s = function 370 Mty_ident p as mty -> 371 begin match p with 372 Pident id -> 373 begin try Tbl.find id s.modtypes with Not_found -> mty end 374 | Pdot(p, n, pos) -> 375 Mty_ident(Pdot(module_path s p, n, pos)) 376 | Papply _ -> 377 fatal_error "Subst.modtype" 378 end 379 | Mty_signature sg -> 380 Mty_signature(signature s sg) 381 | Mty_functor(id, arg, res) -> 382 let id' = Ident.rename id in 383 Mty_functor(id', may_map (modtype s) arg, 384 modtype (add_module id (Pident id') s) res) 385 | Mty_alias(pres, p) -> 386 Mty_alias(pres, module_path s p) 387 388and signature s sg = 389 (* Components of signature may be mutually recursive (e.g. type declarations 390 or class and type declarations), so first build global renaming 391 substitution... *) 392 let (new_idents, s') = rename_bound_idents s [] sg in 393 (* ... then apply it to each signature component in turn *) 394 List.map2 (signature_component s') sg new_idents 395 396and signature_component s comp newid = 397 match comp with 398 Sig_value(_id, d) -> 399 Sig_value(newid, value_description s d) 400 | Sig_type(_id, d, rs) -> 401 Sig_type(newid, type_declaration s d, rs) 402 | Sig_typext(_id, ext, es) -> 403 Sig_typext(newid, extension_constructor s ext, es) 404 | Sig_module(_id, d, rs) -> 405 Sig_module(newid, module_declaration s d, rs) 406 | Sig_modtype(_id, d) -> 407 Sig_modtype(newid, modtype_declaration s d) 408 | Sig_class(_id, d, rs) -> 409 Sig_class(newid, class_declaration s d, rs) 410 | Sig_class_type(_id, d, rs) -> 411 Sig_class_type(newid, cltype_declaration s d, rs) 412 413and module_declaration s decl = 414 { 415 md_type = modtype s decl.md_type; 416 md_attributes = attrs s decl.md_attributes; 417 md_loc = loc s decl.md_loc; 418 } 419 420and modtype_declaration s decl = 421 { 422 mtd_type = may_map (modtype s) decl.mtd_type; 423 mtd_attributes = attrs s decl.mtd_attributes; 424 mtd_loc = loc s decl.mtd_loc; 425 } 426 427(* For every binding k |-> d of m1, add k |-> f d to m2 428 and return resulting merged map. *) 429 430let merge_tbls f m1 m2 = 431 Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2 432 433(* Composition of substitutions: 434 apply (compose s1 s2) x = apply s2 (apply s1 x) *) 435 436let compose s1 s2 = 437 { types = merge_tbls (type_path s2) s1.types s2.types; 438 modules = merge_tbls (module_path s2) s1.modules s2.modules; 439 modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes; 440 for_saving = s1.for_saving || s2.for_saving } 441