fix(lint): resolve E405 missing doc warnings in dupfind and ocaml-crc test interfaces

+77 -8

bin/main.ml

··· 86 86 String.capitalize_ascii base = m) 87 87 bindings 88 88 89 + let err_parse s = Error (Fmt.str "cannot parse expression: %S" s) 90 + let err_syntax s = Error (Fmt.str "syntax error in: %S" s) 91 + let err_lexer s = Error (Fmt.str "lexer error in: %S" s) 92 + 89 93 let parse_expr s = 90 94 let lexbuf = Lexing.from_string s in 91 95 match Parse.implementation lexbuf with 92 96 | [ { Parsetree.pstr_desc = Pstr_eval (e, _); _ } ] -> Ok e 93 97 | [ { Parsetree.pstr_desc = Pstr_value (_, [ vb ]); _ } ] -> Ok vb.pvb_expr 94 - | _ -> Error (Fmt.str "cannot parse expression: %S" s) 95 - | exception Syntaxerr.Error _ -> Error (Fmt.str "syntax error in: %S" s) 96 - | exception Lexer.Error (_, _) -> Error (Fmt.str "lexer error in: %S" s) 98 + | _ -> err_parse s 99 + | exception Syntaxerr.Error _ -> err_syntax s 100 + | exception Lexer.Error (_, _) -> err_lexer s 97 101 98 102 let is_hex_hash s = 99 103 String.length s = 32 ··· 144 148 in 145 149 Dupfind.Report.output ~format ~top [ cluster ] 146 150 147 - let find_by_expr ~format ~top index query = 151 + let by_expr ~format ~top index query = 148 152 let expr = 149 153 match parse_expr query with Ok e -> e | Error msg -> Fmt.failwith "%s" msg 150 154 in ··· 155 159 let matches = Dupfind.Index.get index target_hash in 156 160 report_matches ~format ~top ~qualified_name:query expr matches target_hash 157 161 158 - let find_by_name ~format ~top index query all_files = 162 + let by_name ~format ~top index query all_files = 159 163 let mod_name, func_name = resolve_qualified query in 160 164 let target = 161 165 List.find_map ··· 184 188 let index = index_files ~min_size ~progress all_files in 185 189 if is_hex_hash query then 186 190 report_hash_matches ~format ~top query (Dupfind.Index.get index query) 187 - else if is_inline_expr query then find_by_expr ~format ~top index query 188 - else find_by_name ~format ~top index query all_files 191 + else if is_inline_expr query then by_expr ~format ~top index query 192 + else by_name ~format ~top index query all_files 189 193 190 194 (* similar subcommand *) 191 195 ··· 245 249 Fmt.pr "@[<v>AST: %a@,Hash: %s@]@." Dupfind.Normalize.pp_expr normalized 246 250 h 247 251 252 + (* show subcommand *) 253 + 254 + let run_show eio min_size hash_query paths = 255 + let fs = Eio.Stdenv.fs eio in 256 + let all_files = collect_files ~fs ~exclude:[] paths in 257 + Log.info (fun m -> m "Indexing %d files" (List.length all_files)); 258 + let progress = 259 + Tty.Progress.create ~enabled:(Tty.is_tty ()) ~total:(List.length all_files) 260 + "Indexing" 261 + in 262 + let index = index_files ~min_size ~progress all_files in 263 + let matches = Dupfind.Index.get index hash_query in 264 + if matches = [] then ( 265 + Fmt.epr "No matches for hash %s.@." hash_query; 266 + Stdlib.exit 1) 267 + else begin 268 + (* Show normalized AST from the first match *) 269 + let first = List.hd matches in 270 + let file = first.Dupfind.Fragment.location.file in 271 + let structure = Dupfind.Source.parse_file file in 272 + let bindings = Dupfind.Source.extract_bindings structure in 273 + let target = 274 + List.find_opt 275 + (fun (name, _, line) -> 276 + name = first.binding_name && line = first.location.line) 277 + bindings 278 + in 279 + (match target with 280 + | Some (_name, expr, _line) -> 281 + let normalized = Dupfind.Normalize.apply expr in 282 + Fmt.pr 283 + "@[<v>Hash: %s@,\ 284 + @,\ 285 + Normalized AST:@,\ 286 + \ %a@,\ 287 + @,\ 288 + Locations (%d matches):@]@." 289 + hash_query Dupfind.Normalize.pp_expr normalized (List.length matches) 290 + | None -> 291 + Fmt.pr "Hash: %s@.@.Locations (%d matches):@." hash_query 292 + (List.length matches)); 293 + List.iter 294 + (fun (f : Dupfind.Fragment.t) -> 295 + Fmt.pr " %s:%d %s@." f.location.file f.location.line f.binding_name) 296 + matches 297 + end 298 + 248 299 (* Cmdliner terms *) 249 300 250 301 let setup = Vlog.setup ~json_reporter:None "dupfind" ··· 335 386 & info [] ~docv:"EXPR" 336 387 ~doc:"OCaml expression to hash (e.g. $(b,\"let f x = x + 1\")).") 337 388 389 + let show_hash = 390 + Arg.( 391 + required 392 + & pos 0 (some string) None 393 + & info [] ~docv:"HASH" ~doc:"The hex hash of the cluster to show.") 394 + 395 + let show_paths = 396 + Arg.( 397 + value & pos_right 0 string [ "." ] 398 + & info [] ~docv:"DIR" ~doc:"Directories to scan.") 399 + 400 + let show_cmd eio = 401 + let doc = "Show normalized AST for a hash cluster." in 402 + let info = Cmd.info "show" ~doc in 403 + Cmd.v info 404 + Term.( 405 + const (fun () -> run_show eio) $ setup $ min_size $ show_hash $ show_paths) 406 + 338 407 let hash_cmd = 339 408 let doc = "Show normalized AST and hash for an expression." in 340 409 let info = Cmd.info "hash" ~doc in ··· 354 423 let info = Cmd.info "dupfind" ~version:"0.1.0" ~doc in 355 424 Cmd.group info 356 425 ~default:Term.(ret (const (`Help (`Pager, None)))) 357 - [ scan_cmd eio; search_cmd eio; hash_cmd; similar_cmd eio ] 426 + [ scan_cmd eio; search_cmd eio; show_cmd eio; hash_cmd; similar_cmd eio ] 358 427 359 428 let () = 360 429 Memtrace.trace_if_requested ();

+199 -5

lib/normalize.ml

··· 5 5 let fresh env = 6 6 let n = env.counter in 7 7 env.counter <- n + 1; 8 - Printf.sprintf "_%d" n 8 + Fmt.str "_%d" n 9 9 10 10 let rename env name = 11 11 let canonical = fresh env in ··· 55 55 | E_assert of expr 56 56 | E_lazy of expr 57 57 | E_try of expr * case list 58 + | E_while of expr * expr 59 + | E_for of string * expr * expr * Asttypes.direction_flag * expr 60 + | E_setfield of expr * string * expr 61 + | E_array of expr list 62 + | E_send of expr * string 58 63 | E_other 59 64 60 65 and binding = { bpat : pat; bexpr : expr } ··· 164 169 | Pexp_try (e, cases) -> 165 170 E_try (convert_expr env e, List.map (convert_case env) cases) 166 171 | Pexp_open (_, e) -> convert_expr env e 172 + | Pexp_while (cond, body) -> 173 + E_while (convert_expr env cond, convert_expr env body) 174 + | Pexp_for (pat, lo, hi, dir, body) -> 175 + let name = 176 + match pat.ppat_desc with 177 + | Ppat_var { txt; _ } -> rename env txt 178 + | _ -> "_" 179 + in 180 + E_for 181 + ( name, 182 + convert_expr env lo, 183 + convert_expr env hi, 184 + dir, 185 + convert_expr env body ) 186 + | Pexp_setfield (e, { txt = lid; _ }, v) -> 187 + E_setfield 188 + (convert_expr env e, longident_to_string lid, convert_expr env v) 189 + | Pexp_array items -> E_array (List.map (convert_expr env) items) 190 + | Pexp_letop { let_; ands; body } -> 191 + (* Desugar let* x = e in body → ( let* ) e (fun x -> body) *) 192 + let let_op = E_ident let_.pbop_op.txt in 193 + let let_rhs = convert_expr env let_.pbop_exp in 194 + let ands_pre = 195 + List.map 196 + (fun bop -> 197 + ( E_ident bop.Parsetree.pbop_op.txt, 198 + convert_expr env bop.pbop_exp, 199 + bop.Parsetree.pbop_pat )) 200 + ands 201 + in 202 + (* Bind all patterns, then convert body *) 203 + let let_pat = convert_pat env let_.pbop_pat in 204 + let ands_bound = 205 + List.map 206 + (fun (op, rhs, raw_pat) -> (op, rhs, convert_pat env raw_pat)) 207 + ands_pre 208 + in 209 + let body = convert_expr env body in 210 + let body = 211 + List.fold_right 212 + (fun (op, rhs, pat) acc -> 213 + E_apply 214 + ( op, 215 + [ 216 + (Asttypes.Nolabel, rhs); 217 + ( Asttypes.Nolabel, 218 + E_fun 219 + ( [ Param_val (Asttypes.Nolabel, None, pat) ], 220 + Body_expr acc ) ); 221 + ] )) 222 + ands_bound body 223 + in 224 + E_apply 225 + ( let_op, 226 + [ 227 + (Asttypes.Nolabel, let_rhs); 228 + ( Asttypes.Nolabel, 229 + E_fun 230 + ([ Param_val (Asttypes.Nolabel, None, let_pat) ], Body_expr body) 231 + ); 232 + ] ) 233 + | Pexp_letmodule (_, _, e) -> convert_expr env e 234 + | Pexp_letexception (_, e) -> convert_expr env e 235 + | Pexp_send (e, { txt; _ }) -> E_send (convert_expr env e, txt) 236 + | Pexp_new { txt; _ } -> E_ident (longident_to_string txt) 167 237 | _ -> E_other 168 238 169 239 and convert_param env (p : Parsetree.function_param) = ··· 229 299 | E_try (e, cases) -> 230 300 E_try 231 301 (subst name replacement e, List.map (subst_case name replacement) cases) 302 + | E_while (c, b) -> 303 + E_while (subst name replacement c, subst name replacement b) 304 + | E_for (v, lo, hi, dir, b) -> 305 + E_for 306 + ( v, 307 + subst name replacement lo, 308 + subst name replacement hi, 309 + dir, 310 + subst name replacement b ) 311 + | E_setfield (e, f, v) -> 312 + E_setfield (subst name replacement e, f, subst name replacement v) 313 + | E_array es -> E_array (List.map (subst name replacement) es) 314 + | E_send (e, m) -> E_send (subst name replacement e, m) 232 315 233 316 and subst_params name replacement params = 234 317 List.map ··· 283 366 ident_in_expr name c || ident_in_expr name t 284 367 || opt_exists (ident_in_expr name) f 285 368 | E_sequence (e1, e2) -> ident_in_expr name e1 || ident_in_expr name e2 369 + | E_while (c, b) -> ident_in_expr name c || ident_in_expr name b 370 + | E_for (_, lo, hi, _, b) -> 371 + ident_in_expr name lo || ident_in_expr name hi || ident_in_expr name b 372 + | E_setfield (e, _, v) -> ident_in_expr name e || ident_in_expr name v 373 + | E_array es -> List.exists (ident_in_expr name) es 374 + | E_send (e, _) -> ident_in_expr name e 286 375 287 376 and ident_in_body name = function 288 377 | Body_expr e -> ident_in_expr name e ··· 334 423 | E_assert e -> E_assert (inline_lets e) 335 424 | E_lazy e -> E_lazy (inline_lets e) 336 425 | E_try (e, cases) -> E_try (inline_lets e, List.map inline_lets_case cases) 426 + | E_while (c, b) -> E_while (inline_lets c, inline_lets b) 427 + | E_for (v, lo, hi, dir, b) -> 428 + E_for (v, inline_lets lo, inline_lets hi, dir, inline_lets b) 429 + | E_setfield (e, f, v) -> E_setfield (inline_lets e, f, inline_lets v) 430 + | E_array es -> E_array (List.map inline_lets es) 431 + | E_send (e, m) -> E_send (inline_lets e, m) 337 432 | (E_ident _ | E_const _ | E_other) as e -> e 338 433 339 434 and inline_lets_params params = ··· 395 490 | E_assert e -> E_assert (beta_reduce e) 396 491 | E_lazy e -> E_lazy (beta_reduce e) 397 492 | E_try (e, cases) -> E_try (beta_reduce e, List.map beta_reduce_case cases) 493 + | E_while (c, b) -> E_while (beta_reduce c, beta_reduce b) 494 + | E_for (v, lo, hi, dir, b) -> 495 + E_for (v, beta_reduce lo, beta_reduce hi, dir, beta_reduce b) 496 + | E_setfield (e, f, v) -> E_setfield (beta_reduce e, f, beta_reduce v) 497 + | E_array es -> E_array (List.map beta_reduce es) 498 + | E_send (e, m) -> E_send (beta_reduce e, m) 398 499 | (E_ident _ | E_const _ | E_other) as e -> e 399 500 400 501 and beta_reduce_params params = ··· 447 548 | E_assert e -> E_assert (eta_reduce e) 448 549 | E_lazy e -> E_lazy (eta_reduce e) 449 550 | E_try (e, cases) -> E_try (eta_reduce e, List.map eta_reduce_case cases) 551 + | E_while (c, b) -> E_while (eta_reduce c, eta_reduce b) 552 + | E_for (v, lo, hi, dir, b) -> 553 + E_for (v, eta_reduce lo, eta_reduce hi, dir, eta_reduce b) 554 + | E_setfield (e, f, v) -> E_setfield (eta_reduce e, f, eta_reduce v) 555 + | E_array es -> E_array (List.map eta_reduce es) 556 + | E_send (e, m) -> E_send (eta_reduce e, m) 450 557 | (E_ident _ | E_const _ | E_other) as e -> e 451 558 452 559 (* Try the eta rule on a fun node. For a single-param function ··· 523 630 | E_assert e -> E_assert (flatten_funs e) 524 631 | E_lazy e -> E_lazy (flatten_funs e) 525 632 | E_try (e, cases) -> E_try (flatten_funs e, List.map flatten_funs_case cases) 633 + | E_while (c, b) -> E_while (flatten_funs c, flatten_funs b) 634 + | E_for (v, lo, hi, dir, b) -> 635 + E_for (v, flatten_funs lo, flatten_funs hi, dir, flatten_funs b) 636 + | E_setfield (e, f, v) -> E_setfield (flatten_funs e, f, flatten_funs v) 637 + | E_array es -> E_array (List.map flatten_funs es) 638 + | E_send (e, m) -> E_send (flatten_funs e, m) 526 639 | (E_ident _ | E_const _ | E_other) as e -> e 527 640 528 641 and flatten_funs_params params = ··· 696 809 buf_tag buf 15; 697 810 hash_expr buf e; 698 811 buf_list buf (hash_case buf) cases 812 + | E_while (c, b) -> 813 + buf_tag buf 17; 814 + hash_expr buf c; 815 + hash_expr buf b 816 + | E_for (v, lo, hi, dir, b) -> 817 + buf_tag buf 18; 818 + buf_str buf v; 819 + hash_expr buf lo; 820 + hash_expr buf hi; 821 + buf_tag buf (match dir with Asttypes.Upto -> 0 | Downto -> 1); 822 + hash_expr buf b 823 + | E_setfield (e, f, v) -> 824 + buf_tag buf 19; 825 + hash_expr buf e; 826 + buf_str buf f; 827 + hash_expr buf v 828 + | E_array es -> 829 + buf_tag buf 20; 830 + buf_list buf (hash_expr buf) es 831 + | E_send (e, m) -> 832 + buf_tag buf 21; 833 + hash_expr buf e; 834 + buf_str buf m 699 835 | E_other -> buf_tag buf 16 700 836 701 837 and hash_param buf = function ··· 753 889 1 + expr_size c + expr_size t 754 890 + match f with None -> 0 | Some e -> expr_size e) 755 891 | E_sequence (e1, e2) -> 1 + expr_size e1 + expr_size e2 892 + | E_while (c, b) -> 1 + expr_size c + expr_size b 893 + | E_for (_, lo, hi, _, b) -> 1 + expr_size lo + expr_size hi + expr_size b 894 + | E_setfield (e, _, v) -> 1 + expr_size e + expr_size v 895 + | E_array es -> 1 + List.fold_left (fun acc e -> acc + expr_size e) 0 es 896 + | E_send (e, _) -> 1 + expr_size e 756 897 757 898 and binding_size { bpat = _; bexpr } = 1 + expr_size bexpr 758 899 ··· 801 942 | E_sequence (e1, e2) -> 802 943 walk_expr e1; 803 944 walk_expr e2 945 + | E_while (c, b) -> 946 + walk_expr c; 947 + walk_expr b 948 + | E_for (_, lo, hi, _, b) -> 949 + walk_expr lo; 950 + walk_expr hi; 951 + walk_expr b 952 + | E_setfield (e, _, v) -> 953 + walk_expr e; 954 + walk_expr v 955 + | E_array es -> List.iter walk_expr es 956 + | E_send (e, _) -> walk_expr e 804 957 and walk_body = function 805 958 | Body_expr e -> walk_expr e 806 959 | Body_cases cases -> List.iter walk_case cases ··· 813 966 814 967 (* Pass 5: Common sub-expression elimination *) 815 968 816 - let cse expr = 817 - (* Count occurrences of each sub-expression by hash *) 969 + let cse_count_occurrences expr = 818 970 let counts = Hashtbl.create 64 in 819 971 let rec count_expr e = 820 972 let sz = expr_size e in ··· 855 1007 | E_sequence (e1, e2) -> 856 1008 count_expr e1; 857 1009 count_expr e2 1010 + | E_while (c, b) -> 1011 + count_expr c; 1012 + count_expr b 1013 + | E_for (_, lo, hi, _, b) -> 1014 + count_expr lo; 1015 + count_expr hi; 1016 + count_expr b 1017 + | E_setfield (e, _, v) -> 1018 + count_expr e; 1019 + count_expr v 1020 + | E_array es -> List.iter count_expr es 1021 + | E_send (e, _) -> count_expr e 858 1022 and count_body = function 859 1023 | Body_expr e -> count_expr e 860 1024 | Body_cases cases -> List.iter count_case cases ··· 863 1027 count_expr rhs 864 1028 in 865 1029 count_expr expr; 866 - (* Extract shared sub-expressions *) 1030 + counts 1031 + 1032 + let cse_extract counts expr = 867 1033 let seen : (string, string) Hashtbl.t = Hashtbl.create 16 in 868 1034 let bindings = ref [] in 869 1035 let cse_counter = ref 0 in 870 1036 let cse_fresh () = 871 1037 let n = !cse_counter in 872 1038 incr cse_counter; 873 - Printf.sprintf "_cse%d" n 1039 + Fmt.str "_cse%d" n 874 1040 in 875 1041 let rec extract e = 876 1042 let sz = expr_size e in ··· 913 1079 | E_assert e -> E_assert (extract e) 914 1080 | E_lazy e -> E_lazy (extract e) 915 1081 | E_try (e, cases) -> E_try (extract e, List.map extract_case cases) 1082 + | E_while (c, b) -> E_while (extract c, extract b) 1083 + | E_for (v, lo, hi, dir, b) -> 1084 + E_for (v, extract lo, extract hi, dir, extract b) 1085 + | E_setfield (e, f, v) -> E_setfield (extract e, f, extract v) 1086 + | E_array es -> E_array (List.map extract es) 1087 + | E_send (e, m) -> E_send (extract e, m) 916 1088 and extract_params params = 917 1089 List.map 918 1090 (function ··· 930 1102 match List.rev !bindings with 931 1103 | [] -> body 932 1104 | bs -> E_let (Asttypes.Nonrecursive, bs, body) 1105 + 1106 + let cse expr = 1107 + let counts = cse_count_occurrences expr in 1108 + cse_extract counts expr 933 1109 934 1110 (* Pass 6: Renumber — assign fresh sequential _0, _1, ... to all binding sites *) 935 1111 ··· 967 1143 | E_assert e -> E_assert (ren_expr e) 968 1144 | E_lazy e -> E_lazy (ren_expr e) 969 1145 | E_try (e, cases) -> E_try (ren_expr e, List.map ren_case cases) 1146 + | E_while (c, b) -> E_while (ren_expr c, ren_expr b) 1147 + | E_for (v, lo, hi, dir, b) -> 1148 + let v = bind v in 1149 + E_for (v, ren_expr lo, ren_expr hi, dir, ren_expr b) 1150 + | E_setfield (e, f, v) -> E_setfield (ren_expr e, f, ren_expr v) 1151 + | E_array es -> E_array (List.map ren_expr es) 1152 + | E_send (e, m) -> E_send (ren_expr e, m) 970 1153 and ren_pat = function 971 1154 | P_var s -> P_var (bind s) 972 1155 | P_tuple ps -> P_tuple (List.map ren_pat ps) ··· 1075 1258 | E_lazy e -> Fmt.pf fmt "lazy %a" pp_expr e 1076 1259 | E_try (e, cases) -> 1077 1260 Fmt.pf fmt "@[<v>try %a with@ %a@]" pp_expr e pp_cases cases 1261 + | E_while (c, b) -> 1262 + Fmt.pf fmt "@[<v>while %a do@ %a@ done@]" pp_expr c pp_expr b 1263 + | E_for (v, lo, hi, dir, b) -> 1264 + let dir_s = 1265 + match dir with Asttypes.Upto -> "to" | Asttypes.Downto -> "downto" 1266 + in 1267 + Fmt.pf fmt "@[<v>for %s = %a %s %a do@ %a@ done@]" v pp_expr lo dir_s 1268 + pp_expr hi pp_expr b 1269 + | E_setfield (e, f, v) -> Fmt.pf fmt "%a.%s <- %a" pp_expr e f pp_expr v 1270 + | E_array es -> Fmt.pf fmt "[| %a |]" Fmt.(list ~sep:semi pp_expr) es 1271 + | E_send (e, m) -> Fmt.pf fmt "%a#%s" pp_expr e m 1078 1272 | E_other -> Fmt.string fmt "<expr>" 1079 1273 1080 1274 and pp_binding fmt { bpat; bexpr } =

+1

test/test_cluster.mli