1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Jacques Garrigue, Kyoto University RIMS *) 6(* *) 7(* Copyright 2001 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* Copyright 2001 Kyoto University *) 10(* *) 11(* All rights reserved. This file is distributed under the terms of *) 12(* the GNU Lesser General Public License version 2.1, with the *) 13(* special exception on linking described in the file LICENSE. *) 14(* *) 15(**************************************************************************) 16 17open StdLabels 18open Asttypes 19open Parsetree 20 21let norec = ref false 22 23let input_file file = 24 let ic = try open_in file with _ -> failwith ("input_file : " ^ file) in 25 let b = Buffer.create 1024 in 26 let buf = String.create 1024 and len = ref 0 in 27 while len := input ic buf 0 1024; !len > 0 do 28 Buffer.add_substring b buf 0 !len 29 done; 30 close_in ic; 31 Buffer.contents b 32 33module SMap = struct 34 include Map.Make(struct type t = string let compare = compare end) 35 let rec removes l m = 36 match l with [] -> m 37 | k::l -> 38 let m = try remove k m with Not_found -> m in 39 removes l m 40end 41 42let rec labels_of_sty sty = 43 match sty.ptyp_desc with 44 Ptyp_arrow (lab, _, rem) -> lab :: labels_of_sty rem 45 | Ptyp_alias (rem, _) -> labels_of_sty rem 46 | _ -> [] 47 48let rec labels_of_cty cty = 49 match cty.pcty_desc with 50 Pcty_arrow (lab, _, rem) -> 51 let (labs, meths) = labels_of_cty rem in 52 (lab :: labs, meths) 53 | Pcty_signature { pcsig_fields = fields } -> 54 ([], 55 List.fold_left fields ~init:[] ~f: 56 begin fun meths -> function 57 { pctf_desc = Pctf_meth (s, _, sty) } -> (s, labels_of_sty sty)::meths 58 | _ -> meths 59 end) 60 | _ -> 61 ([],[]) 62 63let rec pattern_vars pat = 64 match pat.ppat_desc with 65 Ppat_var s -> [s.txt] 66 | Ppat_alias (pat, s) -> 67 s.txt :: pattern_vars pat 68 | Ppat_tuple l 69 | Ppat_array l -> 70 List.concat (List.map pattern_vars l) 71 | Ppat_construct (_, Some pat) 72 | Ppat_variant (_, Some pat) 73 | Ppat_constraint (pat, _) -> 74 pattern_vars pat 75 | Ppat_record(l, _) -> 76 List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p)) 77 | Ppat_or (pat1, pat2) -> 78 pattern_vars pat1 @ pattern_vars pat2 79 | Ppat_lazy pat -> pattern_vars pat 80 | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ 81 | Ppat_type _ | Ppat_unpack _ -> 82 [] 83 84let pattern_name pat = 85 match pat.ppat_desc with 86 Ppat_var s -> Some s 87 | Ppat_constraint ({ppat_desc = Ppat_var s}, _) -> Some s 88 | _ -> None 89 90let insertions = ref [] 91let add_insertion pos s = insertions := (pos,s) :: !insertions 92let sort_insertions () = 93 List.sort !insertions ~cmp:(fun (pos1,_) (pos2,_) -> pos1 - pos2) 94 95let is_space = function ' '|'\t'|'\n'|'\r' -> true | _ -> false 96let is_alphanum = function 'A'..'Z'|'a'..'z'|'_'|'\192'..'\214'|'\216'..'\246' 97 | '\248'..'\255'|'\''|'0'..'9' -> true 98 | _ -> false 99 100(* Remove "(" or "begin" before a pattern *) 101let rec insertion_point pos ~text = 102 let pos' = ref (pos-1) in 103 while is_space text.[!pos'] do decr pos' done; 104 if text.[!pos'] = '(' then insertion_point !pos' ~text else 105 if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" 106 && not (is_alphanum text.[!pos'-5]) then insertion_point (!pos'-4) ~text 107 else pos 108 109(* Search "=" or "->" before "function" *) 110let rec insertion_point2 pos ~text = 111 let pos' = ref (pos-1) in 112 while is_space text.[!pos'] do decr pos' done; 113 if text.[!pos'] = '(' then insertion_point2 !pos' ~text else 114 if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" 115 && not (is_alphanum text.[!pos'-5]) then insertion_point2 (!pos'-4) ~text 116 else if text.[!pos'] = '=' then Some !pos' else 117 if !pos' >= 1 && text.[!pos'-1] = '-' && text.[!pos'] = '>' 118 then Some (!pos' - 1) 119 else None 120 121let rec insert_labels ~labels ~text expr = 122 match labels, expr.pexp_desc with 123 l::labels, Pexp_function(l', _, [pat, rem]) -> 124 if l <> "" && l.[0] <> '?' && l' = "" then begin 125 let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in 126 let pos = insertion_point start_c ~text in 127 match pattern_name pat with 128 | Some name when l = name.txt -> add_insertion pos "~" 129 | _ -> add_insertion pos ("~" ^ l ^ ":") 130 end; 131 insert_labels ~labels ~text rem 132 | l::labels, Pexp_function(l', _, lst) -> 133 let pos = expr.pexp_loc.Location.loc_start.Lexing.pos_cnum in 134 if l <> "" && l.[0] <> '?' && l' = "" 135 && String.sub text ~pos ~len:8 = "function" then begin 136 String.blit ~src:"match th" ~src_pos:0 ~dst:text 137 ~dst_pos:pos ~len:8; 138 add_insertion (pos+6) (l ^ " wi"); 139 match insertion_point2 pos ~text with 140 Some pos' -> 141 add_insertion pos' ("~" ^ l ^ " ") 142 | None -> 143 add_insertion pos ("fun ~" ^ l ^ " -> ") 144 end; 145 List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) 146 | _, Pexp_match( _, lst) -> 147 List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) 148 | _, Pexp_try(expr, lst) -> 149 insert_labels ~labels ~text expr; 150 List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) 151 | _, ( Pexp_let(_,_,e) | Pexp_sequence(_,e) | Pexp_when(_,e) 152 | Pexp_constraint(e,_,_) | Pexp_letmodule(_,_,e) 153 | Pexp_ifthenelse(_,e,None) ) -> 154 insert_labels ~labels ~text e 155 | _, Pexp_ifthenelse (_, e1, Some e2) -> 156 insert_labels ~labels ~text e1; 157 insert_labels ~labels ~text e2 158 | _ -> 159 () 160 161let rec insert_labels_class ~labels ~text expr = 162 match labels, expr.pcl_desc with 163 l::labels, Pcl_fun(l', _, pat, rem) -> 164 if l <> "" && l.[0] <> '?' && l' = "" then begin 165 let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in 166 let pos = insertion_point start_c ~text in 167 match pattern_name pat with 168 | Some name when l = name.txt -> add_insertion pos "~" 169 | _ -> add_insertion pos ("~" ^ l ^ ":") 170 end; 171 insert_labels_class ~labels ~text rem 172 | labels, (Pcl_constraint (expr, _) | Pcl_let (_, _, expr)) -> 173 insert_labels_class ~labels ~text expr 174 | _ -> 175 () 176 177let rec insert_labels_type ~labels ~text ty = 178 match labels, ty.ptyp_desc with 179 l::labels, Ptyp_arrow(l', _, rem) -> 180 if l <> "" && l.[0] <> '?' && l' = "" then begin 181 let start_c = ty.ptyp_loc.Location.loc_start.Lexing.pos_cnum in 182 let pos = insertion_point start_c ~text in 183 add_insertion pos (l ^ ":") 184 end; 185 insert_labels_type ~labels ~text rem 186 | _ -> 187 () 188 189let rec insert_labels_app ~labels ~text args = 190 match labels, args with 191 l::labels, (l',arg)::args -> 192 if l <> "" && l.[0] <> '?' && l' = "" then begin 193 let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in 194 let pos = insertion_point pos0 ~text in 195 match arg.pexp_desc with 196 | Pexp_ident({ txt = Longident.Lident name }) 197 when l = name && pos = pos0 -> 198 add_insertion pos "~" 199 | _ -> add_insertion pos ("~" ^ l ^ ":") 200 end; 201 insert_labels_app ~labels ~text args 202 | _ -> 203 () 204 205let insert_labels_app ~labels ~text args = 206 let labels, opt_labels = 207 List.partition labels ~f:(fun l -> l = "" || l.[0] <> '?') in 208 let nopt_labels = 209 List.map opt_labels 210 ~f:(fun l -> String.sub l ~pos:1 ~len:(String.length l - 1)) in 211 (* avoid ambiguous labels *) 212 if List.exists labels ~f:(List.mem ~set:nopt_labels) then () else 213 let aopt_labels = opt_labels @ nopt_labels in 214 let args, lab_args = List.partition args ~f:(fun (l,_) -> l = "") in 215 (* only optional arguments are labeled *) 216 if List.for_all lab_args ~f:(fun (l,_) -> List.mem l ~set:aopt_labels) 217 then insert_labels_app ~labels ~text args 218 219let rec add_labels_expr ~text ~values ~classes expr = 220 let add_labels_rec ?(values=values) expr = 221 add_labels_expr ~text ~values ~classes expr in 222 match expr.pexp_desc with 223 Pexp_apply ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })}, args) -> 224 begin try 225 let labels = SMap.find s values in 226 insert_labels_app ~labels ~text args 227 with Not_found -> () 228 end; 229 List.iter args ~f:(fun (_,e) -> add_labels_rec e) 230 | Pexp_apply ({pexp_desc=Pexp_send 231 ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })}, 232 meth)}, 233 args) -> 234 begin try 235 if SMap.find s values = ["<object>"] then 236 let labels = SMap.find (s ^ "#" ^ meth) values in 237 insert_labels_app ~labels ~text args 238 with Not_found -> () 239 end 240 | Pexp_apply ({pexp_desc=Pexp_new ({ txt = Longident.Lident s })}, args) -> 241 begin try 242 let labels = SMap.find s classes in 243 insert_labels_app ~labels ~text args 244 with Not_found -> () 245 end 246 | Pexp_let (recp, lst, expr) -> 247 let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in 248 let vals = SMap.removes vars values in 249 List.iter lst ~f: 250 begin fun (_,e) -> 251 add_labels_rec e ~values:(if recp = Recursive then vals else values) 252 end; 253 add_labels_rec expr ~values:vals 254 | Pexp_function (_, None, lst) -> 255 List.iter lst ~f: 256 (fun (p,e) -> 257 add_labels_rec e ~values:(SMap.removes (pattern_vars p) values)) 258 | Pexp_function (_, Some e, lst) 259 | Pexp_match (e, lst) 260 | Pexp_try (e, lst) -> 261 add_labels_rec e; 262 List.iter lst ~f: 263 (fun (p,e) -> 264 add_labels_rec e ~values:(SMap.removes (pattern_vars p) values)) 265 | Pexp_apply (e, args) -> 266 List.iter add_labels_rec (e :: List.map snd args) 267 | Pexp_tuple l | Pexp_array l -> 268 List.iter add_labels_rec l 269 | Pexp_construct (_, Some e) 270 | Pexp_variant (_, Some e) 271 | Pexp_field (e, _) 272 | Pexp_constraint (e, _, _) 273 | Pexp_send (e, _) 274 | Pexp_setinstvar (_, e) 275 | Pexp_letmodule (_, _, e) 276 | Pexp_assert e 277 | Pexp_lazy e 278 | Pexp_poly (e, _) 279 | Pexp_newtype (_, e) 280 | Pexp_open (_, e) -> 281 add_labels_rec e 282 | Pexp_record (lst, opt) -> 283 List.iter lst ~f:(fun (_,e) -> add_labels_rec e); 284 begin match opt with Some e -> add_labels_rec e | None -> () end 285 | Pexp_setfield (e1, _, e2) 286 | Pexp_ifthenelse (e1, e2, None) 287 | Pexp_sequence (e1, e2) 288 | Pexp_while (e1, e2) 289 | Pexp_when (e1, e2) -> 290 add_labels_rec e1; add_labels_rec e2 291 | Pexp_ifthenelse (e1, e2, Some e3) -> 292 add_labels_rec e1; add_labels_rec e2; add_labels_rec e3 293 | Pexp_for (s, e1, e2, _, e3) -> 294 add_labels_rec e1; add_labels_rec e2; 295 add_labels_rec e3 ~values:(SMap.removes [s.txt] values) 296 | Pexp_override lst -> 297 List.iter lst ~f:(fun (_,e) -> add_labels_rec e) 298 | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _ 299 | Pexp_new _ | Pexp_object _ | Pexp_pack _ -> 300 () 301 302let rec add_labels_class ~text ~classes ~values ~methods cl = 303 match cl.pcl_desc with 304 Pcl_constr _ -> () 305 | Pcl_structure { pcstr_self = p; pcstr_fields = l } -> 306 let values = SMap.removes (pattern_vars p) values in 307 let values = 308 match pattern_name p with None -> values 309 | Some s -> 310 List.fold_left methods 311 ~init:(SMap.add s.txt ["<object>"] values) 312 ~f:(fun m (k,l) -> SMap.add (s.txt^"#"^k) l m) 313 in 314 ignore (List.fold_left l ~init:values ~f: 315 begin fun values -> function e -> match e.pcf_desc with 316 | Pcf_val (s, _, _, e) -> 317 add_labels_expr ~text ~classes ~values e; 318 SMap.removes [s.txt] values 319 | Pcf_meth (s, _, _, e) -> 320 begin try 321 let labels = List.assoc s.txt methods in 322 insert_labels ~labels ~text e 323 with Not_found -> () 324 end; 325 add_labels_expr ~text ~classes ~values e; 326 values 327 | Pcf_init e -> 328 add_labels_expr ~text ~classes ~values e; 329 values 330 | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> values 331 end) 332 | Pcl_fun (_, opt, pat, cl) -> 333 begin match opt with None -> () 334 | Some e -> add_labels_expr ~text ~classes ~values e 335 end; 336 let values = SMap.removes (pattern_vars pat) values in 337 add_labels_class ~text ~classes ~values ~methods cl 338 | Pcl_apply (cl, args) -> 339 List.iter args ~f:(fun (_,e) -> add_labels_expr ~text ~classes ~values e); 340 add_labels_class ~text ~classes ~values ~methods cl 341 | Pcl_let (recp, lst, cl) -> 342 let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in 343 let vals = SMap.removes vars values in 344 List.iter lst ~f: 345 begin fun (_,e) -> 346 add_labels_expr e ~text ~classes 347 ~values:(if recp = Recursive then vals else values) 348 end; 349 add_labels_class cl ~text ~classes ~values:vals ~methods 350 | Pcl_constraint (cl, _) -> 351 add_labels_class ~text ~classes ~values ~methods cl 352 353let add_labels ~intf ~impl ~file = 354 insertions := []; 355 let values, classes = 356 List.fold_left intf ~init:(SMap.empty, SMap.empty) ~f: 357 begin fun (values, classes as acc) item -> 358 match item.psig_desc with 359 Psig_value (name, {pval_type = sty}) -> 360 (SMap.add name.txt (labels_of_sty sty) values, classes) 361 | Psig_class l -> 362 (values, 363 List.fold_left l ~init:classes ~f: 364 begin fun classes {pci_name=name; pci_expr=cty} -> 365 SMap.add name.txt (labels_of_cty cty) classes 366 end) 367 | _ -> 368 acc 369 end 370 in 371 let text = input_file file in 372 ignore (List.fold_right impl ~init:(values, classes) ~f: 373 begin fun item (values, classes as acc) -> 374 match item.pstr_desc with 375 Pstr_value (recp, l) -> 376 let names = 377 List.concat (List.map l ~f:(fun (p,_) -> pattern_vars p)) in 378 List.iter l ~f: 379 begin fun (pat, expr) -> 380 begin match pattern_name pat with 381 | Some s -> 382 begin try 383 let labels = SMap.find s.txt values in 384 insert_labels ~labels ~text expr; 385 if !norec then () else 386 let values = 387 SMap.fold 388 (fun s l m -> 389 if List.mem s names then SMap.add s l m else m) 390 values SMap.empty in 391 add_labels_expr expr ~text ~values ~classes:SMap.empty 392 with Not_found -> () 393 end 394 | None -> () 395 end; 396 end; 397 (SMap.removes names values, classes) 398 | Pstr_primitive (s, {pval_type=sty}) -> 399 begin try 400 let labels = SMap.find s.txt values in 401 insert_labels_type ~labels ~text sty; 402 (SMap.removes [s.txt] values, classes) 403 with Not_found -> acc 404 end 405 | Pstr_class l -> 406 let names = List.map l ~f:(fun pci -> pci.pci_name.txt) in 407 List.iter l ~f: 408 begin fun {pci_name=name; pci_expr=expr} -> 409 try 410 let (labels, methods) = SMap.find name.txt classes in 411 insert_labels_class ~labels ~text expr; 412 if !norec then () else 413 let classes = 414 SMap.fold 415 (fun s (l,_) m -> 416 if List.mem s names then SMap.add s l m else m) 417 classes SMap.empty in 418 add_labels_class expr ~text ~classes ~methods 419 ~values:SMap.empty 420 with Not_found -> () 421 end; 422 (values, SMap.removes names classes) 423 | _ -> 424 acc 425 end); 426 if !insertions <> [] then begin 427 let backup = file ^ ".bak" in 428 if Sys.file_exists backup then Sys.remove file 429 else Sys.rename file backup; 430 let oc = open_out file in 431 let last_pos = 432 List.fold_left (sort_insertions ()) ~init:0 ~f: 433 begin fun pos (pos', s) -> 434 output oc text pos (pos'-pos); 435 output_string oc s; 436 pos' 437 end in 438 if last_pos < String.length text then 439 output oc text last_pos (String.length text - last_pos); 440 close_out oc 441 end 442 else prerr_endline ("No labels to insert in " ^ file) 443 444let process_file file = 445 prerr_endline ("Processing " ^ file); 446 if Filename.check_suffix file ".ml" then 447 let intf = Filename.chop_suffix file ".ml" ^ ".mli" in 448 let ic = open_in intf in 449 let lexbuf = Lexing.from_channel ic in 450 Location.init lexbuf intf; 451 let intf = Parse.interface lexbuf in 452 close_in ic; 453 let ic = open_in file in 454 let lexbuf = Lexing.from_channel ic in 455 Location.init lexbuf file; 456 let impl = Parse.implementation lexbuf in 457 close_in ic; 458 add_labels ~intf ~impl ~file 459 else prerr_endline (file ^ " is not an implementation") 460 461let main () = 462 let files = ref [] in 463 Arg.parse ["-norec", Arg.Set norec, "do not labelize recursive calls"] 464 (fun f -> files := f :: !files) 465 "addlabels [-norec] <files>"; 466 let files = List.rev !files in 467 List.iter files ~f:process_file 468 469let () = main () 470